lisp/net/rcirc.el

   1 ;;; rcirc.el --- default, simple IRC client.
   2
   3 ;; Copyright (C) 2005, 2006 Free Software Foundation, Inc.
   4
   5 ;; Author: Ryan Yeske
   6 ;; URL: http://www.nongnu.org/rcirc
   7 ;; Keywords: comm
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; This file 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 file 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; Internet Relay Chat (IRC) is a form of instant communication over
  29 ;; the Internet. It is mainly designed for group (many-to-many)
  30 ;; communication in discussion forums called channels, but also allows
  31 ;; one-to-one communication.
  32
  33 ;; Rcirc has simple defaults and clear and consistent behaviour.
  34 ;; Message arrival timestamps, activity notification on the modeline,
  35 ;; message filling, nick completion, and keepalive pings are all
  36 ;; enabled by default, but can easily be adjusted or turned off.  Each
  37 ;; discussion takes place in its own buffer and there is a single
  38 ;; server buffer per connection.
  39
  40 ;; Open a new irc connection with:
  41 ;; M-x irc RET
  42
  43 ;;; Code:
  44
  45 (require 'ring)
  46 (require 'time-date)
  47 (eval-when-compile (require 'cl))
  48
  49 (defgroup rcirc nil
  50   "Simple IRC client."
  51   :version "22.1"
  52   :prefix "rcirc"
  53   :group 'applications)
  54
  55 (defcustom rcirc-server "irc.freenode.net"
  56   "The default server to connect to."
  57   :type 'string
  58   :group 'rcirc)
  59
  60 (defcustom rcirc-port 6667
  61   "The default port to connect to."
  62   :type 'integer
  63   :group 'rcirc)
  64
  65 (defcustom rcirc-nick (user-login-name)
  66   "Your nick."
  67   :type 'string
  68   :group 'rcirc)
  69
  70 (defcustom rcirc-user-name (user-login-name)
  71   "Your user name sent to the server when connecting."
  72   :type 'string
  73   :group 'rcirc)
  74
  75 (defcustom rcirc-user-full-name (if (string= (user-full-name) "")
  76                                  rcirc-user-name
  77                                (user-full-name))
  78   "The full name sent to the server when connecting."
  79   :type 'string
  80   :group 'rcirc)
  81
  82 (defcustom rcirc-startup-channels-alist '(("^irc.freenode.net$" "#emacs"))
  83   "Alist of channels to join at startup.
  84 Each element looks like (SERVER-REGEXP . CHANNEL-LIST)."
  85   :type '(alist :key-type string :value-type (repeat string))
  86   :group 'rcirc)
  87
  88 (defcustom rcirc-fill-flag t
  89   "*Non-nil means line-wrap messages printed in channel buffers."
  90   :type 'boolean
  91   :group 'rcirc)
  92
  93 (defcustom rcirc-fill-column nil
  94   "*Column beyond which automatic line-wrapping should happen.
  95 If nil, use value of `fill-column'.  If 'frame-width, use the
  96 maximum frame width."
  97   :type '(choice (const :tag "Value of `fill-column'")
  98                  (const :tag "Full frame width" frame-width)
  99                  (integer :tag "Number of columns"))
 100   :group 'rcirc)
 101
 102 (defcustom rcirc-fill-prefix nil
 103   "*Text to insert before filled lines.
 104 If nil, calculate the prefix dynamically to line up text
 105 underneath each nick."
 106   :type '(choice (const :tag "Dynamic" nil)
 107                  (string :tag "Prefix text"))
 108   :group 'rcirc)
 109
 110 (defvar rcirc-ignore-buffer-activity-flag nil
 111   "If non-nil, ignore activity in this buffer.")
 112 (make-variable-buffer-local 'rcirc-ignore-buffer-activity-flag)
 113
 114 (defcustom rcirc-time-format "%H:%M "
 115   "*Describes how timestamps are printed.
 116 Used as the first arg to `format-time-string'."
 117   :type 'string
 118   :group 'rcirc)
 119
 120 (defcustom rcirc-input-ring-size 1024
 121   "*Size of input history ring."
 122   :type 'integer
 123   :group 'rcirc)
 124
 125 (defcustom rcirc-read-only-flag t
 126   "*Non-nil means make text in IRC buffers read-only."
 127   :type 'boolean
 128   :group 'rcirc)
 129
 130 (defcustom rcirc-buffer-maximum-lines nil
 131   "*The maximum size in lines for rcirc buffers.
 132 Channel buffers are truncated from the top to be no greater than this
 133 number.  If zero or nil, no truncating is done."
 134   :type '(choice (const :tag "No truncation" nil)
 135                  (integer :tag "Number of lines"))
 136   :group 'rcirc)
 137
 138 (defcustom rcirc-authinfo nil
 139   "List of authentication passwords.
 140 Each element of the list is a list with a SERVER-REGEXP string
 141 and a method symbol followed by method specific arguments.
 142
 143 The valid METHOD symbols are `nickserv', `chanserv' and
 144 `bitlbee'.
 145
 146 The required ARGUMENTS for each METHOD symbol are:
 147   `nickserv': NICK PASSWORD
 148   `chanserv': NICK CHANNEL PASSWORD
 149   `bitlbee': NICK PASSWORD
 150
 151 Example:
 152  ((\"freenode\" nickserv \"bob\" \"p455w0rd\")
 153   (\"freenode\" chanserv \"bob\" \"#bobland\" \"passwd99\")
 154   (\"bitlbee\" bitlbee \"robert\" \"sekrit\"))"
 155   :type '(alist :key-type (string :tag "Server")
 156                 :value-type (choice (list :tag "NickServ"
 157                                           (const nickserv)
 158                                           (string :tag "Nick")
 159                                           (string :tag "Password"))
 160                                     (list :tag "ChanServ"
 161                                           (const chanserv)
 162                                           (string :tag "Nick")
 163                                           (string :tag "Channel")
 164                                           (string :tag "Password"))
 165                                     (list :tag "BitlBee"
 166                                           (const bitlbee)
 167                                           (string :tag "Nick")
 168                                           (string :tag "Password"))))
 169   :group 'rcirc)
 170
 171 (defcustom rcirc-auto-authenticate-flag t
 172   "*Non-nil means automatically send authentication string to server.
 173 See also `rcirc-authinfo'."
 174   :type 'boolean
 175   :group 'rcirc)
 176
 177 (defcustom rcirc-prompt "> "
 178   "Prompt string to use in IRC buffers.
 179
 180 The following replacements are made:
 181 %n is your nick.
 182 %s is the server.
 183 %t is the buffer target, a channel or a user.
 184
 185 Setting this alone will not affect the prompt;
 186 use either M-x customize or also call `rcirc-update-prompt'."
 187   :type 'string
 188   :set 'rcirc-set-changed
 189   :initialize 'custom-initialize-default
 190   :group 'rcirc)
 191
 192 (defcustom rcirc-ignore-list ()
 193   "List of ignored nicks.
 194 Use /ignore to list them, use /ignore NICK to add or remove a nick."
 195   :type '(repeat string)
 196   :group 'rcirc)
 197
 198 (defcustom rcirc-nick-abbrevs nil
 199   "List of short replacements for printing nicks."
 200   :type '(alist :key-type (string :tag "Nick")
 201                 :value-type (string :tag "Abbrev"))
 202   :group 'rcirc)
 203
 204 (defvar rcirc-ignore-list-automatic ()
 205   "List of ignored nicks added to `rcirc-ignore-list' because of renaming.
 206 When an ignored person renames, their nick is added to both lists.
 207 Nicks will be removed from the automatic list on follow-up renamings or
 208 parts.")
 209
 210 (defcustom rcirc-print-hooks nil
 211   "Hook run after text is printed.
 212 Called with 5 arguments, PROCESS, SENDER, RESPONSE, TARGET and TEXT."
 213   :type 'hook
 214   :group 'rcirc)
 215
 216 (defcustom rcirc-always-use-server-buffer-flag nil
 217   "Non-nil means messages without a channel target will go to the server buffer."
 218   :type 'boolean
 219   :group 'rcirc)
 220
 221 (defvar rcirc-prompt-start-marker nil)
 222 (defvar rcirc-prompt-end-marker nil)
 223
 224 (defvar rcirc-nick-table nil)
 225
 226 (defvar rcirc-nick-syntax-table
 227   (let ((table (make-syntax-table text-mode-syntax-table)))
 228     (mapc (lambda (c) (modify-syntax-entry c "w" table))
 229           "[]\\`_^{|}-")
 230     (modify-syntax-entry ?' "_" table)
 231     table)
 232   "Syntax table which includes all nick characters as word constituents.")
 233
 234 ;; each process has an alist of (target . buffer) pairs
 235 (defvar rcirc-buffer-alist nil)
 236
 237 (defvar rcirc-activity nil
 238   "List of channels with unviewed activity.")
 239
 240 (defvar rcirc-activity-string ""
 241   "String displayed in modeline representing `rcirc-activity'.")
 242 (put 'rcirc-activity-string 'risky-local-variable t)
 243
 244 (defvar rcirc-process nil
 245   "The server process associated with this buffer.")
 246
 247 (defvar rcirc-target nil
 248   "The channel or user associated with this buffer.")
 249
 250 (defvar rcirc-urls nil
 251   "List of urls seen in the current buffer.")
 252
 253 (defvar rcirc-keepalive-seconds 60
 254   "Number of seconds between keepalive pings.")
 255
 256 (defconst rcirc-id-string (concat "rcirc on GNU Emacs " emacs-version))
 257 \f
 258 (defvar rcirc-startup-channels nil)
 259 ;;;###autoload
 260 (defun rcirc (arg)
 261   "Connect to IRC.
 262 If ARG is non-nil, prompt for a server to connect to."
 263   (interactive "P")
 264   (if arg
 265       (let* ((server (read-string "IRC Server: " rcirc-server))
 266              (port (read-string "IRC Port: " (number-to-string rcirc-port)))
 267              (nick (read-string "IRC Nick: " rcirc-nick))
 268              (channels (split-string
 269                         (read-string "IRC Channels: "
 270                                      (mapconcat 'identity
 271                                                 (rcirc-startup-channels server)
 272                                                 " "))
 273                         "[, ]+" t)))
 274         (rcirc-connect server port nick rcirc-user-name rcirc-user-full-name
 275                        channels))
 276     ;; make new connection using defaults unless already connected to
 277     ;; the default rcirc-server
 278     (let ((default-server (default-value 'rcirc-server))
 279           connected)
 280       (dolist (p (rcirc-process-list))
 281         (when (string= default-server (process-name p))
 282           (setq connected p)))
 283       (if (not connected)
 284           (rcirc-connect rcirc-server rcirc-port rcirc-nick
 285                          rcirc-user-name rcirc-user-full-name
 286                          (rcirc-startup-channels rcirc-server))
 287         (switch-to-buffer (process-buffer connected))
 288         (message "Connected to %s" rcirc-server)))))
 289
 290 ;;;###autoload
 291 (defalias 'irc 'rcirc)
 292
 293 \f
 294 (defvar rcirc-process-output nil)
 295 (defvar rcirc-topic nil)
 296 (defvar rcirc-keepalive-timer nil)
 297 (defvar rcirc-last-server-message-time nil)
 298 (defun rcirc-connect (server port nick user-name full-name startup-channels)
 299   (add-hook 'window-configuration-change-hook
 300             'rcirc-window-configuration-change)
 301
 302   (save-excursion
 303     (message "Connecting to %s..." server)
 304     (let* ((inhibit-eol-conversion)
 305            (port-number (if (stringp port)
 306                             (string-to-number port)
 307                           port))
 308            (process (open-network-stream server nil server port-number)))
 309       ;; set up process
 310       (set-process-coding-system process 'raw-text 'raw-text)
 311       (set-process-filter process 'rcirc-filter)
 312       (switch-to-buffer (rcirc-generate-new-buffer-name process nil))
 313       (set-process-buffer process (current-buffer))
 314       (set-process-sentinel process 'rcirc-sentinel)
 315       (rcirc-mode process nil)
 316       (make-local-variable 'rcirc-buffer-alist)
 317       (setq rcirc-buffer-alist nil)
 318       (make-local-variable 'rcirc-nick-table)
 319       (setq rcirc-nick-table (make-hash-table :test 'equal))
 320       (make-local-variable 'rcirc-server)
 321       (setq rcirc-server server)
 322       (make-local-variable 'rcirc-nick)
 323       (setq rcirc-nick nick)
 324       (make-local-variable 'rcirc-process-output)
 325       (setq rcirc-process-output nil)
 326       (make-local-variable 'rcirc-startup-channels)
 327       (setq rcirc-startup-channels startup-channels)
 328       (make-local-variable 'rcirc-last-server-message-time)
 329       (setq rcirc-last-server-message-time (current-time))
 330
 331       ;; identify
 332       (rcirc-send-string process (concat "NICK " nick))
 333       (rcirc-send-string process (concat "USER " user-name
 334                                       " hostname servername :"
 335                                       full-name))
 336
 337       ;; setup ping timer if necessary
 338       (unless rcirc-keepalive-timer
 339         (setq rcirc-keepalive-timer
 340               (run-at-time 0 rcirc-keepalive-seconds 'rcirc-keepalive)))
 341
 342       (message "Connecting to %s...done" server)
 343
 344       ;; return process object
 345       process)))
 346
 347 (defmacro with-rcirc-process-buffer (process &rest body)
 348   (declare (indent 1) (debug t))
 349   `(with-current-buffer (process-buffer ,process)
 350      ,@body))
 351
 352 (defun rcirc-keepalive ()
 353   "Send keep alive pings to active rcirc processes.
 354 Kill processes that have not received a server message since the
 355 last ping."
 356   (if (rcirc-process-list)
 357       (mapc (lambda (process)
 358               (with-rcirc-process-buffer process
 359                 (if (> (cadr (time-since rcirc-last-server-message-time))
 360                        rcirc-keepalive-seconds)
 361                     (kill-process process)
 362                   (rcirc-send-string process (concat "PING " rcirc-server)))))
 363             (rcirc-process-list))
 364     (cancel-timer rcirc-keepalive-timer)
 365     (setq rcirc-keepalive-timer nil)))
 366
 367 (defvar rcirc-debug-buffer " *rcirc debug*")
 368 (defvar rcirc-debug-flag nil
 369   "If non-nil, write information to `rcirc-debug-buffer'.")
 370 (defun rcirc-debug (process text)
 371   "Add an entry to the debug log including PROCESS and TEXT.
 372 Debug text is written to `rcirc-debug-buffer' if `rcirc-debug-flag'
 373 is non-nil."
 374   (when rcirc-debug-flag
 375     (save-excursion
 376       (save-window-excursion
 377         (set-buffer (get-buffer-create rcirc-debug-buffer))
 378         (goto-char (point-max))
 379         (insert (concat
 380                  "["
 381                  (format-time-string "%Y-%m-%dT%T ") (process-name process)
 382                  "] "
 383                  text))))))
 384
 385 (defvar rcirc-sentinel-hooks nil
 386   "Hook functions called when the process sentinel is called.
 387 Functions are called with PROCESS and SENTINEL arguments.")
 388
 389 (defun rcirc-sentinel (process sentinel)
 390   "Called when PROCESS receives SENTINEL."
 391   (let ((sentinel (replace-regexp-in-string "\n" "" sentinel)))
 392     (rcirc-debug process (format "SENTINEL: %S %S\n" process sentinel))
 393     (with-rcirc-process-buffer process
 394       (dolist (buffer (cons nil (mapcar 'cdr rcirc-buffer-alist)))
 395         (with-current-buffer (or buffer (current-buffer))
 396           (rcirc-print process "rcirc.el" "ERROR" rcirc-target
 397                        (format "%s: %s (%S)"
 398                                (process-name process)
 399                                sentinel
 400                                (process-status process)) t)
 401           ;; remove the prompt from buffers
 402           (let ((inhibit-read-only t))
 403             (delete-region rcirc-prompt-start-marker
 404                            rcirc-prompt-end-marker)))))
 405     (run-hook-with-args 'rcirc-sentinel-hooks process sentinel)))
 406
 407 (defun rcirc-process-list ()
 408   "Return a list of rcirc processes."
 409   (let (ps)
 410     (mapc (lambda (p)
 411             (when (process-buffer p)
 412               (with-rcirc-process-buffer p
 413                 (when (eq major-mode 'rcirc-mode)
 414                   (setq ps (cons p ps))))))
 415           (process-list))
 416     ps))
 417
 418 (defvar rcirc-receive-message-hooks nil
 419   "Hook functions run when a message is received from server.
 420 Function is called with PROCESS, COMMAND, SENDER, ARGS and LINE.")
 421 (defun rcirc-filter (process output)
 422   "Called when PROCESS receives OUTPUT."
 423   (rcirc-debug process output)
 424   (with-rcirc-process-buffer process
 425     (setq rcirc-last-server-message-time (current-time))
 426     (setq rcirc-process-output (concat rcirc-process-output output))
 427     (when (= (aref rcirc-process-output
 428                    (1- (length rcirc-process-output))) ?\n)
 429       (mapc (lambda (line)
 430               (rcirc-process-server-response process line))
 431             (split-string rcirc-process-output "[\n\r]" t))
 432       (setq rcirc-process-output nil))))
 433
 434 (defvar rcirc-trap-errors-flag t)
 435 (defun rcirc-process-server-response (process text)
 436   (if rcirc-trap-errors-flag
 437       (condition-case err
 438           (rcirc-process-server-response-1 process text)
 439         (error
 440          (rcirc-print process "RCIRC" "ERROR" nil
 441                       (format "\"%s\" %s" text err) t)))
 442     (rcirc-process-server-response-1 process text)))
 443
 444 (defun rcirc-process-server-response-1 (process text)
 445   (if (string-match "^\\(:\\([^ ]+\\) \\)?\\([^ ]+\\) \\(.+\\)$" text)
 446       (let* ((user (match-string 2 text))
 447              (sender (rcirc-user-nick user))
 448              (cmd (match-string 3 text))
 449              (args (match-string 4 text))
 450              (handler (intern-soft (concat "rcirc-handler-" cmd))))
 451         (string-match "^\\([^:]*\\):?\\(.+\\)?$" args)
 452         (let* ((args1 (match-string 1 args))
 453                (args2 (match-string 2 args))
 454                (args (delq nil (append (split-string args1 " " t)
 455                                        (list args2)))))
 456         (if (not (fboundp handler))
 457             (rcirc-handler-generic process cmd sender args text)
 458           (funcall handler process sender args text))
 459         (run-hook-with-args 'rcirc-receive-message-hooks
 460                             process cmd sender args text)))
 461     (message "UNHANDLED: %s" text)))
 462
 463 (defun rcirc-handler-generic (process command sender args text)
 464   "Generic server response handler."
 465   (rcirc-print process sender command nil
 466                (mapconcat 'identity (cdr args) " ") t))
 467
 468 (defun rcirc-send-string (process string)
 469   "Send PROCESS a STRING plus a newline."
 470   (let ((string (concat (encode-coding-string string
 471                                               buffer-file-coding-system)
 472                         "\n")))
 473     (unless (eq (process-status rcirc-process) 'open)
 474       (error "Network connection to %s is not open"
 475              (process-name rcirc-process)))
 476     (rcirc-debug process string)
 477     (process-send-string process string)))
 478
 479 (defun rcirc-server (process)
 480   "Return PROCESS server, given by the 001 response."
 481   (with-rcirc-process-buffer process
 482     rcirc-server))
 483
 484 (defun rcirc-nick (process)
 485   "Return PROCESS nick."
 486   (with-rcirc-process-buffer process
 487     rcirc-nick))
 488
 489 (defun rcirc-abbrev-nick (nick)
 490   "If NICK has an entry in `rcirc-nick-abbrevs', return its abbreviation,
 491 otherwise return NICK."
 492   (or (cdr (assoc nick rcirc-nick-abbrevs)) nick))
 493
 494 (defvar rcirc-max-message-length 450
 495   "Messages longer than this value will be split.")
 496
 497 (defun rcirc-send-message (process target message &optional noticep)
 498   "Send TARGET associated with PROCESS a privmsg with text MESSAGE.
 499 If NOTICEP is non-nil, send a notice instead of privmsg."
 500   ;; max message length is 512 including CRLF
 501   (let* ((response (if noticep "NOTICE" "PRIVMSG"))
 502          (oversize (> (length message) rcirc-max-message-length))
 503          (text (if oversize
 504                    (substring message 0 rcirc-max-message-length)
 505                  message))
 506          (text (if (string= text "")
 507                    " "
 508                  text))
 509          (more (if oversize
 510                    (substring message rcirc-max-message-length))))
 511     (rcirc-get-buffer-create process target)
 512     (rcirc-print process (rcirc-nick process) response target text)
 513     (rcirc-send-string process (concat response " " target " :" text))
 514     (when more (rcirc-send-message process target more noticep))))
 515
 516 (defvar rcirc-input-ring nil)
 517 (defvar rcirc-input-ring-index 0)
 518 (defun rcirc-prev-input-string (arg)
 519   (ring-ref rcirc-input-ring (+ rcirc-input-ring-index arg)))
 520
 521 (defun rcirc-insert-prev-input (arg)
 522   (interactive "p")
 523   (when (<= rcirc-prompt-end-marker (point))
 524     (delete-region rcirc-prompt-end-marker (point-max))
 525     (insert (rcirc-prev-input-string 0))
 526     (setq rcirc-input-ring-index (1+ rcirc-input-ring-index))))
 527
 528 (defun rcirc-insert-next-input (arg)
 529   (interactive "p")
 530   (when (<= rcirc-prompt-end-marker (point))
 531     (delete-region rcirc-prompt-end-marker (point-max))
 532     (setq rcirc-input-ring-index (1- rcirc-input-ring-index))
 533     (insert (rcirc-prev-input-string -1))))
 534
 535 (defvar rcirc-nick-completions nil)
 536 (defvar rcirc-nick-completion-start-offset nil)
 537 (defun rcirc-complete-nick ()
 538   "Cycle through nick completions from list of nicks in channel."
 539   (interactive)
 540   (if (eq last-command 'rcirc-complete-nick)
 541       (setq rcirc-nick-completions
 542             (append (cdr rcirc-nick-completions)
 543                     (list (car rcirc-nick-completions))))
 544     (setq rcirc-nick-completion-start-offset
 545           (- (save-excursion
 546                (if (re-search-backward " " rcirc-prompt-end-marker t)
 547                    (1+ (point))
 548                  rcirc-prompt-end-marker))
 549              rcirc-prompt-end-marker))
 550     (setq rcirc-nick-completions
 551           (let ((completion-ignore-case t))
 552             (all-completions
 553              (buffer-substring
 554               (+ rcirc-prompt-end-marker
 555                  rcirc-nick-completion-start-offset)
 556               (point))
 557              (mapcar (lambda (x) (cons x nil))
 558                      (rcirc-channel-nicks rcirc-process
 559                                           (rcirc-buffer-target)))))))
 560   (let ((completion (car rcirc-nick-completions)))
 561     (when completion
 562       (delete-region (+ rcirc-prompt-end-marker
 563                         rcirc-nick-completion-start-offset)
 564                      (point))
 565       (insert (concat completion
 566                       (if (= (+ rcirc-prompt-end-marker
 567                                 rcirc-nick-completion-start-offset)
 568                              rcirc-prompt-end-marker)
 569                           ": "))))))
 570
 571 (defun rcirc-buffer-target (&optional buffer)
 572   "Return the name of target for BUFFER.
 573 If buffer is nil, return the target of the current buffer."
 574   (with-current-buffer (or buffer (current-buffer))
 575     rcirc-target))
 576
 577 (defvar rcirc-mode-map (make-sparse-keymap)
 578   "Keymap for rcirc mode.")
 579
 580 (define-key rcirc-mode-map (kbd "RET") 'rcirc-send-input)
 581 (define-key rcirc-mode-map (kbd "M-p") 'rcirc-insert-prev-input)
 582 (define-key rcirc-mode-map (kbd "M-n") 'rcirc-insert-next-input)
 583 (define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete-nick)
 584 (define-key rcirc-mode-map (kbd "C-c C-b") 'rcirc-browse-url)
 585 (define-key rcirc-mode-map (kbd "C-c C-c") 'rcirc-edit-multiline)
 586 (define-key rcirc-mode-map (kbd "C-c C-j") 'rcirc-cmd-join)
 587 (define-key rcirc-mode-map (kbd "C-c C-k") 'rcirc-cmd-kick)
 588 (define-key rcirc-mode-map (kbd "C-c C-l") 'rcirc-cmd-list)
 589 (define-key rcirc-mode-map (kbd "C-c C-d") 'rcirc-cmd-mode)
 590 (define-key rcirc-mode-map (kbd "C-c C-m") 'rcirc-cmd-msg)
 591 (define-key rcirc-mode-map (kbd "C-c C-r") 'rcirc-cmd-nick) ; rename
 592 (define-key rcirc-mode-map (kbd "C-c C-o") 'rcirc-cmd-oper)
 593 (define-key rcirc-mode-map (kbd "C-c C-p") 'rcirc-cmd-part)
 594 (define-key rcirc-mode-map (kbd "C-c C-q") 'rcirc-cmd-query)
 595 (define-key rcirc-mode-map (kbd "C-c C-t") 'rcirc-cmd-topic)
 596 (define-key rcirc-mode-map (kbd "C-c C-n") 'rcirc-cmd-names)
 597 (define-key rcirc-mode-map (kbd "C-c C-w") 'rcirc-cmd-whois)
 598 (define-key rcirc-mode-map (kbd "C-c C-x") 'rcirc-cmd-quit)
 599 (define-key rcirc-mode-map (kbd "C-c TAB") ; C-i
 600   'rcirc-toggle-ignore-buffer-activity)
 601 (define-key rcirc-mode-map (kbd "C-c C-s") 'rcirc-switch-to-server-buffer)
 602 (define-key rcirc-mode-map (kbd "C-c C-a") 'rcirc-jump-to-first-unread-line)
 603
 604 (defvar rcirc-browse-url-map (make-sparse-keymap)
 605   "Keymap used for browsing URLs in `rcirc-mode'.")
 606
 607 (define-key rcirc-browse-url-map (kbd "RET") 'rcirc-browse-url-at-point)
 608 (define-key rcirc-browse-url-map (kbd "<mouse-2>") 'rcirc-browse-url-at-mouse)
 609
 610 (defvar rcirc-short-buffer-name nil
 611   "Generated abbreviation to use to indicate buffer activity.")
 612
 613 (defvar rcirc-mode-hook nil
 614   "Hook run when setting up rcirc buffer.")
 615
 616 (defun rcirc-mode (process target)
 617   "Major mode for IRC channel buffers.
 618
 619 \\{rcirc-mode-map}"
 620   (kill-all-local-variables)
 621   (use-local-map rcirc-mode-map)
 622   (setq mode-name "rcirc")
 623   (setq major-mode 'rcirc-mode)
 624
 625   (make-local-variable 'rcirc-input-ring)
 626   (setq rcirc-input-ring (make-ring rcirc-input-ring-size))
 627   (make-local-variable 'rcirc-process)
 628   (setq rcirc-process process)
 629   (make-local-variable 'rcirc-target)
 630   (setq rcirc-target target)
 631   (make-local-variable 'rcirc-topic)
 632   (setq rcirc-topic nil)
 633
 634   (make-local-variable 'rcirc-short-buffer-name)
 635   (setq rcirc-short-buffer-name nil)
 636   (make-local-variable 'rcirc-urls)
 637   (setq rcirc-urls nil)
 638   (setq use-hard-newlines t)
 639
 640   ;; setup the prompt and markers
 641   (make-local-variable 'rcirc-prompt-start-marker)
 642   (setq rcirc-prompt-start-marker (make-marker))
 643   (set-marker rcirc-prompt-start-marker (point-max))
 644   (make-local-variable 'rcirc-prompt-end-marker)
 645   (setq rcirc-prompt-end-marker (make-marker))
 646   (set-marker rcirc-prompt-end-marker (point-max))
 647   (rcirc-update-prompt)
 648   (goto-char rcirc-prompt-end-marker)
 649   (make-local-variable 'overlay-arrow-position)
 650   (setq overlay-arrow-position (make-marker))
 651   (set-marker overlay-arrow-position nil)
 652
 653   ;; add to buffer list, and update buffer abbrevs
 654   (when target                          ; skip server buffer
 655     (let ((buffer (current-buffer)))
 656       (with-rcirc-process-buffer process
 657         (setq rcirc-buffer-alist (cons (cons target buffer)
 658                                        rcirc-buffer-alist))))
 659     (rcirc-update-short-buffer-names))
 660
 661   (run-hooks 'rcirc-mode-hook))
 662
 663 (defun rcirc-update-prompt (&optional all)
 664   "Reset the prompt string in the current buffer.
 665
 666 If ALL is non-nil, update prompts in all IRC buffers."
 667   (if all
 668       (mapc (lambda (process)
 669               (mapc (lambda (buffer)
 670                       (with-current-buffer buffer
 671                         (rcirc-update-prompt)))
 672                     (with-rcirc-process-buffer process
 673                       (mapcar 'cdr rcirc-buffer-alist))))
 674             (rcirc-process-list))
 675     (let ((inhibit-read-only t)
 676           (prompt (or rcirc-prompt "")))
 677       (mapc (lambda (rep)
 678               (setq prompt
 679                     (replace-regexp-in-string (car rep) (regexp-quote (cdr rep)) prompt)))
 680             (list (cons "%n" (with-rcirc-process-buffer rcirc-process
 681                                rcirc-nick))
 682                   (cons "%s" (with-rcirc-process-buffer rcirc-process
 683                                rcirc-server))
 684                   (cons "%t" (or rcirc-target ""))))
 685       (save-excursion
 686         (delete-region rcirc-prompt-start-marker rcirc-prompt-end-marker)
 687         (goto-char rcirc-prompt-start-marker)
 688         (let ((start (point)))
 689           (insert-before-markers prompt)
 690           (set-marker rcirc-prompt-start-marker start)
 691           (when (not (zerop (- rcirc-prompt-end-marker
 692                                rcirc-prompt-start-marker)))
 693             (add-text-properties rcirc-prompt-start-marker
 694                                  rcirc-prompt-end-marker
 695                                  (list 'face 'rcirc-prompt
 696                                        'read-only t 'field t
 697                                        'front-sticky t 'rear-nonsticky t))))))))
 698
 699 (defun rcirc-set-changed (option value)
 700   "Set OPTION to VALUE and do updates after a customization change."
 701   (set-default option value)
 702   (cond ((eq option 'rcirc-prompt)
 703          (rcirc-update-prompt 'all))
 704         (t
 705          (error "Bad option %s" option))))
 706
 707 (defun rcirc-channel-p (target)
 708   "Return t if TARGET is a channel name."
 709   (and target
 710        (not (zerop (length target)))
 711        (or (eq (aref target 0) ?#)
 712            (eq (aref target 0) ?&))))
 713
 714 (defun rcirc-kill-buffer-hook ()
 715   "Part the channel when killing an rcirc buffer."
 716   (when (eq major-mode 'rcirc-mode)
 717     (rcirc-kill-buffer-hook-1)))
 718 (defun rcirc-kill-buffer-hook-1 ()
 719   (let ((buffer (current-buffer)))
 720     (rcirc-clear-activity buffer)
 721     (when (and rcirc-process
 722                (eq (process-status rcirc-process) 'open))
 723       (with-rcirc-process-buffer rcirc-process
 724         (setq rcirc-buffer-alist
 725               (rassq-delete-all buffer rcirc-buffer-alist)))
 726       (rcirc-update-short-buffer-names)
 727       (if (rcirc-channel-p rcirc-target)
 728           (rcirc-send-string rcirc-process
 729                              (concat "PART " rcirc-target
 730                                      " :Killed buffer"))
 731         (when rcirc-target
 732           (rcirc-remove-nick-channel rcirc-process
 733                                      (rcirc-nick rcirc-process)
 734                                      rcirc-target))))))
 735
 736 (add-hook 'kill-buffer-hook 'rcirc-kill-buffer-hook)
 737
 738 (defun rcirc-generate-new-buffer-name (process target)
 739   "Return a buffer name based on PROCESS and TARGET.
 740 This is used for the initial name given to IRC buffers."
 741   (if target
 742       (concat target "@" (process-name process))
 743     (concat "*" (process-name process) "*")))
 744
 745 (defun rcirc-get-buffer (process target &optional server)
 746   "Return the buffer associated with the PROCESS and TARGET.
 747
 748 If optional argument SERVER is non-nil, return the server buffer
 749 if there is no existing buffer for TARGET, otherwise return nil."
 750   (with-rcirc-process-buffer process
 751     (if (null target)
 752         (current-buffer)
 753       (let ((buffer (cdr (assoc-string target rcirc-buffer-alist t))))
 754         (or buffer (when server (current-buffer)))))))
 755
 756 (defun rcirc-get-buffer-create (process target)
 757   "Return the buffer associated with the PROCESS and TARGET.
 758 Create the buffer if it doesn't exist."
 759   (let ((buffer (rcirc-get-buffer process target)))
 760     (if buffer
 761         (progn
 762           (when (not rcirc-target)
 763             (setq rcirc-target target))
 764           buffer)
 765         ;; create the buffer
 766         (with-rcirc-process-buffer process
 767           (let ((new-buffer (get-buffer-create
 768                              (rcirc-generate-new-buffer-name process target))))
 769             (with-current-buffer new-buffer
 770               (rcirc-mode process target))
 771             (rcirc-put-nick-channel process (rcirc-nick process) target)
 772             new-buffer)))))
 773
 774 (defun rcirc-send-input ()
 775   "Send input to target associated with the current buffer."
 776   (interactive)
 777   (if (< (point) rcirc-prompt-end-marker)
 778       ;; copy the line down to the input area
 779       (progn
 780         (forward-line 0)
 781         (let ((start (if (eq (point) (point-min))
 782                          (point)
 783                        (if (get-text-property (1- (point)) 'hard)
 784                            (point)
 785                          (previous-single-property-change (point) 'hard))))
 786               (end (next-single-property-change (1+ (point)) 'hard)))
 787           (goto-char (point-max))
 788           (insert (replace-regexp-in-string
 789                    "\n\\s-+" " "
 790                    (buffer-substring-no-properties start end)))))
 791     ;; process input
 792     (goto-char (point-max))
 793     (let ((target (rcirc-buffer-target))
 794           (start rcirc-prompt-end-marker))
 795       (when (not (equal 0 (- (point) start)))
 796         ;; delete a trailing newline
 797         (when (eq (point) (point-at-bol))
 798           (delete-backward-char 1))
 799         (let ((input (buffer-substring-no-properties
 800                       rcirc-prompt-end-marker (point))))
 801           (dolist (line (split-string input "\n"))
 802             (rcirc-process-input-line rcirc-process target line))
 803           ;; add to input-ring
 804           (save-excursion
 805             (ring-insert rcirc-input-ring input)
 806             (setq rcirc-input-ring-index 0)))))))
 807
 808 (defun rcirc-process-input-line (process target line)
 809   (if (string-match "^/\\([^ ]+\\) ?\\(.*\\)$" line)
 810       (rcirc-process-command (match-string 1 line)
 811                              (match-string 2 line)
 812                              line)
 813     (rcirc-process-message line)))
 814
 815 (defun rcirc-process-message (line)
 816   (if (not rcirc-target)
 817       (message "Not joined")
 818     (delete-region rcirc-prompt-end-marker (point))
 819     (rcirc-send-message rcirc-process rcirc-target line)))
 820
 821 (defun rcirc-process-command (command args line)
 822   (if (eq (aref command 0) ?/)
 823       ;; "//text" will send "/text" as a message
 824       (rcirc-process-message (substring line 1))
 825     (let* ((fun (intern-soft (concat "rcirc-cmd-" command))))
 826       (newline)
 827       (with-current-buffer (current-buffer)
 828         (delete-region rcirc-prompt-end-marker (point))
 829         (if (string= command "me")
 830             (rcirc-print rcirc-process (rcirc-nick rcirc-process)
 831                          "ACTION" rcirc-target args)
 832           (rcirc-print rcirc-process (rcirc-nick rcirc-process)
 833                        "COMMAND" rcirc-target line))
 834         (set-marker rcirc-prompt-end-marker (point))
 835         (if (fboundp fun)
 836             (funcall fun args rcirc-process rcirc-target)
 837           (rcirc-send-string rcirc-process
 838                              (concat command " " args)))))))
 839
 840 (defvar rcirc-parent-buffer nil)
 841 (defvar rcirc-window-configuration nil)
 842 (defun rcirc-edit-multiline ()
 843   "Move current edit to a dedicated buffer."
 844   (interactive)
 845   (let ((pos (1+ (- (point) rcirc-prompt-end-marker))))
 846     (goto-char (point-max))
 847     (let ((text (buffer-substring rcirc-prompt-end-marker (point)))
 848           (parent (buffer-name))
 849           (process rcirc-process))
 850       (delete-region rcirc-prompt-end-marker (point))
 851       (setq rcirc-window-configuration (current-window-configuration))
 852       (pop-to-buffer (concat "*multiline " parent "*"))
 853       (rcirc-multiline-edit-mode)
 854       (setq rcirc-parent-buffer parent)
 855       (setq rcirc-process process)
 856       (insert text)
 857       (and (> pos 0) (goto-char pos))
 858       (message "Type C-c C-c to return text to %s, or C-c C-k to cancel" parent))))
 859
 860 (define-derived-mode rcirc-multiline-edit-mode
 861   text-mode "rcirc multi"
 862   "Major mode for multiline edits
 863 \\{rcirc-multiline-edit-mode-map}"
 864   (make-local-variable 'rcirc-parent-buffer)
 865   (make-local-variable 'rcirc-process))
 866
 867 (define-key rcirc-multiline-edit-mode-map
 868   (kbd "C-c C-c") 'rcirc-multiline-edit-submit)
 869 (define-key rcirc-multiline-edit-mode-map
 870   (kbd "C-x C-s") 'rcirc-multiline-edit-submit)
 871 (define-key rcirc-multiline-edit-mode-map
 872   (kbd "C-c C-k") 'rcirc-multiline-edit-cancel)
 873 (define-key rcirc-multiline-edit-mode-map
 874   (kbd "ESC ESC ESC") 'rcirc-multiline-edit-cancel)
 875
 876 (defun rcirc-multiline-edit-submit ()
 877   "Send the text in buffer back to parent buffer."
 878   (interactive)
 879   (assert (and (eq major-mode 'rcirc-multiline-edit-mode)))
 880   (assert rcirc-parent-buffer)
 881   (untabify (point-min) (point-max))
 882   (let ((text (buffer-substring (point-min) (point-max)))
 883         (buffer (current-buffer))
 884         (pos (point)))
 885     (set-buffer rcirc-parent-buffer)
 886     (goto-char (point-max))
 887     (insert text)
 888     (kill-buffer buffer)
 889     (set-window-configuration rcirc-window-configuration)
 890     (goto-char (+ rcirc-prompt-end-marker (1- pos)))))
 891
 892 (defun rcirc-multiline-edit-cancel ()
 893   "Cancel the multiline edit."
 894   (interactive)
 895   (assert (and (eq major-mode 'rcirc-multiline-edit-mode)))
 896   (kill-buffer (current-buffer))
 897   (set-window-configuration rcirc-window-configuration))
 898
 899 (defun rcirc-get-any-buffer (process)
 900   "Return a buffer for PROCESS, either the one selected or the process buffer."
 901   (let ((buffer (window-buffer (selected-window))))
 902     (if (and buffer
 903              (with-current-buffer buffer
 904                (and (eq major-mode 'rcirc-mode)
 905                     (eq rcirc-process process))))
 906         buffer
 907       (process-buffer process))))
 908
 909 (defcustom rcirc-response-formats
 910   '(("PRIVMSG" . "%T<%n> %m")
 911     ("NOTICE"  . "%T-%n- %m")
 912     ("ACTION"  . "%T[%n] %m")
 913     ("COMMAND" . "%T%m")
 914     ("ERROR"   . "%T%fw!!! %m")
 915     (t         . "%T%fp*** %fs%n %r %m"))
 916   "An alist of formats used for printing responses.
 917 The format is looked up using the response-type as a key;
 918 if no match is found, the default entry (with a key of `t') is used.
 919
 920 The entry's value part should be a string, which is inserted with
 921 the of the following escape sequences replaced by the described values:
 922
 923   %m        The message text
 924   %n        The sender's nick (with face `rcirc-my-nick' or `rcirc-other-nick')
 925   %r        The response-type
 926   %T        The timestamp (with face `rcirc-timestamp')
 927   %t        The target
 928   %fw       Following text uses the face `font-lock-warning-face'
 929   %fp       Following text uses the face `rcirc-server-prefix'
 930   %fs       Following text uses the face `rcirc-server'
 931   %f[FACE]  Following text uses the face FACE
 932   %f-       Following text uses the default face
 933   %%        A literal `%' character
 934 "
 935   :type '(alist :key-type (choice (string :tag "Type")
 936                                   (const :tag "Default" t))
 937                 :value-type string)
 938   :group 'rcirc)
 939
 940 (defun rcirc-format-response-string (process sender response target text)
 941   "Return a nicely-formatted response string, incorporating TEXT
 942 \(and perhaps other arguments).  The specific formatting used
 943 is found by looking up RESPONSE in `rcirc-response-formats'."
 944   (let ((chunks
 945          (split-string (or (cdr (assoc response rcirc-response-formats))
 946                            (cdr (assq t rcirc-response-formats)))
 947                        "%"))
 948         (result "")
 949         (face nil)
 950         key face-key repl)
 951     (when (equal (car chunks) "")
 952       (pop chunks))
 953     (dolist (chunk chunks)
 954       (if (equal chunk "")
 955           (setq key ?%)
 956         (setq key (aref chunk 0))
 957         (setq chunk (substring chunk 1)))
 958       (setq repl
 959             (cond ((eq key ?%)
 960                    ;; %% -- literal % character
 961                    "%")
 962                   ((eq key ?n)
 963                    ;; %n -- nick
 964                    (rcirc-facify (concat (rcirc-abbrev-nick sender)
 965                                          (and target (concat "," target)))
 966                                  (if (string= sender (rcirc-nick process))
 967                                      'rcirc-my-nick
 968                                    'rcirc-other-nick)))
 969                   ((eq key ?T)
 970                    ;; %T -- timestamp
 971                    (rcirc-facify
 972                     (format-time-string rcirc-time-format (current-time))
 973                     'rcirc-timestamp))
 974                   ((eq key ?m)
 975                    ;; %m -- message text
 976                    ;; We add the text property `rcirc-text' to identify this
 977                    ;; as the body text.
 978                    (propertize
 979                     (rcirc-mangle-text process (rcirc-facify text face))
 980                     'rcirc-text text))
 981                   ((eq key ?t)
 982                    ;; %t -- target
 983                    (rcirc-facify (or rcirc-target "") face))
 984                   ((eq key ?r)
 985                    ;; %r -- response
 986                    (rcirc-facify response face))
 987                   ((eq key ?f)
 988                    ;; %f -- change face
 989                    (setq face-key (aref chunk 0))
 990                    (setq chunk (substring chunk 1))
 991                    (cond ((eq face-key ?w)
 992                           ;; %fw -- warning face
 993                           (setq face 'font-lock-warning-face))
 994                          ((eq face-key ?p)
 995                           ;; %fp -- server-prefix face
 996                           (setq face 'rcirc-server-prefix))
 997                          ((eq face-key ?s)
 998                           ;; %fs -- warning face
 999                           (setq face 'rcirc-server))
1000                          ((eq face-key ?-)
1001                           ;; %fs -- warning face
1002                           (setq face nil))
1003                          ((and (eq face-key ?\[)
1004                                (string-match "^\\([^]]*\\)[]]" chunk)
1005                                (facep (match-string 1 chunk)))
1006                           ;; %f[...] -- named face
1007                           (setq face (intern (match-string 1 chunk)))
1008                           (setq chunk (substring chunk (match-end 0)))))
1009                    "")))
1010       (setq result (concat result repl (rcirc-facify chunk face))))
1011     result))
1012
1013 (defun rcirc-target-buffer (process sender response target text)
1014   "Return a buffer to print the server response."
1015   (assert (not (bufferp target)))
1016   (with-rcirc-process-buffer process
1017     (cond ((not target)
1018            (if rcirc-always-use-server-buffer-flag
1019                (process-buffer process)
1020              (rcirc-get-any-buffer process)))
1021           ((not (rcirc-channel-p target))
1022            ;; message from another user
1023            (if (string= response "PRIVMSG")
1024                (rcirc-get-buffer-create process (if (string= sender rcirc-nick)
1025                                                     target
1026                                                   sender))
1027              (rcirc-get-buffer process target t)))
1028           ((or (rcirc-get-buffer process target)
1029                (rcirc-get-any-buffer process))))))
1030
1031 (defvar rcirc-activity-type nil)
1032 (make-variable-buffer-local 'rcirc-activity-type)
1033 (defun rcirc-print (process sender response target text &optional activity)
1034   "Print TEXT in the buffer associated with TARGET.
1035 Format based on SENDER and RESPONSE.  If ACTIVITY is non-nil,
1036 record activity."
1037   (unless (or (member sender rcirc-ignore-list)
1038               (member (with-syntax-table rcirc-nick-syntax-table
1039                         (when (string-match "^\\([^/]\\w*\\)[:,]" text)
1040                           (match-string 1 text))) rcirc-ignore-list))
1041     (let* ((buffer (rcirc-target-buffer process sender response target text))
1042            (inhibit-read-only t))
1043       (with-current-buffer buffer
1044         (let ((moving (= (point) rcirc-prompt-end-marker))
1045               (old-point (point-marker))
1046               (fill-start (marker-position rcirc-prompt-start-marker)))
1047
1048           (unless (string= sender (rcirc-nick process))
1049             ;; only decode text from other senders, not ours
1050             (setq text (decode-coding-string (or text "")
1051                                              buffer-file-coding-system))
1052             ;; mark the line with overlay arrow
1053             (unless (or (marker-position overlay-arrow-position)
1054                         (get-buffer-window (current-buffer)))
1055               (set-marker overlay-arrow-position
1056                           (marker-position rcirc-prompt-start-marker))))
1057
1058           ;; temporarily set the marker insertion-type because
1059           ;; insert-before-markers results in hidden text in new buffers
1060           (goto-char rcirc-prompt-start-marker)
1061           (set-marker-insertion-type rcirc-prompt-start-marker t)
1062           (set-marker-insertion-type rcirc-prompt-end-marker t)
1063
1064           (let ((fmted-text
1065                  (rcirc-format-response-string process sender response nil
1066                                                text)))
1067
1068             (insert fmted-text (propertize "\n" 'hard t))
1069             (set-marker-insertion-type rcirc-prompt-start-marker nil)
1070             (set-marker-insertion-type rcirc-prompt-end-marker nil)
1071
1072             ;; fill the text we just inserted, maybe
1073             (when (and rcirc-fill-flag
1074                        (not (string= response "372"))) ;/motd
1075               (let ((fill-prefix
1076                      (or rcirc-fill-prefix
1077                          (make-string
1078                           (or (next-single-property-change 0 'rcirc-text
1079                                                            fmted-text)
1080                               8)
1081                           ?\s)))
1082                     (fill-column (cond ((eq rcirc-fill-column 'frame-width)
1083                                         (1- (frame-width)))
1084                                        (rcirc-fill-column
1085                                         rcirc-fill-column)
1086                                        (t fill-column))))
1087                 (fill-region fill-start rcirc-prompt-start-marker 'left t))))
1088
1089           ;; set inserted text to be read-only
1090           (when rcirc-read-only-flag
1091             (put-text-property rcirc-prompt-start-marker fill-start 'read-only t)
1092             (let ((inhibit-read-only t))
1093               (put-text-property rcirc-prompt-start-marker fill-start
1094                                  'front-sticky t)
1095               (put-text-property (1- (point)) (point) 'rear-nonsticky t)))
1096
1097           ;; truncate buffer if it is very long
1098           (save-excursion
1099             (when (and rcirc-buffer-maximum-lines
1100                        (> rcirc-buffer-maximum-lines 0)
1101                        (= (forward-line (- rcirc-buffer-maximum-lines)) 0))
1102               (delete-region (point-min) (point))))
1103
1104           ;; set the window point for buffers show in windows
1105           (walk-windows (lambda (w)
1106                           (unless (eq (selected-window) w)
1107                             (when (and (eq (current-buffer)
1108                                            (window-buffer w))
1109                                        (>= (window-point w)
1110                                            rcirc-prompt-end-marker))
1111                               (set-window-point w (point-max)))))
1112                         nil t)
1113
1114           ;; restore the point
1115           (goto-char (if moving rcirc-prompt-end-marker old-point))
1116
1117           ;; flush undo (can we do something smarter here?)
1118           (buffer-disable-undo)
1119           (buffer-enable-undo))
1120
1121         ;; record modeline activity
1122         (when activity
1123           (let ((nick-match
1124                  (string-match (concat "\\b"
1125                                        (regexp-quote (rcirc-nick process))
1126                                        "\\b")
1127                                text)))
1128             (when (or (not rcirc-ignore-buffer-activity-flag)
1129                       ;; always notice when our nick is mentioned, even
1130                       ;; if ignoring channel activity
1131                       nick-match)
1132               (rcirc-record-activity
1133                (current-buffer)
1134                (when (or nick-match (not (rcirc-channel-p rcirc-target)))
1135                  'nick)))))
1136
1137         (sit-for 0)                     ; displayed text before hook
1138         (run-hook-with-args 'rcirc-print-hooks
1139                             process sender response target text)))))
1140
1141 (defun rcirc-startup-channels (server)
1142   "Return the list of startup channels for SERVER."
1143   (let (channels)
1144     (dolist (i rcirc-startup-channels-alist)
1145       (if (string-match (car i) server)
1146           (setq channels (append channels (cdr i)))))
1147     channels))
1148
1149 (defun rcirc-join-channels (process channels)
1150   "Join CHANNELS."
1151   (save-window-excursion
1152     (dolist (channel channels)
1153       (with-rcirc-process-buffer process
1154         (rcirc-cmd-join channel process)))))
1155 \f
1156 ;;; nick management
1157 (defun rcirc-user-nick (user)
1158   "Return the nick from USER.  Remove any non-nick junk."
1159   (save-match-data
1160     (if (string-match "^[@%+]?\\([^! ]+\\)!?" (or user ""))
1161         (match-string 1 user)
1162       user)))
1163
1164 (defun rcirc-user-non-nick (user)
1165   "Return the non-nick portion of USER."
1166   (if (string-match "^[@+]?[^! ]+!?\\(.*\\)" (or user ""))
1167       (match-string 1 user)
1168     user))
1169
1170 (defun rcirc-nick-channels (process nick)
1171   "Return list of channels for NICK."
1172   (with-rcirc-process-buffer process
1173     (mapcar (lambda (x) (car x))
1174             (gethash nick rcirc-nick-table))))
1175
1176 (defun rcirc-put-nick-channel (process nick channel)
1177   "Add CHANNEL to list associated with NICK."
1178   (with-rcirc-process-buffer process
1179     (let* ((chans (gethash nick rcirc-nick-table))
1180            (record (assoc-string channel chans t)))
1181       (if record
1182           (setcdr record (current-time))
1183         (puthash nick (cons (cons channel (current-time))
1184                             chans)
1185                  rcirc-nick-table)))))
1186
1187 (defun rcirc-nick-remove (process nick)
1188   "Remove NICK from table."
1189   (with-rcirc-process-buffer process
1190     (remhash nick rcirc-nick-table)))
1191
1192 (defun rcirc-remove-nick-channel (process nick channel)
1193   "Remove the CHANNEL from list associated with NICK."
1194   (with-rcirc-process-buffer process
1195     (let* ((chans (gethash nick rcirc-nick-table))
1196            (newchans
1197             ;; instead of assoc-string-delete-all:
1198             (let ((record (assoc-string channel chans t)))
1199               (when record
1200                 (setcar record 'delete)
1201                 (assq-delete-all 'delete chans)))))
1202       (if newchans
1203           (puthash nick newchans rcirc-nick-table)
1204         (remhash nick rcirc-nick-table)))))
1205
1206 (defun rcirc-channel-nicks (process channel)
1207   "Return the list of nicks in CHANNEL sorted by last activity."
1208   (with-rcirc-process-buffer process
1209     (let (nicks)
1210       (maphash
1211        (lambda (k v)
1212          (let ((record (assoc-string channel v t)))
1213            (if record
1214                (setq nicks (cons (cons k (cdr record)) nicks)))))
1215        rcirc-nick-table)
1216       (mapcar (lambda (x) (car x))
1217               (sort nicks (lambda (x y) (time-less-p (cdr y) (cdr x))))))))
1218
1219 (defun rcirc-ignore-update-automatic (nick)
1220   "Remove NICK from `rcirc-ignore-list'
1221 if NICK is also on `rcirc-ignore-list-automatic'."
1222   (when (member nick rcirc-ignore-list-automatic)
1223       (setq rcirc-ignore-list-automatic
1224             (delete nick rcirc-ignore-list-automatic)
1225             rcirc-ignore-list
1226             (delete nick rcirc-ignore-list))))
1227 \f
1228 ;;; activity tracking
1229 (defvar rcirc-track-minor-mode-map (make-sparse-keymap)
1230   "Keymap for rcirc track minor mode.")
1231
1232 (define-key rcirc-track-minor-mode-map (kbd "C-c `") 'rcirc-next-active-buffer)
1233 (define-key rcirc-track-minor-mode-map (kbd "C-c C-@") 'rcirc-next-active-buffer)
1234 (define-key rcirc-track-minor-mode-map (kbd "C-c C-SPC") 'rcirc-next-active-buffer)
1235
1236 ;;; FIXME: the code to insert `rcirc-activity-string' into
1237 ;;; `global-mode-string' isn't called when the mode is activated by
1238 ;;; customize.  I don't know how to set that up.
1239 (define-minor-mode rcirc-track-minor-mode
1240   "Global minor mode for tracking activity in rcirc buffers."
1241   :init-value nil
1242   :lighter ""
1243   :keymap rcirc-track-minor-mode-map
1244   :global t
1245   :group 'rcirc
1246   (or global-mode-string (setq global-mode-string '("")))
1247   ;; toggle the mode-line channel indicator
1248   (if rcirc-track-minor-mode
1249       (and (not (memq 'rcirc-activity-string global-mode-string))
1250            (setq global-mode-string
1251                  (append global-mode-string '(rcirc-activity-string))))
1252     (setq global-mode-string
1253           (delete 'rcirc-activity-string global-mode-string))))
1254
1255 (or (assq 'rcirc-ignore-buffer-activity-flag minor-mode-alist)
1256     (setq minor-mode-alist
1257           (cons '(rcirc-ignore-buffer-activity-flag " Ignore") minor-mode-alist)))
1258
1259 (defun rcirc-toggle-ignore-buffer-activity ()
1260   "Toggle the value of `rcirc-ignore-buffer-activity-flag'."
1261   (interactive)
1262   (setq rcirc-ignore-buffer-activity-flag
1263         (not rcirc-ignore-buffer-activity-flag))
1264   (message (if rcirc-ignore-buffer-activity-flag
1265                "Ignore activity in this buffer"
1266              "Notice activity in this buffer"))
1267   (force-mode-line-update))
1268
1269 (defvar rcirc-switch-to-buffer-function 'switch-to-buffer
1270   "Function to use when switching buffers.
1271 Possible values are `switch-to-buffer', `pop-to-buffer', and
1272 `display-buffer'.")
1273
1274 (defun rcirc-switch-to-server-buffer ()
1275   "Switch to the server buffer associated with current channel buffer."
1276   (interactive)
1277   (funcall rcirc-switch-to-buffer-function (process-buffer rcirc-process)))
1278
1279 (defun rcirc-jump-to-first-unread-line ()
1280   "Move the point to the first unread line in this buffer."
1281   (interactive)
1282   (when (marker-position overlay-arrow-position)
1283     (goto-char overlay-arrow-position)))
1284
1285 (defvar rcirc-last-non-irc-buffer nil
1286   "The buffer to switch to when there is no more activity.")
1287
1288 (defun rcirc-next-active-buffer (arg)
1289   "Go to the ARGth rcirc buffer with activity.
1290 The function given by `rcirc-switch-to-buffer-function' is used to
1291 show the buffer."
1292   (interactive "p")
1293   (if rcirc-activity
1294       (progn
1295         (unless (eq major-mode 'rcirc-mode)
1296           (setq rcirc-last-non-irc-buffer (current-buffer)))
1297         (if (and (> arg 0)
1298                  (<= arg (length rcirc-activity)))
1299             (funcall rcirc-switch-to-buffer-function
1300                      (nth (1- arg) rcirc-activity))
1301           (message "Invalid arg: %d" arg)))
1302     (if (eq major-mode 'rcirc-mode)
1303         (if (not (and rcirc-last-non-irc-buffer
1304                       (buffer-live-p rcirc-last-non-irc-buffer)))
1305             (message "No IRC activity.  Start something.")
1306           (message "No more IRC activity.  Go back to work.")
1307           (funcall rcirc-switch-to-buffer-function rcirc-last-non-irc-buffer)
1308           (setq rcirc-last-non-irc-buffer nil))
1309       (message "No IRC activity."))))
1310
1311 (defvar rcirc-activity-hooks nil
1312   "Hook to be run when there is channel activity.
1313
1314 Functions are called with a single argument, the buffer with the
1315 activity.  Only run if the buffer is not visible and
1316 `rcirc-ignore-buffer-activity-flag' is non-nil.")
1317
1318 (defun rcirc-record-activity (buffer type)
1319   "Record BUFFER activity with TYPE."
1320   (with-current-buffer buffer
1321     (when (not (get-buffer-window (current-buffer) t))
1322       (add-to-list 'rcirc-activity (current-buffer))
1323       (if (not rcirc-activity-type)
1324           (setq rcirc-activity-type type))
1325       (rcirc-update-activity-string)))
1326   (run-hook-with-args 'rcirc-activity-hooks buffer))
1327
1328 (defun rcirc-clear-activity (buffer)
1329   "Clear the BUFFER activity."
1330   (setq rcirc-activity (delete buffer rcirc-activity))
1331   (with-current-buffer buffer
1332     (setq rcirc-activity-type nil)))
1333
1334 ;; TODO: add mouse properties
1335 (defun rcirc-update-activity-string ()
1336   "Update mode-line string."
1337   (setq rcirc-activity-string
1338         (if (not rcirc-activity)
1339                ""
1340           (concat " ["
1341                   (mapconcat
1342                    (lambda (b)
1343                      (let ((s (rcirc-short-buffer-name b)))
1344                        (with-current-buffer b
1345                          (if (not (eq rcirc-activity-type 'nick))
1346                              s
1347                            (rcirc-facify s 'rcirc-mode-line-nick)))))
1348                    rcirc-activity ",")
1349                   "]"))))
1350
1351 (defun rcirc-short-buffer-name (buffer)
1352   "Return a short name for BUFFER to use in the modeline indicator."
1353   (with-current-buffer buffer
1354     (or rcirc-short-buffer-name (buffer-name))))
1355
1356 (defvar rcirc-current-buffer nil)
1357 (defun rcirc-window-configuration-change ()
1358   "Go through visible windows and remove buffers from activity list.
1359 Also, clear the overlay arrow if the current buffer is now hidden."
1360   (let ((current-now-hidden t))
1361     (walk-windows (lambda (w)
1362                     (let ((buf (window-buffer w)))
1363                       (rcirc-clear-activity buf)
1364                       (when (eq buf rcirc-current-buffer)
1365                         (setq current-now-hidden nil)))))
1366     (when (and rcirc-current-buffer current-now-hidden)
1367       (with-current-buffer rcirc-current-buffer
1368         (when (eq major-mode 'rcirc-mode)
1369           (marker-position overlay-arrow-position)
1370           (set-marker overlay-arrow-position nil)))))
1371
1372   ;; remove any killed buffers from list
1373   (setq rcirc-activity
1374         (delq nil (mapcar (lambda (buf) (when (buffer-live-p buf) buf))
1375                           rcirc-activity)))
1376   (rcirc-update-activity-string)
1377   (setq rcirc-current-buffer (current-buffer)))
1378
1379 \f
1380 ;;; buffer name abbreviation
1381 (defun rcirc-update-short-buffer-names ()
1382   (let ((bufalist
1383          (apply 'append (mapcar (lambda (process)
1384                                   (with-rcirc-process-buffer process
1385                                     rcirc-buffer-alist))
1386                                 (rcirc-process-list)))))
1387     (dolist (i (rcirc-abbreviate bufalist))
1388       (with-current-buffer (cdr i)
1389         (setq rcirc-short-buffer-name (car i))))))
1390
1391 (defun rcirc-abbreviate (pairs)
1392   (apply 'append (mapcar 'rcirc-rebuild-tree (rcirc-make-trees pairs))))
1393
1394 (defun rcirc-rebuild-tree (tree &optional acc)
1395   (let ((ch (char-to-string (car tree))))
1396     (dolist (x (cdr tree))
1397       (if (listp x)
1398           (setq acc (append acc
1399                            (mapcar (lambda (y)
1400                                      (cons (concat ch (car y))
1401                                            (cdr y)))
1402                                    (rcirc-rebuild-tree x))))
1403         (setq acc (cons (cons ch x) acc))))
1404     acc))
1405
1406 (defun rcirc-make-trees (pairs)
1407   (let (alist)
1408     (mapc (lambda (pair)
1409             (if (consp pair)
1410                 (let* ((str (car pair))
1411                        (data (cdr pair))
1412                        (char (unless (zerop (length str))
1413                                (aref str 0)))
1414                        (rest (unless (zerop (length str))
1415                                (substring str 1)))
1416                        (part (if char (assq char alist))))
1417                   (if part
1418                       ;; existing partition
1419                       (setcdr part (cons (cons rest data) (cdr part)))
1420                     ;; new partition
1421                     (setq alist (cons (if char
1422                                           (list char (cons rest data))
1423                                         data)
1424                                       alist))))
1425               (setq alist (cons pair alist))))
1426           pairs)
1427     ;; recurse into cdrs of alist
1428     (mapc (lambda (x)
1429             (when (and (listp x) (listp (cadr x)))
1430               (setcdr x (if (> (length (cdr x)) 1)
1431                             (rcirc-make-trees (cdr x))
1432                           (setcdr x (list (cdadr x)))))))
1433           alist)))
1434 \f
1435 ;;; /commands these are called with 3 args: PROCESS, TARGET, which is
1436 ;; the current buffer/channel/user, and ARGS, which is a string
1437 ;; containing the text following the /cmd.
1438
1439 (defmacro defun-rcirc-command (command argument docstring interactive-form
1440                                        &rest body)
1441   "Define a command."
1442   `(defun ,(intern (concat "rcirc-cmd-" (symbol-name command)))
1443      (,@argument &optional process target)
1444      ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values of"
1445               "\nbuffer local variables `rcirc-process' and `rcirc-target',"
1446               "\nwill be used.")
1447      ,interactive-form
1448      (let ((process (or process rcirc-process))
1449            (target (or target rcirc-target)))
1450        ,@body)))
1451
1452 (defun-rcirc-command msg (message)
1453   "Send private MESSAGE to TARGET."
1454   (interactive "i")
1455   (if (null message)
1456       (progn
1457         (setq target (completing-read "Message nick: "
1458                                       (with-rcirc-process-buffer rcirc-process
1459                                         rcirc-nick-table)))
1460         (when (> (length target) 0)
1461           (setq message (read-string (format "Message %s: " target)))
1462           (when (> (length message) 0)
1463             (rcirc-send-message process target message))))
1464     (if (not (string-match "\\([^ ]+\\) \\(.+\\)" message))
1465         (message "Not enough args, or something.")
1466       (setq target (match-string 1 message)
1467             message (match-string 2 message))
1468       (rcirc-send-message process target message))))
1469
1470 (defun-rcirc-command query (nick)
1471   "Open a private chat buffer to NICK."
1472   (interactive (list (completing-read "Query nick: "
1473                                       (with-rcirc-process-buffer rcirc-process
1474                                         rcirc-nick-table))))
1475   (let ((existing-buffer (rcirc-get-buffer process nick)))
1476     (switch-to-buffer (or existing-buffer
1477                           (rcirc-get-buffer-create process nick)))
1478     (when (not existing-buffer)
1479       (rcirc-cmd-whois nick))))
1480
1481 (defun-rcirc-command join (channel)
1482   "Join CHANNEL."
1483   (interactive "sJoin channel: ")
1484   (let ((buffer (rcirc-get-buffer-create process
1485                                          (car (split-string channel)))))
1486     (when (not (eq (selected-window) (minibuffer-window)))
1487       (funcall rcirc-switch-to-buffer-function buffer))
1488     (rcirc-send-string process (concat "JOIN " channel))))
1489
1490 (defun-rcirc-command part (channel)
1491   "Part CHANNEL."
1492   (interactive "sPart channel: ")
1493   (let ((channel (if (> (length channel) 0) channel target)))
1494     (rcirc-send-string process (concat "PART " channel " :" rcirc-id-string))))
1495
1496 (defun-rcirc-command quit (reason)
1497   "Send a quit message to server with REASON."
1498   (interactive "sQuit reason: ")
1499   (rcirc-send-string process (concat "QUIT :"
1500                                      (if (not (zerop (length reason)))
1501                                          reason
1502                                        rcirc-id-string))))
1503
1504 (defun-rcirc-command nick (nick)
1505   "Change nick to NICK."
1506   (interactive "i")
1507   (when (null nick)
1508     (setq nick (read-string "New nick: " (rcirc-nick process))))
1509   (rcirc-send-string process (concat "NICK " nick)))
1510
1511 (defun-rcirc-command names (channel)
1512   "Display list of names in CHANNEL or in current channel if CHANNEL is nil.
1513 If called interactively, prompt for a channel when prefix arg is supplied."
1514   (interactive "P")
1515   (if (interactive-p)
1516       (if channel
1517           (setq channel (read-string "List names in channel: " target))))
1518   (let ((channel (if (> (length channel) 0)
1519                      channel
1520                    target)))
1521     (rcirc-send-string process (concat "NAMES " channel))))
1522
1523 (defun-rcirc-command topic (topic)
1524   "List TOPIC for the TARGET channel.
1525 With a prefix arg, prompt for new topic."
1526   (interactive "P")
1527   (if (and (interactive-p) topic)
1528       (setq topic (read-string "New Topic: " rcirc-topic)))
1529   (rcirc-send-string process (concat "TOPIC " target
1530                                      (when (> (length topic) 0)
1531                                        (concat " :" topic)))))
1532
1533 (defun-rcirc-command whois (nick)
1534   "Request information from server about NICK."
1535   (interactive (list
1536                 (completing-read "Whois: "
1537                                  (with-rcirc-process-buffer rcirc-process
1538                                    rcirc-nick-table))))
1539   (rcirc-send-string process (concat "WHOIS " nick)))
1540
1541 (defun-rcirc-command mode (args)
1542   "Set mode with ARGS."
1543   (interactive (list (concat (read-string "Mode nick or channel: ")
1544                              " " (read-string "Mode: "))))
1545   (rcirc-send-string process (concat "MODE " args)))
1546
1547 (defun-rcirc-command list (channels)
1548   "Request information on CHANNELS from server."
1549   (interactive "sList Channels: ")
1550   (rcirc-send-string process (concat "LIST " channels)))
1551
1552 (defun-rcirc-command oper (args)
1553   "Send operator command to server."
1554   (interactive "sOper args: ")
1555   (rcirc-send-string process (concat "OPER " args)))
1556
1557 (defun-rcirc-command quote (message)
1558   "Send MESSAGE literally to server."
1559   (interactive "sServer message: ")
1560   (rcirc-send-string process message))
1561
1562 (defun-rcirc-command kick (arg)
1563   "Kick NICK from current channel."
1564   (interactive (list
1565                 (concat (completing-read "Kick nick: "
1566                                          (rcirc-channel-nicks rcirc-process
1567                                                               rcirc-target))
1568                         (read-from-minibuffer "Kick reason: "))))
1569   (let* ((arglist (split-string arg))
1570          (argstring (concat (car arglist) " :"
1571                             (mapconcat 'identity (cdr arglist) " "))))
1572     (rcirc-send-string process (concat "KICK " target " " argstring))))
1573
1574 (defun rcirc-cmd-ctcp (args &optional process target)
1575   (if (string-match "^\\([^ ]+\\)\\s-+\\(.+\\)$" args)
1576       (let ((target (match-string 1 args))
1577             (request (match-string 2 args)))
1578         (rcirc-send-string process
1579                            (format "PRIVMSG %s \C-a%s\C-a"
1580                                    target (upcase request))))
1581     (rcirc-print process (rcirc-nick process) "ERROR" nil
1582                  "usage: /ctcp NICK REQUEST")))
1583
1584 (defun rcirc-cmd-me (args &optional process target)
1585   (rcirc-send-string process (format "PRIVMSG %s :\C-aACTION %s\C-a"
1586                                      target args)))
1587
1588 (defun-rcirc-command ignore (nick)
1589   "Manage the ignore list.
1590 Ignore NICK, unignore NICK if already ignored, or list ignored
1591 nicks when no NICK is given.  When listing ignored nicks, the
1592 ones added to the list automatically are marked with an asterisk."
1593   (interactive "sToggle ignoring of nick: ")
1594   (when (not (string= "" nick))
1595     (if (member nick rcirc-ignore-list)
1596         (setq rcirc-ignore-list (delete nick rcirc-ignore-list))
1597       (setq rcirc-ignore-list (cons nick rcirc-ignore-list))))
1598   (rcirc-print process (rcirc-nick process) "IGNORE" target
1599                (mapconcat
1600                 (lambda (nick)
1601                   (concat nick
1602                           (if (member nick rcirc-ignore-list-automatic)
1603                               "*" "")))
1604                 rcirc-ignore-list " ")))
1605
1606 \f
1607 (defun rcirc-message-leader (sender face)
1608   "Return a string with SENDER propertized with FACE."
1609   (rcirc-facify (concat "<" sender "> ") face))
1610
1611 (defun rcirc-facify (string face)
1612   "Return a copy of STRING with FACE property added."
1613   (propertize (or string "") 'face face 'rear-nonsticky t))
1614
1615 (defvar rcirc-url-regexp
1616   (rx word-boundary
1617       (or "www."
1618           (and (or "http" "https" "ftp" "file" "gopher" "news" "telnet" "wais"
1619                    "mailto")
1620                "://"
1621                (1+ (char "a-zA-Z0-9_."))
1622                (optional ":" (1+ (char "0-9")))))
1623       (1+ (char "-a-zA-Z0-9_=!?#$\@~`%&*+|\\/:;.,{}[]"))
1624       (char "-a-zA-Z0-9_=#$\@~`%&*+|\\/:;{}[]"))
1625   "Regexp matching URLs.  Set to nil to disable URL features in rcirc.")
1626
1627 (defun rcirc-browse-url (&optional arg)
1628   "Prompt for URL to browse based on URLs in buffer."
1629   (interactive)
1630   (let ((completions (mapcar (lambda (x) (cons x nil)) rcirc-urls))
1631         (initial-input (car rcirc-urls))
1632         (history (cdr rcirc-urls)))
1633     (browse-url (completing-read "rcirc browse-url: "
1634                                  completions nil nil initial-input 'history)
1635                 arg)))
1636
1637 (defun rcirc-browse-url-at-point (point)
1638   "Send URL at point to `browse-url'."
1639   (interactive "d")
1640   (let ((beg (previous-single-property-change point 'mouse-face))
1641         (end (next-single-property-change point 'mouse-face)))
1642     (browse-url (buffer-substring-no-properties beg end))))
1643
1644 (defun rcirc-browse-url-at-mouse (event)
1645   "Send URL at mouse click to `browse-url'."
1646   (interactive "e")
1647   (let ((position (event-end event)))
1648     (with-current-buffer (window-buffer (posn-window position))
1649       (rcirc-browse-url-at-point (posn-point position)))))
1650
1651 (defun rcirc-map-regexp (function regexp string)
1652   "Return a copy of STRING after calling FUNCTION for each REGEXP match.
1653 FUNCTION takes 3 arguments, MATCH-START, MATCH-END, and STRING."
1654   (let ((start 0))
1655     (while (string-match regexp string start)
1656       (setq start (match-end 0))
1657       (funcall function (match-beginning 0) (match-end 0) string)))
1658   string)
1659
1660 (defun rcirc-mangle-text (process text)
1661   "Return TEXT with properties added based on various patterns."
1662   ;; ^B
1663   (setq text
1664         (rcirc-map-regexp
1665          (lambda (start end string)
1666            (let ((orig-face (get-text-property start 'face string)))
1667                (add-text-properties
1668                 start end
1669                 (list 'face (if (listp orig-face)
1670                                 (append orig-face
1671                                         (list 'bold))
1672                               (list orig-face 'bold))
1673                       'rear-nonsticky t)
1674                 string)))
1675            "\x02.*?\x02"
1676            text))
1677   ;; TODO: deal with ^_ and ^C colors sequences
1678   (while (string-match "\\(.*\\)[\x02\x01]\\(.*\\)" text)
1679     (setq text (concat (match-string 1 text)
1680                        (match-string 2 text))))
1681   ;; my nick
1682   (setq text
1683         (with-syntax-table rcirc-nick-syntax-table
1684           (rcirc-map-regexp (lambda (start end string)
1685                               (add-text-properties
1686                                start end
1687                                (list 'face 'rcirc-nick-in-message
1688                                      'rear-nonsticky t)
1689                                string))
1690                             (concat "\\b"
1691                                     (regexp-quote (rcirc-nick process))
1692                                     "\\b")
1693                             text)))
1694   ;; urls
1695   (setq text
1696         (rcirc-map-regexp
1697          (lambda (start end string)
1698            (let ((orig-face (get-text-property start 'face string)))
1699              (add-text-properties start end
1700                                   (list 'face (if (listp orig-face)
1701                                                   (append orig-face
1702                                                           (list 'bold))
1703                                                 (list orig-face 'bold))
1704                                         'rear-nonsticky t
1705                                         'mouse-face 'highlight
1706                                         'keymap rcirc-browse-url-map)
1707                                   string))
1708              (push (substring-no-properties string start end) rcirc-urls))
1709            rcirc-url-regexp
1710            text))
1711   text)
1712
1713 \f
1714 ;;; handlers
1715 ;; these are called with the server PROCESS, the SENDER, which is a
1716 ;; server or a user, depending on the command, the ARGS, which is a
1717 ;; list of strings, and the TEXT, which is the original server text,
1718 ;; verbatim
1719 (defun rcirc-handler-001 (process sender args text)
1720   (rcirc-handler-generic process "001" sender args text)
1721   ;; set the real server name
1722   (with-rcirc-process-buffer process
1723     (setq rcirc-server sender)
1724     (setq rcirc-nick (car args))
1725     (rcirc-update-prompt)
1726     (when rcirc-auto-authenticate-flag (rcirc-authenticate))
1727     (rcirc-join-channels process rcirc-startup-channels)))
1728
1729 (defun rcirc-handler-PRIVMSG (process sender args text)
1730   (let ((target (if (rcirc-channel-p (car args))
1731                     (car args)
1732                   sender))
1733         (message (or (cadr args) "")))
1734     (if (string-match "^\C-a\\(.*\\)\C-a$" message)
1735         (rcirc-handler-CTCP process target sender (match-string 1 message))
1736       (rcirc-print process sender "PRIVMSG" target message t))
1737     ;; update nick timestamp
1738     (if (member target (rcirc-nick-channels process sender))
1739         (rcirc-put-nick-channel process sender target))))
1740
1741 (defun rcirc-handler-NOTICE (process sender args text)
1742   (let ((target (car args))
1743         (message (cadr args)))
1744     (if (string-match "^\C-a\\(.*\\)\C-a$" message)
1745         (rcirc-handler-CTCP-response process target sender
1746                                      (match-string 1 message))
1747       (rcirc-print process sender "NOTICE"
1748                    (cond ((rcirc-channel-p target)
1749                           target)
1750                          ;;; -ChanServ- [#gnu] Welcome...
1751                          ((string-match "^\\[\\(#[^ ]+\\)\\]" message)
1752                           (match-string 1 message))
1753                          (sender
1754                           (if (string= sender (rcirc-server process))
1755                               nil       ; server notice
1756                             sender)))
1757                  message t))))
1758
1759 (defun rcirc-handler-WALLOPS (process sender args text)
1760   (rcirc-print process sender "WALLOPS" sender (car args) t))
1761
1762 (defun rcirc-handler-JOIN (process sender args text)
1763   (let ((channel (car args)))
1764     (rcirc-get-buffer-create process channel)
1765     (rcirc-print process sender "JOIN" channel "")
1766
1767     ;; print in private chat buffer if it exists
1768     (when (rcirc-get-buffer rcirc-process sender)
1769       (rcirc-print process sender "JOIN" sender channel))
1770
1771     (rcirc-put-nick-channel process sender channel)))
1772
1773 ;; PART and KICK are handled the same way
1774 (defun rcirc-handler-PART-or-KICK (process response channel sender nick args)
1775   (rcirc-print process sender response channel (concat channel " " args))
1776
1777   ;; print in private chat buffer if it exists
1778   (when (rcirc-get-buffer rcirc-process nick)
1779     (rcirc-print process sender response nick (concat channel " " args)))
1780
1781   (if (not (string= nick (rcirc-nick process)))
1782       ;; this is someone else leaving
1783       (rcirc-remove-nick-channel process nick channel)
1784     ;; this is us leaving
1785     (mapc (lambda (n)
1786             (rcirc-remove-nick-channel process n channel))
1787           (rcirc-channel-nicks process channel))
1788
1789     ;; if the buffer is still around, make it inactive
1790     (let ((buffer (rcirc-get-buffer process channel)))
1791       (when buffer
1792         (with-current-buffer buffer
1793           (setq rcirc-target nil))))))
1794
1795 (defun rcirc-handler-PART (process sender args text)
1796   (rcirc-ignore-update-automatic sender)
1797   (rcirc-handler-PART-or-KICK process "PART"
1798                               (car args) sender sender
1799                               (cadr args)))
1800
1801 (defun rcirc-handler-KICK (process sender args text)
1802   (rcirc-handler-PART-or-KICK process "KICK" (car args) sender (cadr args)
1803                               (caddr args)))
1804
1805 (defun rcirc-handler-QUIT (process sender args text)
1806   (rcirc-ignore-update-automatic sender)
1807   (mapc (lambda (channel)
1808           (rcirc-print process sender "QUIT" channel (apply 'concat args)))
1809         (rcirc-nick-channels process sender))
1810
1811   ;; print in private chat buffer if it exists
1812   (when (rcirc-get-buffer rcirc-process sender)
1813     (rcirc-print process sender "QUIT" sender (apply 'concat args)))
1814
1815   (rcirc-nick-remove process sender))
1816
1817 (defun rcirc-handler-NICK (process sender args text)
1818   (let* ((old-nick sender)
1819          (new-nick (car args))
1820          (channels (rcirc-nick-channels process old-nick)))
1821     ;; update list of ignored nicks
1822     (rcirc-ignore-update-automatic old-nick)
1823     (when (member old-nick rcirc-ignore-list)
1824       (add-to-list 'rcirc-ignore-list new-nick)
1825       (add-to-list 'rcirc-ignore-list-automatic new-nick))
1826     ;; print message to nick's channels
1827     (dolist (target channels)
1828       (rcirc-print process sender "NICK" target new-nick))
1829     ;; update private chat buffer, if it exists
1830     (let ((chat-buffer (rcirc-get-buffer process old-nick)))
1831       (when chat-buffer
1832         (with-current-buffer chat-buffer
1833           (rcirc-print process sender "NICK" old-nick new-nick)
1834           (setq rcirc-target new-nick)
1835           (rename-buffer (rcirc-generate-new-buffer-name process new-nick)))))
1836     ;; remove old nick and add new one
1837     (with-rcirc-process-buffer process
1838       (let ((v (gethash old-nick rcirc-nick-table)))
1839         (remhash old-nick rcirc-nick-table)
1840         (puthash new-nick v rcirc-nick-table))
1841       ;; if this is our nick...
1842       (when (string= old-nick rcirc-nick)
1843         (setq rcirc-nick new-nick)
1844         (rcirc-update-prompt t)
1845         ;; reauthenticate
1846         (when rcirc-auto-authenticate-flag (rcirc-authenticate))))))
1847
1848 (defun rcirc-handler-PING (process sender args text)
1849   (rcirc-send-string process (concat "PONG " (car args))))
1850
1851 (defun rcirc-handler-PONG (process sender args text)
1852   ;; do nothing
1853   )
1854
1855 (defun rcirc-handler-TOPIC (process sender args text)
1856   (let ((topic (cadr args)))
1857     (rcirc-print process sender "TOPIC" (car args) topic)
1858     (with-current-buffer (rcirc-get-buffer process (car args))
1859       (setq rcirc-topic topic))))
1860
1861 (defun rcirc-handler-332 (process sender args text)
1862   "RPL_TOPIC"
1863   (let ((buffer (or (rcirc-get-buffer process (cadr args))
1864                     (rcirc-get-temp-buffer-create process (cadr args)))))
1865     (with-current-buffer buffer
1866       (setq rcirc-topic (caddr args)))))
1867
1868 (defun rcirc-handler-333 (process sender args text)
1869   "Not in rfc1459.txt"
1870   (let ((buffer (or (rcirc-get-buffer process (cadr args))
1871                     (rcirc-get-temp-buffer-create process (cadr args)))))
1872     (with-current-buffer buffer
1873       (let ((setter (caddr args))
1874             (time (current-time-string
1875                    (seconds-to-time
1876                     (string-to-number (cadddr args))))))
1877         (rcirc-print process sender "TOPIC" (cadr args)
1878                      (format "%s (%s on %s)" rcirc-topic setter time))))))
1879
1880 (defun rcirc-handler-477 (process sender args text)
1881   "ERR_NOCHANMODES"
1882   (rcirc-print process sender "477" (cadr args) (caddr args)))
1883
1884 (defun rcirc-handler-MODE (process sender args text)
1885   (let ((target (car args))
1886         (msg (mapconcat 'identity (cdr args) " ")))
1887     (rcirc-print process sender "MODE"
1888                  (if (string= target (rcirc-nick process))
1889                      nil
1890                    target)
1891                  msg)
1892
1893     ;; print in private chat buffers if they exist
1894     (mapc (lambda (nick)
1895             (when (rcirc-get-buffer process nick)
1896               (rcirc-print process sender "MODE" nick msg)))
1897           (cddr args))))
1898
1899 (defun rcirc-get-temp-buffer-create (process channel)
1900   "Return a buffer based on PROCESS and CHANNEL."
1901   (let ((tmpnam (concat " " (downcase channel) "TMP" (process-name process))))
1902     (get-buffer-create tmpnam)))
1903
1904 (defun rcirc-handler-353 (process sender args text)
1905   "RPL_NAMREPLY"
1906   (let ((channel (caddr args)))
1907     (mapc (lambda (nick)
1908             (rcirc-put-nick-channel process nick channel))
1909           (split-string (cadddr args) " " t))
1910     (with-current-buffer (rcirc-get-temp-buffer-create process channel)
1911       (goto-char (point-max))
1912       (insert (car (last args)) " "))))
1913
1914 (defun rcirc-handler-366 (process sender args text)
1915   "RPL_ENDOFNAMES"
1916   (let* ((channel (cadr args))
1917          (buffer (rcirc-get-temp-buffer-create process channel)))
1918     (with-current-buffer buffer
1919       (rcirc-print process sender "NAMES" channel
1920                    (buffer-substring (point-min) (point-max))))
1921     (kill-buffer buffer)))
1922
1923 (defun rcirc-handler-433 (process sender args text)
1924   "ERR_NICKNAMEINUSE"
1925   (rcirc-handler-generic process "433" sender args text)
1926   (let* ((new-nick (concat (cadr args) "`")))
1927     (with-rcirc-process-buffer process
1928       (rcirc-cmd-nick new-nick nil process))))
1929
1930 (defun rcirc-authenticate ()
1931   "Send authentication to process associated with current buffer.
1932 Passwords are stored in `rcirc-authinfo' (which see)."
1933   (interactive)
1934   (with-rcirc-process-buffer rcirc-process
1935     (dolist (i rcirc-authinfo)
1936       (let ((server (car i))
1937             (nick (caddr i))
1938             (method (cadr i))
1939             (args (cdddr i)))
1940         (when (and (string-match server rcirc-server)
1941                    (string-match nick rcirc-nick))
1942           (cond ((equal method 'nickserv)
1943                  (rcirc-send-string
1944                   rcirc-process
1945                   (concat
1946                    "PRIVMSG nickserv :identify "
1947                    (car args))))
1948                 ((equal method 'chanserv)
1949                  (rcirc-send-string
1950                   rcirc-process
1951                   (concat
1952                    "PRIVMSG chanserv :identify "
1953                    (cadr args) " " (car args))))
1954                 ((equal method 'bitlbee)
1955                  (rcirc-send-string
1956                   rcirc-process
1957                   (concat "PRIVMSG &bitlbee :identify " (car args))))
1958                 (t
1959                  (message "No %S authentication method defined"
1960                           method))))))))
1961
1962 (defun rcirc-handler-INVITE (process sender args text)
1963   (rcirc-print process sender "INVITE" nil (mapconcat 'identity args " ") t))
1964
1965 (defun rcirc-handler-ERROR (process sender args text)
1966   (rcirc-print process sender "ERROR" nil (mapconcat 'identity args " ")))
1967
1968 (defun rcirc-handler-CTCP (process target sender text)
1969   (if (string-match "^\\([^ ]+\\) *\\(.*\\)$" text)
1970       (let* ((request (upcase (match-string 1 text)))
1971              (args (match-string 2 text))
1972              (handler (intern-soft (concat "rcirc-handler-ctcp-" request))))
1973         (if (not (fboundp handler))
1974             (rcirc-print process sender "ERROR" target
1975                          (format "%s sent unsupported ctcp: %s" sender text)
1976                          t)
1977           (funcall handler process target sender args)
1978           (if (not (string= request "ACTION"))
1979               (rcirc-print process sender "CTCP" target
1980                            (format "%s" text) t))))))
1981
1982 (defun rcirc-handler-ctcp-VERSION (process target sender args)
1983   (rcirc-send-string process
1984                      (concat "NOTICE " sender
1985                              " :\C-aVERSION " rcirc-id-string
1986                              "\C-a")))
1987
1988 (defun rcirc-handler-ctcp-ACTION (process target sender args)
1989   (rcirc-print process sender "ACTION" target args t))
1990
1991 (defun rcirc-handler-ctcp-TIME (process target sender args)
1992   (rcirc-send-string process
1993                      (concat "NOTICE " sender
1994                              " :\C-aTIME " (current-time-string) "\C-a")))
1995
1996 (defun rcirc-handler-CTCP-response (process target sender message)
1997   (rcirc-print process sender "CTCP" nil message t))
1998 \f
1999 (defgroup rcirc-faces nil
2000   "Faces for rcirc."
2001   :group 'rcirc
2002   :group 'faces)
2003
2004 (defface rcirc-my-nick                  ; font-lock-function-name-face
2005   '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
2006     (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
2007     (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
2008     (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
2009     (((class color) (min-colors 8)) (:foreground "blue" :weight bold))
2010     (t (:inverse-video t :weight bold)))
2011   "The face used to highlight my messages."
2012   :group 'rcirc-faces)
2013
2014 (defface rcirc-other-nick            ; font-lock-variable-name-face
2015   '((((class grayscale) (background light))
2016      (:foreground "Gray90" :weight bold :slant italic))
2017     (((class grayscale) (background dark))
2018      (:foreground "DimGray" :weight bold :slant italic))
2019     (((class color) (min-colors 88) (background light)) (:foreground "DarkGoldenrod"))
2020     (((class color) (min-colors 88) (background dark)) (:foreground "LightGoldenrod"))
2021     (((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
2022     (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
2023     (((class color) (min-colors 8)) (:foreground "yellow" :weight light))
2024     (t (:weight bold :slant italic)))
2025   "The face used to highlight other messages."
2026   :group 'rcirc-faces)
2027
2028 (defface rcirc-server                   ; font-lock-comment-face
2029   '((((class grayscale) (background light))
2030      (:foreground "DimGray" :weight bold :slant italic))
2031     (((class grayscale) (background dark))
2032      (:foreground "LightGray" :weight bold :slant italic))
2033     (((class color) (min-colors 88) (background light))
2034      (:foreground "Firebrick"))
2035     (((class color) (min-colors 88) (background dark))
2036      (:foreground "chocolate1"))
2037     (((class color) (min-colors 16) (background light))
2038      (:foreground "red"))
2039     (((class color) (min-colors 16) (background dark))
2040      (:foreground "red1"))
2041     (((class color) (min-colors 8) (background light))
2042      )
2043     (((class color) (min-colors 8) (background dark))
2044      )
2045     (t (:weight bold :slant italic)))
2046   "The face used to highlight server messages."
2047   :group 'rcirc-faces)
2048
2049 (defface rcirc-server-prefix     ; font-lock-comment-delimiter-face
2050   '((default :inherit rcirc-server)
2051     (((class grayscale)))
2052     (((class color) (min-colors 16)))
2053     (((class color) (min-colors 8) (background light))
2054      :foreground "red")
2055     (((class color) (min-colors 8) (background dark))
2056      :foreground "red1"))
2057   "The face used to highlight server prefixes."
2058   :group 'rcirc-faces)
2059
2060 (defface rcirc-timestamp
2061   '((t (:inherit default)))
2062   "The face used to highlight timestamps."
2063   :group 'rcirc-faces)
2064
2065 (defface rcirc-nick-in-message          ; font-lock-keyword-face
2066   '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold))
2067     (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
2068     (((class color) (min-colors 88) (background light)) (:foreground "Purple"))
2069     (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1"))
2070     (((class color) (min-colors 16) (background light)) (:foreground "Purple"))
2071     (((class color) (min-colors 16) (background dark)) (:foreground "Cyan"))
2072     (((class color) (min-colors 8)) (:foreground "cyan" :weight bold))
2073     (t (:weight bold)))
2074   "The face used to highlight instances of nick within messages."
2075   :group 'rcirc-faces)
2076
2077 (defface rcirc-prompt                   ; comint-highlight-prompt
2078   '((((min-colors 88) (background dark)) (:foreground "cyan1"))
2079     (((background dark)) (:foreground "cyan"))
2080     (t (:foreground "dark blue")))
2081   "The face used to highlight prompts."
2082   :group 'rcirc-faces)
2083
2084 (defface rcirc-mode-line-nick
2085   '((t (:bold t)))
2086   "The face used indicate activity directed at you."
2087   :group 'rcirc-faces)
2088 \f
2089 ;; When using M-x flyspell-mode, only check words after the prompt
2090 (put 'rcirc-mode 'flyspell-mode-predicate 'rcirc-looking-at-input)
2091 (defun rcirc-looking-at-input ()
2092   "Returns true if point is past the input marker."
2093   (>= (point) rcirc-prompt-end-marker))
2094 \f
2095
2096 (provide 'rcirc)
2097
2098 ;; arch-tag: b471b7e8-6b5a-4399-b2c6-a3c78dfc8ffb
2099 ;;; rcirc.el ends here