lisp/erc/erc-netsplit.el

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