lisp/erc/erc-netsplit.el

   1 ;;; erc-netsplit.el --- Reduce JOIN/QUIT messages on netsplits
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
   4
   5 ;; Author: Mario Lang <mlang@delysid.org>
   6 ;; Keywords: comm
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs 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 3, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs 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 ;;; Commentary:
  26
  27 ;; This module hides quit/join messages if a netsplit occurs.
  28 ;; To enable, add the following to your ~/.emacs:
  29 ;; (require 'erc-netsplit)
  30 ;; (erc-netsplit-mode 1)
  31
  32 ;;; Code:
  33
  34 (require 'erc)
  35 (eval-when-compile (require 'cl))
  36
  37 (defgroup erc-netsplit nil
  38   "Netsplit detection tries to automatically figure when a
  39 netsplit happens, and filters the QUIT messages. It also keeps
  40 track of netsplits, so that it can filter the JOIN messages on a netjoin too."
  41   :group 'erc)
  42
  43 ;;;###autoload (autoload 'erc-netsplit-mode "erc-netsplit")
  44 (define-erc-module netsplit nil
  45   "This mode hides quit/join messages if a netsplit occurs."
  46   ((erc-netsplit-install-message-catalogs)
  47    (add-hook 'erc-server-JOIN-functions 'erc-netsplit-JOIN)
  48    (add-hook 'erc-server-MODE-functions 'erc-netsplit-MODE)
  49    (add-hook 'erc-server-QUIT-functions 'erc-netsplit-QUIT)
  50    (add-hook 'erc-timer-hook 'erc-netsplit-timer))
  51   ((remove-hook 'erc-server-JOIN-functions 'erc-netsplit-JOIN)
  52    (remove-hook 'erc-server-MODE-functions 'erc-netsplit-MODE)
  53    (remove-hook 'erc-server-QUIT-functions 'erc-netsplit-QUIT)
  54    (remove-hook 'erc-timer-hook 'erc-netsplit-timer)))
  55
  56 (defcustom erc-netsplit-show-server-mode-changes-flag nil
  57   "Set to t to enable display of server mode changes."
  58   :group 'erc-netsplit
  59   :type 'boolean)
  60
  61 (defcustom erc-netsplit-debug nil
  62   "If non-nil, debug messages will be shown in the
  63 sever buffer."
  64   :group 'erc-netsplit
  65   :type 'boolean)
  66
  67 (defcustom erc-netsplit-regexp
  68   "^[^ @!\"\n]+\\.[^ @!\n]+ [^ @!\n]+\\.[^ @!\"\n]+$"
  69   "This regular expression should match quit reasons produced
  70 by netsplits."
  71   :group 'erc-netsplit
  72   :type 'regexp)
  73
  74 (defcustom erc-netsplit-hook nil
  75   "Run whenever a netsplit is detected the first time.
  76 Args: PROC is the process the netsplit originated from and
  77       SPLIT is the netsplit (e.g. \"server.name.1 server.name.2\")."
  78   :group 'erc-hooks
  79   :type 'hook)
  80
  81 (defcustom erc-netjoin-hook nil
  82   "Run whenever a netjoin is detected the first time.
  83 Args: PROC is the process the netjoin originated from and
  84       SPLIT is the netsplit (e.g. \"server.name.1 server.name.2\")."
  85   :group 'erc-hooks
  86   :type 'hook)
  87
  88 (defvar erc-netsplit-list nil
  89   "This is a list of the form
  90 \((\"a.b.c.d e.f.g\" TIMESTAMP FIRST-JOIN \"nick1\" ... \"nickn\") ...)
  91 where FIRST-JOIN is t or nil, depending on whether or not the first
  92 join from that split has been detected or not.")
  93 (make-variable-buffer-local 'erc-netsplit-list)
  94
  95 (defun erc-netsplit-install-message-catalogs ()
  96   (erc-define-catalog
  97    'english
  98    '((netsplit         . "netsplit: %s")
  99      (netjoin          . "netjoin: %s, %N were split")
 100      (netjoin-done     . "netjoin: All lost souls are back!")
 101      (netsplit-none    . "No netsplits in progress")
 102      (netsplit-wholeft . "split: %s missing: %n %t"))))
 103
 104 (defun erc-netsplit-JOIN (proc parsed)
 105   "Show/don't show rejoins."
 106   (let ((nick (erc-response.sender parsed))
 107         (no-next-hook nil))
 108     (dolist (elt erc-netsplit-list)
 109       (if (member nick (nthcdr 3 elt))
 110           (progn
 111             (if (not (caddr elt))
 112                 (progn
 113                   (erc-display-message
 114                    parsed 'notice (process-buffer proc)
 115                    'netjoin ?s (car elt) ?N (length (nthcdr 3 elt)))
 116                   (setcar (nthcdr 2 elt) t)
 117                   (run-hook-with-args 'erc-netjoin-hook proc (car elt))))
 118             ;; need to remove this nick, perhaps the whole entry here.
 119             ;; Note that by removing the nick now, we can't tell if further
 120             ;; join messages (for other channels) should also be
 121             ;; suppressed.
 122             (if (null (nthcdr 4 elt))
 123                 (progn
 124                   (erc-display-message
 125                    parsed 'notice (process-buffer proc)
 126                    'netjoin-done ?s (car elt))
 127                   (setq erc-netsplit-list (delq elt erc-netsplit-list)))
 128               (delete nick elt))
 129             (setq no-next-hook t))))
 130     no-next-hook))
 131
 132 (defun erc-netsplit-MODE (proc parsed)
 133   "Hide mode changes from servers."
 134   ;; regexp matches things with a . in them, and no ! or @ in them.
 135   (when (string-match "^[^@!\n]+\\.[^@!\n]+$" (erc-response.sender parsed))
 136     (and erc-netsplit-debug
 137          (erc-display-message
 138           parsed 'notice (process-buffer proc)
 139           "[debug] server mode change."))
 140     (not erc-netsplit-show-server-mode-changes-flag)))
 141
 142 (defun erc-netsplit-QUIT (proc parsed)
 143   "Detect netsplits."
 144   (let ((split (erc-response.contents parsed))
 145         (nick (erc-response.sender parsed))
 146         ass)
 147     (when (string-match erc-netsplit-regexp split)
 148       (setq ass (assoc split erc-netsplit-list))
 149       (if ass
 150           ;; element for this netsplit exists already
 151           (progn
 152             (setcdr (nthcdr 2 ass) (cons nick (nthcdr 3 ass)))
 153             (when (caddr ass)
 154               ;; There was already a netjoin for this netsplit, it
 155               ;; seems like the old one didn't get finished...
 156               (erc-display-message
 157                parsed 'notice (process-buffer proc)
 158                'netsplit ?s split)
 159               (setcar (nthcdr 2 ass) t)
 160               (run-hook-with-args 'erc-netsplit-hook proc split)))
 161         ;; element for this netsplit does not yet exist
 162         (setq erc-netsplit-list
 163               (cons (list split
 164                           (erc-current-time)
 165                           nil
 166                           nick)
 167                     erc-netsplit-list))
 168         (erc-display-message
 169          parsed 'notice (process-buffer proc)
 170          'netsplit ?s split)
 171         (run-hook-with-args 'erc-netsplit-hook proc split))
 172       t)))
 173
 174 (defun erc-netsplit-timer (now)
 175   "Clean cruft from `erc-netsplit-list' older than 10 minutes."
 176   (when erc-server-connected
 177     (dolist (elt erc-netsplit-list)
 178       (when (> (erc-time-diff (cadr elt) now) 600)
 179         (when erc-netsplit-debug
 180           (erc-display-message
 181            nil 'notice (current-buffer)
 182            (concat "Netsplit: Removing " (car elt))))
 183         (setq erc-netsplit-list (delq elt erc-netsplit-list))))))
 184
 185 ;;;###autoload
 186 (defun erc-cmd-WHOLEFT ()
 187   "Show who's gone."
 188   (erc-with-server-buffer
 189     (if (null erc-netsplit-list)
 190         (erc-display-message
 191          nil 'notice 'active
 192          'netsplit-none)
 193       (dolist (elt erc-netsplit-list)
 194         (erc-display-message
 195          nil 'notice 'active
 196          'netsplit-wholeft ?s (car elt)
 197          ?n (mapconcat 'erc-extract-nick (nthcdr 3 elt) " ")
 198          ?t (if (caddr elt)
 199                 "(joining)"
 200               "")))))
 201   t)
 202
 203 (defalias 'erc-cmd-WL 'erc-cmd-WHOLEFT)
 204
 205 (provide 'erc-netsplit)
 206
 207 ;;; erc-netsplit.el ends here
 208 ;;
 209 ;; Local Variables:
 210 ;; indent-tabs-mode: t
 211 ;; tab-width: 8
 212 ;; End:
 213
 214 ;; arch-tag: 61a85cb0-7e7b-4312-a4f6-313c7a25a6e8