8887394e7df15d224078ee758843b8de603e3a1b
[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      ()))
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      (:italic t)))
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-unloaded-face
80   '((t
81      (:italic t :inverse-video t)))
82   "Face used for displaying the unloaded addon."
83   :group 'riece-addon-list-faces)
84 (defvar riece-addon-list-unloaded-face 'riece-addon-list-unloaded-face)
85
86 (defface riece-addon-list-description-face
87   '((((class color)
88       (background dark))
89      (:foreground "lightyellow"))
90     (((class color)
91       (background light))
92      (:foreground "blue4"))
93     (t
94      ()))
95   "Face used for displaying the description addon."
96   :group 'riece-addon-list-faces)
97 (defvar riece-addon-list-description-face 'riece-addon-list-description-face)
98
99 (defcustom riece-addon-list-mark-face-alist
100   '((?+ . riece-addon-list-enabled-face)
101     (?- . riece-addon-list-disabled-face)
102     (?! . riece-addon-list-unsupported-face)
103     (?? . riece-addon-list-uninstalled-face)
104     (?  . riece-addon-list-unloaded-face))
105   "An alist mapping marks on riece-addon-list-buffer to faces."
106   :type 'list
107   :group 'riece-addon-list)
108
109 (defcustom riece-addon-list-font-lock-keywords
110   '(("^\\([-+!? ] \\S-+\\)\\s-+\\(.*\\)"
111      (1 (cdr (assq (aref (match-string 1) 0)
112                    riece-addon-list-mark-face-alist)))
113      (2 riece-addon-list-description-face)))
114   "Default expressions to addon in riece-addon-list-mode."
115   :type '(repeat (list string))
116   :group 'riece-addon-list)
117
118 (defvar riece-addon-list-mode-map
119   (let ((keymap (make-sparse-keymap)))
120     (define-key keymap "+" 'riece-command-enable-addon)
121     (define-key keymap "-" 'riece-command-disable-addon)
122     (define-key keymap "i" 'riece-command-insinuate-addon)
123     (define-key keymap "u" 'riece-command-uninstall-addon)
124     (define-key keymap "U" 'riece-command-unload-addon)
125     (define-key keymap "n" 'next-line)
126     (define-key keymap "p" 'previous-line)
127     (define-key keymap " " 'scroll-up)
128     (define-key keymap [delete] 'scroll-down)
129     (define-key keymap "q" 'bury-buffer)
130     keymap))
131
132 (defun riece-load-and-build-addon-dependencies (addons)
133   (let ((load-path (cons riece-addon-directory load-path))
134         dependencies)
135     (while addons
136       (require (car addons))            ;error will be reported here
137       (let* ((requires-function
138               (intern-soft
139                (concat (symbol-name (car addons)) "-requires")))
140              (requires
141               (if (and requires-function
142                        (fboundp requires-function))
143                   (funcall requires-function)))
144              (pointer requires)
145              entry)
146         ;; Increment succs' pred count.
147         (if (setq entry (assq (car addons) dependencies))
148             (setcar (cdr entry) (+ (length requires) (nth 1 entry)))
149           (setq dependencies (cons (list (car addons) (length requires))
150                                    dependencies)))
151         ;; Merge pred's succs.
152         (while pointer
153           (if (setq entry (assq (car pointer) dependencies))
154               (setcdr (cdr entry) (cons (car addons) (nthcdr 2 entry)))
155             (setq dependencies (cons (list (car pointer) 0 (car addons))
156                                      dependencies)))
157           (setq pointer (cdr pointer))))
158       (setq addons (cdr addons)))
159     dependencies))
160
161 (defun riece-sort-addon-dependencies (dependencies)
162   (let ((pointer dependencies)
163         addons queue)
164     (while pointer
165       (if (zerop (nth 1 (car pointer)))
166           (setq dependencies (delq (car pointer) dependencies)
167                 queue (cons (car pointer) queue)))
168       (setq pointer (cdr pointer)))
169     (while queue
170       (setq addons (cons (cons (car (car queue)) (nthcdr 2 (car queue)))
171                          addons)
172             pointer (nthcdr 2 (car queue)))
173       (while pointer
174         (let* ((entry (assq (car pointer) dependencies))
175                (count (1- (nth 1 entry))))
176           (if (zerop count)
177               (setq dependencies (delq entry dependencies)
178                     queue (nconc queue (list entry)))
179             (setcar (cdr entry) count)))
180         (setq pointer (cdr pointer)))
181       (setq queue (cdr queue)))
182     (if dependencies
183         (error "Circular add-on dependency found: %S" dependencies))
184     (nreverse addons)))
185
186 (defun riece-resolve-addons (addons)
187   ;; Add files in riece-addon-directory to addons.
188   (if (file-directory-p riece-addon-directory)
189       (setq addons (nconc
190                     addons
191                     (mapcar
192                      (lambda (name)
193                        (unless (file-directory-p
194                                 (expand-file-name name riece-addon-directory))
195                          (intern (file-name-sans-extension name))))
196                      (directory-files riece-addon-directory nil "\\`[^.]")))))
197   ;; Sort & uniquify.
198   (setq addons (sort addons (lambda (symbol1 symbol2)
199                               (string-lessp (symbol-name symbol1)
200                                             (symbol-name symbol2)))))
201   (let ((pointer addons))
202     (while pointer
203       (if (memq (car pointer) (cdr pointer))
204           (setcar pointer nil))
205       (setq pointer (cdr pointer)))
206     (delq nil addons))
207   ;; Build & resolve dependencies.
208   (riece-sort-addon-dependencies
209    (riece-load-and-build-addon-dependencies addons)))
210
211 (defun riece-insinuate-addon-1 (addon verbose)
212   (if (get addon 'riece-addon-insinuated)
213       (if verbose
214           (message "Add-on %S is already insinuated" addon))
215     (require addon)
216     (funcall (intern (concat (symbol-name addon) "-insinuate")))
217     (put addon 'riece-addon-insinuated t)
218     (if verbose
219         (message "Add-on %S is insinuated" addon))
220     (unless (get addon 'riece-addon-default-disabled)
221       (riece-enable-addon addon t))))
222
223 (defun riece-insinuate-addon (addon &optional verbose)
224   (unless (assq addon riece-addon-dependencies)
225     (setq riece-addons (cons addon riece-addons)
226           riece-save-variables-are-dirty t
227           riece-addon-dependencies
228           (riece-resolve-addons
229            (cons addon (mapcar #'car riece-addon-dependencies)))))
230   (let ((pointer riece-addon-dependencies)
231         addons)
232     (while pointer
233       (unless (get (car (car pointer)) 'riece-addon-insinuated)
234         (setq addons (cons (car (car pointer)) addons)))
235       (if (eq (car (car pointer)) addon)
236           (setq pointer nil)
237         (setq pointer (cdr pointer))))
238     (setq addons (nreverse addons))
239     (if (and (> (length addons) 1)
240              (eq verbose 'ask)
241              (not (y-or-n-p (format "%s will be insinuated.  Continue? "
242                                     (mapconcat #'symbol-name addons ", ")))))
243         (error "Insinuate operation was cancelled"))
244     (while addons
245       (riece-insinuate-addon-1 (car addons) verbose)
246       (setq addons (cdr addons)))))
247
248 (defun riece-uninstall-addon (addon &optional verbose)
249   (if (not (get addon 'riece-addon-insinuated))
250       (if verbose
251           (message "Add-on %S is not insinuated" addon))
252     (let ((entry (assq addon riece-addon-dependencies))
253           (uninstall (intern-soft (concat (symbol-name addon) "-uninstall"))))
254       (if entry
255           (if (cdr entry)
256               (if (= (length (cdr entry)) 1)
257                   (error "%S depends on %S" (car (cdr entry)) addon)
258                 (error "%s depend on %S"
259                        (mapconcat #'symbol-name (cdr entry) ", ")
260                        addon))
261             (riece-disable-addon addon verbose)
262             (if (and uninstall
263                      (fboundp uninstall))
264                 (funcall uninstall))
265             (setq riece-addon-dependencies
266                   (delq entry riece-addon-dependencies))
267             (put addon 'riece-addon-insinuated nil)
268             (setq riece-addons (delq addon riece-addons)
269                   riece-save-variables-are-dirty t
270                   riece-addon-dependencies
271                   (riece-resolve-addons
272                    (delq addon (mapcar #'car riece-addon-dependencies))))))
273       (if verbose
274           (message "Add-on %S is uninstalled" addon)))))
275
276 (defun riece-enable-addon (addon &optional verbose)
277   (unless (get addon 'riece-addon-insinuated)
278     (error "Add-on %S is not insinuated" addon))
279   (let ((enable (intern-soft (concat (symbol-name addon) "-enable"))))
280     (if (or (null enable)
281             (not (fboundp enable)))
282         (if verbose
283             (message "Add-on %S doesn't support enable/disable" addon))
284       (if (get addon 'riece-addon-enabled)
285           (if verbose
286               (message "Add-on %S is already enabled" addon))
287         (funcall enable)
288         (put addon 'riece-addon-enabled t)
289         (if verbose
290             (message "Add-on %S enabled" addon))))))
291
292 (defun riece-disable-addon (addon &optional verbose)
293   (unless (get addon 'riece-addon-insinuated)
294     (error "Add-on %S is not insinuated" addon))
295   (let ((disable (intern-soft (concat (symbol-name addon) "-disable"))))
296     (if (or (null disable)
297             (not (fboundp disable)))
298         (if verbose
299             (message "Add-on %S doesn't support enable/disable" addon))
300       (if (get addon 'riece-addon-enabled)
301           (progn
302             (funcall disable)
303             (put addon 'riece-addon-enabled nil)
304             (if verbose
305                 (message "Add-on %S disabled" addon)))
306         (if verbose
307             (message "Add-on %S is already enabled" addon))))))
308
309 (put 'riece-addon-list-mode 'font-lock-defaults
310      '(riece-addon-list-font-lock-keywords t))
311
312 (defun riece-addon-list-mode ()
313   "Major mode for displaying addon list.
314 All normal editing commands are turned off."
315   (kill-all-local-variables)
316   (buffer-disable-undo)
317   (setq major-mode 'riece-addon-list-mode
318         mode-name "AddOns"
319         mode-line-buffer-identification
320         (riece-mode-line-buffer-identification '("Riece: %12b"))
321         truncate-lines t
322         buffer-read-only t)
323   (use-local-map riece-addon-list-mode-map)
324   (make-local-variable 'font-lock-defaults)
325   (setq font-lock-defaults '(riece-addon-list-font-lock-keywords t))
326   ;; In XEmacs, auto-initialization of font-lock is not effective
327   ;; if buffer-file-name is not set.
328   (font-lock-set-defaults)
329   (run-hooks 'riece-addon-list-mode-hook))
330
331 (defun riece-command-list-addons ()
332   (interactive)
333   (set-buffer (riece-get-buffer-create "*AddOn*" 'riece-addon-list-mode))
334   (riece-addon-list-mode)
335   (let ((inhibit-read-only t)
336         buffer-read-only
337         (pointer riece-addon-dependencies)
338         module-description-alist
339         description enable point)
340     (while pointer
341       (setq description (intern-soft (concat (symbol-name (car (car pointer)))
342                                              "-description"))
343             module-description-alist
344             (cons (cons (car (car pointer))
345                         (if (and description
346                                  (boundp description))
347                             (symbol-value description)
348                           "(no description)"))
349                   module-description-alist)
350             pointer (cdr pointer)))
351     (setq pointer riece-addon-modules)
352     (while pointer
353       (unless (assq (car (car pointer))
354                     module-description-alist)
355         (setq module-description-alist
356               (cons (car pointer) module-description-alist)))
357       (setq pointer (cdr pointer)))
358     (erase-buffer)
359     (riece-kill-all-overlays)
360     (setq pointer (sort module-description-alist
361                         (lambda (entry1 entry2)
362                           (string-lessp (symbol-name (car entry1))
363                                         (symbol-name (car entry2))))))
364     (while pointer
365       (setq enable (intern-soft (concat (symbol-name (car (car pointer)))
366                                         "-enable")))
367       (setq point (point))
368       (insert (format "%c %-15S %s\n"
369                       (if (not (featurep (car (car pointer))))
370                           ? 
371                         (if (not (get (car (car pointer))
372                                       'riece-addon-insinuated))
373                             ??
374                           (if (or (null enable)
375                                   (not (fboundp enable)))
376                               ?!
377                             (if (get (car (car pointer)) 'riece-addon-enabled)
378                                 ?+
379                               ?-))))
380                       (car (car pointer))
381                       (cdr (car pointer))))
382       (put-text-property point (point) 'riece-addon (car (car pointer)))
383       (setq pointer (cdr pointer)))
384     (insert "
385 Symbols in the leftmost column:
386
387    +     The add-on is enabled.
388    -     The add-on is disabled.
389    !     The add-on doesn't support enable/disable operation.
390    ?     The add-on is not insinuated.
391          The add-on is not loaded.
392 ")
393     (insert (substitute-command-keys "
394 Useful keys:
395
396    `\\[riece-command-enable-addon]' to enable the current add-on.
397    `\\[riece-command-disable-addon]' to disable the current add-on.
398    `\\[riece-command-insinuate-addon]' to insinuate the add-on.
399    `\\[riece-command-uninstall-addon]' to uninstall the current add-on.
400    `\\[riece-command-unload-addon]' to unload the current add-on.
401 "))
402     (goto-char (point-min))
403     (pop-to-buffer (current-buffer))
404     (delete-other-windows)))
405
406 (defun riece-addon-list-set-point (addon)
407   (let ((point (point-min)))
408     (while (and (not (eq (get-text-property point 'riece-addon) addon))
409                 (setq point (next-single-property-change point
410                                                          'riece-addon))))
411     (if point
412         (goto-char point))))
413
414 (defun riece-command-enable-addon (addon)
415   (interactive
416    (list
417     (or (if (eq major-mode 'riece-addon-list-mode)
418             (get-text-property (point) 'riece-addon))
419         (intern-soft
420          (completing-read "Add-on: "
421                           (mapcar (lambda (dependency)
422                                     (list (symbol-name (car dependency))))
423                                   riece-addon-dependencies)
424                           (lambda (pointer)
425                             (let ((enabled
426                                    (intern-soft (concat (car pointer)
427                                                         "-enabled"))))
428                               (and enabled
429                                    (null (symbol-value enabled)))))
430                           t)))))
431   (riece-enable-addon addon t)
432   (when (eq major-mode 'riece-addon-list-mode)
433     (riece-command-list-addons)
434     (riece-addon-list-set-point addon)))
435
436 (defun riece-command-disable-addon (addon)
437   (interactive
438    (list
439     (or (if (eq major-mode 'riece-addon-list-mode)
440             (get-text-property (point) 'riece-addon))
441         (intern-soft
442          (completing-read "Add-on: "
443                           (mapcar (lambda (dependency)
444                                     (list (symbol-name (car dependency))))
445                                   riece-addon-dependencies)
446                           (lambda (pointer)
447                             (let ((enabled
448                                    (intern-soft (concat (car pointer)
449                                                         "-enabled"))))
450                               (and enabled
451                                    (symbol-value enabled))))
452                           t)))))
453   (riece-disable-addon addon t)
454   (when (eq major-mode 'riece-addon-list-mode)
455     (riece-command-list-addons)
456     (riece-addon-list-set-point addon)))
457
458 (defun riece-command-insinuate-addon (addon)
459   (interactive
460    (list
461     (or (if (eq major-mode 'riece-addon-list-mode)
462             (get-text-property (point) 'riece-addon))
463         (intern-soft
464          (completing-read "Add-on: "
465                           (mapcar (lambda (dependency)
466                                     (list (symbol-name (car dependency))))
467                                   riece-addon-modules)
468                           (lambda (pointer)
469                             (not (get (car pointer) 'riece-addon-insinuated)))
470                           t)))))
471   (riece-insinuate-addon addon 'ask)
472   (when (eq major-mode 'riece-addon-list-mode)
473     (riece-command-list-addons)
474     (riece-addon-list-set-point addon)))
475
476 (defun riece-command-uninstall-addon (addon)
477   (interactive
478    (list
479     (or (if (eq major-mode 'riece-addon-list-mode)
480             (get-text-property (point) 'riece-addon))
481         (intern-soft
482          (completing-read "Add-on: "
483                           (mapcar (lambda (dependency)
484                                     (list (symbol-name (car dependency))))
485                                   riece-addon-dependencies)
486                           (lambda (pointer)
487                             (get (car pointer) 'riece-addon-insinuated))
488                           t)))))
489   (riece-uninstall-addon addon t)
490   (when (eq major-mode 'riece-addon-list-mode)
491     (riece-command-list-addons)
492     (riece-addon-list-set-point addon)))
493
494 (defun riece-command-unload-addon (addon)
495   (interactive
496    (list
497     (or (if (eq major-mode 'riece-addon-list-mode)
498             (get-text-property (point) 'riece-addon))
499         (intern-soft
500          (completing-read "Add-on: "
501                           (mapcar (lambda (dependency)
502                                     (list (symbol-name (car dependency))))
503                                   riece-addon-dependencies)
504                           (lambda (pointer)
505                             (get (car pointer) 'riece-addon-insinuated))
506                           t)))))
507   (riece-uninstall-addon addon t)
508   (if (get addon 'riece-addon-not-unloadable)
509       (message "Add-on %S is not allowed to unload" addon)
510     (unload-feature addon)
511     (message "Add-on %S is unloaded" addon))
512   (when (eq major-mode 'riece-addon-list-mode)
513     (riece-command-list-addons)
514     (riece-addon-list-set-point addon)))
515
516 (provide 'riece-addon)
517
518 ;;; riece-addon.el ends here