a172310231c7c51155f1f3b5003e5ca81c50a41c
[riece] / lisp / riece-addon.el
1 ;;; riece-addon.el --- add-on management
2 ;; Copyright (C) 1998-2004 Daiki Ueno
3
4 ;; Author: Daiki Ueno <ueno@unixuser.org>
5 ;; Created: 1998-09-28
6 ;; Keywords: IRC, riece
7
8 ;; This file is part of Riece.
9
10 ;; This program is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; This program is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
24
25 ;;; Code:
26
27 (require 'font-lock)
28 (require 'riece-options)
29 (require 'riece-compat)
30 (require 'riece-misc)
31 (require 'riece-addon-modules)
32
33 (defgroup riece-addon-list nil
34   "Add-on listing."
35   :tag "Addon list"
36   :prefix "riece-addon-list-"
37   :group 'riece)
38
39 (defgroup riece-addon-list-faces nil
40   "Faces for riece-addon-list-mode."
41   :tag "Faces"
42   :prefix "riece-addon-list-"
43   :group 'riece-addon-list)
44
45 (defface riece-addon-list-enabled-face
46   '((((class color) (background dark))
47      (:foreground "PaleTurquoise" :bold t))
48     (t
49      (:bold t)))
50   "Face used for displaying the enabled addon."
51   :group 'riece-addon-list-faces)
52 (defvar riece-addon-list-enabled-face 'riece-addon-list-enabled-face)
53
54 (defface riece-addon-list-disabled-face
55   '((((class color) (background dark))
56      (:foreground "PaleTurquoise" :italic t))
57     (t
58      (:italic t)))
59   "Face used for displaying the disabled addon."
60   :group 'riece-addon-list-faces)
61 (defvar riece-addon-list-disabled-face 'riece-addon-list-disabled-face)
62
63 (defface riece-addon-list-unsupported-face
64   '((((class color) (background dark))
65      (:foreground "PaleTurquoise"))
66     (t
67      ()))
68   "Face used for displaying the unsupported addon."
69   :group 'riece-addon-list-faces)
70 (defvar riece-addon-list-unsupported-face 'riece-addon-list-unsupported-face)
71
72 (defface riece-addon-list-uninstalled-face
73   '((t
74      (:foreground "red")))
75   "Face used for displaying the uninstalled addon."
76   :group 'riece-addon-list-faces)
77 (defvar riece-addon-list-uninstalled-face 'riece-addon-list-uninstalled-face)
78
79 (defface riece-addon-list-description-face
80   '((((class color)
81       (background dark))
82      (:foreground "lightyellow"))
83     (((class color)
84       (background light))
85      (:foreground "blue4"))
86     (t
87      ()))
88   "Face used for displaying the description addon."
89   :group 'riece-addon-list-faces)
90 (defvar riece-addon-list-description-face 'riece-addon-list-description-face)
91
92 (defcustom riece-addon-list-mark-face-alist
93   '((?+ . riece-addon-list-enabled-face)
94     (?- . riece-addon-list-disabled-face)
95     (?! . riece-addon-list-unsupported-face)
96     (?  . riece-addon-list-uninstalled-face))
97   "An alist mapping marks on riece-addon-list-buffer to faces."
98   :type 'list
99   :group 'riece-addon-list)
100
101 (defcustom riece-addon-list-font-lock-keywords
102   '(("^\\([-+! ] [^:]+\\): \\(.*\\)"
103      (1 (cdr (assq (aref (match-string 1) 0)
104                    riece-addon-list-mark-face-alist)))
105      (2 riece-addon-list-description-face)))
106   "Default expressions to addon in riece-addon-list-mode."
107   :type '(repeat (list string))
108   :group 'riece-addon-list)
109
110 (defvar riece-addon-list-mode-map
111   (let ((keymap (make-sparse-keymap)))
112     (define-key keymap "+" 'riece-command-enable-addon)
113     (define-key keymap "-" 'riece-command-disable-addon)
114     (define-key keymap "I" 'riece-command-insinuate-addon)
115     (define-key keymap "D" 'riece-command-uninstall-addon)
116     (define-key keymap "n" 'next-line)
117     (define-key keymap "p" 'previous-line)
118     (define-key keymap " " 'scroll-up)
119     (define-key keymap [delete] 'scroll-down)
120     (define-key keymap "q" 'bury-buffer)
121     keymap))
122
123 (defun riece-load-and-build-addon-dependencies (addons)
124   (let ((load-path (cons riece-addon-directory load-path))
125         dependencies)
126     (while addons
127       (require (car addons))            ;error will be reported here
128       (let* ((requires
129               (funcall (or (intern-soft
130                             (concat (symbol-name (car addons)) "-requires"))
131                            #'ignore)))
132              (pointer requires)
133              entry)
134         ;; Increment succs' pred count.
135         (if (setq entry (assq (car addons) dependencies))
136             (setcar (cdr entry) (+ (length requires) (nth 1 entry)))
137           (setq dependencies (cons (list (car addons) (length requires))
138                                    dependencies)))
139         ;; Merge pred's succs.
140         (while pointer
141           (if (setq entry (assq (car pointer) dependencies))
142               (setcdr (cdr entry) (cons (car addons) (nthcdr 2 entry)))
143             (setq dependencies (cons (list (car pointer) 0 (car addons))
144                                      dependencies)))
145           (setq pointer (cdr pointer))))
146       (setq addons (cdr addons)))
147     dependencies))
148
149 (defun riece-sort-addon-dependencies (dependencies)
150   (let ((pointer dependencies)
151         addons queue)
152     (while pointer
153       (if (zerop (nth 1 (car pointer)))
154           (setq dependencies (delq (car pointer) dependencies)
155                 queue (cons (car pointer) queue)))
156       (setq pointer (cdr pointer)))
157     (while queue
158       (setq addons (cons (cons (car (car queue)) (nthcdr 2 (car queue)))
159                          addons)
160             pointer (nthcdr 2 (car queue)))
161       (while pointer
162         (let* ((entry (assq (car pointer) dependencies))
163                (count (1- (nth 1 entry))))
164           (if (zerop count)
165               (setq dependencies (delq entry dependencies)
166                     queue (nconc queue (list entry)))
167             (setcar (cdr entry) count)))
168         (setq pointer (cdr pointer)))
169       (setq queue (cdr queue)))
170     (if dependencies
171         (error "Circular add-on dependency found: %S" dependencies))
172     (nreverse addons)))
173
174 (defun riece-resolve-addons (addons)
175   ;; Add files in riece-addon-directory to addons.
176   (if (file-directory-p riece-addon-directory)
177       (setq addons (nconc
178                     addons
179                     (mapcar
180                      (lambda (name)
181                        (unless (file-directory-p
182                                 (expand-file-name name riece-addon-directory))
183                          (intern (file-name-sans-extension name))))
184                      (directory-files riece-addon-directory nil "\\`[^.]")))))
185   ;; Sort & uniquify.
186   (setq addons (sort addons (lambda (symbol1 symbol2)
187                               (string-lessp (symbol-name symbol1)
188                                             (symbol-name symbol2)))))
189   (let ((pointer addons))
190     (while pointer
191       (if (memq (car pointer) (cdr pointer))
192           (setcar pointer nil))
193       (setq pointer (cdr pointer)))
194     (delq nil addons))
195   ;; Build & resolve dependencies.
196   (riece-sort-addon-dependencies
197    (riece-load-and-build-addon-dependencies addons)))
198
199 (defun riece-insinuate-addon (addon &optional verbose)
200   (unless (assq addon riece-addon-dependencies)
201     (setq riece-addons (cons addon riece-addons)
202           riece-addon-dependencies (riece-resolve-addons
203                                     (copy-sequence riece-addons))))
204   (if (get addon 'riece-addon-insinuated)
205       (if verbose
206           (message "Add-on %S is already insinuated" addon))
207     (funcall (intern (concat (symbol-name addon) "-insinuate")))
208     (put addon 'riece-addon-insinuated t)
209     (if verbose
210         (message "Add-on %S is insinuated" addon))))
211
212 (defun riece-uninstall-addon (addon &optional verbose)
213   (if (not (get addon 'riece-addon-insinuated))
214       (if verbose
215           (message "Add-on %S is not insinuated" addon))
216     (let ((entry (assq addon riece-addon-dependencies))
217           (enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
218       (if entry
219           (if (cdr entry)
220               (if (= (length (cdr entry)) 1)
221                   (error "%S depends %S" (car (cdr entry)) addon)
222                 (error "%s depends %S" (mapconcat #'identity (cdr entry) ",")
223                        addon))
224             (if (and enabled
225                      (symbol-value enabled))
226                 (riece-disable-addon addon verbose))
227             (funcall (or (intern-soft (concat (symbol-name addon)
228                                               "-uninstall"))
229                          #'ignore))
230             (setq riece-addon-dependencies
231                   (delq entry riece-addon-dependencies))
232             (remprop addon 'riece-addon-insinuated)
233             (setq riece-addons (delq addon riece-addons)
234                   riece-addon-dependencies (riece-resolve-addons
235                                             (copy-sequence riece-addons)))))
236       (if verbose
237           (message "Add-on %S is uninstalled" addon)))))
238
239 (defun riece-enable-addon (addon &optional verbose)
240   (unless (get addon 'riece-addon-insinuated)
241     (error "Add-on %S is not insinuated" addon))
242   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
243     (if (null enabled)
244         (if verbose
245             (message "Add-on %S doesn't support enable/disable" addon))
246       (if (symbol-value enabled)
247           (if verbose
248               (message "Add-on %S is already enabled" addon))
249         (funcall (intern (concat (symbol-name addon) "-enable")))
250         (if verbose
251             (message "Add-on %S enabled" addon))))))
252
253 (defun riece-disable-addon (addon &optional verbose)
254   (unless (get addon 'riece-addon-insinuated)
255     (error "Add-on %S is not insinuated" addon))
256   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
257     (if (null enabled)
258         (if verbose
259             (message "Add-on %S doesn't support enable/disable" addon))
260       (if (symbol-value enabled)
261           (progn
262             (funcall (intern (concat (symbol-name addon) "-disable")))
263             (if verbose
264                 (message "Add-on %S disabled" addon)))
265         (if verbose
266             (message "Add-on %S is already enabled" addon))))))
267
268 (put 'riece-addon-list-mode 'font-lock-defaults
269      '(riece-addon-list-font-lock-keywords t))
270
271 (defun riece-addon-list-mode ()
272   "Major mode for displaying addon list.
273 All normal editing commands are turned off."
274   (kill-all-local-variables)
275   (buffer-disable-undo)
276   (setq major-mode 'riece-addon-list-mode
277         mode-name "AddOns"
278         mode-line-buffer-identification
279         (riece-mode-line-buffer-identification '("Riece: %12b"))
280         truncate-lines t
281         buffer-read-only t)
282   (use-local-map riece-addon-list-mode-map)
283   (make-local-variable 'font-lock-defaults)
284   (setq font-lock-defaults '(riece-addon-list-font-lock-keywords t))
285   ;; In XEmacs, auto-initialization of font-lock is not effective
286   ;; if buffer-file-name is not set.
287   (font-lock-set-defaults)
288   (run-hooks 'riece-addon-list-mode-hook))
289
290 (defun riece-command-list-addons ()
291   (interactive)
292   (set-buffer (riece-get-buffer-create "*AddOns*" 'riece-addon-list-mode))
293   (riece-addon-list-mode)
294   (let ((inhibit-read-only t)
295         buffer-read-only
296         (pointer riece-addon-dependencies)
297         module-description-alist
298         description enabled point)
299     (while pointer
300       
301       (setq description (intern-soft (concat (symbol-name (car (car pointer)))
302                                              "-description"))
303             module-description-alist
304             (cons (cons (car (car pointer))
305                         (if description
306                             (symbol-value description)
307                           "(no description)"))
308                   module-description-alist)
309             pointer (cdr pointer)))
310     (setq pointer riece-addon-modules)
311     (while pointer
312       (unless (assq (car (car pointer))
313                     module-description-alist)
314         (setq module-description-alist
315               (cons (car pointer) module-description-alist)))
316       (setq pointer (cdr pointer)))
317     (erase-buffer)
318     (riece-kill-all-overlays)
319     (setq pointer (sort module-description-alist
320                         (lambda (entry1 entry2)
321                           (string-lessp (symbol-name (car entry1))
322                                         (symbol-name (car entry2))))))
323     (while pointer
324       (setq enabled (intern-soft (concat (symbol-name (car (car pointer)))
325                                          "-enabled")))
326       (setq point (point))
327       (insert (format "%c %S: %s\n"
328                       (if (not (get (car (car pointer))
329                                     'riece-addon-insinuated))
330                           ? 
331                         (if (null enabled)
332                             ?!
333                           (if (symbol-value enabled)
334                               ?+
335                             ?-)))
336                       (car (car pointer))
337                       (cdr (car pointer))))
338       (put-text-property point (point) 'riece-addon (car (car pointer)))
339       (setq pointer (cdr pointer)))
340     (insert "
341 Symbols in the leftmost column:
342
343   +     The add-on is enabled.
344   -     The add-on is disabled.
345   !     The add-on doesn't support enable/disable operation.
346         The add-on is not insinuated.
347 ")
348     (insert (substitute-command-keys "
349 Useful keys:
350
351   `\\[riece-command-enable-addon]' to enable the current add-on.
352   `\\[riece-command-disable-addon]' to disable the current add-on.
353 "))
354     (goto-char (point-min))
355     (pop-to-buffer (current-buffer))
356     (delete-other-windows)))
357
358 (defun riece-command-enable-addon (addon)
359   (interactive
360    (list
361     (or (if (eq major-mode 'riece-addon-list-mode)
362             (get-text-property (point) 'riece-addon))
363         (intern-soft
364          (completing-read "Add-on: "
365                           (mapcar (lambda (dependency)
366                                     (list (symbol-name (car dependency))))
367                                   riece-addon-dependencies)
368                           (lambda (pointer)
369                             (let ((enabled
370                                    (intern-soft (concat (car pointer)
371                                                         "-enabled"))))
372                               (and enabled
373                                    (null (symbol-value enabled)))))
374                           t)))))
375   (riece-enable-addon addon t)
376   (when (eq major-mode 'riece-addon-list-mode)
377     (riece-command-list-addons)
378     (let ((point (point-min)))
379       (while (and (not (eq (get-text-property point 'riece-addon) addon))
380                   (setq point (next-single-property-change point
381                                                            'riece-addon))))
382       (if point
383           (goto-char point)))))
384
385 (defun riece-command-disable-addon (addon)
386   (interactive
387    (list
388     (or (if (eq major-mode 'riece-addon-list-mode)
389             (get-text-property (point) 'riece-addon))
390         (intern-soft
391          (completing-read "Add-on: "
392                           (mapcar (lambda (dependency)
393                                     (list (symbol-name (car dependency))))
394                                   riece-addon-dependencies)
395                           (lambda (pointer)
396                             (let ((enabled
397                                    (intern-soft (concat (car pointer)
398                                                         "-enabled"))))
399                               (and enabled
400                                    (symbol-value enabled))))
401                           t)))))
402   (riece-disable-addon addon t)
403   (when (eq major-mode 'riece-addon-list-mode)
404     (riece-command-list-addons)
405     (let ((point (point-min)))
406       (while (and (not (eq (get-text-property point 'riece-addon) addon))
407                   (setq point (next-single-property-change point
408                                                            'riece-addon))))
409       (if point
410           (goto-char point)))))
411
412 (defun riece-command-insinuate-addon (addon)
413   (interactive
414    (list
415     (or (if (eq major-mode 'riece-addon-list-mode)
416             (get-text-property (point) 'riece-addon))
417         (intern-soft
418          (completing-read "Add-on: "
419                           (mapcar (lambda (dependency)
420                                     (list (symbol-name (car dependency))))
421                                   riece-addon-modules)
422                           (lambda (pointer)
423                             (get (car pointer) 'riece-addon-insinuated))
424                           t)))))
425   (riece-insinuate-addon addon t)
426   (when (eq major-mode 'riece-addon-list-mode)
427     (riece-command-list-addons)
428     (let ((point (point-min)))
429       (while (and (not (eq (get-text-property point 'riece-addon) addon))
430                   (setq point (next-single-property-change point
431                                                            'riece-addon))))
432       (if point
433           (goto-char point)))))
434
435 (defun riece-command-uninstall-addon (addon)
436   (interactive
437    (list
438     (or (if (eq major-mode 'riece-addon-list-mode)
439             (get-text-property (point) 'riece-addon))
440         (intern-soft
441          (completing-read "Add-on: "
442                           (mapcar (lambda (dependency)
443                                     (list (symbol-name (car dependency))))
444                                   riece-addon-dependencies)
445                           nil t)))))
446   (riece-uninstall-addon addon t)
447   (when (eq major-mode 'riece-addon-list-mode)
448     (riece-command-list-addons)
449     (let ((point (point-min)))
450       (while (and (not (eq (get-text-property point 'riece-addon) addon))
451                   (setq point (next-single-property-change point
452                                                            'riece-addon))))
453       (if point
454           (goto-char point)))))
455
456 (provide 'riece-addon)
457
458 ;;; riece-addon.el ends here