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