summaryrefslogtreecommitdiff
path: root/elisp/erbot/erbmsg.el
diff options
context:
space:
mode:
Diffstat (limited to 'elisp/erbot/erbmsg.el')
-rw-r--r--elisp/erbot/erbmsg.el583
1 files changed, 583 insertions, 0 deletions
diff --git a/elisp/erbot/erbmsg.el b/elisp/erbot/erbmsg.el
new file mode 100644
index 0000000..4a0f748
--- /dev/null
+++ b/elisp/erbot/erbmsg.el
@@ -0,0 +1,583 @@
+;;; erbmsg.el --- memoserv-esque functions for Erbot
+;; $Id: erbmsg.el,v 1.26 2007/11/23 16:31:59 deego Exp $
+;; Copyright (C) 2004 Sebastian Freundt
+;; Emacs Lisp Archive entry
+;; Filename: erbmsg.el
+;; Package: erbmsg
+;; Authors: Sebastian Freundt <freundt@math.tu-berlin.de>
+;; Keywords: memo, message,
+;; Version: still conceptional
+;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErBot
+;; URL: http://www.emacswiki.org/cgi-bin/wiki.pl?ErbMsg
+;; For latest version:
+
+(defconst erbot-home-page
+ "http://savannah.nongnu.org/projects/erbot")
+(defconst erbmsg-version
+ "Version 0.2 $Revision: 1.26 $")
+
+
+;; This file is NOT (yet) part of GNU Emacs.
+
+;; This is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; This is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+
+;; See also:
+
+;;; Comments:
+
+;; - To automagically save the whole message table with each incoming message
+;; put following to your .erbot:
+;;
+;; (add-hook 'erbmsg-new-msg-post-hook 'erbmsg-regular-dump)
+;;
+;; - To clean up message cookies with every flushed message, add
+;;
+;; (add-hook 'erbmsg-flush-post-hook 'erbmsg-garbage-cleanse-cookies)
+
+
+;;; TODOs that have been done:
+
+;; 2004/06/22:
+;; - added dump routines to dump message hash tables to hard disk
+;; - added routines for restoring from dumped message files
+;; - added interval within erbot does not notify on channel joins
+;; - added erbmsg-new-msg-(pre|post)-hook
+;; 2004/04/09:
+;; - added support for multiple recipients (see fs-memo for syntax)
+;; - abstracted fs-memo stuff to two defuns (erbmsg-memo-parse-msg and erbmsg-memorize-msg)
+;; 2004/04/01:
+;; - added hooks
+;; 2004/03/31:
+;; - store which channel the memo came from
+;; - added garbage collection function (erbmsg-garbage-cleanse-cookies) to
+;; clean up erbmsg-msg-cookie-hash-table from unreferenced cookies
+
+;;; TODO:
+;; - functionality to forget the erbmsg-question-* pile effectively
+;; - save erbmsg-msg-hash-table across sessions
+;; - expire cookies in erbmsg-msg-cookie-hash-table some time (after 3 notifications?)
+
+;;; Data
+
+
+(defvar erbmsg-msg-hash-table (make-hash-table :test 'equal)
+ "This is a hash-table holding all the messages via cookies.")
+
+(defvar erbmsg-internal-msg-cookie nil
+ "Message cookie for internal communication.")
+
+(defvar erbmsg-msg-cookie-hash-table (make-hash-table :test 'equal)
+ "This is the hash-table for message cookies, the actual
+messages are saved here")
+
+(defgroup erbmsg nil
+ "The erbmsg module for erbot"
+ :group 'erbot)
+
+(defcustom erbmsg-default-magic-words nil
+ "List of default magic words for messages with magic words."
+ :group 'erbmsg)
+
+
+;;; dump settings
+
+(defcustom erbmsg-dump-file "~/public_html/data/messages.dump"
+ "File to dump message hash tables to."
+ :group 'erbmsg)
+
+(defcustom erbmsg-auto-restore-message-tables t
+ "Whether to automagically restore contents of `erbmsg-dump-file'."
+ :group 'erbmsg
+ :type 'boolean)
+
+(defcustom erbmsg-auto-dump-message-tables nil
+ "Whether to automagically dump hash tables to `erbmsg-dump-file'."
+ :group 'erbmsg
+ :type 'boolean)
+
+
+
+;;; uncomment this to normalize to UTC
+;;(set-time-zone-rule "UTC0")
+
+(defvar erbmsg-after-load-hook nil
+ "Hook called after `erbmsg' has been loaded.")
+
+(defvar erbmsg-new-msg-pre-hook nil
+ "Hook called before a new message has been posted.
+The raw message is passed as argument.")
+(defvar erbmsg-new-msg-post-hook
+ (when erbmsg-auto-dump-message-tables
+ '(erbmsg-regular-dump))
+ "Hook called after a new message has been posted.
+The parsed message \(split to nicks and actual message text\)
+is passed as argument.")
+(defvar erbmsg-flush-pre-hook nil
+ "Hook called before erbmsg-flush-pending-msgs is called.")
+(defvar erbmsg-flush-post-hook nil
+ "Hook called before erbmsg-flush-pending-msgs is called.")
+
+
+;;; this is too useful to not add it here
+(add-hook 'erbmsg-flush-post-hook 'erbmsg-garbage-cleanse-cookies)
+
+
+;; interface functions
+(defun fs-memo (&rest msg)
+ "Specify your message and the nick to dedicate to here, as in:
+
+#somechan> ,memo somenick hello somenick, don't forget
+
+Allowed syntaxes:
+,memo [to|for] <nick> msg
+,memo [to|for] <nick> <nick> <nick>: msg
+
+Note: magic words are not currently implemented."
+ (or (and erbot-erbmsg-p
+ msg
+ (let* ((msg-raw (erbutils-stringize msg))
+ (nicks+msg (erbmsg-memo-parse-msg msg-raw)))
+ (run-hook-with-args 'erbmsg-new-msg-pre-hook msg-raw)
+ (mapc (lambda (nick+msg)
+ (let* ((nick (car nick+msg))
+ (msg (nth 1 nick+msg)))
+ (erbmsg-memorize-msg nick msg)))
+ nicks+msg)
+ (run-hook-with-args 'erbmsg-new-msg-post-hook nicks+msg)
+ "msg memorized for delivery"))
+ (if msg (format "error: %S NOT parsed") (fs-memos))
+ 'noreply))
+(defalias 'fs-msg-wmw 'fs-memo) ;; just for compatibility
+(defalias 'fs-msg-with-magic-words 'fs-memo)
+
+
+(defun erbmsg-memo-parse-msg (raw-msg)
+ "Parses MSG for any of the allowed memo syntaxes and returns a list
+\(\(nick msg) (nick msg) ...)"
+ (let* ((nick-msg (cond ((string-match "^\\(?:to\\|for\\)?\\b\\(.+\\)\\b:\\(.*\\)" raw-msg)
+ (cons (match-string 1 raw-msg) (match-string 2 raw-msg)))
+ ((string-match "^\\(?:to\\|for\\)?\\(?:\\s-\\|\\b\\)\\(\\S-+\\)\\s-\\(.*\\)" raw-msg)
+ (cons (match-string 1 raw-msg) (match-string 2 raw-msg)))
+ (t nil)))
+ (nicks (split-string (replace-regexp-in-string ",\\|\\band\\b" "" (car nick-msg))))
+ (msg (replace-regexp-in-string "^\\s-+" "" (cdr nick-msg))))
+ (mapcar (lambda (nick)
+ (list nick msg))
+ nicks)))
+;;(erbmsg-memo-parse-msg "hroptatyr and deego: huhu! :)")
+
+(defun erbmsg-memorize-msg (nick msg &optional magic-words)
+ "Memorizes NICKs MSG."
+ (let* ((nicks-ht (or (gethash nick erbmsg-msg-hash-table)
+ (puthash nick
+ (make-hash-table :test 'equal)
+ erbmsg-msg-hash-table)))
+ (cnick fs-nick)
+ (cchan fs-tgt)
+ (ctime (current-time))
+ ;; composition of the new memo
+ (newmsg (vector cnick cchan msg ctime magic-words))
+ (newcookie (erbmsg-generate-msg-cookie newmsg))
+ ;; now memos from that user already in the system
+ (cmsgs (gethash cnick nicks-ht)))
+ (add-to-list 'cmsgs newcookie)
+ (puthash cnick cmsgs nicks-ht)))
+
+
+
+(defun fs-memos (&rest line)
+ "This is redundant but more clean than in `erbmsg-parse'."
+ (and erbot-erbmsg-p
+ (let* ((linecar (car line))
+ (internalp (and erbmsg-internal-msg-cookie
+ (eq linecar ':internal)
+ (eq erbmsg-internal-msg-cookie (cadr line))))
+ (nick (or (and internalp
+ (car (cdr-safe (cdr-safe line))))
+ fs-nick))
+ (fromnicks (and (null internalp)
+ (mapcar (lambda (s) (format "%s" s)) line)))
+ (nicks-ht (gethash nick erbmsg-msg-hash-table))
+ pending-msgs)
+ (and nicks-ht
+ (maphash (lambda (fromnick msg-cookies)
+ (setq pending-msgs
+ (append pending-msgs (or (and (null fromnicks)
+ msg-cookies)
+ (and (member fromnick fromnicks)
+ msg-cookies)))))
+ nicks-ht))
+ (or (and pending-msgs
+ (let ((msg-cookie))
+ (format "erm, %s, %s msgs pending, see them? %s"
+ nick
+ (length pending-msgs)
+ (erbmsg-question `((notice (erbmsg-notice-pending-msgs ,nick ',pending-msgs))
+ (query (erbmsg-query-pending-msgs ,nick ',pending-msgs))
+ (post (erbmsg-post-pending-msgs ,nick ',pending-msgs))
+ (flush (erbmsg-flush-pending-msgs ,nick ',pending-msgs))
+ (no (ignore))
+ (memo-help (erbmsg-help)))
+ nick))))
+ (and (null internalp)
+ (format ":( no msgs for you, %s\n%s" nick
+ (fs-describe "help-memo")))))))
+(defalias 'fs-msg-mymsgs 'fs-memos)
+(defalias 'fs-mymemos 'fs-memos)
+(defalias 'fs-msgs 'fs-msg-mymsgs)
+(defalias 'fs-mymsgs 'fs-msg-mymsgs)
+
+(defun fsi-erbmsg-version (&rest ignore)
+ "Spits out `erbmsg-version'."
+ erbmsg-version)
+(defalias 'fs-msg-version 'fs-erbmsg-version)
+
+
+(defcustom erbmsg-notify-on-join-timeout 2
+ "Interval in seconds to wait between notification on channel joins."
+ :group 'erbmsg)
+
+(defvar erbmsg-last-nicks-join nil
+ "List of nicks with last join time.")
+
+(defun erbmsg-put-alist (item value alist)
+ "Modify ALIST to set VALUE to ITEM.
+If there is a pair whose car is ITEM, replace its cdr by VALUE.
+If there is not such pair, create new pair (ITEM . VALUE) and
+return new alist whose car is the new pair and cdr is ALIST.
+\[tomo's ELIS like function]"
+ (let ((pair (assoc item alist)))
+ (if pair
+ (progn
+ (setcdr pair value)
+ alist)
+ (cons (cons item value) alist)
+ )))
+
+(defun erbmsg-set-alist (symbol item value)
+ "Modify a alist indicated by SYMBOL to set VALUE to ITEM."
+ (or (boundp symbol)
+ (set symbol nil))
+ (set symbol (erbmsg-put-alist item value (symbol-value symbol))))
+
+(defun erbmsg-notify-msg-on-JOIN (process parsed)
+ "Notifies users about left messages
+when joining the channel"
+ (and erbot-erbmsg-p
+ (let* ((usernickhost (if erbot-on-new-erc-p
+ (erc-response.sender parsed)
+ (aref parsed 1)))
+ (channel (if erbot-on-new-erc-p
+ (nth 0 (erc-response.command-args parsed))
+ (aref parsed 2)))
+ (nick (car (erc-parse-user usernickhost)))
+ (last-access (cdr-safe (assoc nick erbmsg-last-nicks-join))))
+ (erbmsg-set-alist 'erbmsg-last-nicks-join nick (current-time))
+ (setq erbmsg-internal-msg-cookie (random))
+ (let* ((msgs (fs-msg-mymsgs :internal erbmsg-internal-msg-cookie nick)))
+ (and msgs
+ (or (null last-access)
+ (> (- (nth 1 (current-time)) (nth 1 last-access))
+ erbmsg-notify-on-join-timeout))
+ (erc-message "PRIVMSG"
+ (format "%s %s"
+ channel
+ msgs)))
+ 'noreply))))
+(if (and (boundp 'erbot-on-new-erc-p) erbot-on-new-erc-p)
+ (add-hook 'erc-server-JOIN-functions 'erbmsg-notify-msg-on-JOIN)
+ (add-hook 'erc-server-JOIN-hook 'erbmsg-notify-msg-on-JOIN))
+
+
+
+(defun erbmsg-parse (msg proc nick tgt localp userinfo)
+ "When having (require 'erbmsg) and (setq erbot-erbmsg-p t)
+this function is called with every message typed.
+
+It checks for `nick' being in `erbmsg-msg-hash-table',
+if so, i.e. `nick' is about to have messages pending for delivery,
+it will be checked here if `nick' says the ~magic words~,
+if that's also the case, the message will be spit out.
+
+Currently this function also plays the role as question handler,
+see erbmsg-question part below :)."
+ (let* ((nicks-ht (gethash nick erbmsg-msg-hash-table))
+ (pending-msgs)
+
+ ;; now the stuff for question handling
+ (nicks-q-ht (gethash nick erbmsg-question-hash-table))
+ (pending-actions))
+
+ ;; erbmsg-question handling
+ (and nicks-q-ht
+ (maphash (lambda (keyword action-forms)
+ (and (string-match (format "\\b%S\\b" keyword)
+ msg)
+ (let ((func (intern (format "fs-%s" keyword))))
+ (and (fboundp func)
+ (funcall func)))))
+ nicks-q-ht))))
+
+
+(defun erbmsg-generate-msg-cookie (message)
+ "Generates a message cookie for `message' and returns it."
+ (let* ((msg-cookie (format "%.4x%.4x"
+ (mod (random) 65536) (mod (random) 65536))))
+ (puthash msg-cookie message erbmsg-msg-cookie-hash-table)
+ msg-cookie))
+
+(defun erbmsg-get-msgs (msg-cookies)
+ "Gets messages by `msg-cookie'."
+ (mapcar (lambda (msg-cookie)
+ (gethash msg-cookie erbmsg-msg-cookie-hash-table))
+ msg-cookies))
+
+
+;; reply functions
+(defun erbmsg-notice-pending-msgs (nick msg-cookies)
+ "NOTICEs all `msgs' to the user `nick'."
+ (erbmsg-send-pending-msgs nick msg-cookies "NOTICE" nick))
+
+(defun erbmsg-query-pending-msgs (nick msg-cookies)
+ "PRIVMSGs all `msgs' to the user `nick'."
+ (erbmsg-send-pending-msgs nick msg-cookies "PRIVMSG" nick))
+
+(defun erbmsg-post-pending-msgs (nick msg-cookies)
+ "Publically post all `msgs' to current channel"
+ (erbmsg-send-pending-msgs nick msg-cookies "PRIVMSG" fs-tgt))
+
+(defun erbmsg-send-pending-msgs (nick msg-cookies &optional method target)
+ "PRIVMSGs all `msgs' to the user `nick',
+instead of PRIVMSG you may specify another sending method."
+ (let ((msgs (erbmsg-get-msgs msg-cookies))
+ (method (or method "PRIVMSG"))
+ (target (or target fs-nick)))
+ (and msgs
+ (mapc (lambda (msg)
+ (or (and msg
+ (let ((msgfrom (aref msg 0))
+ (msgchan (aref msg 1))
+ (msgtext (aref msg 2))
+ (msgtime (aref msg 3)))
+ (erc-message method
+ (format "%s %s@%s %s: %s"
+ target
+ msgfrom
+ msgchan
+ (format-time-string "%D %T (%Z)" msgtime)
+ msgtext))))
+ (erc-message method (format "%s invalid message cookie" target))))
+ msgs))))
+
+(defun erbmsg-flush-pending-msgs (nick msg-cookies)
+ "Flushes all pending messages for user `nick'."
+ (run-hook-with-args 'erbmsg-flush-pre-hook nick msg-cookies)
+ (erbmsg-flush-msg-cookies msg-cookies)
+ (remhash nick erbmsg-msg-hash-table)
+ (remhash nick erbmsg-question-hash-table)
+ (erc-send-message "flushed")
+ (run-hook-with-args 'erbmsg-flush-post-hook nick msg-cookies))
+
+(defun erbmsg-flush-msg-cookie (msg-cookie)
+ "Flushes `msg-cookie'."
+ (remhash msg-cookie erbmsg-msg-cookie-hash-table))
+(defun erbmsg-flush-msg-cookies (msg-cookies)
+ "Flushes a collection of `msg-cookies'."
+ (mapc 'erbmsg-flush-msg-cookie msg-cookies))
+
+
+(defun erbmsg-help (&rest ignore)
+ "Spits out some detour to the wiki help page."
+ (erc-send-message "help? whom to help? see http://www.emacswiki.org/cgi-bin/wiki/ErbMsg"))
+
+
+
+
+
+;; garbage collection
+
+(defun erbmsg-garbage-cleanse-cookies (&rest ignore)
+ "Collects garbage from `erbmsg-msg-cookie-hash-table' when
+there's no referring entry in `erbmsg-msg-hash-table'."
+ (maphash (lambda (cookie-k cookie-v)
+ (let ((cookie cookie-k)
+ (referred))
+ (catch 'ref-exists-p
+ (maphash (lambda (memo-k memo-v)
+ (maphash (lambda (from cookie-list)
+ (and (member cookie cookie-list)
+ (setq referred t)
+ (throw 'ref-exists-p t)))
+ memo-v))
+ erbmsg-msg-hash-table))
+ (unless referred
+ (remhash cookie erbmsg-msg-cookie-hash-table))))
+ erbmsg-msg-cookie-hash-table))
+;; erbmsg-msg-cookie-hash-table
+;; (erbmsg-garbage-cleanse-cookies)
+
+
+
+
+
+;;; just some tricks to create gazillions of msgs w/o IRC
+;; (clrhash erbmsg-msg-hash-table)
+;; (puthash "hroptatyr" (make-hash-table :test 'equal) erbmsg-msg-hash-table)
+;; (puthash "asathor" '("22224444" "33336666") (gethash "hroptatyr" erbmsg-msg-hash-table))
+
+
+
+
+
+
+
+;;; this will get more abstract and move to an own modules soon :)
+(defvar erbmsg-question-hash-table (make-hash-table :test 'equal)
+ "Hash table to hold who may be about to have the choice.")
+
+(defvar erbmsg-question-verbosity nil
+ "Controls how talkative erbot is when being in question mode.")
+
+(defvar erbmsg-question-handler nil
+ "command temporarily bound to certain users.")
+
+(defun erbmsg-question (choices nick)
+ "Declares choices for interactively control erbot's
+more complex tasks.
+
+`choices' is an alist (action action-forms),
+`action-forms' will be eval'd if nick uses the magic word once again."
+ (let* ((nicks-ht (puthash nick (make-hash-table :test 'equal) erbmsg-question-hash-table)))
+ (mapc (lambda (choice)
+ (let* ((magic-word (car choice))
+ (action-forms (cdr choice))
+ (internal-name (intern (format "fs-%s" magic-word))))
+ (and ;;(not (fboundp internal-name))
+ (fset internal-name
+ `(lambda (&rest ignore)
+ (and (erbmsg-question-user-allowed-p fs-nick ',magic-word)
+ (mapc 'eval ',action-forms))
+ (erbmsg-question-user-answer fs-nick ',magic-word))))
+ (puthash magic-word action-forms nicks-ht)))
+ choices)
+ (format "[type %s]"
+ (mapconcat (lambda (choice)
+ (format "%s%s"
+ erbn-char
+ (car choice)))
+ choices "/"))))
+
+;;(symbol-function 'fs-flush)
+
+
+(defun erbmsg-question-user-allowed-p (nick erbot-command)
+ "Tests whether the user `nick' is allowed to use `erbot-command',
+i.e. if the user has been offered such an action."
+ (let* ((nicks-ht (gethash nick erbmsg-question-hash-table))
+ (command-p (and nicks-ht
+ (gethash erbot-command nicks-ht))))
+ (null (null command-p))))
+(defun erbmsg-question-user-answer (nick erbot-command &optional answer)
+ "Tests whether the user `nick' is allowed to use `erbot-command',
+if so return 'noreply, if not return an according answer."
+ (or (and (not (erbmsg-question-user-allowed-p nick erbot-command))
+ 'noreply) ;;; "You are currently not allowed to use this function. :(")
+ 'noreply))
+
+
+;;; dumping code
+;; this code is to make erbot remember messages after restarts
+
+(defun erbmsg-regular-dump (&rest ignore)
+ "Fun wrapper to call `erbmsg-dump-tables'."
+ (interactive)
+ (erbmsg-dump-tables))
+
+(defun erbmsg-dump-tables (&optional file)
+ "Dumps known message hash tables to a buffer in order to save it."
+ (interactive "Ferbmsg dump file: ")
+ (let ((file (or file
+ erbmsg-dump-file)))
+ (with-temp-buffer
+ (mapc (lambda (htable)
+ (insert (format "[%s \n [\n" htable))
+ (maphash
+ (lambda (key val)
+ (insert
+ (format " [%S %s]\n" key
+ (cond
+ ((hash-table-p val)
+ (let (valstring)
+ (maphash
+ (lambda (k2 v2)
+ (setq valstring
+ (format "%s[%S %S]"
+ (or valstring "") k2 v2)))
+ val)
+ (format "(%s)" valstring)))
+ (t (format "%S" val))))))
+ (eval htable))
+ (insert (format " ]\n]\n")))
+ '(erbmsg-msg-hash-table erbmsg-msg-cookie-hash-table))
+ (write-file erbmsg-dump-file))))
+
+(defun erbmsg-restore-tables (&optional file)
+ "Restores known message hash tables from FILE or `erbmsg-dump-file'."
+ (interactive "ferbmsg dump file: ")
+ (let* ((file (or file
+ erbmsg-dump-file))
+ (file-vector
+ (and (file-readable-p file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (eval (erbn-read (format "(setq file-vector '(%s))"
+ (erbutils-buffer-string))))))))
+ (mapvector
+ (lambda (tablevector)
+ (let ((table (aref tablevector 0))
+ (vector (aref tablevector 1)))
+ (mapvector
+ (lambda (keyval)
+ (let ((key (aref keyval 0))
+ (val (aref keyval 1)))
+ (cond ((listp val)
+ (let ((nickht (make-hash-table :test 'equal)))
+ (mapc
+ (lambda (htvec)
+ (let ((k2 (aref htvec 0))
+ (v2 (aref htvec 1)))
+ (puthash k2 v2 nickht)))
+ val)
+ (puthash key nickht (eval table))))
+ (t (puthash key val (eval table))))))
+ vector)))
+ file-vector)))
+
+(when (and erbot-erbmsg-p
+ erbmsg-auto-restore-message-tables
+ ;;(eq (hash-table-count erbmsg-msg-hash-table) 0)
+ )
+ (erbmsg-restore-tables))
+
+
+(provide 'erbmsg)
+
+;;; erbmsg.el ends here
+
+;; Local variables:
+;; indent-tab-mode: nil
+;; End:
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-17 10:52:13 +0000