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