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
  32 (defgroup riece-addon-list nil
  33   "Add-on listing."
  34   :tag "Addon list"
  35   :prefix "riece-addon-list-"
  36   :group 'riece)
  37
  38 (defgroup riece-addon-list-faces nil
  39   "Faces for riece-addon-list-mode."
  40   :tag "Faces"
  41   :prefix "riece-addon-list-"
  42   :group 'riece-addon-list)
  43
  44 (defface riece-addon-list-enabled-face
  45   '((((class color) (background dark))
  46      (:foreground "PaleTurquoise" :bold t))
  47     (t
  48      (:bold t)))
  49   "Face used for displaying the enabled addon."
  50   :group 'riece-addon-list-faces)
  51 (defvar riece-addon-list-enabled-face 'riece-addon-list-enabled-face)
  52
  53 (defface riece-addon-list-disabled-face
  54   '((((class color) (background dark))
  55      (:foreground "PaleTurquoise" :italic t))
  56     (t
  57      (:italic t)))
  58   "Face used for displaying the disabled addon."
  59   :group 'riece-addon-list-faces)
  60 (defvar riece-addon-list-disabled-face 'riece-addon-list-disabled-face)
  61
  62 (defface riece-addon-list-unsupported-face
  63   '((((class color) (background dark))
  64      (:foreground "PaleTurquoise"))
  65     (t
  66      ()))
  67   "Face used for displaying the unsupported addon."
  68   :group 'riece-addon-list-faces)
  69 (defvar riece-addon-list-unsupported-face 'riece-addon-list-unsupported-face)
  70
  71 (defface riece-addon-list-unknown-face
  72   '((t
  73      (:foreground "red")))
  74   "Face used for displaying the unknown addon."
  75   :group 'riece-addon-list-faces)
  76 (defvar riece-addon-list-unknown-face 'riece-addon-list-unknown-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-unsupported-face)
  95     (?? . riece-addon-list-unknown-face))
  96   "An alist mapping marks on riece-addon-list-buffer to faces."
  97   :type 'list
  98   :group 'riece-addon-list)
  99
 100 (defcustom riece-addon-list-font-lock-keywords
 101   '(("^\\([-+!?] [^:]+\\): \\(.*\\)"
 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 (defvar riece-addon-list-mode-map
 110   (let ((keymap (make-sparse-keymap)))
 111     (define-key keymap "+" 'riece-command-enable-addon)
 112     (define-key keymap "-" 'riece-command-disable-addon)
 113     (define-key keymap "n" 'next-line)
 114     (define-key keymap "p" 'previous-line)
 115     (define-key keymap " " 'scroll-up)
 116     (define-key keymap [delete] 'scroll-down)
 117     (define-key keymap "q" 'bury-buffer)
 118     keymap))
 119
 120 (defun riece-load-and-build-addon-dependencies (addons)
 121   (let ((load-path (cons riece-addon-directory load-path))
 122         dependencies)
 123     (while addons
 124       (require (car addons))            ;error will be reported here
 125       (let* ((requires
 126               (funcall (or (intern-soft
 127                             (concat (symbol-name (car addons)) "-requires"))
 128                            #'ignore)))
 129              (pointer requires)
 130              entry)
 131         ;; Increment succs' pred count.
 132         (if (setq entry (assq (car addons) dependencies))
 133             (setcar (cdr entry) (+ (length requires) (nth 1 entry)))
 134           (setq dependencies (cons (list (car addons) (length requires))
 135                                    dependencies)))
 136         ;; Merge pred's succs.
 137         (while pointer
 138           (if (setq entry (assq (car pointer) dependencies))
 139               (setcdr (cdr entry) (cons (car addons) (nthcdr 2 entry)))
 140             (setq dependencies (cons (list (car pointer) 0 (car addons))
 141                                      dependencies)))
 142           (setq pointer (cdr pointer))))
 143       (setq addons (cdr addons)))
 144     dependencies))
 145
 146 (defun riece-sort-addon-dependencies (dependencies)
 147   (let ((pointer dependencies)
 148         addons queue)
 149     (while pointer
 150       (if (zerop (nth 1 (car pointer)))
 151           (setq dependencies (delq (car pointer) dependencies)
 152                 queue (cons (car pointer) queue)))
 153       (setq pointer (cdr pointer)))
 154     (while queue
 155       (setq addons (cons (cons (car (car queue)) (nthcdr 2 (car queue)))
 156                          addons)
 157             pointer (nthcdr 2 (car queue)))
 158       (while pointer
 159         (let* ((entry (assq (car pointer) dependencies))
 160                (count (1- (nth 1 entry))))
 161           (if (zerop count)
 162               (setq dependencies (delq entry dependencies)
 163                     queue (nconc queue (list entry)))
 164             (setcar (cdr entry) count)))
 165         (setq pointer (cdr pointer)))
 166       (setq queue (cdr queue)))
 167     (if dependencies
 168         (error "Circular add-on dependency found: %S" dependencies))
 169     (nreverse addons)))
 170
 171 (defun riece-resolve-addons (addons)
 172   ;; Add files in riece-addon-directory to addons.
 173   (if (file-directory-p riece-addon-directory)
 174       (setq addons (nconc
 175                     addons
 176                     (mapcar
 177                      (lambda (name)
 178                        (unless (file-directory-p
 179                                 (expand-file-name name riece-addon-directory))
 180                          (intern (file-name-sans-extension name))))
 181                      (directory-files riece-addon-directory nil "\\`[^.]")))))
 182   ;; Sort & uniquify.
 183   (setq addons (sort addons (lambda (symbol1 symbol2)
 184                               (string-lessp (symbol-name symbol1)
 185                                             (symbol-name symbol2)))))
 186   (let ((pointer addons))
 187     (while pointer
 188       (if (memq (car pointer) (cdr pointer))
 189           (setcar pointer nil))
 190       (setq pointer (cdr pointer)))
 191     (delq nil addons))
 192   ;; Build & resolve dependencies.
 193   (riece-sort-addon-dependencies
 194    (riece-load-and-build-addon-dependencies addons)))
 195
 196 (defun riece-insinuate-addon (addon &optional verbose)
 197   (if (get addon 'riece-addon-insinuated)
 198       (if verbose
 199           (message "Add-on %S is already insinuated" addon))
 200     (funcall (intern (concat (symbol-name addon) "-insinuate")))
 201     (put addon 'riece-addon-insinuated t)
 202     (if verbose
 203         (message "Add-on %S is insinuated" addon))))
 204
 205 (defun riece-uninstall-addon (addon &optional verbose)
 206   (if (not (get addon 'riece-addon-insinuated))
 207       (if verbose
 208           (message "Add-on %S is not insinuated" addon))
 209     (let ((entry (assq addon riece-addon-dependencies))
 210           (enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 211       (if entry
 212           (if (cdr entry)
 213               (if (= (length (cdr entry)) 1)
 214                   (error "%S depends %S" (car (cdr entry)) addon)
 215                 (error "%s depends %S" (mapconcat #'identity (cdr entry) ",")
 216                        addon))
 217             (if (and enabled
 218                      (symbol-value enabled))
 219                 (riece-disable-addon addon verbose))
 220             (funcall (or (intern-soft (concat (symbol-name addon)
 221                                               "-uninstall"))
 222                          #'ignore))
 223             (setq riece-addon-dependencies
 224                   (delq entry riece-addon-dependencies))
 225             (put addon 'riece-addon-insinuated nil)))
 226       (if verbose
 227           (message "Add-on %S is uninstalled" addon)))))
 228
 229 (defun riece-enable-addon (addon &optional verbose)
 230   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 231     (if (null enabled)
 232         (if verbose
 233             (message "Add-on %S doesn't support enable/disable" addon))
 234       (if (symbol-value enabled)
 235           (if verbose
 236               (message "Add-on %S is already enabled" addon))
 237         (funcall (intern (concat (symbol-name addon) "-enable")))
 238         (if verbose
 239             (message "Add-on %S enabled" addon))))))
 240
 241 (defun riece-disable-addon (addon &optional verbose)
 242   (let ((enabled (intern-soft (concat (symbol-name addon) "-enabled"))))
 243     (if (null enabled)
 244         (if verbose
 245             (message "Add-on %S doesn't support enable/disable" addon))
 246       (if (symbol-value enabled)
 247           (progn
 248             (funcall (intern (concat (symbol-name addon) "-disable")))
 249             (if verbose
 250                 (message "Add-on %S disabled" addon)))
 251         (if verbose
 252             (message "Add-on %S is already enabled" addon))))))
 253
 254 (put 'riece-addon-list-mode 'font-lock-defaults
 255      '(riece-addon-list-font-lock-keywords t))
 256
 257 (defun riece-addon-list-mode ()
 258   "Major mode for displaying addon list.
 259 All normal editing commands are turned off."
 260   (kill-all-local-variables)
 261   (buffer-disable-undo)
 262   (setq major-mode 'riece-addon-list-mode
 263         mode-name "AddOns"
 264         mode-line-buffer-identification
 265         (riece-mode-line-buffer-identification '("Riece: %12b"))
 266         truncate-lines t
 267         buffer-read-only t)
 268   (use-local-map riece-addon-list-mode-map)
 269   (make-local-variable 'font-lock-defaults)
 270   (setq font-lock-defaults '(riece-addon-list-font-lock-keywords t))
 271   ;; In XEmacs, auto-initialization of font-lock is not effective
 272   ;; if buffer-file-name is not set.
 273   (font-lock-set-defaults)
 274   (run-hooks 'riece-addon-list-mode-hook))
 275
 276 (defun riece-command-list-addons ()
 277   (interactive)
 278   (set-buffer (riece-get-buffer-create "*AddOns*" 'riece-addon-list-mode))
 279   (riece-addon-list-mode)
 280   (let ((inhibit-read-only t)
 281         buffer-read-only
 282         (pointer (sort (copy-sequence riece-addon-dependencies)
 283                        (lambda (dependency1 dependency2)
 284                          (string-lessp (symbol-name (car dependency1))
 285                                        (symbol-name (car dependency2))))))
 286         enabled description point)
 287     (erase-buffer)
 288     (riece-kill-all-overlays)
 289     (while pointer
 290       (setq enabled (intern-soft (concat (symbol-name (car (car pointer)))
 291                                          "-enabled"))
 292             description (intern-soft (concat (symbol-name (car (car pointer)))
 293                                              "-description")))
 294       (setq point (point))
 295       (insert (format "%c %S: %s\n"
 296                       (if (not (featurep (car (car pointer))))
 297                           ??
 298                         (if (null enabled)
 299                             ?!
 300                           (if (symbol-value enabled)
 301                               ?+
 302                             ?-)))
 303                       (car (car pointer))
 304                       (if description
 305                           (symbol-value description)
 306                         "(no description)")))
 307       (put-text-property point (point) 'riece-addon (car (car pointer)))
 308       (setq pointer (cdr pointer)))
 309     (insert "
 310 Symbols in the leftmost column:
 311
 312   +     The add-on is enabled.
 313   -     The add-on is disabled.
 314   !     The add-on doesn't support enable/disable operation.
 315   ?     The add-on status is unknown.
 316 ")
 317     (insert (substitute-command-keys "
 318 Useful keys:
 319
 320   `\\[riece-command-enable-addon]' to enable the current add-on.
 321   `\\[riece-command-disable-addon]' to disable the current add-on.
 322 "))
 323     (goto-char (point-min))
 324     (pop-to-buffer (current-buffer))
 325     (delete-other-windows)))
 326
 327 (defun riece-command-enable-addon (addon)
 328   (interactive
 329    (list
 330     (or (if (eq major-mode 'riece-addon-list-mode)
 331             (get-text-property (point) 'riece-addon))
 332         (intern-soft
 333          (completing-read "Add-on: "
 334                           (mapcar (lambda (dependency)
 335                                     (list (symbol-name (car dependency))))
 336                                   riece-addon-dependencies)
 337                           (lambda (pointer)
 338                             (let ((enabled
 339                                    (intern-soft (concat (car pointer)
 340                                                         "-enabled"))))
 341                               (and enabled
 342                                    (null (symbol-value enabled)))))
 343                           t)))))
 344   (riece-enable-addon addon t)
 345   (when (eq major-mode 'riece-addon-list-mode)
 346     (riece-command-list-addons)
 347     (let ((point (point-min)))
 348       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 349                   (setq point (next-single-property-change point
 350                                                            'riece-addon))))
 351       (if point
 352           (goto-char point)))))
 353
 354 (defun riece-command-disable-addon (addon)
 355   (interactive
 356    (list
 357     (or (if (eq major-mode 'riece-addon-list-mode)
 358             (get-text-property (point) 'riece-addon))
 359         (intern-soft
 360          (completing-read "Add-on: "
 361                           (mapcar (lambda (dependency)
 362                                     (list (symbol-name (car dependency))))
 363                                   riece-addon-dependencies)
 364                           (lambda (pointer)
 365                             (let ((enabled
 366                                    (intern-soft (concat (car pointer)
 367                                                         "-enabled"))))
 368                               (and enabled
 369                                    (symbol-value enabled))))
 370                           t)))))
 371   (riece-disable-addon addon t)
 372   (when (eq major-mode 'riece-addon-list-mode)
 373     (riece-command-list-addons)
 374     (let ((point (point-min)))
 375       (while (and (not (eq (get-text-property point 'riece-addon) addon))
 376                   (setq point (next-single-property-change point
 377                                                            'riece-addon))))
 378       (if point
 379           (goto-char point)))))
 380
 381 (provide 'riece-addon)
 382
 383 ;;; riece-addon.el ends here