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