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