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-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     (if (if (eq verbose 'ask)
 239             (y-or-n-p (format "%s will be insinuated.  Continue?"
 240                               (mapconcat #'symbol-name addons ", ")))
 241           verbose)
 242         (while addons
 243           (riece-insinuate-addon-1 (car addons) verbose)
 244           (setq addons (cdr addons))))))
 245
 246 (defun riece-uninstall-addon (addon &optional verbose)
 247   (if (not (get addon 'riece-addon-insinuated))
 248       (if verbose
 249           (message "Add-on %S is not insinuated" addon))
 250     (let ((entry (assq addon riece-addon-dependencies))
 251           (uninstall (intern-soft (concat (symbol-name addon) "-uninstall"))))
 252       (if entry
 253           (if (cdr entry)
 254               (if (= (length (cdr entry)) 1)
 255                   (error "%S depends on %S" (car (cdr entry)) addon)
 256                 (error "%s depend on %S"
 257                        (mapconcat #'symbol-name (cdr entry) ", ")
 258                        addon))
 259             (riece-disable-addon addon verbose)
 260             (if (and uninstall
 261                      (fboundp uninstall))
 262                 (funcall uninstall))
 263             (setq riece-addon-dependencies
 264                   (delq entry riece-addon-dependencies))
 265             (put addon 'riece-addon-insinuated nil)
 266             (setq riece-addons (delq addon riece-addons)
 267                   riece-save-variables-are-dirty t
 268                   riece-addon-dependencies
 269                   (riece-resolve-addons
 270                    (delq addon (mapcar #'car riece-addon-dependencies))))))
 271       (if verbose
 272           (message "Add-on %S is uninstalled" addon)))))
 273
 274 (defun riece-enable-addon (addon &optional verbose)
 275   (unless (get addon 'riece-addon-insinuated)
 276     (error "Add-on %S is not insinuated" addon))
 277   (let ((enable (intern-soft (concat (symbol-name addon) "-enable"))))
 278     (if (or (null enable)
 279             (not (fboundp enable)))
 280         (if verbose
 281             (message "Add-on %S doesn't support enable/disable" addon))
 282       (if (get addon 'riece-addon-enabled)
 283           (if verbose
 284               (message "Add-on %S is already enabled" addon))
 285         (funcall enable)
 286         (put addon 'riece-addon-enabled t)
 287         (if verbose
 288             (message "Add-on %S enabled" addon))))))
 289
 290 (defun riece-disable-addon (addon &optional verbose)
 291   (unless (get addon 'riece-addon-insinuated)
 292     (error "Add-on %S is not insinuated" addon))
 293   (let ((disable (intern-soft (concat (symbol-name addon) "-disable"))))
 294     (if (or (null disable)
 295             (not (fboundp disable)))
 296         (if verbose
 297             (message "Add-on %S doesn't support enable/disable" addon))
 298       (if (get addon 'riece-addon-enabled)
 299           (progn
 300             (funcall disable)
 301             (put addon 'riece-addon-enabled nil)
 302             (if verbose
 303                 (message "Add-on %S disabled" addon)))
 304         (if verbose
 305             (message "Add-on %S is already enabled" addon))))))
 306
 307 (put 'riece-addon-list-mode 'font-lock-defaults
 308      '(riece-addon-list-font-lock-keywords t))
 309
 310 (defun riece-addon-list-mode ()
 311   "Major mode for displaying addon list.
 312 All normal editing commands are turned off."
 313   (kill-all-local-variables)
 314   (buffer-disable-undo)
 315   (setq major-mode 'riece-addon-list-mode
 316         mode-name "AddOns"
 317         mode-line-buffer-identification
 318         (riece-mode-line-buffer-identification '("Riece: %12b"))
 319         truncate-lines t
 320         buffer-read-only t)
 321   (use-local-map riece-addon-list-mode-map)
 322   (make-local-variable 'font-lock-defaults)
 323   (setq font-lock-defaults '(riece-addon-list-font-lock-keywords t))
 324   ;; In XEmacs, auto-initialization of font-lock is not effective
 325   ;; if buffer-file-name is not set.
 326   (font-lock-set-defaults)
 327   (run-hooks 'riece-addon-list-mode-hook))
 328
 329 (defun riece-command-list-addons ()
 330   (interactive)
 331   (set-buffer (riece-get-buffer-create "*AddOn*" 'riece-addon-list-mode))
 332   (riece-addon-list-mode)
 333   (let ((inhibit-read-only t)
 334         buffer-read-only
 335         (pointer riece-addon-dependencies)
 336         module-description-alist
 337         description enable point)
 338     (while pointer
 339       (setq description (intern-soft (concat (symbol-name (car (car pointer)))
 340                                              "-description"))
 341             module-description-alist
 342             (cons (cons (car (car pointer))
 343                         (if (and description
 344                                  (boundp description))
 345                             (symbol-value description)
 346                           "(no description)"))
 347                   module-description-alist)
 348             pointer (cdr pointer)))
 349     (setq pointer riece-addon-modules)
 350     (while pointer
 351       (unless (assq (car (car pointer))
 352                     module-description-alist)
 353         (setq module-description-alist
 354               (cons (car pointer) module-description-alist)))
 355       (setq pointer (cdr pointer)))
 356     (erase-buffer)
 357     (riece-kill-all-overlays)
 358     (setq pointer (sort module-description-alist
 359                         (lambda (entry1 entry2)
 360                           (string-lessp (symbol-name (car entry1))
 361                                         (symbol-name (car entry2))))))
 362     (while pointer
 363       (setq enable (intern-soft (concat (symbol-name (car (car pointer)))
 364                                         "-enable")))
 365       (setq point (point))
 366       (insert (format "%c %-15S %s\n"
 367                       (if (not (featurep (car (car pointer))))
 368                           ?
 369                         (if (not (get (car (car pointer))
 370                                       'riece-addon-insinuated))
 371                             ??
 372                           (if (or (null enable)
 373                                   (not (fboundp enable)))
 374                               ?!
 375                             (if (get (car (car pointer)) 'riece-addon-enabled)
 376                                 ?+
 377                               ?-))))
 378                       (car (car pointer))
 379                       (cdr (car pointer))))
 380       (put-text-property point (point) 'riece-addon (car (car pointer)))
 381       (setq pointer (cdr pointer)))
 382     (insert "
 383 Symbols in the leftmost column:
 384
 385    +     The add-on is enabled.
 386    -     The add-on is disabled.
 387    !     The add-on doesn't support enable/disable operation.
 388    ?     The add-on is not insinuated.
 389          The add-on is not loaded.
 390 ")
 391     (insert (substitute-command-keys "
 392 Useful keys:
 393
 394    `\\[riece-command-enable-addon]' to enable the current add-on.
 395    `\\[riece-command-disable-addon]' to disable the current add-on.
 396    `\\[riece-command-insinuate-addon]' to insinuate the add-on.
 397    `\\[riece-command-uninstall-addon]' to uninstall the current add-on.
 398    `\\[riece-command-unload-addon]' to unload the current add-on.
 399 "))
 400     (goto-char (point-min))
 401     (pop-to-buffer (current-buffer))
 402     (delete-other-windows)))
 403
 404 (defun riece-addon-list-set-point (addon)
 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-enable-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-dependencies)
 422                           (lambda (pointer)
 423                             (let ((enabled
 424                                    (intern-soft (concat (car pointer)
 425                                                         "-enabled"))))
 426                               (and enabled
 427                                    (null (symbol-value enabled)))))
 428                           t)))))
 429   (riece-enable-addon addon t)
 430   (when (eq major-mode 'riece-addon-list-mode)
 431     (riece-command-list-addons)
 432     (riece-addon-list-set-point addon)))
 433
 434 (defun riece-command-disable-addon (addon)
 435   (interactive
 436    (list
 437     (or (if (eq major-mode 'riece-addon-list-mode)
 438             (get-text-property (point) 'riece-addon))
 439         (intern-soft
 440          (completing-read "Add-on: "
 441                           (mapcar (lambda (dependency)
 442                                     (list (symbol-name (car dependency))))
 443                                   riece-addon-dependencies)
 444                           (lambda (pointer)
 445                             (let ((enabled
 446                                    (intern-soft (concat (car pointer)
 447                                                         "-enabled"))))
 448                               (and enabled
 449                                    (symbol-value enabled))))
 450                           t)))))
 451   (riece-disable-addon addon t)
 452   (when (eq major-mode 'riece-addon-list-mode)
 453     (riece-command-list-addons)
 454     (riece-addon-list-set-point addon)))
 455
 456 (defun riece-command-insinuate-addon (addon)
 457   (interactive
 458    (list
 459     (or (if (eq major-mode 'riece-addon-list-mode)
 460             (get-text-property (point) 'riece-addon))
 461         (intern-soft
 462          (completing-read "Add-on: "
 463                           (mapcar (lambda (dependency)
 464                                     (list (symbol-name (car dependency))))
 465                                   riece-addon-modules)
 466                           (lambda (pointer)
 467                             (not (get (car pointer) 'riece-addon-insinuated)))
 468                           t)))))
 469   (riece-insinuate-addon addon 'ask)
 470   (when (eq major-mode 'riece-addon-list-mode)
 471     (riece-command-list-addons)
 472     (riece-addon-list-set-point addon)))
 473
 474 (defun riece-command-uninstall-addon (addon)
 475   (interactive
 476    (list
 477     (or (if (eq major-mode 'riece-addon-list-mode)
 478             (get-text-property (point) 'riece-addon))
 479         (intern-soft
 480          (completing-read "Add-on: "
 481                           (mapcar (lambda (dependency)
 482                                     (list (symbol-name (car dependency))))
 483                                   riece-addon-dependencies)
 484                           (lambda (pointer)
 485                             (get (car pointer) 'riece-addon-insinuated))
 486                           t)))))
 487   (riece-uninstall-addon addon t)
 488   (when (eq major-mode 'riece-addon-list-mode)
 489     (riece-command-list-addons)
 490     (riece-addon-list-set-point addon)))
 491
 492 (defun riece-command-unload-addon (addon)
 493   (interactive
 494    (list
 495     (or (if (eq major-mode 'riece-addon-list-mode)
 496             (get-text-property (point) 'riece-addon))
 497         (intern-soft
 498          (completing-read "Add-on: "
 499                           (mapcar (lambda (dependency)
 500                                     (list (symbol-name (car dependency))))
 501                                   riece-addon-dependencies)
 502                           (lambda (pointer)
 503                             (get (car pointer) 'riece-addon-insinuated))
 504                           t)))))
 505   (riece-uninstall-addon addon t)
 506   (if (get addon 'riece-addon-not-unloadable)
 507       (message "Add-on %S is not allowed to unload" addon)
 508     (unload-feature addon)
 509     (message "Add-on %S is unloaded" addon))
 510   (when (eq major-mode 'riece-addon-list-mode)
 511     (riece-command-list-addons)
 512     (riece-addon-list-set-point addon)))
 513
 514 (provide 'riece-addon)
 515
 516 ;;; riece-addon.el ends here