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