cgit.sxemacs.org Git - packages/blob - xemacs-packages/zenirc/src/zenirc-trigger.el

   1 ;;; zenirc-trigger.el
   2
   3 ;; Copyright (C) 1997 Noah S. Friedman
   4 ;; Copyright (C) 1997, 1998 Per Persson
   5
   6 ;; Author: Noah Friedman <friedman@prep.ai.mit.edu>
   7 ;; Maintainer: pp@sno.pp.se
   8 ;; Keywords: zenirc, extensions, oink
   9 ;; Created: 1997-03-01
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15 ;;
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20 ;;
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program; if not, you can either send email to this
  23 ;; program's maintainer or write to: The Free Software Foundation,
  24 ;; Inc.; 675 Massachusetts Avenue; Cambridge, MA 02139, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Use this package to define "triggers" regexps.
  29 ;; For example, you can define a function /time and specify a regexp that
  30 ;; sends the current time whenever someone asks "what time is it?":
  31 ;;
  32 ;; (zenirc-trigger-register "time" 'current-time-string "what time is it\\?")
  33 ;;
  34 ;; You can also use the /trigger command in the *zenirc* buffer:
  35 ;;
  36 ;; /trigger set time "what time is it\\?" current-time-string
  37 ;;
  38 ;; People have defined more interesting triggers such as horoscopes, zippy
  39 ;; quotes, etc.
  40
  41 ;;; Code:
  42
  43 (require 'zenirc)
  44 (require 'backquote)
  45
  46 (defvar zenirc-trigger-table nil)
  47 (defvar zenirc-command-trigger-hook '(zenirc-command-trigger))
  48
  49 ;; Changing this to NOTICE will generally avoid loops from other clients
  50 ;; that also load this.  But that's less fun.
  51 (defconst zenirc-trigger-response-type "PRIVMSG")
  52
  53 (defun zenirc-trigger-register (name response &optional regexp pass-string)
  54   "Define a trigger named NAME, that runs RESPONSE when REGEXP is seen,
  55 passing the matched-string if PASS-STRING is true.
  56 When a string mathcing REGEXP is detected in a zenirc buffer, the function
  57 RESPONSE is called with no arguments by default, or with the matched string
  58 if PASS-STRING is non-nil.  That function should return a string
  59 which is to be sent to the originator of the message matching REGEXP.
  60 It may instead return a list of strings, in which case each string is
  61 sent as a separate message.
  62
  63 NAME can be used as a key for changing, deleting, activating, and
  64 deactivating the trigger via /trigger subcommands."
  65   (zenirc-trigger-make-command name response)
  66   (and regexp
  67        (zenirc-trigger-set-trigger name regexp response pass-string)))
  68
  69 ;;; Users shouldn't generally need to make use of anything below here.
  70
  71 (defun zenirc-trigger-make-command (name response)
  72   (let* ((symname (format "zenirc-command-%s" name))
  73          (cmdsym (intern symname))
  74          (cmdhook (intern (concat symname "-hook"))))
  75     (zenirc-add-hook cmdhook cmdsym)
  76     (fset cmdsym
  77           (` (lambda (proc victim)
  78                (zenirc-trigger-send-fn-result proc victim '(, response)))))))
  79
  80 (defun zenirc-trigger-set-trigger (name regexp response &optional pass-string)
  81   (and (stringp name)
  82        (setq name (intern name)))
  83   (let ((elt (assq name zenirc-trigger-table)))
  84     (cond (elt
  85            (setcar (nthcdr 1 elt) t)
  86            (setcar (nthcdr 2 elt) regexp)
  87            (setcar (nthcdr 3 elt) response)
  88            (setcar (nthcdr 4 elt) pass-string))
  89           (t
  90            (setq zenirc-trigger-table
  91                  (cons (list name t regexp response pass-string)
  92                        zenirc-trigger-table))))))
  93
  94 ;; Returns nil if the named trigger doesn't exist, t otherwise.
  95 (defun zenirc-trigger-activate (name state)
  96   (and (stringp name) (setq name (intern name)))
  97   (let ((elt (assq name zenirc-trigger-table)))
  98     (cond (elt
  99            (setcar (nthcdr 1 elt) state)
 100            t)
 101           (t nil))))
 102
 103 (defun zenirc-trigger-enable (name)
 104   (zenirc-trigger-activate name t))
 105
 106 (defun zenirc-trigger-disable (name)
 107   (zenirc-trigger-activate name nil))
 108
 109 \f
 110 (defun zenirc-server-PRIVMSG-trigger (proc parsedmsg)
 111   (save-match-data
 112     (let ((case-fold-search t)
 113           (trigger-table zenirc-trigger-table)
 114           regexp fn)
 115       (while trigger-table
 116         (cond ((nth 1 (car trigger-table))
 117                (setq regexp (nth 2 (car trigger-table)))
 118                (and regexp
 119                     (string-match regexp (aref parsedmsg 3))
 120                     (let ((victim (zenirc-trigger-parse-sender parsedmsg))
 121                           (msg (zenirc-trigger-response
 122                                 (nth 3 (car trigger-table))
 123                                 (and (nth 4 (car trigger-table))
 124                                      (match-string 0 (aref parsedmsg 3))))))
 125                       (zenirc-trigger-send-response proc victim msg)))))
 126         (setq trigger-table (cdr trigger-table))))))
 127
 128 (defun zenirc-trigger-parse-sender (parsedmsg)
 129   (let ((from (aref parsedmsg 2)))
 130     (cond ((zenirc-names-equal-p from zenirc-nick)
 131            (zenirc-extract-nick (aref parsedmsg 1)))
 132           (t from))))
 133
 134 (defun zenirc-trigger-response (fn msg)
 135   (cond ((stringp fn) fn)
 136         (t (if msg
 137                (funcall fn msg)
 138              (funcall fn)))))
 139
 140 (defun zenirc-trigger-send-fn-result (proc victim fn &optional msg)
 141   (setq victim (cdr victim))
 142   (cond ((or (null victim)
 143              (string= "" victim))
 144          (setq victim zenirc-current-victim)))
 145   (zenirc-trigger-send-response proc victim (zenirc-trigger-response fn msg)))
 146
 147 (defun zenirc-trigger-send-response (proc victim msg)
 148   (cond ((stringp msg)
 149          (zenirc-message proc 'trigger-sent victim msg)
 150          (process-send-string proc (concat zenirc-trigger-response-type
 151                                            " " victim " :" msg "\n")))
 152         (t
 153          (while msg
 154            (zenirc-message proc 'trigger-sent victim (car msg))
 155            (process-send-string proc
 156                                 (concat zenirc-trigger-response-type
 157                                         " " victim " :" (car msg) "\n"))
 158            (setq msg (cdr msg))))))
 159
 160 \f
 161 ;; Parser for /trigger command.  This figures out the trigger subcommand
 162 ;; and calls the appropriate routine to handle it.
 163 ;; The function dispatched should be named "zenirc-trigger-do-FOO-command",
 164 ;; where FOO is one of `list', `set', `enable', `disable', etc.
 165 ;; With no arguments, lists available subcommands.
 166 (defun zenirc-command-trigger (proc parsedcmd)
 167   (let* ((cmd (zenirc-parse-firstword (cdr parsedcmd)))
 168          (fn (intern-soft (concat "zenirc-trigger-do-" (car cmd) "-command"))))
 169     (cond ((and fn (fboundp fn))
 170            (funcall fn proc cmd))
 171           ((null (car cmd))
 172            (zenirc-message proc 'trigger-subcommands
 173                            (mapconcat 'identity
 174                                       (zenirc-trigger-subcommand-list)
 175                                       ", ")))
 176           (t
 177            (zenirc-message proc 'trigger-command-undefined (car cmd))))))
 178
 179 ;; Returns a list of defined subcommands to /trigger.
 180 (defun zenirc-trigger-subcommand-list ()
 181   (save-match-data
 182     (let* ((prefix "zenirc-trigger-do-")
 183            (suffix "-command")
 184            (re (concat suffix "$")))
 185       (sort (mapcar (function (lambda (s)
 186                                 (substring s (length prefix)
 187                                            (- (length suffix)))))
 188               (all-completions prefix obarray
 189                                (function
 190                                 (lambda (s)
 191                                   (string-match re (symbol-name s))))))
 192             'string-lessp))))
 193
 194 (defun zenirc-trigger-do-list-command (proc args)
 195   (let ((table zenirc-trigger-table))
 196     (zenirc-message proc 'trigger-list-head)
 197     (zenirc-message proc 'trigger-list-line)
 198     (while table
 199       (zenirc-message proc 'trigger-list-item
 200                       (nth 0 (car table))
 201                       (nth 1 (car table))
 202                       (prin1-to-string (nth 2 (car table)))
 203                       (prin1-to-string (nth 3 (car table))))
 204       (setq table (cdr table)))
 205     (zenirc-message proc 'trigger-list-end)))
 206
 207 (defun zenirc-trigger-do-set-command (proc args)
 208   (let* ((parsed1 (zenirc-parse-firstword (cdr args)))
 209          (name (car parsed1))
 210          (parsed2 (read-from-string (cdr parsed1)))
 211          (regexp (car parsed2))
 212          (fn (car (read-from-string (substring (cdr parsed1)
 213                                                (cdr parsed2))))))
 214     (zenirc-trigger-register name fn regexp)
 215     (zenirc-message proc 'trigger-enable name)))
 216
 217 (defun zenirc-trigger-do-delete-command (proc args)
 218   (let ((names (zenirc-parse-words (cdr args)))
 219         (known nil)
 220         (unknown nil)
 221         elt)
 222     (while names
 223       ;; If intern-soft returns nil, assq will return nil.
 224       (setq elt (assq (intern-soft (car names)) zenirc-trigger-table))
 225       (if (null elt)
 226           (setq unknown (cons (car names) unknown))
 227         (setq zenirc-trigger-table (delq elt zenirc-trigger-table))
 228         (setq known (cons (car names) known)))
 229       (setq names (cdr names)))
 230     (and known
 231          (zenirc-message proc 'trigger-deleted (nreverse known)))
 232     (and unknown
 233          (zenirc-message proc trigger-undefined (nreverse unknown)))))
 234
 235 (defun zenirc-trigger-do-enable-command (proc args)
 236   (zenirc-trigger-do-activation proc (cdr args) t))
 237
 238 (defun zenirc-trigger-do-disable-command (proc args)
 239   (zenirc-trigger-do-activation proc (cdr args) nil))
 240
 241 (defun zenirc-trigger-do-activation (proc args state)
 242   (let ((msg (if state 'trigger-enable 'trigger-disable))
 243         (names (zenirc-parse-words args))
 244         (known nil)
 245         (unknown nil))
 246     (while names
 247       (if (zenirc-trigger-activate (car names) state)
 248           (setq known (cons (car names) known))
 249         (setq unknown (cons (car names) unknown)))
 250       (setq names (cdr names)))
 251     (and known
 252          (zenirc-message proc msg (nreverse known)))
 253     (and unknown
 254          (zenirc-message proc trigger-undefined (nreverse unknown)))))
 255
 256 \f
 257 (provide 'zenirc-trigger)
 258
 259 (zenirc-lang-define-catalog 'english
 260   '((trigger-sent      . "[trigger] Sent to %s: %s")
 261     (trigger-enable    . "[info] Triggers enabled: %s")
 262     (trigger-disable   . "[info] Triggers disabled: %s")
 263     (trigger-deleted   . "[info] Triggers deleted: %s")
 264     (trigger-undefined . "[info] Undefined triggers: %s")
 265     (trigger-list-head . "[trigger] Name       On? Regexp          Function")
 266     (trigger-list-line . "[trigger] ----       --- ------          --------")
 267     (trigger-list-item . "[trigger] %-10s %-3s %-15s %s")
 268     (trigger-list-end  . "[trigger] End of list.")
 269     (trigger-subcommands . "[info] Trigger subcommands: %s")
 270     (trigger-command-undefined . "[info] undefined trigger command: %s")))
 271
 272 (zenirc-add-hook 'zenirc-server-PRIVMSG-hook
 273                  'zenirc-server-PRIVMSG-trigger 'append)
 274
 275 ;;; zenirc-trigger.el ends here
 276