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