+++ /dev/null
-;;; circe-autoloads.el --- automatically extracted autoloads
-;;
-;;; Code:
-(add-to-list 'load-path (directory-file-name (or (file-name-directory #$) (car load-path))))
-\f
-;;;### (autoloads nil "circe" "circe.el" (22555 30982 0 0))
-;;; Generated autoloads from circe.el
-
-(autoload 'circe-version "circe" "\
-Display Circe's version.
-
-\(fn)" t nil)
-
-(autoload 'circe "circe" "\
-Connect to IRC.
-
-Connect to the given network specified by NETWORK-OR-SERVER.
-
-When this function is called, it collects options from the
-SERVER-OPTIONS argument, the user variable
-`circe-network-options', and the defaults found in
-`circe-network-defaults', in this order.
-
-If NETWORK-OR-SERVER is not found in any of these variables, the
-argument is assumed to be the host name for the server, and all
-relevant settings must be passed via SERVER-OPTIONS.
-
-All SERVER-OPTIONS are treated as variables by getting the string
-\"circe-\" prepended to their name. This variable is then set
-locally in the server buffer.
-
-See `circe-network-options' for a list of common options.
-
-\(fn NETWORK-OR-SERVER &rest SERVER-OPTIONS)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "circe-color-nicks" "circe-color-nicks.el"
-;;;;;; (22555 30982 0 0))
-;;; Generated autoloads from circe-color-nicks.el
-
-(autoload 'enable-circe-color-nicks "circe-color-nicks" "\
-Enable the Color Nicks module for Circe.
-This module colors all encountered nicks in a cross-server fashion.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "circe-highlight-all-nicks" "circe-highlight-all-nicks.el"
-;;;;;; (22555 30982 0 0))
-;;; Generated autoloads from circe-highlight-all-nicks.el
-
-(autoload 'enable-circe-highlight-all-nicks "circe-highlight-all-nicks" "\
-Enable the Highlight Nicks module for Circe.
-This module highlights all occurances of nicks in the current
-channel in messages of other people.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "circe-lagmon" "circe-lagmon.el" (22555 30982
-;;;;;; 0 0))
-;;; Generated autoloads from circe-lagmon.el
-
-(defvar circe-lagmon-mode nil "\
-Non-nil if Circe-Lagmon mode is enabled.
-See the `circe-lagmon-mode' command
-for a description of this minor mode.
-Setting this variable directly does not take effect;
-either customize it (see the info node `Easy Customization')
-or call the function `circe-lagmon-mode'.")
-
-(custom-autoload 'circe-lagmon-mode "circe-lagmon" nil)
-
-(autoload 'circe-lagmon-mode "circe-lagmon" "\
-Circe-lagmon-mode monitors the amount of lag on your
-connection to each server, and displays the lag time in seconds
-in the mode-line.
-
-\(fn &optional ARG)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "circe-new-day-notifier" "circe-new-day-notifier.el"
-;;;;;; (22555 30982 0 0))
-;;; Generated autoloads from circe-new-day-notifier.el
-
-(autoload 'enable-circe-new-day-notifier "circe-new-day-notifier" "\
-
-
-\(fn)" t nil)
-
-(autoload 'disable-circe-new-day-notifier "circe-new-day-notifier" "\
-
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "lui-autopaste" "lui-autopaste.el" (22555 30982
-;;;;;; 0 0))
-;;; Generated autoloads from lui-autopaste.el
-
-(autoload 'enable-lui-autopaste "lui-autopaste" "\
-Enable the lui autopaste feature.
-
-If you enter more than `lui-autopaste-lines' at once, Lui will
-ask if you would prefer to use a paste service instead. If you
-agree, Lui will paste your input to `lui-autopaste-function' and
-replace it with the resulting URL.
-
-\(fn)" t nil)
-
-(autoload 'disable-lui-autopaste "lui-autopaste" "\
-Disable the lui autopaste feature.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "lui-irc-colors" "lui-irc-colors.el" (22555
-;;;;;; 30982 0 0))
-;;; Generated autoloads from lui-irc-colors.el
-
-(autoload 'enable-lui-irc-colors "lui-irc-colors" "\
-Enable IRC color interpretation for Lui.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "lui-track-bar" "lui-track-bar.el" (22555 30982
-;;;;;; 0 0))
-;;; Generated autoloads from lui-track-bar.el
-
-(autoload 'enable-lui-track-bar "lui-track-bar" "\
-Enable a bar in Lui buffers that shows where you stopped reading.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil "shorten" "shorten.el" (22555 30982 0 0))
-;;; Generated autoloads from shorten.el
-
-(autoload 'shorten-strings "shorten" "\
-Takes a list of strings and returns an alist ((STRING
-. SHORTENED-STRING) ...). Uses `shorten-split-function' to split
-the strings, and `shorten-join-function' to join shortened
-components back together into SHORTENED-STRING. See also
-`shorten-validate-component-function'.
-
-\(fn STRINGS)" nil nil)
-
-;;;***
-\f
-;;;### (autoloads nil "tracking" "tracking.el" (22555 30982 0 0))
-;;; Generated autoloads from tracking.el
-
-(defvar tracking-mode nil "\
-Non-nil if Tracking mode is enabled.
-See the `tracking-mode' command
-for a description of this minor mode.
-Setting this variable directly does not take effect;
-either customize it (see the info node `Easy Customization')
-or call the function `tracking-mode'.")
-
-(custom-autoload 'tracking-mode "tracking" nil)
-
-(autoload 'tracking-mode "tracking" "\
-Allow cycling through modified buffers.
-This mode in itself does not track buffer modification, but
-provides an API for programs to add buffers as modified (using
-`tracking-add-buffer').
-
-Once this mode is active, modified buffers are shown in the mode
-line. The user can cycle through them using
-\\[tracking-next-buffer].
-
-\(fn &optional ARG)" t nil)
-
-(autoload 'tracking-add-buffer "tracking" "\
-Add BUFFER as being modified with FACES.
-This does check whether BUFFER is currently visible.
-
-If FACES is given, it lists the faces that might be appropriate
-for BUFFER in the mode line. The highest-priority face of these
-and the current face of the buffer, if any, is used. Priority is
-decided according to `tracking-faces-priorities'.
-
-\(fn BUFFER &optional FACES)" nil nil)
-
-(autoload 'tracking-remove-buffer "tracking" "\
-Remove BUFFER from being tracked.
-
-\(fn BUFFER)" nil nil)
-
-(autoload 'tracking-next-buffer "tracking" "\
-Switch to the next active buffer.
-
-\(fn)" t nil)
-
-(autoload 'tracking-previous-buffer "tracking" "\
-Switch to the last active buffer.
-
-\(fn)" t nil)
-
-;;;***
-\f
-;;;### (autoloads nil nil ("circe-chanop.el" "circe-compat.el" "circe-pkg.el"
-;;;;;; "irc.el" "lcs.el" "lui-format.el" "lui-logging.el" "lui.el"
-;;;;;; "make-tls-process.el") (22555 30982 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; End:
-;;; circe-autoloads.el ends here
+++ /dev/null
-;;; circe-chanop.el --- Provide common channel operator commands
-
-;; Copyright (C) 2006, 2015 Jorgen Schaefer
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-
-;; This file is part of Circe.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This Circe module provides some often-used chanop commands. I was
-;; very reluctant to add this. None of these commands will make it in
-;; the core, or even be provided by default. You should have to go to
-;; great lengths to use them.
-
-;; Always remember the Tao of IRC:
-;;
-;; IGNORE is the weapon of an IRC knight. Not as clumsy or as
-;; random as a kickban.
-
-;;; Code:
-
-(require 'circe)
-
-(defun circe-command-MODE (mode)
- "Set MODE in the current channel."
- (interactive "sMode change: ")
- (cond
- ((not (string-match "^[+-]" mode))
- (irc-send-raw (circe-server-process)
- (format "MODE %s" mode)))
- ((eq major-mode 'circe-channel-mode)
- (irc-send-raw (circe-server-process)
- (format "MODE %s %s" circe-chat-target mode)))
- (t
- (circe-display-server-message "Not in a channel buffer."))))
-
-(defun circe-command-BANS (&optional ignored)
- "Show channel bans"
- (if (not circe-chat-target)
- (circe-display-server-message "No target for current buffer")
- (irc-send-raw (circe-server-process)
- (format "MODE %s +b" circe-chat-target))))
-
-(defun circe-command-KICK (nick &optional reason)
- "Kick WHO from the current channel with optional REASON."
- (interactive "sKick who: \nsWhy: ")
- (if (not (eq major-mode 'circe-channel-mode))
- (circe-display-server-message "Not in a channel buffer.")
- (when (not reason)
- (if (string-match "^\\([^ ]*\\) +\\(.+\\)" nick)
- (setq reason (match-string 2 nick)
- nick (match-string 1 nick))
- (setq reason "-")))
- (irc-send-raw (circe-server-process)
- (format "KICK %s %s :%s"
- circe-chat-target nick reason))))
-
-(defun circe-command-GETOP (&optional ignored)
- "Ask chanserv for op on the current channel."
- (interactive)
- (if (not (eq major-mode 'circe-channel-mode))
- (circe-display-server-message "Not in a channel buffer.")
- (irc-send-PRIVMSG (circe-server-process)
- "chanserv"
- (format "op %s" circe-chat-target))))
-
-(defun circe-command-DROPOP (&optional ignored)
- "Lose op mode on the current channel."
- (interactive)
- (if (not (eq major-mode 'circe-channel-mode))
- (circe-display-server-message "Not in a channel buffer.")
- (irc-send-raw (circe-server-process)
- (format "MODE %s -o %s"
- circe-chat-target
- (circe-nick)))))
-
-;; For KICKBAN (requested by Riastradh), we'd need a callback on a
-;; USERHOST command.
-
-(provide 'circe-chanop)
-;;; circe-chanop.el ends here
+++ /dev/null
-;;; circe-color-nicks.el --- Color nicks in the channel
-
-;; Copyright (C) 2012 Taylan Ulrich Bayırlı/Kammer
-
-;; Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirliNOSPAMgmail.com>
-
-;; This file is part of Circe.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This Circe module adds the ability to assign a color to each
-;; nick in a channel.
-
-;; Some ideas/code copied from rcirc-colors.el.
-
-;; To use it, put the following into your .emacs:
-
-;; (require 'circe-color-nicks)
-;; (enable-circe-color-nicks)
-
-;;; Code:
-
-(require 'circe)
-(require 'color)
-(require 'cl-lib)
-
-;;;###autoload
-(defun enable-circe-color-nicks ()
- "Enable the Color Nicks module for Circe.
-This module colors all encountered nicks in a cross-server fashion."
- (interactive)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (eq major-mode 'circe-channel-mode)
- (add-circe-color-nicks))))
- (add-hook 'circe-channel-mode-hook
- 'add-circe-color-nicks))
-
-(defun disable-circe-color-nicks ()
- "Disable the Color Nicks module for Circe.
-See `enable-circe-color-nicks'."
- (interactive)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (eq major-mode 'circe-channel-mode)
- (remove-circe-color-nicks))))
- (remove-hook 'circe-channel-mode-hook
- 'add-circe-color-nicks))
-
-(defun add-circe-color-nicks ()
- "Add `circe-color-nicks' to `lui-pre-output-hook'."
- (add-hook 'lui-pre-output-hook 'circe-color-nicks))
-
-(defun remove-circe-color-nicks ()
- "Remove `circe-color-nicks' from `lui-pre-output-hook'."
- (remove-hook 'lui-pre-output-hook 'circe-color-nicks))
-
-
-(defgroup circe-color-nicks nil
- "Nicks colorization for Circe"
- :prefix "circe-color-nicks-"
- :group 'circe)
-
-(defcustom circe-color-nicks-min-contrast-ratio 7
- "Minimum contrast ratio from background for generated colors;
-recommended is 7:1, or at least 4.5:1 (7 stands for 7:1 here).
-Lower value allows higher color spread, but could lead to less
-readability."
- :group 'circe-color-nicks)
-
-(defcustom circe-color-nicks-min-difference 17
- "Minimum difference from each other for generated colors."
- :group 'circe-color-nicks)
-
-(defcustom circe-color-nicks-min-fg-difference 17
- "Minimum difference from foreground for generated colors."
- :group 'circe-color-nicks)
-
-(defcustom circe-color-nicks-min-my-message-difference 0
- "Minimum difference from own nick color for generated colors."
- :group 'circe-color-nicks)
-
-(defcustom circe-color-nicks-everywhere nil
- "Whether nicks should be colored in message bodies too."
- :type 'boolean
- :group 'circe-color-nicks)
-
-(defcustom circe-color-nicks-message-blacklist nil
- "Blacklist for nicks that shall never be highlighted inside
- images."
- :type '(repeat string)
- :group 'circe-color-nicks)
-
-(defcustom circe-color-nicks-pool-type 'adaptive
- "Type of the color nick pool.
-Must be one of the following:
-
-'adaptive: Generate colors based on the current theme.
-
-List of strings: Pick colors from the specified list of hex codes
-or color names (see `color-name-rgb-alist')."
- :type '(choice (const :tag "Adaptive" adaptive)
- (repeat string))
- :group 'circe-color-nicks)
-
-
-;;; See http://www.w3.org/TR/2013/NOTE-WCAG20-TECHS-20130905/G18
-
-(defsubst circe-w3-contrast-c-to-l (c)
- (if (<= c 0.03928)
- (/ c 12.92)
- (expt (/ (+ c 0.055) 1.055) 2.4)))
-
-(defsubst circe-w3-contrast-relative-luminance (rgb)
- (apply #'+
- (cl-mapcar (lambda (color coefficient)
- (* coefficient
- (circe-w3-contrast-c-to-l color)))
- rgb
- '(0.2126 0.7152 0.0722))))
-
-(defsubst circe-w3-contrast-contrast-ratio (color1 color2)
- (let ((l1 (+ 0.05 (circe-w3-contrast-relative-luminance color1)))
- (l2 (+ 0.05 (circe-w3-contrast-relative-luminance color2))))
- (if (> l1 l2)
- (/ l1 l2)
- (/ l2 l1))))
-
-
-(defun circe-color-alist ()
- "Return list of colors (name rgb lab) where rgb is 0 to 1."
- (let ((alist (if (display-graphic-p)
- color-name-rgb-alist
- (mapcar (lambda (c)
- (cons (car c) (cddr c)))
- (tty-color-alist))))
- (valmax (float (car (color-values "#ffffff")))))
- (mapcar (lambda (c)
- (let* ((name (car c))
- (rgb (mapcar (lambda (v)
- (/ v valmax))
- (cdr c)))
- (lab (apply #'color-srgb-to-lab rgb)))
- (list name rgb lab)))
- alist)))
-
-(defun circe-color-canonicalize-format (color)
- "Turns COLOR into (name rgb lab) format. Avoid calling this in
-a loop, it's very slow on a tty!"
- (let* ((name color)
- (rgb (circe-color-name-to-rgb color))
- (lab (apply #'color-srgb-to-lab rgb)))
- (list name rgb lab)))
-
-(defun circe-color-contrast-ratio (color1 color2)
- "Gives the contrast ratio between two colors."
- (circe-w3-contrast-contrast-ratio (nth 1 color1) (nth 1 color2)))
-
-(defun circe-color-diff (color1 color2)
- "Gives the difference between two colors per CIEDE2000."
- (color-cie-de2000 (nth 2 color1) (nth 2 color2)))
-
-(defun circe-color-name-to-rgb (color)
- "Like `color-name-to-rgb' but also handles \"unspecified-bg\"
-and \"unspecified-fg\"."
- (cond ((equal color "unspecified-bg") '(0 0 0))
- ((equal color "unspecified-fg") '(1 1 1))
- (t (color-name-to-rgb color))))
-
-
-(defun circe-nick-color-appropriate-p (color bg fg my-msg)
- "Tells whether COLOR is appropriate for being a nick color.
-BG, FG, and MY-MSG are the background, foreground, and my-message
-colors; these are expected as parameters instead of computed here
-because computing them repeatedly is a heavy operation."
- (and (>= (circe-color-contrast-ratio color bg)
- circe-color-nicks-min-contrast-ratio)
- (>= (circe-color-diff color fg)
- circe-color-nicks-min-fg-difference)
- (>= (circe-color-diff color my-msg)
- circe-color-nicks-min-my-message-difference)))
-
-(defun circe-nick-colors-delete-similar (colors)
- "Return list COLORS with pairs of colors filtered out that are
-too similar per `circe-color-nicks-min-difference'. COLORS may
-be mutated."
- (cl-mapl (lambda (rest)
- (let ((color (car rest)))
- (setcdr rest (cl-delete-if
- (lambda (c)
- (< (circe-color-diff color c)
- circe-color-nicks-min-difference))
- (cdr rest)))))
- colors)
- colors)
-
-(defun circe-nick-color-generate-pool ()
- "Return a list of appropriate nick colors."
- (if (consp circe-color-nicks-pool-type)
- circe-color-nicks-pool-type
- (let ((bg (circe-color-canonicalize-format (face-background 'default)))
- (fg (circe-color-canonicalize-format (face-foreground 'default)))
- (my-msg (circe-color-canonicalize-format
- (face-attribute
- 'circe-my-message-face :foreground nil 'default))))
- (mapcar #'car (circe-nick-colors-delete-similar
- (cl-remove-if-not
- (lambda (c)
- (circe-nick-color-appropriate-p c bg fg my-msg))
- (circe-color-alist)))))))
-
-(defun circe-nick-color-pool-test ()
- "Display all appropriate nick colors in a temp buffer."
- (interactive)
- (switch-to-buffer (get-buffer-create "*Circe color test*"))
- (erase-buffer)
- (let ((pool (circe-nick-color-generate-pool)))
- (while pool
- (let ((pt (point)))
- (insert "The quick brown fox jumped over the lazy dog.\n")
- (put-text-property pt (point) 'face `(:foreground ,(pop pool)))))))
-
-(defvar circe-nick-color-pool nil
- "Pool of yet unused nick colors.")
-
-(defvar circe-nick-color-mapping (make-hash-table :test 'equal)
- "Hash-table from nicks to colors.")
-
-(defun circe-nick-color-nick-list ()
- "Return list of all nicks that have a color assigned to them.
-Own and blacklisted nicks are excluded."
- (let ((our-nick (circe-nick))
- (channel-nicks (circe-channel-nicks))
- nicks)
- (maphash
- (lambda (nick color)
- (when (and (member nick channel-nicks)
- (not (string= our-nick nick))
- (not (member nick circe-color-nicks-message-blacklist)))
- (push nick nicks)))
- circe-nick-color-mapping)
- nicks))
-
-(defvar circe-nick-color-timestamps (make-hash-table :test 'equal)
- "Hash-table from colors to the timestamp of their last use.")
-
-(defun circe-nick-color-for-nick (nick)
- "Return the color for NICK. Assigns a color to NICK if one
-wasn't assigned already."
- (let ((color (gethash nick circe-nick-color-mapping)))
- (when (not color)
- ;; NOTE use this as entry point for taking NICK into account for
- ;; picking the new color
- (setq color (circe-nick-color-pick))
- (puthash nick color circe-nick-color-mapping))
- (puthash color (float-time) circe-nick-color-timestamps)
- color))
-
-(defun circe-nick-color-pick ()
- "Picks either a color from the pool of unused colors, or the
-color that was used least recently (i.e. nicks that have it
-assigned have been least recently active)."
- (if (zerop (hash-table-count circe-nick-color-mapping))
- (setq circe-nick-color-pool (circe-nick-color-generate-pool)))
- (or (pop circe-nick-color-pool)
- (circe-nick-color-pick-least-recent)))
-
-(defun circe-nick-color-pick-least-recent ()
- "Pick the color that was used least recently.
-See `circe-nick-color-pick', which is where this is used."
- (let ((least-recent-color nil)
- (oldest-time (float-time)))
- (maphash
- (lambda (color time)
- (if (< time oldest-time)
- (progn
- (setq least-recent-color color)
- (setq oldest-time time))))
- circe-nick-color-timestamps)
- (if least-recent-color
- least-recent-color
- ;; Someone must have messed with `circe-nick-color-mapping', recover by
- ;; re-filling the pool.
- (setq circe-nick-color-pool (circe-nick-color-generate-pool))
- (pop circe-nick-color-pool))))
-
-(defun circe-color-nicks ()
- "Color nicks on this lui output line."
- (when (eq major-mode 'circe-channel-mode)
- (let ((nickstart (text-property-any (point-min) (point-max)
- 'lui-format-argument 'nick)))
- (when nickstart
- (goto-char nickstart)
- (let ((nickend (next-single-property-change nickstart
- 'lui-format-argument))
- (nick (plist-get (plist-get (text-properties-at nickstart)
- 'lui-keywords)
- :nick)))
- (when (not (circe-server-my-nick-p nick))
- (let ((color (circe-nick-color-for-nick nick)))
- (add-face-text-property nickstart nickend
- `(:foreground ,color)))))))
- (when circe-color-nicks-everywhere
- (let ((body (text-property-any (point-min) (point-max)
- 'lui-format-argument 'body)))
- (when body
- (with-syntax-table circe-nick-syntax-table
- (goto-char body)
- (let* ((nicks (circe-nick-color-nick-list))
- (regex (regexp-opt nicks 'words)))
- (let (case-fold-search)
- (while (re-search-forward regex nil t)
- (let* ((nick (match-string-no-properties 0))
- (color (circe-nick-color-for-nick nick)))
- (add-face-text-property (match-beginning 0) (match-end 0)
- `(:foreground ,color))))))))))))
-
-(defun circe-nick-color-reset ()
- "Reset the nick color mapping (and some internal data).
-
-This is useful if you switched between frames supporting
-different color ranges and would like nicks to get new colors
-appropriate to the new color range."
- (interactive)
- (setq circe-nick-color-pool (circe-nick-color-generate-pool))
- (setq circe-nick-color-mapping (make-hash-table :test 'equal))
- (setq circe-nick-color-timestamps (make-hash-table :test 'equal)))
-
-(provide 'circe-color-nicks)
-;;; circe-color-nicks.el ends here
+++ /dev/null
-;;; circe-compat.el --- Compatibility definitions
-
-;; Copyright (C) 2015 Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
-
-;; Author: Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Define functions and variables as needed by Circe to remain
-;; compatible with older Emacsen.
-
-;;; Code:
-
-(when (not (fboundp 'string-trim))
- (defun string-trim (string)
- "Remove leading and trailing whitespace from STRING."
- (if (string-match "\\` *\\(.*[^[:space:]]\\) *\\'" string)
- (match-string 1 string)
- string)))
-
-(when (not (fboundp 'add-face-text-property))
- (defun add-face-text-property (start end face &optional append object)
- (while (/= start end)
- (let* ((next (next-single-property-change start 'face object end))
- (prev (get-text-property start 'face object))
- (value (if (listp prev) prev (list prev))))
- (put-text-property start next 'face
- (if append
- (append value (list face))
- (append (list face) value))
- object)
- (setq start next)))))
-
-(when (not (boundp 'mode-line-misc-info))
- (defvar mode-line-misc-info nil
- "Misc info in the mode line.")
- (add-to-list 'mode-line-format 'mode-line-misc-info t))
-
-(provide 'circe-compat)
-;;; circe-compat.el ends here
+++ /dev/null
-;;; circe-highlight-all-nicks.el --- Highlight all nicks in the current channel
-
-;; Copyright (C) 2005 Jorgen Schaefer
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-
-;; This file is part of Circe.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This Circe module adds the ability to highlight every occurance of
-;; a nick in the current channel in a message by other people.
-
-;; To use it, put the following into your .emacs:
-
-;; (require 'circe-highlight-all-nicks)
-;; (enable-circe-highlight-all-nicks)
-
-;;; Code:
-
-(require 'circe)
-
-(defface circe-highlight-all-nicks-face
- '((t (:foreground "green")))
- "The face used for nicks from the current channel.
-See `enable-circe-highlight-all-nicks'."
- :group 'circe)
-
-;;;###autoload
-(defun enable-circe-highlight-all-nicks ()
- "Enable the Highlight Nicks module for Circe.
-This module highlights all occurances of nicks in the current
-channel in messages of other people."
- (interactive)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (eq major-mode 'circe-channel-mode)
- (add-circe-highlight-all-nicks))))
- (add-hook 'circe-channel-mode-hook
- 'add-circe-highlight-all-nicks))
-
-(defun disable-circe-highlight-all-nicks ()
- "Disable the Highlight Nicks module for Circe.
-See `enable-circe-highlight-all-nicks'."
- (interactive)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (eq major-mode 'circe-channel-mode)
- (remove-circe-highlight-all-nicks))))
- (remove-hook 'circe-channel-mode-hook
- 'add-circe-highlight-all-nicks))
-
-(defun add-circe-highlight-all-nicks ()
- "Add `circe-highlight-all-nicks' to `lui-pre-output-hook'."
- (add-hook 'lui-pre-output-hook 'circe-highlight-all-nicks
- nil t))
-
-(defun remove-circe-highlight-all-nicks ()
- "Remove `circe-highlight-all-nicks' from `lui-pre-output-hook'."
- (remove-hook 'lui-pre-output-hook 'circe-highlight-all-nicks
- t))
-
-(defun circe-highlight-all-nicks ()
- "Highlight all occurances of nicks of the current channel in the message."
- (when (eq major-mode 'circe-channel-mode)
- (let ((body (text-property-any (point-min) (point-max)
- 'lui-format-argument 'body))
- (nicks '())
- (regex nil))
- (when body
- (let ((channel-nicks (circe-channel-nicks)))
- (when channel-nicks
- (mapc (lambda (nick)
- (when (not (circe-server-my-nick-p nick))
- (setq nicks (cons nick nicks))))
- channel-nicks)))
- (setq regex (regexp-opt nicks 'words))
- (goto-char body)
- (while (re-search-forward regex nil t)
- (add-text-properties (match-beginning 0)
- (match-end 0)
- '(face circe-highlight-all-nicks-face)))))))
-
-(provide 'circe-highlight-all-nicks)
-;;; circe-highlight-all-nicks.el ends here
+++ /dev/null
-;;; circe-lagmon.el --- Lag Monitor for Circe
-
-;; Copyright (C) 2011-2012 Jorgen Schaefer
-
-;; Author: John J Foerch <jjfoerchNOSPAMearthlink.net>,
-;; Jorgen Schaefer
-
-;; This file is part of Circe.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;; 02110-1301, USA.
-
-;;; Commentary:
-;;;
-;;; Circe-lagmon-mode monitors the amount of lag on your connection to
-;;; each server, and displays the lag time in seconds in the mode-line.
-;;; It works by managing two timers. Timer1 sends CTCP LAGMON to yourself
-;;; on each server every 60 seconds. Each time around, timer1 starts
-;;; timer2 to monitor for timeouts of these messages. Timer2 cancels
-;;; itself when all of the pings in the round have been answered.
-;;;
-
-;;; Code:
-
-(require 'circe)
-
-;;; User variables
-
-(defgroup circe-lagmon nil
- "Lag Monitor for Circe"
- :prefix "circe-lagmon-"
- :group 'circe)
-
-(defcustom circe-lagmon-timer-tick 5
- "How often to check for lag.
-
-Increase this to improve performance at the cost of accuracy."
- :type 'number
- :group 'circe-lagmon)
-
-(defcustom circe-lagmon-check-interval 60
- "Interval in seconds at which to send the CTCP message."
- :type 'number
- :group 'circe-lagmon)
-
-(defcustom circe-lagmon-reconnect-interval 120
- "Seconds after which to automatically reconnect upon a timeout
-of a lag monitor message. A value of nil disables the feature."
- :type '(choice (const :tag "Disable auto-reconnect" nil)
- number)
- :group 'circe-lagmon)
-
-(defcustom circe-lagmon-mode-line-format-string "lag:%.1f "
- "Format string for displaying the lag in the mode-line."
- :type 'string
- :group 'circe-lagmon)
-
-(defcustom circe-lagmon-mode-line-unknown-lag-string "lag:? "
- "Indicator string for displaying unknown lag in the mode-line."
- :type 'string
- :group 'circe-lagmon)
-
-(defvar circe-lagmon-disabled nil
- "A boolean value if lagmon should be disabled on this network.
-
-Don't set this by hand, use `circe-network-options'.")
-(make-variable-buffer-local 'circe-lagmon-disabled)
-
-
-;;; Internal variables
-;;;
-(defvar circe-lagmon-timer nil)
-
-(defvar circe-lagmon-server-lag nil)
-(make-variable-buffer-local 'circe-lagmon-server-lag)
-
-(defvar circe-lagmon-last-send-time nil)
-(make-variable-buffer-local 'circe-lagmon-last-send-time)
-
-(defvar circe-lagmon-last-receive-time nil)
-(make-variable-buffer-local 'circe-lagmon-last-receive-time)
-
-(defun circe-lagmon-timer-tick ()
- "Function run periodically to check lag.
-
-This will call `circe-lagmon-server-check' in every active server
-buffer. You can call it yourself if you like to force an update,
-there is no harm in running it too often, but it really should be
-run sufficiently often with the timer."
- (dolist (buffer (circe-server-buffers))
- (with-current-buffer buffer
- (when (and (eq major-mode 'circe-server-mode)
- circe-server-process
- (eq (irc-connection-state circe-server-process)
- 'registered)
- (not circe-lagmon-disabled))
- (circe-lagmon-server-check)))))
-
-(defun circe-lagmon-server-check ()
- "Check the current server for lag.
-
-This will reconnect if we haven't heard back for too long, or
-send a request if it's time for that. See
-`circe-lagmon-reconnect-interval' and
-`circe-lagmon-check-interval' to configure the behavior.."
- (let ((now (float-time)))
- (cond
- ;; No answer so far...
- ((and circe-lagmon-last-send-time
- (not circe-lagmon-last-receive-time))
- ;; Count up until the answer comes.
- (let ((lag (/ (- now circe-lagmon-last-send-time) 2)))
- (when (or (not circe-lagmon-server-lag)
- (> lag circe-lagmon-server-lag))
- (setq circe-lagmon-server-lag lag)
- (circe-lagmon-force-mode-line-update)))
- ;; Check for timeout.
- (when (and circe-lagmon-reconnect-interval
- (> now
- (+ circe-lagmon-last-send-time
- circe-lagmon-reconnect-interval)))
- (setq circe-lagmon-last-send-time nil
- circe-lagmon-last-receive-time nil)
- (circe-reconnect)))
- ;; Nothing sent so far, or last send was too long ago.
- ((or (not circe-lagmon-last-send-time)
- (> now
- (+ circe-lagmon-last-send-time
- circe-lagmon-check-interval)))
- (irc-send-raw (circe-server-process)
- (format "PRIVMSG %s :\C-aLAGMON %s\C-a"
- (circe-nick) now)
- :nowait)
- (setq circe-lagmon-last-send-time now
- circe-lagmon-last-receive-time nil))
- )))
-
-(defun circe-lagmon-force-mode-line-update ()
- "Call force-mode-line-update on a circe server buffer and all
-of its chat buffers."
- (force-mode-line-update)
- (dolist (b (circe-server-chat-buffers))
- (with-current-buffer b
- (force-mode-line-update))))
-
-(defun circe-lagmon-format-mode-line-entry ()
- "Format the mode-line entry for displaying the lag."
- (let ((buf (cond
- ((eq major-mode 'circe-server-mode)
- (current-buffer))
- (circe-server-buffer
- circe-server-buffer)
- (t
- nil))))
- (when buf
- (with-current-buffer buf
- (cond
- (circe-lagmon-disabled
- nil)
- (circe-lagmon-server-lag
- (format circe-lagmon-mode-line-format-string
- circe-lagmon-server-lag))
- (t
- circe-lagmon-mode-line-unknown-lag-string))))))
-
-(defun circe-lagmon-init ()
- "Initialize the values of the lag monitor for one server, and
-start the lag monitor if it has not been started."
- (setq circe-lagmon-server-lag nil
- circe-lagmon-last-send-time nil
- circe-lagmon-last-receive-time nil)
- (circe-lagmon-force-mode-line-update)
- (unless circe-lagmon-timer
- (setq circe-lagmon-timer
- (run-at-time nil circe-lagmon-timer-tick
- 'circe-lagmon-timer-tick))))
-
-(defun circe-lagmon--rpl-welcome-handler (conn &rest ignored)
- (with-current-buffer (irc-connection-get conn :server-buffer)
- (circe-lagmon-init)))
-
-(defun circe-lagmon--ctcp-lagmon-handler (conn event sender target argument)
- (when (irc-current-nick-p conn (irc-userstring-nick sender))
- (with-current-buffer (irc-connection-get conn :server-buffer)
- (let* ((now (float-time))
- (lag (/ (- now (string-to-number argument))
- 2)))
- (setq circe-lagmon-server-lag lag
- circe-lagmon-last-receive-time now)
- (circe-lagmon-force-mode-line-update)))))
-
-(defun circe-lagmon--nick-handler (conn event sender new-nick)
- (when (irc-current-nick-p conn (irc-userstring-nick sender))
- (with-current-buffer (irc-connection-get conn :server-buffer)
- (setq circe-lagmon-last-send-time nil))))
-
-;;;###autoload
-(define-minor-mode circe-lagmon-mode
- "Circe-lagmon-mode monitors the amount of lag on your
-connection to each server, and displays the lag time in seconds
-in the mode-line."
- :global t
- (let ((mode-line-entry '(:eval (circe-lagmon-format-mode-line-entry))))
- (remove-hook 'mode-line-modes mode-line-entry)
- (let ((table (circe-irc-handler-table)))
- (irc-handler-remove table "001" 'circe-lagmon--rpl-welcome-handler)
- (irc-handler-remove table "irc.ctcp.LAGMON"
- 'circe-lagmon--ctcp-lagmon-handler)
- (irc-handler-remove table "NICK" 'circe-lagmon--nick-handler))
- (circe-set-display-handler "irc.ctcp.LAGMON" nil)
- (when circe-lagmon-timer
- (cancel-timer circe-lagmon-timer)
- (setq circe-lagmon-timer nil))
- (when circe-lagmon-mode
- (add-hook 'mode-line-modes mode-line-entry)
- (let ((table (circe-irc-handler-table)))
- (irc-handler-add table "001" 'circe-lagmon--rpl-welcome-handler)
- (irc-handler-add table "irc.ctcp.LAGMON"
- 'circe-lagmon--ctcp-lagmon-handler)
- (irc-handler-add table "NICK" 'circe-lagmon--nick-handler))
- (circe-set-display-handler "irc.ctcp.LAGMON" 'circe-display-ignore)
- (dolist (buffer (circe-server-buffers))
- (with-current-buffer buffer
- (setq circe-lagmon-server-lag nil)
- (when (and circe-server-process
- (eq (irc-connection-state circe-server-process)
- 'registered))
- (circe-lagmon-init)))))))
-
-(provide 'circe-lagmon)
-;;; circe-lagmon.el ends here
+++ /dev/null
-;;; circe-new-day-notifier.el --- Send a message every midnight to all
-;;; channels
-
-;; Copyright (C) 2015 Pásztor János
-
-;; Author: Pásztor János <model87NOSPAMfreemail.hu>
-
-;; This file is part of Circe.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 2
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This Circe module adds the ability to send a notification to all
-;; channels every midnight
-
-;; Some ideas/code copied from circe-lagmon.el and
-;; circe-color-nicks.el
-
-;; To use it, put the following into your .emacs:
-
-;; (require 'circe-new-day-notifier)
-;; (enable-circe-new-day-notifier)
-
-;;; Code:
-
-(require 'circe)
-
-(defgroup circe-new-day-notifier nil
- "Midnight notification to Circe"
- :prefix "circe-new-day-notifier-"
- :group 'circe)
-
-(defcustom circe-new-day-notifier-format-message "*** Day changed to {day}"
- "The format string which will be printed to the channels. It
-should contain {day} to print the date. See `circe-display' for
-further documentation"
- :type 'string
- :group 'circe-new-day-notifier)
-
-(defcustom circe-new-day-notifier-date-format "%Y-%m-%d, %A"
- "The date format, which will be used at
-circe-new-day-notifier-format-message. See `format-time-string' for
-documentation"
- :type 'string
- :group 'circe-new-day-notifier)
-
-(defvar circe-new-day-notifier-timer nil)
-
-;;;###autoload
-(defun enable-circe-new-day-notifier ()
- (interactive)
- (unless circe-new-day-notifier-timer
- (setq circe-new-day-notifier-timer
- (run-at-time "24:00:00" (* 24 60 60) 'circe-new-day-notification))))
-
-;;;###autoload
-(defun disable-circe-new-day-notifier ()
- (interactive)
- (when circe-new-day-notifier-timer
- (cancel-timer circe-new-day-notifier-timer)
- (setq circe-new-day-notifier-timer nil)))
-
-(defun circe-new-day-notification ()
- "This function prints the new day notification to each query and chat buffer"
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (derived-mode-p 'circe-chat-mode)
- (circe-display 'circe-new-day-notifier-format-message
- :day (format-time-string circe-new-day-notifier-date-format))))))
-
-(provide 'circe-new-day-notifier)
-;;; circe-new-day-notifier.el ends here
+++ /dev/null
-(define-package "circe" "20161102.1405" "Client for IRC in Emacs"
- '((cl-lib "0.5"))
- :url "https://github.com/jorgenschaefer/circe")
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; circe.el --- Client for IRC in Emacs -*- lexical-binding: t -*-
-
-;; Copyright (C) 2005 - 2015 Jorgen Schaefer
-
-;; Version: 2.3
-;; Keywords: IRC, chat
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-;; URL: https://github.com/jorgenschaefer/circe
-
-;; This file is part of Circe.
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Circe is a Client for IRC in Emacs. It integrates well with the rest
-;; of the editor, using standard Emacs key bindings and indicating
-;; activity in channels in the status bar so it stays out of your way
-;; unless you want to use it.
-
-;;; Code:
-
-(defvar circe-version "2.3"
- "Circe version string.")
-
-(require 'circe-compat)
-
-(require 'ring)
-(require 'timer)
-(require 'lui)
-(require 'lui-format)
-(require 'lcs)
-(require 'irc)
-
-;; Used to be optional. But sorry, we're in the 21st century already.
-(require 'lui-irc-colors)
-
-;; necessary for inheriting from diff-added and diff-removed faces
-(require 'diff-mode)
-
-(defgroup circe nil
- "Yet Another Emacs IRC Client."
- :prefix "circe-"
- :group 'applications)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Customization Options ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;
-;;;; Faces ;;;;
-;;;;;;;;;;;;;;;
-
-(defface circe-prompt-face
- '((t (:weight bold :foreground "Black" :background "LightSeaGreen")))
- "The face for the Circe prompt."
- :group 'circe)
-
-(defface circe-server-face
- '((((type tty)) (:foreground "blue" :weight bold))
- (((background dark)) (:foreground "#5095cf"))
- (((background light)) (:foreground "#3840b0"))
- (t (:foreground "SteelBlue")))
- "The face used to highlight server messages."
- :group 'circe)
-
-(defface circe-highlight-nick-face
- '((default (:weight bold))
- (((type tty)) (:foreground "cyan"))
- (((background dark)) (:foreground "#82e2ed"))
- (((background light)) (:foreground "#0445b7"))
- (t (:foreground "CadetBlue3")))
- "The face used to highlight messages directed to us."
- :group 'circe)
-
-(defface circe-my-message-face '((t))
- "The face used to highlight our own messages."
- :group 'circe)
-
-(defface circe-originator-face '((t))
- "The face used to highlight the originator of a message."
- :group 'circe)
-
-(defface circe-topic-diff-new-face '((t (:inherit diff-added)))
- "The face used for text added to a topic.
-See the {topic-diff} parameter to `circe-format-server-topic'."
- :group 'circe)
-
-(defface circe-topic-diff-removed-face '((t (:inherit diff-removed)))
- "The face used for text removed from a topic.
-See the {topic-diff} parameter to `circe-format-server-topic'."
- :group 'circe)
-
-(defface circe-fool-face
- '((((type tty)) (:foreground "grey40" :bold t))
- (t (:foreground "grey40")))
- "The face used for fools.
-See `circe-fool-list'."
- :group 'circe)
-
-;;;;;;;;;;;;;;;;;;;
-;;;; Variables ;;;;
-;;;;;;;;;;;;;;;;;;;
-
-(defcustom circe-default-nick (user-login-name)
- "The default nick for circe."
- :type 'string
- :group 'circe)
-
-(defcustom circe-default-user circe-default-nick
- "The default user name for circe."
- :type 'string
- :group 'circe)
-
-(defcustom circe-default-realname (if (string= (user-full-name) "")
- circe-default-nick
- (user-full-name))
- "The default real name for circe."
- :type 'string
- :group 'circe)
-
-(defcustom circe-default-ip-family nil
- "Default IP family to use.
-
- 'nil - Use either IPv4 or IPv6.
-
- 'ipv4 - Use IPv4
-
- 'ipv6 - Use IPv6"
- :type '(choice (const :tag "Both" nil)
- (const :tag "IPv4" ipv4)
- (const :tag "IPv6" ipv6))
- :group 'circe)
-
-(defcustom circe-default-directory "~/"
- "The value of `default-directory' for Circe buffers."
- :type 'string
- :group 'circe)
-
-(defcustom circe-network-options nil
- "Network options.
-
-This alist maps network names to respective options.
-
-Common options:
-
- :pass - The IRC server password to use for this network, or a
- function to fetch it.
- :nick - The nick name to use (defaults to `circe-default-nick')
- :user - The user name to use (defaults to `circe-default-user')
- :realname - The real name to use (defaults to `circe-default-realname')
-
- :channels - A plist of channels to join (see `circe-channels').
- :server-buffer-name - Format to be used for the server buffer name
- (see `circe-server-buffer-name')
-
- :host - The host name of the server to connect to.
- :port - The port or service name for the server.
- :use-tls - A boolean indicating as to whether to use TLS or
- not (defaults to nil). If you set this, you'll likely
- have to set :port as well.
- :ip-family - Option to enforce a specific IP version
- (defaults to `circe-default-ip-family')
-
- :nickserv-nick - The nick to authenticate with to nickserv, if configured.
- (defaults to the value of :nick)
- :nickserv-password - The password to use for nickserv
- authentication or a function to fetch it.
-
- :sasl-username - The username for SASL authentication.
- :sasl-password - The password for SASL authentication."
- :type '(alist :key-type string :value-type plist)
- :group 'circe)
-
-(defvar circe-network-defaults
- '(("Freenode" :host "irc.freenode.net" :port (6667 . 6697)
- :tls t
- :nickserv-mask "^NickServ!NickServ@services\\.$"
- :nickserv-identify-challenge "\C-b/msg\\s-NickServ\\s-identify\\s-<password>\C-b"
- :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {nick} {password}"
- :nickserv-identify-confirmation "^You are now identified for \ 2.*\ 2\\.$"
- :nickserv-ghost-command "PRIVMSG NickServ :GHOST {nick} {password}"
- :nickserv-ghost-confirmation "has been ghosted\\.$\\|is not online\\.$"
- )
- ("Coldfront" :host "irc.coldfront.net" :port 6667
- :nickserv-mask "^NickServ!services@coldfront\\.net$"
- :nickserv-identify-challenge "/msg\\s-NickServ\\s-IDENTIFY\\s-\C-_password\C-_"
- :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {password}"
- )
- ("Bitlbee" :host "localhost" :port 6667
- :nickserv-mask "\\(bitlbee\\|root\\)!\\(bitlbee\\|root\\)@"
- :nickserv-identify-challenge "use the \x02identify\x02 command to identify yourself"
- :nickserv-identify-command "PRIVMSG &bitlbee :identify {password}"
- :nickserv-identify-confirmation "Password accepted, settings and accounts loaded"
- :lagmon-disabled t
- )
- ("OFTC" :host "irc.oftc.net" :port (6667 . 6697)
- :nickserv-mask "^NickServ!services@services\\.oftc\\.net$"
- :nickserv-identify-challenge "This nickname is registered and protected."
- :nickserv-identify-command "PRIVMSG NickServ :IDENTIFY {password} {nick}"
- :nickserv-identify-confirmation "^You are successfully identified as \ 2.*\ 2\\.$"
- )
- )
- "Alist of networks and connection settings.
-
-See the `circe' command for details of this variable.")
-
-(defcustom circe-default-quit-message "Using Circe, the loveliest of all IRC clients"
- "The default quit message when no other is given.
-
-This is sent when the server buffer is killed or when /QUIT is
-given with no argument."
- :type 'string
- :group 'circe)
-
-(defcustom circe-default-part-message "Using Circe, the loveliest of all IRC clients"
- "How to part when a channel buffer is killed, or when no
-argument is given to /PART."
- :type 'string
- :group 'circe)
-
-(defcustom circe-auto-query-max 23
- "The maximum number of queries which are opened automatically.
-If more messages arrive - typically in a flood situation - they
-are displayed in the server buffer."
- :type 'integer
- :group 'circe)
-
-(defcustom circe-use-cycle-completion nil
- "Whether Circe should use cycle completion.
-
-If this is not nil, Circe will set `completion-cycle-threshold'
-to t locally in Circe buffers, enabling cycle completion for
-nicks no matter what completion style you use in the rest of
-Emacs. If you set this to nil, Circe will not touch your default
-completion style."
- :type 'boolean
- :group 'circe)
-
-(defcustom circe-reduce-lurker-spam nil
- "If enabled, Circe will stop showing some messages.
-
-This means that JOIN, PART, QUIT and NICK messages are not shown
-for users on channels that have not spoken yet (\"lurker\"), or
-haven't spoken in `circe-active-users-timeout' seconds. When they
-speak for the first time, Circe displays their join time."
- :type 'boolean
- :group 'circe)
-
-(defcustom circe-active-users-timeout nil
- "When non-nil, should be the number of seconds after which
-active users are regarded as inactive again after speaking."
- :type 'integer
- :group 'circe)
-
-(defcustom circe-prompt-string (concat (propertize ">"
- 'face 'circe-prompt-face)
- " ")
- "The string to initialize the prompt with.
-To change the prompt dynamically or just in specific buffers, use
-`lui-set-prompt' in the appropriate hooks."
- :type 'string
- :group 'circe)
-
-(defcustom circe-extra-nicks nil
- "List of other nicks than your current one to highlight."
- :type '(repeat string)
- :group 'circe)
-
-(defcustom circe-highlight-nick-type 'sender
- "How to highlight occurrences of our own nick.
-
- 'sender - Highlight the nick of the sender
- (messages without a sender and your
- own are highlighted with the occurrence
- type instead)
- 'occurrence - Highlight the occurrences of the nick
- 'message - Highlight the message without the sender
- 'all - Highlight the whole line"
- :type '(choice (const :tag "Sender" sender)
- (const :tag "Occurrences" occurrence)
- (const :tag "Message" message)
- (const :tag "Whole line" all))
- :group 'circe)
-
-(defcustom circe-inhibit-nick-highlight-function nil
- "Function for inhibiting nick highlighting.
-If non-nil, its value is called with the respective buffer
-selected and point in the line that's about to get highlighted.
-A non-nil return value inhibits any highlighting."
- :type '(choice (const :tag "None" nil)
- function)
- :group 'circe)
-
-(defcustom circe-completion-suffix ": "
- "A suffix for completed nicks at the beginning of a line."
- :type '(choice (const :tag "The standard suffix" ": "))
- :group 'circe)
-
-(defcustom circe-ignore-list nil
- "List of regular expressions to ignore.
-
-Each regular expression is matched against nick!user@host."
- :type '(repeat regexp)
- :group 'circe)
-
-(defcustom circe-fool-list nil
- "List of regular expressions for fools.
-
-Each regular expression is matched against nick!user@host.
-
-Messages from such people are still inserted, but not shown. They
-can be displayed using \\[lui-toggle-ignored]."
- :type '(repeat regexp)
- :group 'circe)
-
-(defcustom circe-ignore-functions nil
- "A list of functions to check whether we should ignore a message.
-
-These functions get three arguments: NICK, USERHOST, and BODY. If
-one of them returns a non-nil value, the message is ignored."
- :type 'hook
- :group 'circe)
-
-(defcustom circe-split-line-length 440
- "The maximum length of a single message.
-If a message exceeds this size, it is broken into multiple ones.
-
-IRC allows for lines up to 512 bytes. Two of them are CR LF.
-And a typical message looks like this:
-
- :nicky!uhuserNOSPAMhost212223.dialin.fnordisp.net PRIVMSG #lazybastards :Hello!
-
-You can limit here the maximum length of the \"Hello!\" part.
-Good luck."
- :type 'integer
- :group 'circe)
-
-(defcustom circe-server-max-reconnect-attempts 5
- "How often Circe should attempt to reconnect to the server.
-If this is 0, Circe will not reconnect at all. If this is nil,
-it will try to reconnect forever (not recommended)."
- :type 'integer
- :group 'circe)
-
-(defcustom circe-netsplit-delay 60
- "The number of seconds a netsplit may be dormant.
-If anything happens with a netsplit after this amount of time,
-the user is re-notified."
- :type 'number
- :group 'circe)
-
-(defcustom circe-server-killed-confirmation 'ask-and-kill-all
- "How to ask for confirmation when a server buffer is killed.
-This can be one of the following values:
- ask - Ask the user for confirmation
- ask-and-kill-all - Ask the user, and kill all associated buffers
- kill-all - Don't ask the user, and kill all associated buffers
- nil - Kill first, ask never"
- :type '(choice (const :tag "Ask before killing" ask)
- (const :tag "Ask, then kill all associated buffers"
- ask-and-kill-all)
- (const :tag "Don't ask, then kill all associated buffers"
- kill-all)
- (const :tag "Don't ask" nil))
- :group 'circe)
-
-(defcustom circe-channel-killed-confirmation 'ask
- "How to ask for confirmation when a channel buffer is killed.
-This can be one of the following values:
- ask - Ask the user for confirmation
- nil - Don't ask, just kill"
- :type '(choice (const :tag "Ask before killing" ask)
- (const :tag "Don't ask" nil))
- :group 'circe)
-
-(defcustom circe-track-faces-priorities '(circe-highlight-nick-face
- lui-highlight-face
- circe-my-message-face
- circe-server-face)
- "A list of faces which should show up in the tracking.
-The first face is kept if the new message has only lower faces,
-or faces that don't show up at all."
- :type '(repeat face)
- :group 'circe)
-
-(defcustom circe-server-send-unknown-command-p nil
- "Non-nil when Circe should just pass on commands it doesn't know.
-E.g. /fnord foo bar would then just send \"fnord foo bar\" to the
-server."
- :type 'boolean
- :group 'circe)
-
-(defcustom circe-server-connected-hook nil
- "Hook run when we successfully connected to a server.
-This is run from a 001 (RPL_WELCOME) message handler."
- :type 'hook
- :group 'circe)
-
-(defcustom circe-server-auto-join-default-type :immediate
- "The default auto-join type to use.
-
-Possible options:
-
-:immediate - Immediately after registering on the server
-:after-auth - After nickserv authentication succeeded
-:after-cloak - After we have acquired a cloaked host name
-:after-nick - After we regained our preferred nick, or after
- nickserv authentication if we don't need to regain
- it. See `circe-nickserv-ghost-style'.
-
-See `circe-channels' for more details."
- :type '(choice (const :tag "Immediately" :immediate)
- (const :tag "After Authentication" :after-auth)
- (const :tag "After Cloaking" :after-cloak)
- (const :tag "After Nick Regain" :after-nick))
- :group 'circe)
-
-;;;;;;;;;;;;;;;;;
-;;;; Formats ;;;;
-;;;;;;;;;;;;;;;;;
-
-(defgroup circe-format nil
- "Format strings for Circe.
-All these formats always allow the {mynick} and {chattarget} format
-strings."
- :prefix "circe-format-"
- :group 'circe)
-
-(defcustom circe-format-not-tracked
- '(circe-format-server-message
- circe-format-server-notice
- circe--irc-format-server-numeric
- circe-format-server-topic
- circe-format-server-rejoin
- circe-format-server-lurker-activity
- circe-format-server-topic-time
- circe-format-server-topic-time-for-channel
- circe-format-server-netmerge
- circe-format-server-join
- circe-format-server-join-in-channel
- circe-format-server-mode-change
- circe-format-server-nick-change-self
- circe-format-server-nick-change
- circe-format-server-nick-regain
- circe-format-server-part
- circe-format-server-netsplit
- circe-format-server-quit-channel
- circe-format-server-quit)
- "A list of formats that should not trigger tracking."
- :type '(repeat symbol)
- :group 'circe-format)
-
-(defcustom circe-format-server-message "*** {body}"
- "The format for generic server messages.
-{body} - The body of the message."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-self-say "> {body}"
- "The format for messages to queries or channels.
-{nick} - Your nick.
-{body} - The body of the message."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-self-action "* {nick} {body}"
- "The format for actions to queries or channels.
-{nick} - Your nick.
-{body} - The body of the action."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-self-message "-> *{chattarget}* {body}"
- "The format for messages sent to other people outside of queries.
-{chattarget} - The target nick.
-{body} - The body of the message."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-action "* {nick} {body}"
- "The format for actions in queries or channels.
-{nick} - The nick doing the action.
-{body} - The body of the action."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-message-action "* *{nick}* {body}"
- "The format for actions in messages outside of queries.
-{nick} - The nick doing the action.
-{body} - The body of the action."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-say "<{nick}> {body}"
- "The format for normal channel or query talk.
-{nick} - The nick talking.
-{body} - The message."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-message "*{nick}* {body}"
- "The format for a message outside of a query.
-{nick} - The originator.
-{body} - The message."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-notice "-{nick}- {body}"
- "The format for a notice.
-{nick} - The originator.
-{body} - The notice."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-notice "-Server Notice- {body}"
- "The format for a server notice.
-{body} - The notice."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-topic "*** Topic change by {nick} ({userhost}): {new-topic}"
- "The format for topic changes.
-
-The following format arguments are available:
-
- nick - The nick of the user who changed the topic
- userhost - The user@host string of that user
- channel - Where the topic change happened
- new-topic - The new topic
- old-topic - The previous topic
- topic-diff - A colorized diff of the topics"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-lurker-activity
- "*** First activity: {nick} joined {joindelta} ago."
- "The format for the first-activity notice of a user.
-{nick} - The originator.
-{jointime} - The join time of the user (in seconds).
-{joindelta} - The duration from joining until now."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-rejoin
- "*** Re-join: {nick} ({userinfo}), left {departuredelta} ago"
- "The format for the re-join notice of a user.
-
-The following format arguments are available:
-
- nick - The nick of the user who joined
- userhost - The user@host string of the user who joined
- accountname - The account name, if the server supports this
- realname - The real name, if the server supports this
- userinfo - A combination of userhost, accountname, and realname
- channel - A date string describing this time
- departuretime - Time in seconds when the originator had left.
- departuredelta - Description of the time delta since the originator left."
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-server-buffer-name "{host}:{port}"
- "The format for the server buffer name.
-
-The following format arguments are available:
-
- network - The name of the network
- host - The host name of the server
- port - The port number or service name
- service - Alias for port"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-whois-idle-with-signon "*** {whois-nick} is {idle-duration} idle (signon on {signon-date}, {signon-ago} ago)"
- "Format for RPL_WHOISIDLE messages.
-
-The following format arguments are available:
-
- whois-nick - The nick this is about
- idle-seconds - The number of seconds this nick has been idle
- idle-duration - A textual description of the duration of the idle time
- signon-time - The time (in seconds since the epoch) when this user
- signed on
- signon-date - A date string describing this time
- signon-ago - A textual description of the duraction since signon"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-whois-idle "*** {whois-nick} is {idle-duration} idle"
- "Format for RPL_WHOISIDLE messages.
-
-The following format arguments are available:
-
- whois-nick - The nick this is about
- idle-seconds - The number of seconds this nick has been idle
- idle-duration - A textual description of the duration of the idle time"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-topic-time "*** Topic set by {setter} on {topic-date}, {topic-ago} ago"
- "Format for RPL_TOPICWHOTIME messages for the current channel.
-
-The following format arguments are available:
-
- channel - The channel the topic is for
- setter - The nick of the person who set the topic
- setter-userhost - The user@host string of the person who set the topic
- topic-time - The time the topic was set, in seconds since the epoch
- topic-date - A date string describing this time
- topic-ago - A textual description of the duration since the topic
- was set"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-topic-time-for-channel "*** Topic for {channel} set by {setter} on {topic-date}, {topic-ago} ago"
- "Format for RPL_TOPICWHOTIME messages for a channel we are not on.
-
-The following format arguments are available:
-
- channel - The channel the topic is for
- setter - The nick of the person who set the topic
- setter-userhost - The user@host string of the person who set the topic
- topic-time - The time the topic was set, in seconds since the epoch
- topic-date - A date string describing this time
- topic-ago - A textual description of the duration since the topic
- was set"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-channel-creation-time "*** Channel {channel} created on {date}, {ago} ago"
- "Format for RPL_CREATIONTIME messages for the current channel.
-
-The following format arguments are available:
-
- channel - The channel the topic is for
- date - A date string describing this time
- ago - A textual description of the duration since the channel
- was created"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-ctcp-ping "*** CTCP PING request from {nick} ({userhost}) to {target}: {body} ({ago} ago)"
- "Format for CTCP PING requests.
-
-The following format arguments are available:
-
- nick - The nick of the user who sent this PING request
- userhost - The user@host string of the user who sent this request
- target - The target of the message, usually us, but can be a channel
- body - The argument of the PING request, usually a number
- ago - A textual description of the duration since the request
- was sent, if parseable"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-ctcp-ping-reply "*** CTCP PING reply from {nick} ({userhost}) to {target}: {ago} ago ({body})"
- "Format for CTCP PING replies.
-
-The following format arguments are available:
-
- nick - The nick of the user who sent this PING request
- userhost - The user@host string of the user who sent this request
- target - The target of the message, usually us, but can be a channel
- body - The argument of the PING request, usually a number
- ago - A textual description of the duration since the request
- was sent, if parseable"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-ctcp "*** CTCP {command} request from {nick} ({userhost}) to {target}: {body}"
- "Format for CTCP requests.
-
-The following format arguments are available:
-
- nick - The nick of the user who sent this PING request
- userhost - The user@host string of the user who sent this request
- target - The target of the message, usually us, but can be a channel
- command - The CTCP command used
- body - The argument of the PING request, usually a number"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-netsplit "*** Netsplit: {split} (Use /WL to see who left)"
- "Format for netsplit notifications.
-
-The following format arguments are available:
-
- split - The name of the split, usually describing the servers involved"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-netmerge "*** Netmerge: {split}, split {ago} ago (Use /WL to see who's still missing)"
- "Format for netmerge notifications.
-
-The following format arguments are available:
-
- split - The name of the split, usually describing the servers involved
- time - The time when this split happened, in seconds
- date - A date string describing this time
- ago - A textual description of the duration since the split happened"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-join "*** Join: {nick} ({userinfo})"
- "Format for join messages in a channel buffer.
-
-The following format arguments are available:
-
- nick - The nick of the user joining
- userhost - The user@host string for the user
- accountname - The account name, if the server supports this
- realname - The real name, if the server supports this
- userinfo - A combination of userhost, accountname, and realname
- channel - The channel this user is joining"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-join-in-channel "*** Join: {nick} ({userinfo}) joined {channel}"
- "Format for join messages in query buffers of the joining user.
-
-The following format arguments are available:
-
- nick - The nick of the user joining
- userhost - The user@host string for the user
- accountname - The account name, if the server supports this
- realname - The real name, if the server supports this
- userinfo - A combination of userhost, accountname, and realname
- channel - The channel this user is joining"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-mode-change "*** Mode change: {change} on {target} by {setter} ({userhost})"
- "Format for mode changes.
-
-The following format arguments are available:
-
- setter - The name of the split, usually describing the servers involved
- userhost - The user@host string for the user
- target - The target of this mode change
- change - The actual changed modes"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-nick-change-self "*** Nick change: You are now known as {new-nick}"
- "Format for nick changes of the current user.
-
-The following format arguments are available:
-
- old-nick - The old nick this change was from
- new-nick - The new nick this change was to
- userhost - The user@host string for the user"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-nick-change "*** Nick change: {old-nick} ({userhost}) is now known as {new-nick}"
- "Format for nick changes of the current user.
-
-The following format arguments are available:
-
- old-nick - The old nick this change was from
- new-nick - The new nick this change was to
- userhost - The user@host string for the user"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-nick-regain "*** Nick regain: {old-nick} ({userhost}) is now known as {new-nick}"
- "Format for nick changes of the current user.
-
-The following format arguments are available:
-
- old-nick - The old nick this change was from
- new-nick - The new nick this change was to
- userhost - The user@host string for the user"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-part "*** Part: {nick} ({userhost}) left {channel}: {reason}"
- "Format for users parting a channel.
-
-The following format arguments are available:
-
- nick - The nick of the user who left
- userhost - The user@host string for this user
- channel - The channel they left
- reason - The reason they gave for leaving"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-quit-channel "*** Quit: {nick} ({userhost}) left {channel}: {reason}"
- "Format for users quitting from a channel.
-
-The following format arguments are available:
-
- nick - The nick of the user who left
- userhost - The user@host string for this user
- channel - The channel they left
- reason - The reason they gave for leaving"
- :type 'string
- :group 'circe-format)
-
-(defcustom circe-format-server-quit "*** Quit: {nick} ({userhost}) left IRC: {reason}"
- "Format for users quitting.
-
-The following format arguments are available:
-
- nick - The nick of the user who left
- userhost - The user@host string for this user
- reason - The reason they gave for leaving"
- :type 'string
- :group 'circe-format)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Private variables ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar circe-source-url "https://github.com/jorgenschaefer/circe"
- "URL to Circe's source repository")
-
-(defvar circe-host nil
- "The name of the server we're currently connected to.")
-(make-variable-buffer-local 'circe-host)
-
-(defvar circe-port nil
- "The port number or service name of the server.")
-(make-variable-buffer-local 'circe-host)
-
-(defvar circe-network nil
- "The network name of the server we're currently connected to.")
-(make-variable-buffer-local 'circe-network)
-
-(defvar circe-ip-family nil
- "The IP family in use.
-See `make-network-process' and :family for valid values.")
-(make-variable-buffer-local 'circe-ip-family)
-
-(defvar circe-nick nil
- "Our current nick.")
-(make-variable-buffer-local 'circe-nick)
-
-(defvar circe-user nil
- "The current user name.")
-(make-variable-buffer-local 'circe-user)
-
-(defvar circe-realname nil
- "The current real name.")
-(make-variable-buffer-local 'circe-realname)
-
-(defvar circe-pass nil
- "The password for the current server or a function to recall it.
-
-If a function is set it will be called with the value of `circe-host'.")
-(make-variable-buffer-local 'circe-pass)
-
-(defvar circe-sasl-username nil
- "The username for SASL authentication.")
-(make-variable-buffer-local 'circe-sasl-username)
-
-(defvar circe-sasl-password nil
- "The password for SASL authentication.
-
-If a function is set it will be called with the value of
-`circe-host'.")
-(make-variable-buffer-local 'circe-sasl-password)
-
-(defvar circe-use-tls nil
- "If non-nil, use `open-tls-stream' to connect to the server.")
-(make-variable-buffer-local 'circe-use-tls)
-
-(defvar circe-server-process nil
- "The process of the server connection.")
-(make-variable-buffer-local 'circe-server-process)
-
-(defvar circe-server-last-active-buffer nil
- "The last active circe buffer.")
-(make-variable-buffer-local 'circe-server-last-active-buffer)
-
-(defvar circe-display-table nil
- "A hash table mapping commands to their display functions.")
-
-(defvar circe-server-inhibit-auto-reconnect-p nil
- "Non-nil when Circe should not reconnect.
-
-This can be set from commands to avoid reconnecting when the
-server disconnects.")
-(make-variable-buffer-local 'circe-server-inhibit-auto-reconnect-p)
-
-(defvar circe-chat-calling-server-buffer-and-target nil
- "Internal variable to pass the server buffer and target to chat modes.")
-
-(defvar circe-chat-target nil
- "The current target for the buffer.
-This is either a channel or a nick name.")
-(make-variable-buffer-local 'circe-chat-target)
-
-(defvar circe-nick-syntax-table
- (let ((table (make-syntax-table text-mode-syntax-table))
- (special (string-to-list "[]\`_^{}|-")))
- (dolist (char special)
- (modify-syntax-entry char "w" table))
- table)
- "Syntax table to treat nicks as words.
-This is not entirely accurate, as exact chars constituting a nick
-can vary between networks.")
-
-(defvar circe-nickserv-mask nil
- "The regular expression to identify the nickserv on this network.
-
-Matched against nick!user@host.")
-(make-variable-buffer-local 'circe-nickserv-mask)
-
-(defvar circe-nickserv-identify-challenge nil
- "A regular expression matching the nickserv challenge to identify.")
-(make-variable-buffer-local 'circe-nickserv-identify-challenge)
-
-(defvar circe-nickserv-identify-command nil
- "The IRC command to send to identify with nickserv.
-
-This must be a full IRC command. It accepts the following
-formatting options:
-
- {nick} - The nick to identify as
- {password} - The configured nickserv password")
-(make-variable-buffer-local 'circe-nickserv-identify-command)
-
-(defvar circe-nickserv-identify-confirmation nil
- "A regular expression matching a confirmation of authentication.")
-(make-variable-buffer-local 'circe-nickserv-identify-confirmation)
-
-(defvar circe-nickserv-ghost-command nil
- "The IRC command to send to regain/ghost your nick.
-
-This must be a full IRC command. It accepts the following
-formatting options:
-
- {nick} - The nick to ghost
- {password} - The configured nickserv password")
-(make-variable-buffer-local 'circe-nickserv-ghost-command)
-
-(defvar circe-nickserv-ghost-confirmation nil
- "A regular expression matching a confirmation for the GHOST command.
-
-This is used to know when we can set our nick to the regained one
-Leave nil if regaining automatically sets your nick")
-(make-variable-buffer-local 'circe-nickserv-ghost-confirmation)
-
-(defvar circe-nickserv-nick nil
- "The nick we are registered with for nickserv.
-
-Do not set this variable directly. Use `circe-network-options' or
-pass an argument to the `circe' function for this.")
-(make-variable-buffer-local 'circe-nickserv-nick)
-
-(defvar circe-nickserv-password nil
- "The password we use for nickserv on this network.
-
-Can be either a string or a unary function of the nick returning
-a string.
-
-Do not set this variable directly. Use `circe-network-options' or
-pass an argument to the `circe' function for this.")
-(make-variable-buffer-local 'circe-nickserv-password)
-
-(defvar circe-channels nil
- "The default channels to join on this server.
-
-Don't set this variable by hand, use `circe-network-options'.
-
-The value should be a list of channels to join, with optional
-keywords to configure the behavior of the following channels.
-
-Best explained in an example:
-
-\(\"#emacs\" :after-auth \"#channel\" \"#channel2\")
-
-Possible keyword options are:
-
-:immediate - Immediately after registering on the server
-:after-auth - After nickserv authentication succeeded
-:after-cloak - After we have acquired a cloaked host name
-:after-nick - After we regained our preferred nick, or after
- nickserv authentication if we don't need to regain
- it. See `circe-nickserv-ghost-style'.
-
-The default is set in `circe-server-auto-join-default-type'.
-
-A keyword in the first position of the channels list overrides
-`circe-server-auto-join-default-type' for re-joining manually
-joined channels.")
-(make-variable-buffer-local 'circe-channels)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Server Buffer Management ;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Every Circe buffer has an associated server buffer (which might be
-;; the buffer itself). Circe buffers should set the
-;; `circe-server-buffer' variable to the associated server buffer.
-
-(defun circe-server-buffer ()
- "Return the server buffer for the current buffer."
- (let ((buf (if (eq major-mode 'circe-server-mode)
- (current-buffer)
- circe-server-buffer)))
- (cond
- ((not buf)
- (error "Not in a Circe buffer"))
- ((not (buffer-live-p buf))
- (error "The server buffer died, functionality is limited"))
- (t
- buf))))
-
-(defmacro with-circe-server-buffer (&rest body)
- "Run BODY with the current buffer being the current server buffer."
- (declare (indent 0))
- `(with-current-buffer (circe-server-buffer)
- ,@body))
-
-;;;;;;;;;;;;;;;;;;;;;;;
-;;; Editor Commands ;;;
-;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;###autoload
-(defun circe-version ()
- "Display Circe's version."
- (interactive)
- (message "Circe %s" (circe--version)))
-
-(defun circe--version ()
- "Return Circe's version"
- (let ((circe-git-version (circe--git-version)))
- (if circe-git-version
- (format "%s-%s" circe-version circe-git-version)
- (format "%s" circe-version))))
-
-(defun circe--git-version ()
- (let* ((current-file-path (or load-file-name buffer-file-name
- (locate-library "circe.el")))
- (vcs-path (locate-dominating-file current-file-path ".git")))
- (when vcs-path
- (let ((default-directory vcs-path))
- ;; chop off the trailing newline
- (substring (shell-command-to-string "git rev-parse --short HEAD")
- 0 -1)))))
-
-;;;###autoload
-(defun circe (network-or-server &rest server-options)
- "Connect to IRC.
-
-Connect to the given network specified by NETWORK-OR-SERVER.
-
-When this function is called, it collects options from the
-SERVER-OPTIONS argument, the user variable
-`circe-network-options', and the defaults found in
-`circe-network-defaults', in this order.
-
-If NETWORK-OR-SERVER is not found in any of these variables, the
-argument is assumed to be the host name for the server, and all
-relevant settings must be passed via SERVER-OPTIONS.
-
-All SERVER-OPTIONS are treated as variables by getting the string
-\"circe-\" prepended to their name. This variable is then set
-locally in the server buffer.
-
-See `circe-network-options' for a list of common options."
- (interactive (circe--read-network-and-options))
- (let* ((options (circe--server-get-network-options network-or-server
- server-options))
- (buffer (circe--server-generate-buffer options)))
- (with-current-buffer buffer
- (circe-server-mode)
- (circe--server-set-variables options)
- (circe-reconnect))
- (pop-to-buffer-same-window buffer)))
-
-(defun circe--read-network-and-options ()
- "Read a host or network name with completion.
-
-If it's not a network, also read some extra options.
-
-This uses `circe-network-defaults' and `circe-network-options' for
-network names."
- (let ((default-network (if (null circe-network-options)
- (caar circe-network-defaults)
- (caar circe-network-options)))
- (networks nil)
- (completion-ignore-case t)
- network-or-host)
- (dolist (network-spec (append circe-network-options
- circe-network-defaults))
- (when (not (member (car network-spec) networks))
- (push (car network-spec) networks)))
- (setq networks (sort networks 'string-lessp))
- (setq network-or-host (completing-read "Network or host: "
- networks
- nil nil nil nil
- default-network))
- (dolist (network-name networks)
- (when (equal (downcase network-or-host)
- (downcase network-name))
- (setq network-or-host network-name)))
- (if (member network-or-host networks)
- (list network-or-host)
- (list network-or-host
- :host network-or-host
- :port (read-number "Port: " 6667)))))
-
-(defun circe--server-get-network-options (network server-options)
- "Combine server and network options with network defaults.
-
-See `circe-network-options' and `circe-network-defaults'."
- (let ((options (mapcar 'circe--translate-option-names
- (append server-options
- (cdr (assoc network circe-network-options))
- (cdr (assoc network circe-network-defaults))
- (list :network network)))))
- (when (not (plist-get options :host))
- (plist-put options :host network))
- (let ((port (plist-get options :port))
- (use-tls (plist-get options :use-tls)))
- (when (consp port)
- (if use-tls
- (plist-put options :port (cdr port))
- (plist-put options :port (car port)))))
- (dolist (required-option '(:host :port))
- (when (not (plist-get options required-option))
- (error (format "Network option %s not specified" required-option))))
- options))
-
-(defun circe--translate-option-names (option)
- "Translate option names to make them unique.
-
-Some options have multiple names, mainly for historical reasons.
-Unify them here."
- (cond
- ((eq option :service) :port)
- ((eq option :tls) :use-tls)
- ((eq option :family) :ip-family)
- (t option)))
-
-(defun circe--server-generate-buffer (options)
- "Return the server buffer for the connection described in OPTIONS."
- (let* ((network (plist-get options :network))
- (host (plist-get options :host))
- (port (plist-get options :port))
- (buffer-name (lui-format (or (plist-get options :server-buffer-name)
- circe-server-buffer-name)
- :network network
- :host host
- :port port
- :service port)))
- (generate-new-buffer buffer-name)))
-
-(defun circe--server-set-variables (options)
- "Set buffer-local variables described in OPTIONS.
-
-OPTIONS is a plist as passed to `circe'. All options therein are
-set as buffer-local variables. Only the first occurrence of each
-variable is set."
- (setq circe-nick circe-default-nick
- circe-user circe-default-user
- circe-realname circe-default-realname
- circe-ip-family circe-default-ip-family)
- (let ((done nil)
- (todo options))
- (while todo
- (when (not (memq (car todo) done))
- (push (car todo) done)
- (let ((var (intern (format "circe-%s"
- (substring (symbol-name (car todo)) 1))))
- (val (cadr todo)))
- (if (boundp var)
- (set (make-local-variable var) val)
- (warn "Unknown option %s, ignored" (car todo)))))
- (setq todo (cddr todo)))))
-
-(defvar circe-server-reconnect-attempts 0
- "The number of reconnect attempts that Circe has done so far.
-See `circe-server-max-reconnect-attempts'.")
-(make-variable-buffer-local 'circe-server-reconnect-attempts)
-
-(defun circe-reconnect ()
- "Reconnect the current server."
- (interactive)
- (with-circe-server-buffer
- (when (or (called-interactively-p 'any)
- (circe--reconnect-p))
- (setq circe-server-inhibit-auto-reconnect-p t
- circe-server-reconnect-attempts (+ circe-server-reconnect-attempts
- 1))
- (unwind-protect
- (circe-reconnect--internal)
- (setq circe-server-inhibit-auto-reconnect-p nil)))))
-
-(defun circe--reconnect-p ()
- (cond
- (circe-server-inhibit-auto-reconnect-p
- nil)
- ((not circe-server-max-reconnect-attempts)
- t)
- ((<= circe-server-reconnect-attempts
- circe-server-max-reconnect-attempts)
- t)
- (t
- nil)))
-
-(defun circe-reconnect--internal ()
- "The internal function called for reconnecting unconditionally.
-
-Do not use this directly, use `circe-reconnect'"
- (when (and circe-server-process
- (process-live-p circe-server-process))
- (delete-process circe-server-process))
- (circe-display-server-message "Connecting...")
- (dolist (buf (circe-server-chat-buffers))
- (with-current-buffer buf
- (circe-display-server-message "Connecting...")))
- (setq circe-server-process
- (irc-connect
- :host circe-host
- :service circe-port
- :tls circe-use-tls
- :ip-family circe-ip-family
- :handler-table (circe-irc-handler-table)
- :server-buffer (current-buffer)
- :nick circe-nick
- :nick-alternatives (list (circe--nick-next circe-nick)
- (circe--nick-next
- (circe--nick-next circe-nick)))
- :user circe-user
- :mode 8
- :realname circe-realname
- :pass (if (functionp circe-pass)
- (funcall circe-pass circe-host)
- circe-pass)
- :cap-req (append (when (and circe-sasl-username
- circe-sasl-password)
- '("sasl"))
- '("extended-join"))
- :nickserv-nick (or circe-nickserv-nick
- circe-nick)
- :nickserv-password (if (functionp circe-nickserv-password)
- (funcall circe-nickserv-password circe-host)
- circe-nickserv-password)
- :nickserv-mask circe-nickserv-mask
- :nickserv-identify-challenge circe-nickserv-identify-challenge
- :nickserv-identify-command circe-nickserv-identify-command
- :nickserv-identify-confirmation
- circe-nickserv-identify-confirmation
- :nickserv-ghost-command circe-nickserv-ghost-command
- :nickserv-ghost-confirmation circe-nickserv-ghost-confirmation
- :sasl-username circe-sasl-username
- :sasl-password (if (functionp circe-sasl-password)
- (funcall circe-sasl-password
- circe-host)
- circe-sasl-password)
- :ctcp-version (format "Circe: Client for IRC in Emacs, version %s"
- circe-version)
- :ctcp-source circe-source-url
- :ctcp-clientinfo "CLIENTINFO PING SOURCE TIME VERSION"
- :auto-join-after-registration
- (append (circe--auto-join-channel-buffers)
- (circe--auto-join-list :immediate))
- :auto-join-after-host-hiding
- (circe--auto-join-list :after-cloak)
- :auto-join-after-nick-acquisition
- (circe--auto-join-list :after-nick)
- :auto-join-after-nickserv-identification
- (circe--auto-join-list :after-auth)
- :auto-join-after-sasl-login
- (circe--auto-join-list :after-auth))))
-
-(defun circe-reconnect-all ()
- "Reconnect all Circe connections."
- (interactive)
- (dolist (buf (circe-server-buffers))
- (with-current-buffer buf
- (if (called-interactively-p 'any)
- (call-interactively 'circe-reconnect)
- (circe-reconnect)))))
-
-(defun circe--auto-join-list (type)
- "Return the list of channels to join for type TYPE."
- (let ((result nil)
- (current-type circe-server-auto-join-default-type))
- (dolist (channel circe-channels)
- (cond
- ((keywordp channel)
- (setq current-type channel))
- ((eq current-type type)
- (push channel result))))
- (nreverse result)))
-
-(defun circe--auto-join-channel-buffers ()
- "Return a list of channels to join based on channel buffers.
-
-This includes all channel buffers of the current server, but
-excludes and channel that is already listed in
-`circe-channels'."
- (let ((channels nil))
- (dolist (buf (circe-server-chat-buffers))
- (let ((name (with-current-buffer buf
- (when (derived-mode-p 'circe-channel-mode)
- circe-chat-target))))
- (when (and name
- (not (member name circe-channels)))
- (push name channels))))
- channels))
-
-;;;;;;;;;;;;;;;;;
-;;; Base Mode ;;;
-;;;;;;;;;;;;;;;;;
-
-(defvar circe-mode-hook nil
- "Hook run for any Circe mode.")
-
-(defvar circe-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-c C-j") 'circe-command-JOIN)
- (define-key map (kbd "C-c C-r") 'circe-reconnect)
- map)
- "The base keymap for all Circe modes (server, channel, query)")
-
-(defvar circe-server-buffer nil
- "The buffer of the server associated with the current chat buffer.")
-(make-variable-buffer-local 'circe-server-buffer)
-
-(define-derived-mode circe-mode lui-mode "Circe"
- "Base mode for all Circe buffers.
-
-A buffer should never be in this mode directly, but rather in
-modes that derive from this.
-
-The mode inheritance hierarchy looks like this:
-
-lui-mode
-`-circe-mode
- `-circe-server-mode
- `-circe-chat-mode
- `-circe-channel-mode
- `-circe-query-mode"
- (add-hook 'lui-pre-output-hook 'lui-irc-colors
- t t)
- (add-hook 'lui-pre-output-hook 'circe--output-highlight-nick
- t t)
- (add-hook 'completion-at-point-functions 'circe--completion-at-point
- nil t)
- (lui-set-prompt circe-prompt-string)
- (goto-char (point-max))
- (setq lui-input-function 'circe--input
- default-directory (expand-file-name circe-default-directory)
- circe-server-last-active-buffer (current-buffer)
- flyspell-generic-check-word-p 'circe--flyspell-check-word-p)
- (when circe-use-cycle-completion
- (set (make-local-variable 'completion-cycle-threshold)
- t))
- ;; Tab completion should be case-insensitive
- (set (make-local-variable 'completion-ignore-case)
- t)
- (set (make-local-variable 'tracking-faces-priorities)
- circe-track-faces-priorities))
-
-;;;;;;;;;;;;;;;;;;;;
-;;;; Displaying ;;;;
-;;;;;;;;;;;;;;;;;;;;
-
-(defun circe-display (format &rest keywords)
- "Display FORMAT formatted with KEYWORDS in the current Circe buffer.
-See `lui-format' for a description of the format.
-
-If FORMAT contains the word server, the resulting string receives
-a `circe-server-face'. If FORMAT contains the word self, the
-whole string receives a `circe-my-message-face'. If FORMAT is in
-`circe-format-not-tracked', a message of this type is never
-tracked by Lui.
-
-Keywords with the name :nick receive a `circe-originator-face'.
-
-It is always possible to use the mynick or target formats."
- (when (not (circe--display-ignored-p format keywords))
- (let* ((name (symbol-name format))
- (face (cond
- ((string-match "\\<server\\>" name)
- 'circe-server-face)
- ((string-match "\\<self\\>" name)
- 'circe-my-message-face)))
- (keywords (append `(:mynick ,(circe-nick)
- :chattarget ,circe-chat-target)
- (circe--display-add-nick-property
- (if (and (not (null keywords))
- (null (cdr keywords)))
- (car keywords)
- keywords))))
- (text (lui-format format keywords)))
- (when (circe--display-fool-p format keywords)
- (add-face-text-property 0 (length text)
- 'circe-fool-face t text)
- (put-text-property 0 (length text)
- 'lui-fool t
- text))
- (when face
- (add-face-text-property 0 (length text)
- face t text))
- (lui-insert text
- (memq format circe-format-not-tracked)))))
-
-(defun circe-display-server-message (message)
- "Display MESSAGE as a server message."
- (circe-display 'circe-format-server-message
- :body message))
-
-(defun circe--display-add-nick-property (keywords)
- "Add a face to the value of the :nick property in KEYWORDS."
- (let ((keyword nil))
- (mapcar (lambda (entry)
- (cond
- ((or (eq keyword :nick)
- (eq keyword 'nick))
- (setq keyword nil)
- (propertize entry 'face 'circe-originator-face))
- (t
- (setq keyword entry)
- entry)))
- keywords)))
-
-(defun circe--display-ignored-p (_format keywords)
- (let ((nick (plist-get keywords :nick))
- (userhost (plist-get keywords :userhost))
- (body (plist-get keywords :body)))
- (circe--ignored-p nick userhost body)))
-
-(defun circe--display-fool-p (_format keywords)
- (let ((nick (plist-get keywords :nick))
- (userhost (plist-get keywords :userhost))
- (body (plist-get keywords :body)))
- (circe--fool-p nick userhost body)))
-
-(defun circe--ignored-p (nick userhost body)
- "True if this user or message is being ignored.
-
-See `circe-ignore-functions' and `circe-ignore-list'.
-
-NICK, USER and HOST should be the sender of a the command
-COMMAND, which had the arguments ARGS."
- (or (run-hook-with-args-until-success 'circe-ignore-functions
- nick userhost body)
- (circe--ignore-matches-p nick userhost body circe-ignore-list)))
-
-(defun circe--fool-p (nick userhost body)
- "True if this user or message is a fool.
-
-See `circe-fool-list'.
-
-NICK, USER and HOST should be the sender of a the command
-COMMAND, which had the arguments ARGS."
- (circe--ignore-matches-p nick userhost body circe-fool-list))
-
-(defun circe--ignore-matches-p (nick userhost body patterns)
- "Check if a given command does match an ignore pattern.
-
-A pattern matches if it either matches the user NICK!USER@HOST,
-or if it matches the first word in BODY.
-
-PATTERNS should be the list of regular expressions."
- (let ((string (format "%s!%s" nick userhost))
- (target (when (and body
- (string-match "^\\([^ ]*\\)[:,]" body))
- (match-string 1 body))))
- (catch 'return
- (dolist (regex patterns)
- (when (string-match regex string)
- (throw 'return t))
- (when (and (stringp target)
- (string-match regex target))
- (throw 'return t)))
- nil)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Nick Highlighting ;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun circe--output-highlight-nick ()
- "Highlight the nick of the user in the buffer.
-
-This is used in `lui-pre-output-hook'."
- (goto-char (or (text-property-any (point-min) (point-max)
- 'lui-format-argument 'body)
- (point-min)))
- (when (or (not circe-inhibit-nick-highlight-function)
- (not (funcall circe-inhibit-nick-highlight-function)))
- (let* ((nick (circe-nick))
- (nicks (append (and nick (list nick))
- circe-extra-nicks)))
- (when nicks
- ;; Can't use \<...\> because that won't match for \<forcer-\> We
- ;; might eventually use \_< ... \_> if we define symbols to be
- ;; nicks \\= is necessary, because it might be found right where we
- ;; are, and that might not be the beginning of a line... (We start
- ;; searching from the beginning of the body)
- (let ((nick-regex (concat "\\(?:^\\|\\W\\|\\=\\)"
- "\\(" (regexp-opt nicks) "\\)"
- "\\(?:$\\|\\W\\)")))
- (cond
- ((eq circe-highlight-nick-type 'sender)
- (if (text-property-any (point-min)
- (point-max)
- 'face 'circe-originator-face)
- (when (re-search-forward nick-regex nil t)
- (circe--extend-text-having-face
- (point-min) (point-max)
- 'circe-originator-face
- 'circe-highlight-nick-face))
- (let ((circe-highlight-nick-type 'occurrence))
- (circe--output-highlight-nick))))
- ((eq circe-highlight-nick-type 'occurrence)
- (while (re-search-forward nick-regex nil t)
- (add-face-text-property (match-beginning 1)
- (match-end 1)
- 'circe-highlight-nick-face)))
- ((eq circe-highlight-nick-type 'message)
- (when (re-search-forward nick-regex nil t)
- (let* ((start (text-property-any (point-min)
- (point-max)
- 'lui-format-argument 'body))
- (end (when start
- (next-single-property-change start
- 'lui-format-argument))))
- (when (and start end)
- (add-face-text-property start end
- 'circe-highlight-nick-face)))))
- ((eq circe-highlight-nick-type 'all)
- (when (re-search-forward nick-regex nil t)
- (add-face-text-property (point-min) (point-max)
- 'circe-highlight-nick-face)))))))))
-
-(defun circe--extend-text-having-face (from to existing new)
- "Extend property values.
-
-In the text between FROM and TO, find any text that has its face
-property set to EXISTING, and prepend NEW to the value of its
-face property, when necessary by turning it into a list."
- (let ((beg (text-property-any from to 'face existing)))
- (while beg
- (let ((end (next-single-property-change beg 'face)))
- (add-face-text-property beg end new)
- (setq beg (text-property-any end to 'face existing))))))
-
-;;;;;;;;;;;;;;;
-;;;; Input ;;;;
-;;;;;;;;;;;;;;;
-
-(defun circe--input (str)
- "Process STR as input.
-
-This detects commands and interprets them, or sends the input
-using the /SAY command."
- (set-text-properties 0 (length str) nil str)
- (cond
- ((string= str "")
- nil)
- ;; Ignore commands in multiline input
- ((and (not (string-match "\n" str))
- (string-match "\\`/\\([^/ ][^ ]*\\|[^/ ]*\\) ?\\([^\n]*\\)\\'" str))
- (let* ((command (match-string 1 str))
- (args (match-string 2 str))
- (handler (intern-soft (format "circe-command-%s"
- (upcase command)))))
- (cond
- ((string= command "")
- (circe-command-SAY args))
- (handler
- (funcall handler args))
- (circe-server-send-unknown-command-p
- (irc-send-raw (circe-server-process)
- (format "%s %s"
- (upcase command)
- args)))
- (t
- (circe-display-server-message (format "Unknown command: %s"
- command))))))
- (t
- (mapc #'circe-command-SAY
- (circe--list-drop-right (split-string str "\n")
- "^ *$")))))
-
-;;;;;;;;;;;;;;;;;;
-;;;; Flyspell ;;;;
-;;;;;;;;;;;;;;;;;;
-
-(defun circe--flyspell-check-word-p ()
- "Return a true value if flyspell check the word before point.
-
-This is a suitable value for `flyspell-generic-check-word-p'. It
-will also call `lui-flyspell-check-word-p'."
- (cond
- ((not (lui-flyspell-check-word-p))
- nil)
- ((circe-channel-user-p (circe--flyspell-nick-before-point))
- nil)
- (t
- t)))
-
-(defun circe--flyspell-nick-before-point ()
- "Return the IRC nick before point"
- (with-syntax-table circe-nick-syntax-table
- (let (beg end)
- (save-excursion
- (forward-word -1)
- (setq beg (point))
- (forward-word 1)
- (setq end (point)))
- (buffer-substring beg end))))
-
-;;;;;;;;;;;;;;;;;;;;
-;;;; Completion ;;;;
-;;;;;;;;;;;;;;;;;;;;
-
-(defun circe--completion-at-point ()
- "Return a list of possible completions for the current buffer.
-
-This is used in `completion-at-point-functions'."
- ;; Use markers so they move when input happens
- (let ((start (make-marker))
- (end (make-marker)))
- (set-marker end (point))
- (set-marker start
- (save-excursion
- (when (or (looking-back (regexp-quote
- circe-completion-suffix)
- (length circe-completion-suffix))
- (looking-back " " 1))
- (goto-char (match-beginning 0)))
- (cond
- ((<= (point) lui-input-marker)
- lui-input-marker)
- ((re-search-backward "\\s-" lui-input-marker t)
- (1+ (point)))
- (t
- lui-input-marker))))
- (list start end 'circe--completion-table)))
-
-(defun circe--completion-table (string pred action)
- "Completion table to use for Circe buffers.
-
-See `minibuffer-completion-table' for details."
- (cond
- ;; Best completion of STRING
- ((eq action nil)
- (try-completion string
- (circe--completion-candidates
- (if (= (- (point) (length string))
- lui-input-marker)
- circe-completion-suffix
- " "))
- pred))
- ;; A list of possible completions of STRING
- ((eq action t)
- (all-completions string
- (circe--completion-candidates
- (if (= (- (point) (length string))
- lui-input-marker)
- circe-completion-suffix
- " "))
- pred))
- ;; t iff STRING is a valid completion as it stands
- ((eq action 'lambda)
- (test-completion string
- (circe--completion-candidates
- (if (= (- (point) (length string))
- lui-input-marker)
- circe-completion-suffix
- " "))
- pred))
- ;; Boundaries
- ((eq (car-safe action) 'boundaries)
- `(boundaries 0 . ,(length (cdr action))))
- ;; Metadata
- ((eq action 'metadata)
- '(metadata (cycle-sort-function . circe--completion-sort)))))
-
-(defun circe--completion-clean-nick (string)
- (with-temp-buffer
- (insert string)
- (goto-char (point-max))
- (when (or (looking-back circe-completion-suffix nil)
- (looking-back " " nil))
- (replace-match ""))
- (buffer-string)))
-
-(defun circe--completion-sort (collection)
- "Sort the COLLECTION by channel activity for nicks."
- (let* ((proc (circe-server-process))
- (channel (when (and circe-chat-target proc)
- (irc-connection-channel proc circe-chat-target)))
- (decorated (mapcar (lambda (entry)
- (let* ((nick (circe--completion-clean-nick
- entry))
- (user (when channel
- (irc-channel-user channel nick))))
- (list (when user
- (irc-user-last-activity-time user))
- (length entry)
- entry)))
- collection))
- (sorted (sort decorated
- (lambda (a b)
- (cond
- ((and (car a)
- (car b))
- (> (car a)
- (car b)))
- ((and (not (car a))
- (not (car b)))
- (< (cadr a)
- (cadr b)))
- ((car a)
- t)
- (t
- nil))))))
- (mapcar (lambda (entry)
- (nth 2 entry))
- sorted)))
-
-;; FIXME: I do not know why this is here.
-(defvar circe--completion-old-completion-all-sorted-completions nil
- "Variable to know if we can return a cached result.")
-(make-variable-buffer-local
- 'circe--completion-old-completion-all-sorted-completions)
-(defvar circe--completion-cache nil
- "The results we can cache.")
-(make-variable-buffer-local 'circe--completion-cache)
-
-(defun circe--completion-candidates (nick-suffix)
- (if (and circe--completion-old-completion-all-sorted-completions
- (eq completion-all-sorted-completions
- circe--completion-old-completion-all-sorted-completions))
- circe--completion-cache
- (let ((completions (append (circe--commands-list)
- (mapcar (lambda (buf)
- (with-current-buffer buf
- circe-chat-target))
- (circe-server-channel-buffers)))))
- (cond
- ;; In a server buffer, complete all nicks in all channels
- ((eq major-mode 'circe-server-mode)
- (dolist (buf (circe-server-channel-buffers))
- (with-current-buffer buf
- (dolist (nick (circe-channel-nicks))
- (setq completions (cons (concat nick nick-suffix)
- completions))))))
- ;; In a channel buffer, only complete nicks in this channel
- ((eq major-mode 'circe-channel-mode)
- (setq completions (append (delete (concat (circe-nick)
- nick-suffix)
- (mapcar (lambda (nick)
- (concat nick nick-suffix))
- (circe-channel-nicks)))
- completions)))
- ;; In a query buffer, only complete this query partner
- ((eq major-mode 'circe-query-mode)
- (setq completions (cons (concat circe-chat-target nick-suffix)
- completions)))
- ;; Else, we're doing something wrong
- (t
- (error "`circe-possible-completions' called outside of Circe")))
- (setq circe--completion-old-completion-all-sorted-completions
- completion-all-sorted-completions
- circe--completion-cache completions)
- completions)))
-
-(defun circe--commands-list ()
- "Return a list of possible Circe commands."
- (mapcar (lambda (symbol)
- (let ((str (symbol-name symbol)))
- (if (string-match "^circe-command-\\(.*\\)" str)
- (concat "/" (match-string 1 str) " ")
- str)))
- (apropos-internal "^circe-command-")))
-
-;;;;;;;;;;;;;;;;;;;
-;;; Server Mode ;;;
-;;;;;;;;;;;;;;;;;;;
-
-(defvar circe-server-mode-hook nil
- "Hook run when a new Circe server buffer is created.")
-
-(defvar circe-server-mode-map (make-sparse-keymap)
- "The key map for server mode buffers.")
-
-(define-derived-mode circe-server-mode circe-mode "Circe Server"
- "The mode for circe server buffers.
-
-This buffer represents a server connection. When you kill it, the
-server connection is closed. This will make all associated
-buffers unusable. Be sure to use \\[circe-reconnect] if you want
-to reconnect to the server.
-
-\\{circe-server-mode-map}"
- (add-hook 'kill-buffer-hook 'circe-server-killed nil t))
-
-(defun circe-server-killed ()
- "Run when the server buffer got killed.
-
-This will IRC, and ask the user whether to kill all of the
-server's chat buffers."
- (when circe-server-killed-confirmation
- (when (not (y-or-n-p
- (if (eq circe-server-killed-confirmation 'ask-and-kill-all)
- "Really kill all buffers of this server? (if not, try `circe-reconnect') "
- "Really kill the IRC connection? (if not, try `circe-reconnect') ")))
- (error "Buffer not killed as per user request")))
- (setq circe-server-inhibit-auto-reconnect-p t)
- (ignore-errors
- (irc-send-QUIT circe-server-process circe-default-quit-message))
- (ignore-errors
- (delete-process circe-server-process))
- (when (or (eq circe-server-killed-confirmation 'ask-and-kill-all)
- (eq circe-server-killed-confirmation 'kill-all))
- (dolist (buf (circe-server-chat-buffers))
- (let ((circe-channel-killed-confirmation nil))
- (kill-buffer buf)))))
-
-(defun circe-server-buffers ()
- "Return a list of all server buffers in this Emacs instance."
- (let ((result nil))
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when (eq major-mode 'circe-server-mode)
- (setq result (cons buf result)))))
- (nreverse result)))
-
-(defun circe-server-process ()
- "Return the current server process."
- (with-circe-server-buffer
- circe-server-process))
-
-(defun circe-server-my-nick-p (nick)
- "Return non-nil when NICK is our current nick."
- (let ((proc (circe-server-process)))
- (when proc
- (irc-current-nick-p proc nick))))
-
-(defun circe-nick ()
- "Return our current nick."
- (let ((proc (circe-server-process)))
- (when proc
- (irc-current-nick proc))))
-
-(defun circe-server-last-active-buffer ()
- "Return the last active buffer of this server."
- (with-circe-server-buffer
- (if (and circe-server-last-active-buffer
- (bufferp circe-server-last-active-buffer)
- (buffer-live-p circe-server-last-active-buffer))
- circe-server-last-active-buffer
- (current-buffer))))
-
-;; There really ought to be a hook for this
-(defadvice select-window (after circe-server-track-select-window
- (window &optional norecord))
- "Remember the current buffer as the last active buffer.
-This is used by Circe to know where to put spurious messages."
- (with-current-buffer (window-buffer window)
- (when (derived-mode-p 'circe-mode)
- (let ((buf (current-buffer)))
- (ignore-errors
- (with-circe-server-buffer
- (setq circe-server-last-active-buffer buf)))))))
-(ad-activate 'select-window)
-
-(defun circe-reduce-lurker-spam ()
- "Return the value of `circe-reduce-lurker-spam'.
-
-This uses a buffer-local value first, then the one in the server
-buffer.
-
-Use this instead of accessing the variable directly to enable
-setting the variable through network options."
- (if (local-variable-p 'circe-reduce-lurker-spam)
- circe-reduce-lurker-spam
- (with-circe-server-buffer
- circe-reduce-lurker-spam)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Chat Buffer Management ;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Server buffers keep track of associated chat buffers. This enables
-;; us to not rely on buffer names staying the same, as well as keeping
-;; buffers from different servers and even server connections apart
-;; cleanly.
-
-(defvar circe-server-chat-buffer-table nil
- "A hash table of chat buffers associated with this server.")
-(make-variable-buffer-local 'circe-server-chat-buffer-table)
-
-(defun circe-server-get-chat-buffer (target)
- "Return the chat buffer addressing TARGET, or nil if none."
- (with-circe-server-buffer
- (when circe-server-chat-buffer-table
- (let* ((target-name (irc-isupport--case-fold (circe-server-process)
- target))
- (buf (gethash target-name circe-server-chat-buffer-table)))
- (if (buffer-live-p buf)
- buf
- (remhash target-name circe-server-chat-buffer-table)
- nil)))))
-
-(defun circe-server-create-chat-buffer (target chat-mode)
- "Return a new buffer addressing TARGET in CHAT-MODE."
- (with-circe-server-buffer
- (let* ((target-name (irc-isupport--case-fold (circe-server-process)
- target))
- (chat-buffer (generate-new-buffer target))
- (server-buffer (current-buffer))
- (circe-chat-calling-server-buffer-and-target (cons server-buffer
- target-name)))
- (when (not circe-server-chat-buffer-table)
- (setq circe-server-chat-buffer-table (make-hash-table :test 'equal)))
- (puthash target-name chat-buffer circe-server-chat-buffer-table)
- (with-current-buffer chat-buffer
- (funcall chat-mode))
- chat-buffer)))
-
-(defun circe-server-get-or-create-chat-buffer (target chat-mode)
- "Return a buffer addressing TARGET; create one in CHAT-MODE if none exists."
- (let ((buf (circe-server-get-chat-buffer target)))
- (if buf
- buf
- (circe-server-create-chat-buffer target chat-mode))))
-
-(defun circe-server-remove-chat-buffer (target-or-buffer)
- "Remove the buffer addressing TARGET-OR-BUFFER."
- (with-circe-server-buffer
- (let* ((target (if (bufferp target-or-buffer)
- (circe-server-chat-buffer-target target-or-buffer)
- target-or-buffer))
- (target-name (irc-isupport--case-fold (circe-server-process)
- target)))
- (remhash target-name circe-server-chat-buffer-table))))
-
-(defun circe-server-rename-chat-buffer (old-name new-name)
- "Note that the chat buffer addressing OLD-NAME now addresses NEW-NAME."
- (with-circe-server-buffer
- (let* ((old-target-name (irc-isupport--case-fold (circe-server-process)
- old-name))
- (new-target-name (irc-isupport--case-fold (circe-server-process)
- new-name))
- (buf (gethash old-target-name circe-server-chat-buffer-table)))
- (when buf
- (remhash old-target-name circe-server-chat-buffer-table)
- (puthash new-target-name buf circe-server-chat-buffer-table)
- (with-current-buffer buf
- (setq circe-chat-target new-name)
- (rename-buffer new-name t))))))
-
-(defun circe-server-chat-buffer-target (&optional buffer)
- "Return the chat target of BUFFER, or the current buffer if none."
- (if buffer
- (with-current-buffer buffer
- circe-chat-target)
- circe-chat-target))
-
-(defun circe-server-chat-buffers ()
- "Return the list of chat buffers on this server."
- (with-circe-server-buffer
- (when circe-server-chat-buffer-table
- (let ((buffer-list nil))
- (maphash (lambda (target-name buffer)
- (if (buffer-live-p buffer)
- (push buffer buffer-list)
- (remhash target-name circe-server-chat-buffer-table)))
- circe-server-chat-buffer-table)
- buffer-list))))
-
-(defun circe-server-channel-buffers ()
- "Return a list of all channel buffers of this server."
- (let ((result nil))
- (dolist (buf (circe-server-chat-buffers))
- (with-current-buffer buf
- (when (eq major-mode 'circe-channel-mode)
- (setq result (cons buf result)))))
- (nreverse result)))
-
-;;;;;;;;;;;;;;;;;
-;;; Chat Mode ;;;
-;;;;;;;;;;;;;;;;;
-
-(defvar circe-chat-mode-hook nil
- "Hook run when a new chat buffer (channel or query) is created.")
-
-(defvar circe-chat-mode-map (make-sparse-keymap)
- "Base key map for all Circe chat buffers (channel, query).")
-
-;; Defined here as we use it, but do not necessarily want to use the
-;; full module.
-(defvar lui-logging-format-arguments nil
- "A list of arguments to be passed to `lui-format'.
-This can be used to extend the formatting possibilities of the
-file name for lui applications.")
-(make-variable-buffer-local 'lui-logging-format-arguments)
-
-(define-derived-mode circe-chat-mode circe-mode "Circe Chat"
- "The circe chat major mode.
-
-This is the common mode used for both queries and channels.
-It should not be used directly.
-TARGET is the default target to send data to.
-SERVER-BUFFER is the server buffer of this chat buffer."
- (setq circe-server-buffer (car circe-chat-calling-server-buffer-and-target)
- circe-chat-target (cdr circe-chat-calling-server-buffer-and-target))
- (let ((network (with-circe-server-buffer
- circe-network)))
- (make-local-variable 'mode-line-buffer-identification)
- (setq mode-line-buffer-identification
- (list (format "%%b@%-8s" network)))
- (setq lui-logging-format-arguments
- `(:target ,circe-chat-target :network ,network)))
- (when (equal circe-chat-target "#emacs-circe")
- (set (make-local-variable 'lui-button-issue-tracker)
- "https://github.com/jorgenschaefer/circe/issues/%s")))
-
-(defun circe-chat-disconnected ()
- "The current buffer got disconnected."
- (circe-display-server-message "Disconnected"))
-
-;;;;;;;;;;;;;;;;;;;;
-;;; Channel Mode ;;;
-;;;;;;;;;;;;;;;;;;;;
-
-(defvar circe-channel-mode-hook nil
- "Hook run in a new channel buffer.")
-
-(defvar circe-channel-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-c C-n") 'circe-command-NAMES)
- (define-key map (kbd "C-c C-t") 'circe-command-CHTOPIC)
- map)
- "The key map for channel mode buffers.")
-
-(define-derived-mode circe-channel-mode circe-chat-mode "Circe Channel"
- "The circe channel chat major mode.
-This mode represents a channel you are talking in.
-
-TARGET is the default target to send data to.
-SERVER-BUFFER is the server buffer of this chat buffer.
-
-\\{circe-channel-mode-map}"
- (add-hook 'kill-buffer-hook 'circe-channel-killed nil t))
-
-(defun circe-channel-killed ()
- "Called when the channel buffer got killed.
-
-If we are not on the channel being killed, do nothing. Otherwise,
-if the server is live, and the user wants to kill the buffer,
-send PART to the server and clean up the channel's remaining
-state."
- (when (buffer-live-p circe-server-buffer)
- (when (and circe-channel-killed-confirmation
- (not (y-or-n-p "Really leave this channel? ")))
- (error "Channel not left."))
- (ignore-errors
- (irc-send-PART (circe-server-process)
- circe-chat-target
- circe-default-part-message))
- (ignore-errors
- (circe-server-remove-chat-buffer circe-chat-target))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Channel User Tracking ;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;; Channel mode buffers provide some utility functions to check if a
-;; given user is idle or not.
-
-(defun circe-channel-user-nick-regain-p (_old new)
- "Return true if a nick change from OLD to NEW constitutes a nick regain.
-
-A nick was regained if the NEW nick was also a recent user."
- (let ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target)))
- (when channel
- (irc-channel-recent-user channel new))))
-
-(defun circe-channel-user-p (nick)
- "Return non-nil when NICK belongs to a channel user."
- (cond
- ((eq major-mode 'circe-query-mode)
- (irc-string-equal-p (circe-server-process)
- nick
- circe-chat-target))
- ((eq major-mode 'circe-channel-mode)
- (let ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target)))
- (when channel
- (if (irc-channel-user channel nick)
- t
- nil))))))
-
-(defun circe-channel-nicks ()
- "Return a list of nicks in the current channel."
- (let* ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target))
- (nicks nil))
- (when channel
- (maphash (lambda (_folded-nick user)
- (push (irc-user-nick user) nicks))
- (irc-channel-users channel)))
- nicks))
-
-(defun circe-user-channels (nick)
- "Return a list of channel buffers for the user named NICK."
- (let* ((result nil))
- (dolist (channel (irc-connection-channel-list (circe-server-process)))
- (when (irc-channel-user channel nick)
- (let* ((name (irc-channel-name channel))
- (buf (circe-server-get-chat-buffer name)))
- (when buf
- (push buf result)))))
- result))
-
-(defun circe-lurker-p (nick)
- "Return a true value if this nick is regarded inactive."
- (let* ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target))
- (user (when channel
- (irc-channel-user channel nick)))
- (recent-user (when channel
- (irc-channel-recent-user channel nick)))
- (last-active (cond
- (user
- (irc-user-last-activity-time user))
- (recent-user
- (irc-user-last-activity-time recent-user)))))
- (cond
- ;; If we do not track lurkers, no one is ever a lurker.
- ((not (circe-reduce-lurker-spam))
- nil)
- ;; We ourselves are never lurkers (in this sense).
- ((circe-server-my-nick-p nick)
- nil)
- ;; Someone who isn't even on the channel (e.g. NickServ) isn't a
- ;; lurker, either.
- ((and (not user)
- (not recent-user))
- nil)
- ;; If someone has never been active, they most definitely *are* a
- ;; lurker.
- ((not last-active)
- t)
- ;; But if someone has been active, and we mark active users
- ;; inactive again after a timeout ...
- (circe-active-users-timeout
- ;; They are still lurkers if their activity has been too long
- ;; ago.
- (> (- (float-time)
- last-active)
- circe-active-users-timeout))
- ;; Otherwise, they have been active and we don't mark active
- ;; users inactive again, so nope, not a lurker.
- (t
- nil))))
-
-(defun circe-lurker-rejoin-p (nick channel)
- "Return true if NICK is rejoining CHANNEL.
-
-A user is considered to be rejoining if they were on the channel
-shortly before, and were active then."
- (let* ((channel (irc-connection-channel (circe-server-process)
- channel))
- (user (when channel
- (irc-channel-recent-user channel nick))))
- (when user
- (irc-user-last-activity-time user))))
-
-(defun circe-lurker-display-active (nick userhost)
- "Show that this user is active if they are a lurker."
- (let* ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target))
- (user (when channel
- (irc-channel-user channel nick)))
- (join-time (when user
- (irc-user-join-time user))))
- (when (and (circe-lurker-p nick)
- ;; If we saw them when we joined the channel, no need to
- ;; say "they're suddenly active!!111one".
- join-time)
- (circe-display 'circe-format-server-lurker-activity
- :nick nick
- :userhost (or userhost "server")
- :jointime join-time
- :joindelta (circe-duration-string
- (- (float-time)
- join-time))))))
-
-;;;;;;;;;;;;;;;;;;
-;;; Query Mode ;;;
-;;;;;;;;;;;;;;;;;;
-
-(defvar circe-query-mode-hook nil
- "Hook run when query mode is activated.")
-
-(defvar circe-query-mode-map
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map circe-chat-mode-map)
- map)
- "The key map for query mode buffers.")
-
-(define-derived-mode circe-query-mode circe-chat-mode "Circe Query"
- "The circe query chat major mode.
-This mode represents a query you are talking in.
-
-TARGET is the default target to send data to.
-SERVER-BUFFER is the server buffer of this chat buffer.
-
-\\{circe-query-mode-map}"
- (add-hook 'kill-buffer-hook 'circe-query-killed nil t))
-
-(defun circe-query-killed ()
- "Called when the query buffer got killed."
- (ignore-errors
- (circe-server-remove-chat-buffer circe-chat-target)))
-
-(defun circe-query-auto-query-buffer (who)
- "Return a buffer for a query with `WHO'.
-
-This adheres to `circe-auto-query-max'."
- (or (circe-server-get-chat-buffer who)
- (when (< (circe--query-count)
- circe-auto-query-max)
- (circe-server-get-or-create-chat-buffer who 'circe-query-mode))))
-
-(defun circe--query-count ()
- "Return the number of queries on the current server."
- (let ((num 0))
- (dolist (buf (circe-server-chat-buffers))
- (with-current-buffer buf
- (when (eq major-mode 'circe-query-mode)
- (setq num (+ num 1)))))
- num))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; IRC Protocol Handling ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar circe--irc-handler-table nil
- "The handler table for Circe's IRC connections.
-
-Do not use this directly. Instead, call `circe-irc-handler-table'.")
-
-(defun circe-irc-handler-table ()
- (when (not circe--irc-handler-table)
- (let ((table (irc-handler-table)))
- (irc-handler-add table "irc.registered" #'circe--irc-conn-registered)
- (irc-handler-add table "conn.disconnected" #'circe--irc-conn-disconnected)
- (irc-handler-add table nil #'circe--irc-display-event)
- (irc-handle-registration table)
- (irc-handle-ping-pong table)
- (irc-handle-isupport table)
- (irc-handle-initial-nick-acquisition table)
- (irc-handle-ctcp table)
- (irc-handle-state-tracking table)
- (irc-handle-nickserv table)
- (irc-handle-auto-join table)
- (setq circe--irc-handler-table table)))
- circe--irc-handler-table)
-
-(defun circe--irc-conn-registered (conn _event _nick)
- (with-current-buffer (irc-connection-get conn :server-buffer)
- (setq circe-server-reconnect-attempts 0)
- (run-hooks 'circe-server-connected-hook)))
-
-(defun circe--irc-conn-disconnected (conn _event)
- (with-current-buffer (irc-connection-get conn :server-buffer)
- (dolist (buf (circe-server-chat-buffers))
- (with-current-buffer buf
- (circe-chat-disconnected)))
-
- (circe-reconnect)))
-
-(defun circe--irc-display-event (conn event &optional sender &rest args)
- "Display an IRC message.
-
-NICK, USER and HOST specify the originator of COMMAND with ARGS
-as arguments."
- (with-current-buffer (irc-connection-get conn :server-buffer)
- (let* ((display (circe-get-display-handler event))
- (nick (when sender
- (irc-userstring-nick sender)))
- (userhost (when sender
- (irc-userstring-userhost sender))))
- (cond
- ;; Functions get called
- ((functionp display)
- (apply display nick userhost event args))
- ;; Lists describe patterns
- ((consp display)
- (circe--irc-display-format (elt display 1)
- (elt display 0)
- nick userhost event args))
- ;; No configured display handler, show a default
- (t
- (circe--irc-display-default nick userhost event args))))))
-
-(defvar circe--irc-format-server-numeric "*** %s"
- "The format to use for server messages. Do not set this.")
-
-(defun circe--irc-display-format (format target nick userhost event args)
- (let* ((target+name (circe--irc-display-target target nick args))
- (target (car target+name))
- (name (cdr target+name))
- (origin (if userhost
- (format "%s (%s)" nick userhost)
- (format "%s" nick))))
- (with-current-buffer (or target
- (circe-server-last-active-buffer))
- (let ((circe--irc-format-server-numeric
- (if target
- (format "*** %s" format)
- (format "*** [%s] %s" name format))))
- (circe-display 'circe--irc-format-server-numeric
- :nick (or nick "(unknown)")
- :userhost (or userhost "server")
- :origin origin
- :event event
- :command event
- :target name
- :indexed-args args)))))
-
-(defun circe--irc-display-target (target nick args)
- "Return the target buffer and name.
-The buffer might be nil if it is not alive.
-
-See `circe-set-display-handler' for a description of target.
-
-NICK and USERHOST are the originator of COMMAND which had ARGS as
-arguments."
- (cond
- ((eq target 'nick)
- (cons (circe-server-get-chat-buffer nick)
- nick))
- ((numberp target)
- (let ((name (nth target
- args)))
- (cons (circe-server-get-chat-buffer name)
- name)))
- ((eq target 'active)
- (let ((buf (circe-server-last-active-buffer)))
- (cons buf
- (buffer-name buf))))
- ((eq target 'server)
- (cons (current-buffer) (buffer-name)))
- (t
- (error "Bad target in format string: %s" target))))
-
-(defun circe--irc-display-default (nick userhost event args)
- (with-current-buffer (circe-server-last-active-buffer)
- (let ((target (if (circe-server-my-nick-p (car args))
- ""
- (format " to %s" (car args)))))
- (cond
- ((string-match "\\`irc.ctcpreply.\\(.*\\)\\'" event)
- (circe-display-server-message
- (format "CTCP %s reply from %s (%s)%s: %s"
- (match-string 1 event) nick userhost target (cadr args))))
- ((string-match "\\`irc.ctcp.\\(.*\\)\\'" event)
- (circe-display-server-message
- (format "Unknown CTCP request %s from %s (%s)%s: %s"
- (match-string 1 event) nick userhost target (cadr args))))
- (t
- (circe-display-server-message
- (format "[%s from %s%s] %s"
- event
- nick
- (if userhost
- (format " (%s)" userhost)
- "")
- (mapconcat #'identity args " "))))))))
-
-(defun circe-set-display-handler (command handler)
- "Set the display handler for COMMAND to HANDLER.
-
-A handler is either a function or a list.
-
-A function gets called in the server buffer with at least three
-arguments, but possibly more. There's at least NICK and USERHOST
-of the sender, which can be nil, and COMMAND, which is the event
-which triggered this. Further arguments are arguments to the
-event.
-
-Alternatively, the handler can be a list of two elements:
-
- target - The target of this message
- format - The format for this string
-
-The target can be any of:
-
- 'active - The last active buffer of this server
- 'nick - The nick who sent this message
- 'server - The server buffer for this server
- number - The index of the argument of the target
-
-The format is passed to `lui-format'. Possible format string
-substitutions are {mynick}, {target}, {nick}, {userhost},
-{origin}, {command}, {target}, and indexed arguments for the
-arguments to the IRC message."
- (when (not circe-display-table)
- (setq circe-display-table (make-hash-table :test 'equal)))
- (puthash command handler circe-display-table))
-
-(defun circe-get-display-handler (command)
- "Return the display handler for COMMAND.
-
-See `circe-set-display-handler' for more information."
- (when circe-display-table
- (gethash command circe-display-table)))
-
-;;;;;;;;;;;;;;;;
-;;; Commands ;;;
-;;;;;;;;;;;;;;;;
-
-(defun circe-command-AWAY (reason)
- "Set yourself away with REASON."
- (interactive "sReason: ")
- (irc-send-AWAY (circe-server-process) reason))
-
-(defun circe-command-BACK (&optional ignored)
- "Mark yourself not away anymore.
-
-Arguments are IGNORED."
- (interactive)
- (irc-send-AWAY (circe-server-process)))
-
-(defun circe-command-CHTOPIC (&optional ignored)
- "Insert the topic of the current channel.
-
-Arguments are IGNORED."
- (interactive)
- (if (not circe-chat-target)
- (circe-display-server-message "No target for current buffer")
- (let* ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target))
- (topic (when channel
- (irc-channel-topic channel))))
- (lui-replace-input (format "/TOPIC %s %s"
- circe-chat-target (or topic ""))))
- (goto-char (point-max))))
-
-(defun circe-command-CLEAR (&optional ignored)
- "Delete all buffer contents before the lui prompt."
- (let ((inhibit-read-only t))
- (delete-region (point-min) lui-output-marker)))
-
-(defun circe-command-CTCP (who &optional command argument)
- "Send a CTCP message to WHO containing COMMAND with ARGUMENT.
-If COMMAND is not given, WHO is parsed to contain all of who,
-command and argument.
-If ARGUMENT is nil, it is interpreted as no argument."
- (when (not command)
- (if (string-match "^\\([^ ]*\\) *\\([^ ]*\\) *\\(.*\\)" who)
- (setq command (upcase (match-string 2 who))
- argument (match-string 3 who)
- who (match-string 1 who))
- (circe-display-server-message "Usage: /CTCP <who> <what>")))
- (when (not (string= "" command))
- (irc-send-ctcp (circe-server-process)
- who
- command
- (if (and argument (not (equal argument "")))
- argument
- nil))))
-
-(defun circe-command-FOOL (line)
- "Add the regex on LINE to the `circe-fool-list'."
- (with-current-buffer (circe-server-last-active-buffer)
- (cond
- ((string-match "\\S-+" line)
- (let ((regex (match-string 0 line)))
- (add-to-list 'circe-fool-list regex)
- (circe-display-server-message (format "Recognizing %s as a fool"
- regex))))
- ((not circe-fool-list)
- (circe-display-server-message "Your do not know any fools"))
- (t
- (circe-display-server-message "Your list of fools:")
- (dolist (regex circe-fool-list)
- (circe-display-server-message (format "- %s" regex)))))))
-
-(defun circe-command-GAWAY (reason)
- "Set yourself away on all servers with reason REASON."
- (interactive "sReason: ")
- (dolist (buf (circe-server-buffers))
- (with-current-buffer buf
- (irc-send-AWAY circe-server-process reason))))
-
-(defun circe-command-GQUIT (reason)
- "Quit all servers with reason REASON."
- (interactive "sReason: ")
- (dolist (buf (circe-server-buffers))
- (with-current-buffer buf
- (when (eq (process-status circe-server-process)
- 'open)
- (irc-send-QUIT circe-server-process reason)))))
-
-(defun circe-command-HELP (&optional ignored)
- "Display a list of recognized commands, nicely formatted."
- (circe-display-server-message
- (concat "Recognized commands are: "
- (mapconcat (lambda (s) s) (circe--commands-list) ""))))
-
-(defun circe-command-IGNORE (line)
- "Add the regex on LINE to the `circe-ignore-list'."
- (with-current-buffer (circe-server-last-active-buffer)
- (cond
- ((string-match "\\S-+" line)
- (let ((regex (match-string 0 line)))
- (add-to-list 'circe-ignore-list regex)
- (circe-display-server-message (format "Ignore list, meet %s"
- regex))))
- ((not circe-ignore-list)
- (circe-display-server-message "Your ignore list is empty"))
- (t
- (circe-display-server-message "Your ignore list:")
- (dolist (regex circe-ignore-list)
- (circe-display-server-message (format "- %s" regex)))))))
-
-(defun circe-command-INVITE (nick &optional channel)
- "Invite NICK to CHANNEL.
-When CHANNEL is not given, NICK is assumed to be a string
-consisting of two words, the nick and the channel."
- (interactive "sInvite who: \nsWhere: ")
- (when (not channel)
- (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)" nick)
- (setq channel (match-string 2 nick)
- nick (match-string 1 nick))
- (when (or (string= "" nick) (null nick))
- (circe-display-server-message "Usage: /INVITE <nick> <channel>"))))
- (irc-send-INVITE (circe-server-process)
- nick
- (if (and (null channel)
- (not (null nick)))
- circe-chat-target
- channel)))
-
-(defun circe-command-JOIN (channel)
- "Join CHANNEL. This can also contain a key."
- (interactive "sChannel: ")
- (let (channels keys)
- (when (string-match "^\\s-*\\([^ ]+\\)\\(:? \\([^ ]+\\)\\)?$" channel)
- (setq channels (match-string 1 channel)
- keys (match-string 3 channel))
- (dolist (channel (split-string channels ","))
- (pop-to-buffer
- (circe-server-get-or-create-chat-buffer channel
- 'circe-channel-mode)))
- (irc-send-JOIN (circe-server-process) channels keys))))
-
-(defun circe-command-ME (line)
- "Send LINE to IRC as an action."
- (interactive "sAction: ")
- (if (not circe-chat-target)
- (circe-display-server-message "No target for current buffer")
- (circe-display 'circe-format-self-action
- :body line
- :nick (circe-nick))
- (irc-send-ctcp (circe-server-process)
- circe-chat-target
- "ACTION" line)))
-
-(defun circe-command-MSG (who &optional what)
- "Send a message.
-
-Send WHO a message containing WHAT.
-
-If WHAT is not given, WHO should contain both the nick and the
-message separated by a space."
- (when (not what)
- (if (string-match "^\\([^ ]*\\) \\(.*\\)" who)
- (setq what (match-string 2 who)
- who (match-string 1 who))
- (circe-display-server-message "Usage: /MSG <who> <what>")))
- (when what
- (let ((buf (circe-query-auto-query-buffer who)))
- (if buf
- (with-current-buffer buf
- (circe-command-SAY what)
- (lui-add-input what))
- (with-current-buffer (circe-server-last-active-buffer)
- (irc-send-PRIVMSG (circe-server-process)
- who what)
- (circe-display 'circe-format-self-message
- :target who
- :body what))))))
-
-(defun circe-command-NAMES (&optional channel)
- "List the names of the current channel or CHANNEL."
- (interactive)
- (let ((target (when channel
- (string-trim channel))))
- (when (or (not target)
- (equal target ""))
- (setq target circe-chat-target))
- (if (not target)
- (circe-display-server-message "No target for current buffer")
- (irc-send-NAMES (circe-server-process)
- target))))
-
-(defun circe-command-NICK (newnick)
- "Change nick to NEWNICK."
- (interactive "sNew nick: ")
- (let ((newnick (string-trim newnick)))
- (irc-send-NICK (circe-server-process) newnick)))
-
-(defun circe-command-PART (reason)
- "Part the current channel because of REASON."
- (interactive "sReason: ")
- (if (not circe-chat-target)
- (circe-display-server-message "No target for current buffer")
- (irc-send-PART (circe-server-process)
- circe-chat-target
- (if (equal "" reason)
- circe-default-part-message
- reason))))
-
-(defun circe-command-PING (target)
- "Send a CTCP PING request to TARGET."
- (interactive "sWho: ")
- (let ((target (string-trim target)))
- (irc-send-ctcp (circe-server-process)
- target
- "PING" (format "%s" (float-time)))))
-
-(defun circe-command-QUERY (arg)
- "Open a query with WHO."
- ;; Eventually, this should probably be just the same as
- ;; circe-command-MSG
- (interactive "sQuery with: ")
- (let* (who what)
- (if (string-match "\\`\\s-*\\(\\S-+\\)\\s-\\(\\s-*\\S-.*\\)\\'" arg)
- (setq who (match-string 1 arg)
- what (match-string 2 arg))
- (setq who (string-trim arg)))
- (when (string= who "")
- (circe-display-server-message "Usage: /query <nick> [something to say]"))
- (pop-to-buffer
- (circe-server-get-or-create-chat-buffer who 'circe-query-mode))
- (when what
- (circe-command-SAY what)
- (lui-add-input what))))
-
-(defun circe-command-QUIT (reason)
- "Quit the current server giving REASON."
- (interactive "sReason: ")
- (with-circe-server-buffer
- (setq circe-server-inhibit-auto-reconnect-p t)
- (irc-send-QUIT (circe-server-process)
- (if (equal "" reason)
- circe-default-quit-message
- reason))))
-
-(defun circe-command-QUOTE (line)
- "Send LINE verbatim to the server."
- (interactive "Line: ")
- (irc-send-raw (circe-server-process) line)
- (with-current-buffer (circe-server-last-active-buffer)
- (circe-display-server-message (format "Sent to server: %s"
- line))))
-
-(defun circe-command-SAY (line)
- "Say LINE to the current target."
- (interactive "sSay: ")
- (if (not circe-chat-target)
- (circe-display-server-message "No target for current buffer")
- (dolist (line (circe--split-line line))
- (circe-display 'circe-format-self-say
- :body line
- :nick (circe-nick))
- (irc-send-PRIVMSG (circe-server-process)
- circe-chat-target
- ;; Some IRC servers give an error if there is
- ;; no text at all.
- (if (string= line "")
- " "
- line)))))
-
-(defun circe--split-line (longline)
- "Splits LONGLINE into smaller components.
-
-IRC silently truncates long lines. This splits a long line into
-parts that each are not longer than `circe-split-line-length'."
- (if (< (length longline)
- circe-split-line-length)
- (list longline)
- (with-temp-buffer
- (insert longline)
- (let ((fill-column circe-split-line-length))
- (fill-region (point-min) (point-max)
- nil t))
- (split-string (buffer-string) "\n"))))
-
-(defun circe-command-SV (&optional ignored)
- "Tell the current channel about your client and Emacs version.
-
-Arguments are IGNORED."
- (interactive)
- (circe-command-SAY (format (concat "I'm using Circe version %s "
- "with %s %s (of %s)")
- (circe--version)
- "GNU Emacs"
- emacs-version
- (format-time-string "%Y-%m-%d"
- emacs-build-time))))
-
-(defun circe-command-TOPIC (channel &optional newtopic)
- "Change the topic of CHANNEL to NEWTOPIC."
- (interactive "sChannel: \nsNew topic: ")
- (when (string-match "^\\s-*$" channel)
- (setq channel nil))
- (when (and channel
- (not newtopic)
- (string-match "^\\s-*\\(\\S-+\\)\\( \\(.*\\)\\)?" channel))
- (setq newtopic (match-string 3 channel)
- channel (match-string 1 channel)))
- (cond
- ((and channel newtopic)
- (irc-send-TOPIC (circe-server-process) channel newtopic))
- (channel
- (irc-send-TOPIC (circe-server-process) channel))
- (circe-chat-target
- (irc-send-TOPIC (circe-server-process) circe-chat-target))
- (t
- (circe-display-server-message "No channel given, and no default target."))))
-
-(defun circe-command-UNFOOL (line)
- "Remove the entry LINE from `circe-fool-list'."
- (with-current-buffer (circe-server-last-active-buffer)
- (cond
- ((string-match "\\S-+" line)
- (let ((regex (match-string 0 line)))
- (setq circe-fool-list (delete regex circe-fool-list))
- (circe-display-server-message (format "Assuming %s is not a fool anymore"
- regex))))
- (t
- (circe-display-server-message
- "No one is not a fool anymore? UNFOOL requires one argument")))))
-
-(defun circe-command-UNIGNORE (line)
- "Remove the entry LINE from `circe-ignore-list'."
- (with-current-buffer (circe-server-last-active-buffer)
- (cond
- ((string-match "\\S-+" line)
- (let ((regex (match-string 0 line)))
- (setq circe-ignore-list (delete regex circe-ignore-list))
- (circe-display-server-message (format "Ignore list forgot about %s"
- regex))))
- (t
- (circe-display-server-message
- "Who do you want to unignore? UNIGNORE requires one argument")))))
-
-(defun circe-command-WHOAMI (&optional ignored)
- "Request WHOIS information about yourself.
-
-Arguments are IGNORED."
- (interactive)
- (irc-send-WHOIS (circe-server-process)
- (circe-nick)))
-
-(defun circe-command-WHOIS (whom)
- "Request WHOIS information about WHOM."
- (interactive "sWhois: ")
- (let* ((whom-server-name (split-string whom))
- (whom (car whom-server-name))
- (server-or-name (cadr whom-server-name)))
- (irc-send-WHOIS (circe-server-process) whom server-or-name)))
-
-(defun circe-command-WHOWAS (whom)
- "Request WHOWAS information about WHOM."
- (interactive "sWhois: ")
- (let ((whom (string-trim whom)))
- (irc-send-WHOWAS (circe-server-process) whom)))
-
-(defun circe-command-WL (&optional split)
- "Show the people who left in a netsplit.
-Without any arguments, shows shows the current netsplits and how
-many people are missing. With an argument SPLIT, which must be a
-number, it shows the missing people due to that split."
- (let ((circe-netsplit-list (with-circe-server-buffer
- circe-netsplit-list)))
- (if (or (not split)
- (and (stringp split)
- (string= split "")))
- (if (null circe-netsplit-list)
- (circe-display-server-message "No net split at the moment")
- (let ((n 0))
- (dolist (entry circe-netsplit-list)
- (circe-display-server-message (format "(%d) Missing %d people due to %s"
- n
- (hash-table-count (nth 3 entry))
- (car entry)))
- (setq n (+ n 1)))))
- (let* ((index (if (numberp split)
- split
- (string-to-number split)))
- (entry (nth index circe-netsplit-list)))
- (if (not entry)
- (circe-display-server-message (format "No split number %s - use /WL to see a list"
- split))
- (let ((missing nil))
- (maphash (lambda (_key value)
- (setq missing (cons value missing)))
- (nth 3 entry))
- (circe-display-server-message
- (format "Missing people due to %s: %s"
- (car entry)
- (mapconcat 'identity
- (sort missing
- (lambda (a b)
- (string< (downcase a)
- (downcase b))))
- ", ")))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Display Handlers ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun circe-display-ignore (_nick _userhost _command &rest _args)
- "Don't show a this message.
-
-NICK and USERHOST are the originator of COMMAND which had ARGS as
-arguments."
- 'noop)
-
-(circe-set-display-handler "317" 'circe-display-317)
-(defun circe-display-317 (_sender ignored _numeric _target nick
- idletime &optional signon-time body)
- "Show a 317 numeric (RPL_WHOISIDLE).
-
-Arguments are either of the two:
-
-:<server> 317 <ournick> <nick> <idle> :seconds idle
-:<server> 317 <ournick> <nick> <idle> <signon> :seconds idle, signon time"
- (with-current-buffer (circe-server-last-active-buffer)
- (let ((seconds-idle (string-to-number idletime))
- (signon-time (when body
- (string-to-number signon-time))))
- (if signon-time
- (circe-display 'circe-format-server-whois-idle-with-signon
- :whois-nick nick
- :idle-seconds seconds-idle
- :idle-duration (circe-duration-string seconds-idle)
- :signon-time signon-time
- :signon-date (current-time-string
- (seconds-to-time signon-time))
- :signon-ago (circe-duration-string (- (float-time)
- signon-time)))
- (circe-display 'circe-format-server-whois-idle
- :whois-nick nick
- :idle-seconds seconds-idle
- :idle-duration (circe-duration-string seconds-idle))))))
-
-(circe-set-display-handler "329" 'circe-display-329)
-(defun circe-display-329 (_server ignored _numeric _target channel timestamp)
- "Show a 329 numeric (RPL_CREATIONTIME)."
- (with-current-buffer (or (circe-server-get-chat-buffer channel)
- (circe-server-last-active-buffer))
- (let ((creation-time (string-to-number timestamp)))
- (circe-display 'circe-format-server-channel-creation-time
- :channel channel
- :date (current-time-string
- (seconds-to-time creation-time))
- :ago (circe-duration-string (- (float-time)
- creation-time))))))
-
-(circe-set-display-handler "333" 'circe-display-333)
-(defun circe-display-333 (_server ignored _numeric target
- channel setter topic-time)
- "Show a 333 numeric (RPL_TOPICWHOTIME).
-
-Arguments are either of the two:
-
-:<server> 333 <target> <channel> <nick> 1434996762
-:<server> 333 <target> <channel> <nick>!<user>@<host> 1434996803"
- (let ((channel-buffer (circe-server-get-chat-buffer channel))
- (topic-time (string-to-number topic-time)))
- (with-current-buffer (or channel-buffer
- (circe-server-last-active-buffer))
- (circe-display (if channel-buffer
- 'circe-format-server-topic-time
- 'circe-format-server-topic-time-for-channel)
- :nick target
- :channel channel
- :setter (irc-userstring-nick setter)
- :setter-userhost (or (irc-userstring-userhost setter)
- "(unknown)")
- :topic-time topic-time
- :topic-date (current-time-string
- (seconds-to-time topic-time))
- :topic-ago (circe-duration-string (- (float-time)
- topic-time))))))
-
-(circe-set-display-handler "AUTHENTICATE" 'circe-display-ignore)
-(circe-set-display-handler "CAP" 'circe-display-ignore)
-(circe-set-display-handler "conn.connected" 'circe-display-ignore)
-(circe-set-display-handler "conn.disconnected" 'circe-display-ignore)
-
-(circe-set-display-handler "irc.ctcp" 'circe-display-ignore)
-(circe-set-display-handler "irc.ctcpreply" 'circe-display-ignore)
-
-(circe-set-display-handler "irc.ctcp.ACTION" 'circe-display-ctcp-action)
-(defun circe-display-ctcp-action (nick userhost _command target text)
- "Show an ACTION."
- (cond
- ;; Query
- ((circe-server-my-nick-p target)
- (let ((query-buffer (circe-query-auto-query-buffer nick)))
- (with-current-buffer (or query-buffer
- (circe-server-last-active-buffer))
- (circe-display (if query-buffer
- 'circe-format-action
- 'circe-format-message-action)
- :nick nick
- :userhost (or userhost "server")
- :body text))))
- ;; Channel
- (t
- (with-current-buffer (circe-server-get-or-create-chat-buffer
- target 'circe-channel-mode)
- (circe-lurker-display-active nick userhost)
- (circe-display 'circe-format-action
- :nick nick
- :userhost (or userhost "server")
- :body text)))))
-
-(circe-set-display-handler "irc.ctcp.CLIENTINFO" 'circe-display-ctcp)
-
-(circe-set-display-handler "irc.ctcp.PING" 'circe-display-ctcp-ping)
-(defun circe-display-ctcp-ping (nick userhost _command target text)
- "Show a CTCP PING request."
- (with-current-buffer (circe-server-last-active-buffer)
- (circe-display 'circe-format-server-ctcp-ping
- :nick nick
- :userhost (or userhost "server")
- :target target
- :body (or text "")
- :ago (let ((time (string-to-number text)))
- (if time
- (format "%.2f seconds" (- (float-time) time))
- "unknown seconds")))))
-
-(circe-set-display-handler "irc.ctcpreply.PING" 'circe-display-ctcp-ping-reply)
-(defun circe-display-ctcp-ping-reply (nick userhost _command target text)
- "Show a CTCP PING reply."
- (with-current-buffer (circe-server-last-active-buffer)
- (circe-display 'circe-format-server-ctcp-ping-reply
- :nick nick
- :userhost (or userhost "server")
- :target target
- :body text
- :ago (let ((time (string-to-number text)))
- (if time
- (format "%.2f seconds" (- (float-time) time))
- "unknown seconds")))))
-
-(circe-set-display-handler "irc.ctcp.SOURCE" 'circe-display-ctcp)
-(circe-set-display-handler "irc.ctcp.TIME" 'circe-display-ctcp)
-(circe-set-display-handler "irc.ctcp.VERSION" 'circe-display-ctcp)
-(defun circe-display-ctcp (nick userhost command target text)
- "Show a CTCP request that does not require special handling."
- (with-current-buffer (circe-server-last-active-buffer)
- (circe-display 'circe-format-server-ctcp
- :nick nick
- :userhost (or userhost "server")
- :target target
- :command (substring command 9)
- :body (or text ""))))
-
-(circe-set-display-handler "irc.registered" 'circe-display-ignore)
-
-(circe-set-display-handler "JOIN" 'circe-display-JOIN)
-(defun circe-display-JOIN (nick userhost _command channel
- &optional accountname realname)
- "Show a JOIN message.
-
-The command receives an extra argument, the account name, on some
-IRC servers."
- (let* ((accountname (if (equal accountname "*")
- "(unauthenticated)"
- accountname))
- (userinfo (if accountname
- (format "%s, %s: %s" userhost accountname realname)
- userhost))
- (split (circe--netsplit-join nick)))
- ;; First, update the channel
- (with-current-buffer (circe-server-get-or-create-chat-buffer
- channel 'circe-channel-mode)
- (cond
- (split
- (let ((split-time (cadr split)))
- (when (< (+ split-time circe-netsplit-delay)
- (float-time))
- (circe-display 'circe-format-server-netmerge
- :split (car split)
- :time (cadr split)
- :date (current-time-string
- (seconds-to-time (cadr split)))
- :ago (circe-duration-string
- (- (float-time) (cadr split)))))))
- ((and (circe-reduce-lurker-spam)
- (circe-lurker-rejoin-p nick circe-chat-target))
- (let* ((channel (irc-connection-channel (circe-server-process)
- circe-chat-target))
- (user (when channel
- (irc-channel-recent-user channel nick)))
- (departed (when user
- (irc-user-part-time user))))
- (circe-display 'circe-format-server-rejoin
- :nick nick
- :userhost (or userhost "server")
- :accountname accountname
- :realname realname
- :userinfo userinfo
- :departuretime departed
- :departuredelta (circe-duration-string
- (- (float-time)
- departed)))))
- ((not (circe-reduce-lurker-spam))
- (circe-display 'circe-format-server-join
- :nick nick
- :userhost (or userhost "server")
- :accountname accountname
- :realname realname
- :userinfo userinfo
- :channel circe-chat-target))))
- ;; Next, a possible query buffer. We do this even when the message
- ;; should be ignored by a netsplit, since this can't flood.
- (let ((buf (circe-server-get-chat-buffer nick)))
- (when buf
- (with-current-buffer buf
- (circe-display 'circe-format-server-join-in-channel
- :nick nick
- :userhost (or userhost "server")
- :accountname accountname
- :realname realname
- :userinfo userinfo
- :channel circe-chat-target))))))
-
-(circe-set-display-handler "MODE" 'circe-display-MODE)
-(defun circe-display-MODE (setter userhost _command target &rest modes)
- "Show a MODE message."
- (with-current-buffer (or (circe-server-get-chat-buffer target)
- (circe-server-last-active-buffer))
- (circe-display 'circe-format-server-mode-change
- :setter setter
- :userhost (or userhost "server")
- :target target
- :change (mapconcat #'identity modes " "))))
-
-(circe-set-display-handler "NICK" 'circe-display-NICK)
-(defun circe-display-NICK (old-nick userhost _command new-nick)
- "Show a nick change."
- (if (circe-server-my-nick-p new-nick)
- (dolist (buf (cons (or circe-server-buffer
- (current-buffer))
- (circe-server-chat-buffers)))
- (with-current-buffer buf
- (circe-display 'circe-format-server-nick-change-self
- :old-nick old-nick
- :userhost (or userhost "server")
- :new-nick new-nick)))
- (let ((query-buffer (circe-server-get-chat-buffer old-nick)))
- (when query-buffer
- (with-current-buffer query-buffer
- (circe-server-rename-chat-buffer old-nick new-nick)
- (circe-display 'circe-format-server-nick-change
- :old-nick old-nick
- :new-nick new-nick
- :userhost (or userhost "server")))))
- (dolist (buf (circe-user-channels new-nick))
- (with-current-buffer buf
- (cond
- ((and (circe-reduce-lurker-spam)
- (circe-lurker-p new-nick))
- nil)
- ((circe-channel-user-nick-regain-p old-nick new-nick)
- (circe-display 'circe-format-server-nick-regain
- :old-nick old-nick
- :new-nick new-nick
- :userhost (or userhost "server")))
- (t
- (circe-display 'circe-format-server-nick-change
- :old-nick old-nick
- :new-nick new-nick
- :userhost (or userhost "server"))))))))
-
-(circe-set-display-handler "nickserv.identified" 'circe-display-ignore)
-
-;; NOTICE is also used to encode CTCP replies. irc.el will send
-;; irc.notice events for NOTICEs without CTCP replies, so we show
-;; that, not the raw notice.
-(circe-set-display-handler "NOTICE" 'circe-display-ignore)
-(circe-set-display-handler "irc.notice" 'circe-display-NOTICE)
-(defun circe-display-NOTICE (nick userhost _command target text)
- "Show a NOTICE message."
- (cond
- ((not userhost)
- (with-current-buffer (circe-server-last-active-buffer)
- (circe-display 'circe-format-server-notice
- :server nick
- :body text)))
- ((circe-server-my-nick-p target)
- (with-current-buffer (or (circe-server-get-chat-buffer nick)
- (circe-server-last-active-buffer))
- (circe-display 'circe-format-notice
- :nick nick
- :userhost (or userhost "server")
- :body text)))
- (t
- (with-current-buffer (or (circe-server-get-chat-buffer target)
- (circe-server-last-active-buffer))
- (circe-display 'circe-format-notice
- :nick nick
- :userhost (or userhost "server")
- :body text)))))
-
-(circe-set-display-handler "PART" 'circe-display-PART)
-(defun circe-display-PART (nick userhost _command channel &optional reason)
- "Show a PART message."
- (with-current-buffer (or (circe-server-get-chat-buffer channel)
- (circe-server-last-active-buffer))
- (when (or (not circe-chat-target)
- (not (circe-lurker-p nick)))
- (circe-display 'circe-format-server-part
- :nick nick
- :userhost (or userhost "server")
- :channel channel
- :reason (or reason "[No reason given]")))))
-
-(circe-set-display-handler "PING" 'circe-display-ignore)
-(circe-set-display-handler "PONG" 'circe-display-ignore)
-
-;; PRIVMSG is also used to encode CTCP requests. irc.el will send
-;; irc.message events for PRIVMSGs without CTCP messages, so we show
-;; that, not the raw message.
-(circe-set-display-handler "PRIVMSG" 'circe-display-ignore)
-(circe-set-display-handler "irc.message" 'circe-display-PRIVMSG)
-(defun circe-display-PRIVMSG (nick userhost _command target text)
- "Show a PRIVMSG message."
- (cond
- ((circe-server-my-nick-p target)
- (let ((buf (circe-query-auto-query-buffer nick)))
- (if buf
- (with-current-buffer buf
- (circe-display 'circe-format-say
- :nick nick
- :userhost (or userhost "server")
- :body text))
- (with-current-buffer (circe-server-last-active-buffer)
- (circe-display 'circe-format-message
- :nick nick
- :userhost (or userhost "server")
- :body text)))))
- (t
- (with-current-buffer (circe-server-get-or-create-chat-buffer
- target 'circe-channel-mode)
- (circe-lurker-display-active nick userhost)
- (circe-display 'circe-format-say
- :nick nick
- :userhost (or userhost "server")
- :body text)))))
-
-(circe-set-display-handler "TOPIC" 'circe-display-topic)
-(defun circe-display-topic (nick userhost _command channel new-topic)
- "Show a TOPIC change."
- (with-current-buffer (circe-server-get-or-create-chat-buffer
- channel 'circe-channel-mode)
- (let* ((channel-obj (irc-connection-channel (circe-server-process)
- channel))
- (old-topic (or (when channel
- (irc-channel-last-topic channel-obj))
- "")))
- (circe-display 'circe-format-server-topic
- :nick nick
- :userhost (or userhost "server")
- :channel channel
- :new-topic new-topic
- :old-topic old-topic
- :topic-diff (circe--topic-diff old-topic new-topic)))))
-
-(defun circe--topic-diff (old new)
- "Return a colored topic diff between OLD and NEW."
- (mapconcat (lambda (elt)
- (cond
- ((eq '+ (car elt))
- (let ((s (cadr elt)))
- (add-face-text-property 0 (length s)
- 'circe-topic-diff-new-face nil s)
- s))
- ((eq '- (car elt))
- (let ((s (cadr elt)))
- (add-face-text-property 0 (length s)
- 'circe-topic-diff-removed-face nil s)
- s))
- (t
- (cadr elt))))
- (lcs-unified-diff (circe--topic-diff-split old)
- (circe--topic-diff-split new)
- 'string=)
- ""))
-
-(defun circe--topic-diff-split (str)
- "Split STR into a list of components.
-The list consists of words and spaces."
- (let ((lis nil))
- (with-temp-buffer
- (insert str)
- (goto-char (point-min))
- (while (< (point)
- (point-max))
- (if (or (looking-at "\\w+\\W*")
- (looking-at ".\\s-*"))
- (progn
- (setq lis (cons (match-string 0)
- lis))
- (replace-match ""))
- (error "Can't happen"))))
- (nreverse lis)))
-
-(circe-set-display-handler "channel.quit" 'circe-display-channel-quit)
-(defun circe-display-channel-quit (nick userhost _command channel
- &optional reason)
- "Show a QUIT message."
- (let ((split (circe--netsplit-quit reason nick)))
- (with-current-buffer (circe-server-get-or-create-chat-buffer
- channel 'circe-channel-mode)
- (cond
- (split
- (when (< (+ split circe-netsplit-delay)
- (float-time))
- (circe-display 'circe-format-server-netsplit
- :split reason)))
- ((not (circe-lurker-p nick))
- (circe-display 'circe-format-server-quit-channel
- :nick nick
- :userhost (or userhost "server")
- :channel channel
- :reason (or reason "[no reason given]")))))))
-
-(circe-set-display-handler "QUIT" 'circe-display-QUIT)
-(defun circe-display-QUIT (nick userhost _command &optional reason)
- "Show a QUIT message.
-
-Channel quits are shown already, so just show quits in queries."
- (let ((buf (circe-server-get-chat-buffer nick)))
- (when buf
- (with-current-buffer buf
- (circe-display 'circe-format-server-quit
- :nick nick
- :userhost (or userhost "server")
- :reason (or reason "[no reason given]"))))))
-
-(defvar circe-netsplit-list nil
- "A list of recorded netsplits.
-Every item is a list with four elements:
-- The quit message for this split.
-- The time when last we heard about a join in this split
-- The time when last we heard about a quit in this split
-- A hash table noting which nicks did leave")
-(make-variable-buffer-local 'circe-netsplit-list)
-
-(defun circe--netsplit-join (nick)
- "Search for NICK in the netsplit lists.
-This either returns a pair whose car is the quit message of this
-split, and the cadr the time we last heard anything of the split
-of that user. If the NICK isn't split, this returns nil."
- (with-circe-server-buffer
- (catch 'return
- (dolist (entry circe-netsplit-list)
- (let ((table (nth 3 entry)))
- (when (gethash nick table)
- (let ((name (nth 0 entry))
- (time (nth 1 entry)))
- (remhash nick table)
- (when (= 0 (hash-table-count table))
- (setq circe-netsplit-list
- (delq entry circe-netsplit-list)))
- (setcar (cdr entry)
- (float-time))
- (throw 'return (list name time))))))
- nil)))
-
-(defun circe--netsplit-quit (reason nick)
- "If REASON indicates a netsplit, mark NICK as splitted.
-This either returns the time when last we heard about this split,
-or nil when this isn't a split."
- (when (circe--netsplit-reason-p reason)
- (with-circe-server-buffer
- (let ((entry (assoc reason circe-netsplit-list)))
- (if entry
- (let ((time (nth 2 entry))
- (table (nth 3 entry)))
- (setcar (cddr entry)
- (float-time))
- (puthash nick nick table)
- time)
- ;; New split!
- (let ((table (make-hash-table :test 'equal)))
- (puthash nick nick table)
- (setq circe-netsplit-list
- (cons (list reason 0 (float-time) table)
- circe-netsplit-list))
- 0))))))
-
-(defun circe--netsplit-reason-p (reason)
- "Return non-nil if REASON is the quit message of a netsplit.
-This is true when it contains exactly two hosts, with a single
-space in between them. The hosts must include at least one dot,
-and must not include colons or slashes (else they might be
-URLs). (Thanks to irssi for this criteria list)"
- (if (string-match "^[^ :/]+\\.[^ :/]* [^ :/]+\\.[^ :/]*$"
- reason)
- t
- nil))
-
-(let ((simple-format-specifiers
- '(("INVITE" active "Invite: {origin} invites you to {1}")
- ("KICK" 0 "Kick: {1} kicked by {origin}: {2}")
- ("ERROR" active "Error: {0-}")
- ("001" server "{1}")
- ("002" server "{1}")
- ("003" server "{1}")
- ("004" server "{1-}")
- ("005" server "{1-}")
- ;; IRCnet: * Please wait while we process your connection.
- ("020" server "{0-}")
- ;; IRCnet
- ("042" server "Your unique ID is {1}")
- ("200" active "{1-}")
- ("201" active "{1-}")
- ("203" active "{1-}")
- ("204" active "{1-}")
- ("205" active "{1-}")
- ("206" active "{1-}")
- ("207" active "{1-}")
- ("208" active "{1-}")
- ("209" active "{1-}")
- ("211" active "{1-}")
- ("212" active "{1-}")
- ("219" active "{1-}")
- ("221" active "User mode: {1-}")
- ("234" active "Service: {1-}")
- ("235" active "{1-}")
- ("242" active "{1}")
- ("243" active "{1-}")
- ("250" server "{1}")
- ("251" server "{1}")
- ("252" server "{1-}")
- ("253" server "{1-}")
- ("254" server "{1-}")
- ("255" server "{1}")
- ("256" active "{1-}")
- ("257" active "{1}")
- ("258" active "{1}")
- ("259" active "{1}")
- ("261" active "{1-}")
- ("262" active "{1-}")
- ("263" active "{1-}")
- ("265" server "{1-}")
- ("266" server "{1-}")
- ;; This is returned on both WHOIS and PRIVMSG. It
- ;; should go to the active window for the former, and
- ;; the query window for the latter. Oh well.
- ("301" active "User away: {1}")
- ("302" active "User hosts: {1}")
- ("303" active "Users online: {1}")
- ("305" active "{1}")
- ("306" active "{1}")
- ("307" active "{1-}")
- ;; Coldfront: 310 <nick> is available for help.
- ("310" active "{1-}")
- ("311" active "{1} is {2}@{3} ({5})")
- ("312" active "{1} is on {2} ({3})")
- ("313" active "{1} {2}")
- ("314" active "{1} was {2}@{3} ({5})")
- ("315" active "{2}")
- ("318" active "{2}")
- ("319" active "{1} is on {2}")
- ("320" active "{1-}")
- ("322" active "{1-}")
- ("323" active "{1-}")
- ("324" 1 "Channel mode for {1}: {2-}")
- ("325" 1 "Unique operator on {1} is {2}")
- ("328" 1 "Channel homepage for {1}: {2-}")
- ("330" active "{1} is logged in as {2}")
- ("331" 1 "No topic for {1} set")
- ("332" 1 "Topic for {1}: {2}")
- ("341" active "Inviting {1} to {2}")
- ("346" 1 "Invite mask: {2}")
- ("347" 1 "{2}")
- ("348" 1 "Except mask: {2}")
- ("349" 1 "{2}")
- ("351" active "{1-}")
- ("352" active "{5} ({2}@{3}) in {1} on {4}: {6-}")
- ("353" 2 "Names: {3}")
- ("364" active "{1-}")
- ("365" active "{1-}")
- ("366" 1 "{2}")
- ("367" 1 "Ban mask: {2}")
- ("368" 1 "{2}")
- ("369" active "{1} {2}")
- ("371" active "{1}")
- ("372" server "{1}")
- ("374" active "{1}")
- ("375" server "{1}")
- ("376" server "{1}")
- ("378" active "{1-}")
- ("381" active "{1}")
- ("382" active "{1-}")
- ("391" active "Time on {1}: {2}")
- ("401" active "No such nick: {1}")
- ("402" active "No such server: {1}")
- ("403" active "No such channel: {1}")
- ("404" 1 "Can not send to channel {1}")
- ("405" active "Can not join {1}: {2}")
- ("406" active "{1-}")
- ("407" active "{1-}")
- ("408" active "No such service: {1}")
- ("422" active "{1}")
- ("432" active "Erroneous nick name: {1}")
- ("433" active "Nick name in use: {1}")
- ("437" active "Nick/channel is temporarily unavailable: {1}")
- ("441" 2 "User not on channel: {1}")
- ("442" active "You are not on {1}")
- ("443" 2 "User {1} is already on channel {2}")
- ;; Coldfront: 451 * :You have not registered
- ("451" active "{1-}")
- ("467" 1 "{2}")
- ("470" 1 "{1} made you join {2}: {3-}")
- ("471" 1 "{2}")
- ("472" active "{1-}")
- ("473" active "{1-}")
- ("474" active "{1-}")
- ("475" active "{1-}")
- ("476" active "{1-}")
- ("477" active "{1-}")
- ("481" 1 "{2-}")
- ("484" active "{1-}")
- ;; Coldfront: 671 <nick> is using a Secure Connection
- ("671" active "{1-}")
- ("728" 1 "Quiet mask: {3}")
- ("729" 1 "{3-}")
- ;; Freenode SASL auth
- ("900" active "SASL: {3-}")
- ("903" active "{1-}"))))
- (dolist (fmt simple-format-specifiers)
- (circe-set-display-handler (car fmt) (cdr fmt))))
-
-(defun circe-set-message-target (command target)
- "Set the target of COMMAND to TARGET.
-
-This can be used to change format-based display handlers more
-easily."
- (let ((handler (circe-get-display-handler command)))
- (when (not (consp handler))
- (error "Handler of command %s is not a list" command))
- (setcar handler target)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Helper Functions ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun circe--list-drop-right (list pattern)
- "Drop elements from the right of LIST that match PATTERN.
-
-LIST should be a list of strings, and PATTERN is used as a
-regular expression."
- (let ((list (reverse list)))
- (while (and list
- (string-match pattern (car list)))
- (setq list (cdr list)))
- (nreverse list)))
-
-(defun circe--nick-next (oldnick)
- "Return a new nick to try for OLDNICK."
- (cond
- ;; If the nick ends with -+, replace those with _
- ((string-match "^\\(.*[^-]\\)\\(-+\\)$" oldnick)
- (concat (match-string 1 oldnick)
- (make-string (- (match-end 2)
- (match-beginning 2))
- ?_)))
- ;; If the nick is 9 chars long, take prefix and rotate.
- ((>= (length oldnick)
- 9)
- (when (string-match "^\\(.*[^-_]\\)[-_]*$" oldnick)
- (let ((nick (match-string 1 oldnick)))
- (concat (substring nick 1)
- (string (aref nick 0))))))
- ;; If the nick ends with _+ replace those with - and add one
- ((string-match "^\\(.*[^_]\\)\\(_+\\)$" oldnick)
- (concat (match-string 1 oldnick)
- (make-string (- (match-end 2)
- (match-beginning 2))
- ?-)
- "-"))
- ;; Else, just append -
- (t
- (concat oldnick "-"))))
-
-(defun circe-duration-string (duration)
- "Return a description of a DURATION in seconds."
- (let ((parts `((,(* 12 30 24 60 60) "year")
- (,(* 30 24 60 60) "month")
- (,(* 24 60 60) "day")
- (,(* 60 60) "hour")
- (60 "minute")
- (1 "second")))
- (duration (round duration))
- (result nil))
- (dolist (part parts)
- (let* ((seconds-per-part (car part))
- (description (cadr part))
- (count (/ duration seconds-per-part)))
- (when (not (zerop count))
- (setq result (cons (format "%d %s%s"
- count description
- (if (= count 1) "" "s"))
- result)))
- (setq duration (- duration (* count seconds-per-part)))))
- (if result
- (mapconcat #'identity
- (nreverse result)
- " ")
- "a moment")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Deprecated functions and variables
-
-(define-obsolete-function-alias 'circe-server-nick 'circe-nick
- "Circe 2.0")
-
-(define-obsolete-function-alias 'circe-server-message
- 'circe-display-server-message
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-networks 'circe-network-defaults
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-name 'circe-host
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-service 'circe-port
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-network 'circe-network
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-ip-family 'circe-ip-family
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-nick 'circe-nick
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-user 'circe-user
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-pass 'circe-pass
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-realname 'circe-realname
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-use-tls 'circe-use-tls
- "Circe 2.0")
-
-(define-obsolete-variable-alias 'circe-server-auto-join-channels
- 'circe-channels
- "Circe 2.0")
-
-(provide 'circe)
-;;; circe.el ends here
+++ /dev/null
-;;; irc.el --- Library to handle IRC connections -*- lexical-binding: t -*-
-
-;; Copyright (C) 2015 Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
-
-;; Author: Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
-;; URL: https://github.com/jorgenschaefer/circe
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; The main entry function is `irc-connect'. This creates a new
-;; connection to an IRC server, and also takes an event handler table
-;; which is used to run various event handlers. Handlers receive a
-;; connection object which can be used for other API calls.
-
-;; IRC connection objects also accept connection options. These can be
-;; queried using `irc-connection-get', and are set by `irc-connect' or
-;; later using `irc-connection-put'.
-
-;; Event handler tables are simple maps of names to functions. See
-;; `irc-handler-table', `irc-handler-add' and `irc-handler-run' for
-;; the API.
-
-;; To send commands to the server, use `irc-send-raw' or
-;; `irc-send-command'.
-
-;; The rest of the library are handler packs that add support for
-;; various IRC features.
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'make-tls-process)
-
-(defvar irc-debug-log nil
- "Emit protocol debug info if this is non-nil.")
-
-;;;;;;;;;;;;;;;;;;;;;;;
-;;; Connection function
-
-(defun irc-connect (&rest keywords)
- "Connect to an IRC server.
-
-Supported keyword arguments:
-
-:name NAME -- The name for the process
-:host HOST -- The host to connect to
-:service SERVICE -- The service or port to connect to
-:tls BOOL -- Whether to use TLS
-:family IP-FAMILY -- Force using of ipv4 or ipv6
-:handler-table HANDLER -- The event handler table to send events to.
-
-The following events are supported:
-
-conn.connected conn -- The connection was established
-conn.failed conn -- The connection could not be established
-conn.disconnected conn -- A previously established connection was lost
-
-NNN conn sender args... -- A numeric reply from IRC was received
-COMMAND conn sender args... -- An IRC command message was received"
- (let ((proc (funcall (if (plist-get keywords :tls)
- #'make-tls-process
- #'make-network-process)
- :name (or (plist-get keywords :name)
- (plist-get keywords :host))
- :host (or (plist-get keywords :host)
- (error "Must specify a :host to connect to"))
- :service (or (plist-get keywords :service)
- (error "Must specify a :service to connect to"))
- :family (plist-get keywords :family)
- :coding 'no-conversion
- :nowait (featurep 'make-network-process '(:nowait t))
- :noquery t
- :filter #'irc--filter
- :sentinel #'irc--sentinel
- :plist keywords
- :keepalive t)))
- ;; When we used `make-network-process' without :nowait, the
- ;; sentinel is not called with the open event, so we do this
- ;; manually.
- (when (eq (process-status proc) 'open)
- (irc--sentinel proc "open manually"))
- proc))
-
-(defun irc-connection-get (conn propname)
- "Return the value of CONN's PROPNAME property."
- (process-get conn propname))
-
-(defun irc-connection-put (conn propname value)
- "Change CONN's PROPNAME property to VALUE."
- (process-put conn propname value))
-
-(defun irc--sentinel (proc event)
- (cond
- ((string-match "\\`failed" event)
- (irc-event-emit proc "conn.failed"))
- ((string-match "\\`open" event)
- (irc-event-emit proc "conn.connected"))
- ((string-match "\\`\\(connection broken\\|finished\\|exited abnormally\\)"
- event)
- (irc-event-emit proc "conn.disconnected"))
- ((string-match "\\`\\(deleted\\|killed\\)" event)
- nil)
- (t
- (error "Unknown event in IRC sentinel: %S" event))))
-
-(defvar irc--filter-running-p nil
- "Non-nil when we're currently processing a message.
-
-Yep, this is a mutex. Why would one need a mutex in Emacs, a
-single-threaded application, you ask? Easy!
-
-When, during the execution of a process filter, any piece of code
-waits for process output - e.g. because they started a some
-external program - Emacs will process any input from external
-processes. Including the one for the filter that is currently
-running.
-
-If that process does emit output, the filter is run again, while
-it is already running. If the filter is not careful, this can
-cause data to arrive out of order, or get lost.")
-
-(defun irc--filter (proc data)
- "Handle data from the process."
- (irc-connection-put proc :conn-data
- (concat (or (irc-connection-get proc :conn-data)
- "")
- data))
- (when (not irc--filter-running-p)
- (let ((irc--filter-running-p t)
- (data (irc-connection-get proc :conn-data)))
- (while (string-match "\r?\n" data)
- (let ((line (substring data 0 (match-beginning 0))))
- (setq data (substring data (match-end 0)))
- (irc-connection-put proc :conn-data data)
- (irc--handle-line proc line)
- (setq data (irc-connection-get proc :conn-data)))))))
-
-(defun irc--handle-line (proc line)
- "Handle a single line from the IRC server.
-
-The command is simply passed to the event handler of the IRC
-connection."
- (irc-debug-out proc "S: %s" line)
- (let* ((parsed (irc--parse line))
- (sender (car parsed))
- (command (cadr parsed))
- (args (cddr parsed)))
- (apply #'irc-event-emit proc command sender args)))
-
-(defun irc--parse (line)
- "Parse a line from IRC.
-
-Returns a list: (sender command args...)
-
-A line from IRC is a space-separated list of arguments. If the
-first word starts with a colon, that's the sender. The first or
-second word is the command. All further words are arguments. The
-first word to start with a colon ends the argument list.
-
-Examples:
-
-COMMAND
-COMMAND arg
-COMMAND arg1 arg2
-COMMAND arg1 arg2 :arg3 still arg3
-:sender COMMAND arg1 arg2 :arg3 still arg3"
- (with-temp-buffer
- (insert line)
- (goto-char (point-min))
- (let ((sender nil)
- (args nil))
- ;; Optional sender.
- (when (looking-at ":\\([^ ]+\\) ")
- (setq sender (decode-coding-string
- (match-string 1)
- 'undecided))
- (goto-char (match-end 0)))
-
- ;; COMMAND.
- (unless (looking-at "\\([^ ]+\\)")
- (error "Invalid message: %s" line))
- (push (decode-coding-string (match-string 1) 'undecided)
- args)
- (goto-char (match-end 0))
-
- ;; Arguments.
- (while (re-search-forward " :\\(.*\\)\\| \\([^ ]*\\)" nil t)
- (push (decode-coding-string
- (or (match-string 1)
- (match-string 2))
- 'undecided)
- args))
-
- (cons sender (nreverse args)))))
-
-(defun irc-userstring-nick (userstring)
- "Return the nick in a given USERSTRING.
-
-USERSTRING is a typical nick!user@host prefix as used by IRC."
- (if (string-match "\\`\\([^!]+\\)!\\([^@]+\\)@\\(.*\\)\\'" userstring)
- (match-string 1 userstring)
- userstring))
-
-(defun irc-userstring-userhost (userstring)
- "Return the nick in a given USERSTRING.
-
-USERSTRING is a typical nick!user@host prefix as used by IRC."
- (if (string-match "\\`\\([^!]+\\)!\\([^@]+@.*\\)\\'" userstring)
- (match-string 2 userstring)
- nil))
-
-(defun irc-event-emit (conn event &rest args)
- "Run the event handlers for EVENT in CONN with ARGS."
- (irc-debug-out conn
- "E: %S %s"
- event
- (mapconcat (lambda (elt) (format "%S" elt))
- args
- " "))
- (let ((handler-table (irc-connection-get conn :handler-table)))
- (when handler-table
- (apply #'irc-handler-run handler-table event conn event args)
- (apply #'irc-handler-run handler-table nil conn event args))))
-
-;;;;;;;;;;;;;;;;;;;;;;;
-;;; Event handler table
-
-(defun irc-handler-table ()
- "Return a new event handler table."
- (make-hash-table :test 'equal))
-
-(defun irc-handler-add (table event handler)
- "Add HANDLER for EVENT to the event handler table TABLE."
- (puthash event
- (append (gethash event table)
- (list handler))
- table))
-
-(defun irc-handler-remove (table event handler)
- "Remove HANDLER for EVENT to the event handler table TABLE."
- (puthash event
- (delete handler
- (gethash event table))
- table))
-
-(defun irc-handler-run (table event &rest args)
- "Run the handlers for EVENT in TABLE, passing ARGS to each."
- (dolist (handler (gethash event table))
- (if debug-on-error
- (apply handler args)
- (condition-case err
- (apply handler args)
- (error
- (message "Error running event %S handler %S: %s (args were %S)"
- event handler err args))))))
-
-;;;;;;;;;;;
-;;; Sending
-
-(defun irc-send-raw (conn line &optional flood-handling)
- "Send a line LINE to the IRC connection CONN.
-
-LINE should not include the trailing newline.
-
-FLOOD-HANDLING defines how to handle the situation when we are
-sending too much data. It can have three values:
-
-nil -- Add the message to a queue and send it later
-:nowait -- Send the message immediately, circumventing flood protection
-:drop -- Send the message only if we are not flooding, and drop it if
- we have queued up messages.
-
-The flood protection algorithm works like the one detailed in RFC
-2813, section 5.8 \"Flood control of clients\".
-
- * If `flood-last-message' is less than the current
- time, set it equal.
- * While `flood-last-message' is less than `flood-margin'
- seconds ahead of the current time, send a message, and
- increase `flood-last-message' by `flood-penalty'."
- (cond
- ((null flood-handling)
- (irc-connection-put conn
- :flood-queue
- (append (irc-connection-get conn :flood-queue)
- (list line)))
- (irc-send--queue conn))
- ((eq flood-handling :nowait)
- (irc-send--internal conn line))
- ((eq flood-handling :drop)
- (let ((queue (irc-connection-get conn :flood-queue)))
- (when (not queue)
- (irc-connection-put conn :flood-queue (list line))
- (irc-send--queue conn))))))
-
-(defun irc-send--queue (conn)
- "Send messages from the flood queue in CONN.
-
-See `irc-send-raw' for the algorithm."
- (let ((queue (irc-connection-get conn :flood-queue))
- (last-message (or (irc-connection-get conn :flood-last-message)
- 0))
- (margin (or (irc-connection-get conn :flood-margin)
- 10))
- (penalty (or (irc-connection-get conn :flood-penalty)
- 3))
- (now (float-time)))
- (when (< last-message now)
- (setq last-message now))
- (while (and queue
- (< last-message (+ now margin)))
- (irc-send--internal conn (car queue))
- (setq queue (cdr queue)
- last-message (+ last-message penalty)))
- (irc-connection-put conn :flood-queue queue)
- (irc-connection-put conn :flood-last-message last-message)
- (let ((timer (irc-connection-get conn :flood-timer)))
- (when timer
- (cancel-timer timer)
- (irc-connection-put conn :flood-timer nil))
- (when queue
- (irc-connection-put conn
- :flood-timer
- (run-at-time 1 nil #'irc-send--queue conn))))))
-
-(defun irc-send--internal (conn line)
- "Send LINE to CONN."
- (irc-debug-out conn "C: %s" line)
- (process-send-string conn
- (concat (encode-coding-string line 'utf-8)
- "\r\n")))
-
-(defun irc-send-command (conn command &rest args)
- "Send COMMAND with ARGS to IRC connection CONN."
- (irc-send-raw conn (apply #'irc--format-command command args)))
-
-(defun irc--format-command (command &rest args)
- "Format COMMAND and ARGS for IRC.
-
-The last value in ARGS will be escaped with a leading colon if it
-contains a space. All other arguments are checked to make sure
-they do not contain a space."
- (dolist (arg (cons command args))
- (when (not (stringp arg))
- (error "Argument must be a string")))
- (let* ((prefix (cons command (butlast args)))
- (last (last args)))
- (dolist (arg prefix)
- (when (string-match " " arg)
- (error "IRC protocol error: Argument %S must not contain space"
- arg)))
- (when (and last (or (string-match " " (car last))
- (string-match "^:" (car last))
- (equal "" (car last))))
- (setcar last (concat ":" (car last))))
- (mapconcat #'identity
- (append prefix last)
- " ")))
-
-(defun irc-send-AUTHENTICATE (conn arg)
- "Send an AUTHENTICATE message with ARG.
-
-See https://github.com/atheme/charybdis/blob/master/doc/sasl.txt
-for details."
- (irc-send-command conn "AUTHENTICATE" arg))
-
-(defun irc-send-AWAY (conn &optional reason)
- "Mark yourself as AWAY with reason REASON, or back if reason is nil."
- (if reason
- (irc-send-command conn "AWAY" reason)
- (irc-send-command conn "AWAY")))
-
-(defun irc-send-CAP (conn &rest args)
- "Send a CAP message.
-
-See https://tools.ietf.org/html/draft-mitchell-irc-capabilities-01
-for details."
- (apply #'irc-send-command conn "CAP" args))
-
-(defun irc-send-INVITE (conn nick channel)
- "Invite NICK to CHANNEL."
- (irc-send-command conn "INVITE" nick channel))
-
-(defun irc-send-JOIN (conn channel &optional key)
- "Join CHANNEL.
-
-If KEY is given, use it to join the password-protected channel."
- (if key
- (irc-send-command conn "JOIN" channel key)
- (irc-send-command conn "JOIN" channel)))
-
-(defun irc-send-NAMES (conn &optional channel)
- "Retrieve user names from the server, optionally limited to CHANNEL."
- (if channel
- (irc-send-command conn "NAMES" channel)
- (irc-send-command conn "NAMES")))
-
-(defun irc-send-NICK (conn nick)
- "Change your own nick to NICK."
- (irc-send-command conn "NICK" nick))
-
-(defun irc-send-NOTICE (conn msgtarget text-to-be-sent)
- "Send a private notice containing TEXT-TO-BE-SENT to MSGTARGET.
-
-MSGTARGET can be either a nick or a channel."
- (irc-send-command conn "NOTICE" msgtarget text-to-be-sent))
-
-(defun irc-send-PART (conn channel reason)
- "Leave CHANNEL with reason REASON."
- (irc-send-command conn "PART" channel reason))
-
-(defun irc-send-PASS (conn password)
- "Authenticate to the server using PASSWORD."
- (irc-send-command conn "PASS" password))
-
-(defun irc-send-PONG (conn server)
- "Respond to a PING message."
- (irc-send-raw conn
- (irc--format-command "PONG" server)
- :nowait))
-
-(defun irc-send-PRIVMSG (conn msgtarget text-to-be-sent)
- "Send a private message containing TEXT-TO-BE-SENT to MSGTARGET.
-
-MSGTARGET can be either a nick or a channel."
- (irc-send-command conn "PRIVMSG" msgtarget text-to-be-sent))
-
-(defun irc-send-QUIT (conn reason)
- "Leave IRC with reason REASON."
- (irc-send-command conn "QUIT" reason))
-
-(defun irc-send-TOPIC (conn channel &optional new-topic)
- "Retrieve or set the topic of CHANNEL
-
-If NEW-TOPIC is given, set this as the new topic. If it is
-omitted, retrieve the current topic."
- (if new-topic
- (irc-send-command conn "TOPIC" channel new-topic)
- (irc-send-command conn "TOPIC" channel)))
-
-(defun irc-send-USER (conn user mode realname)
- "Send a USER message for registration.
-
-MODE should be an integer as per RFC 2812"
- (irc-send-command conn "USER" user (format "%s" mode) "*" realname))
-
-(defun irc-send-WHOIS (conn target &optional server-or-name)
- "Retrieve current whois information on TARGET."
- (if server-or-name
- (irc-send-command conn "WHOIS" target server-or-name)
- (irc-send-command conn "WHOIS" target)))
-
-(defun irc-send-WHOWAS (conn target)
- "Retrieve past whois information on TARGET."
- (irc-send-command conn "WHOWAS" target))
-
-;;;;;;;;;;;;;;;
-;;; Debug stuff
-
-(defun irc-debug-out (conn fmt &rest args)
- (when irc-debug-log
- (let ((name (format "*IRC Protocol %s:%s*"
- (irc-connection-get conn :host)
- (irc-connection-get conn :service))))
- (with-current-buffer (get-buffer-create name)
- (save-excursion
- (goto-char (point-max))
- (insert (apply #'format fmt args) "\n"))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Handler: Registration
-
-(defun irc-handle-registration (table)
- "Add command handlers to TABLE to handle registration.
-
-This will send the usual startup messages after we are connected.
-
-Events emitted:
-
-\"irc.registered\" current-nick -- We have successfully
- registered with the IRC server. Most commands can be used now.
- In particular, joining channels is only possible now.
-
-\"sasl.login\" nick!user@host account -- SASL log in was
- successful.
-
-Connection options used:
-
-:nick -- The nick to use to register with the server
-:user -- The user name to use
-:mode -- The initial mode to use; an integer. See RFC 2812 for
- the meaning.
-:realname -- The realname to use for the registration
-:pass -- The server password to send
-:cap-req -- CAP protocol capabilities to request, if available
-:sasl-username -- The SASL username to send, if sasl is available
-:sasl-password -- The SASL password to send, if sasl is available
-
-Connection options set:
-
-:connection-state -- One of nil, connected, registered, disconnected
- See `irc-connection-state' for an interface to this.
-:cap-supported-p -- Non-nil if the server supports the CAP protocol
-:cap-ack -- The list of active capabilities negotiated with the server"
- (irc-handler-add table "conn.connected"
- #'irc-handle-registration--connected)
- (irc-handler-add table "conn.disconnected"
- #'irc-handle-registration--disconnected)
- (irc-handler-add table "001" ;; RPL_WELCOME
- #'irc-handle-registration--rpl-welcome)
- (irc-handler-add table "CAP"
- #'irc-handle-registration--cap)
- (irc-handler-add table "AUTHENTICATE"
- #'irc-handle-registration--authenticate)
- (irc-handler-add table "900" ;; RPL_LOGGEDIN
- #'irc-handle-registration--logged-in))
-
-(defun irc-handle-registration--connected (conn _event)
- (irc-connection-put conn :connection-state 'connected)
- (when (irc-connection-get conn :cap-req)
- (irc-send-CAP conn "LS"))
- (let ((password (irc-connection-get conn :pass)))
- (when password
- (irc-send-PASS conn password)))
- (irc-send-NICK conn (irc-connection-get conn :nick))
- (irc-send-USER conn
- (irc-connection-get conn :user)
- (irc-connection-get conn :mode)
- (irc-connection-get conn :realname)))
-
-(defun irc-handle-registration--disconnected (conn _event)
- (irc-connection-put conn :connection-state 'disconnected))
-
-(defun irc-handle-registration--rpl-welcome (conn _event _sender target
- &rest ignored)
- (irc-connection-put conn :connection-state 'registered)
- (irc-event-emit conn "irc.registered" target))
-
-(defun irc-handle-registration--cap (conn _event _sender _target
- subcommand arg)
- (cond
- ((equal subcommand "LS")
- (let ((supported (split-string arg))
- (wanted nil))
- (dolist (cap (irc-connection-get conn :cap-req))
- (when (member cap supported)
- (setq wanted (append wanted (list cap)))))
- (if wanted
- (irc-send-CAP conn "REQ" (mapconcat #'identity wanted " "))
- (irc-send-CAP conn "END"))))
- ((equal subcommand "ACK")
- (let ((acked (split-string arg)))
- (irc-connection-put conn :cap-ack acked)
- (if (and (member "sasl" acked)
- (irc-connection-get conn :sasl-username)
- (irc-connection-get conn :sasl-password))
- (irc-send-AUTHENTICATE conn "PLAIN")
- (irc-send-CAP conn "END"))))
- (t
- (message "Unknown CAP response from server: %s %s" subcommand arg))))
-
-(defun irc-handle-registration--authenticate (conn _event _sender arg)
- (if (equal arg "+")
- (let ((username (irc-connection-get conn :sasl-username))
- (password (irc-connection-get conn :sasl-password)))
- (irc-send-AUTHENTICATE conn (base64-encode-string
- (format "%s\x00%s\x00%s"
- username username password)))
- (irc-send-CAP conn "END"))
- (message "Unknown AUTHENTICATE response from server: %s" arg)))
-
-(defun irc-handle-registration--logged-in (conn _event _sender _target
- userhost account _message)
- (irc-event-emit conn "sasl.login" userhost account))
-
-(defun irc-connection-state (conn)
- "connecting connected registered disconnected"
- (let ((state (irc-connection-get conn :connection-state)))
- (if (null state)
- 'connecting
- state)))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; Handler: Ping-Pong
-
-(defun irc-handle-ping-pong (table)
- "Add command handlers to respond to PING requests."
- (irc-handler-add table "PING" #'irc-handle-ping-pong--ping))
-
-(defun irc-handle-ping-pong--ping (conn _event _sender argument)
- (irc-send-PONG conn argument))
-
-;;;;;;;;;;;;;;;;;;;;;
-;;; Handler: ISUPPORT
-
-(defun irc-handle-isupport (table)
- "Add command handlers to track 005 RPL_ISUPPORT capabilities."
- (irc-handler-add table "005" #'irc-handle-isupport--005))
-
-(defun irc-handle-isupport--005 (conn _event _sender _target &rest args)
- (irc-connection-put
- conn :isupport
- (append (irc-connection-get conn :isupport)
- (irc-handle-isupport--capabilities-to-alist args))))
-
-(defun irc-handle-isupport--capabilities-to-alist (capabilities)
- (mapcar (lambda (cap)
- (if (string-match "\\`\\([^=]+\\)=\\(.*\\)\\'" cap)
- (cons (match-string 1 cap)
- (match-string 2 cap))
- (cons cap t)))
- capabilities))
-
-(defun irc-isupport (conn capability)
- "Return the value of CAPABILITY of CONN.
-
-These capabilities are set when the server sends a 005
-RPL_ISUPPORT message. The return value is either the value of the
-capability, or t if it is a boolean capability that is present.
-If the capability is not present, the return value is nil."
- (cdr (assoc capability
- (irc-connection-get conn :isupport))))
-
-(defun irc-string-equal-p (conn s1 s2)
- "Compare S1 to S2 case-insensitively.
-
-What case means is defined by the server of CONN."
- (equal (irc-isupport--case-fold conn s1)
- (irc-isupport--case-fold conn s2)))
-
-(defvar irc-isupport--ascii-table
- (let ((table (make-string 128 0))
- (char 0))
- (while (<= char 127)
- (if (and (<= ?A char)
- (<= char ?Z))
- (aset table char (+ char (- ?a ?A)))
- (aset table char char))
- (setq char (1+ char)))
- table)
- "A case mapping table for the ascii CASEMAPPING.")
-
-(defvar irc-isupport--rfc1459-table
- (let ((table (concat irc-isupport--ascii-table))) ; copy string
- (aset table ?\[ ?\{)
- (aset table ?\] ?\})
- (aset table ?\\ ?\|)
- (aset table ?^ ?\~)
- table)
- "A case mapping table for the rfc1459 CASEMAPPING.")
-
-(defvar irc-isupport--rfc1459-strict-table
- (let ((table (concat irc-isupport--ascii-table))) ; copy string
- (aset table ?\[ ?\{)
- (aset table ?\] ?\})
- (aset table ?\\ ?\|)
- table)
- "A case mapping table for the rfc1459-strict CASEMAPPING.")
-
-(defun irc-isupport--case-fold (conn s)
- "Translate S to be a lower-case.
-
-This uses the case mapping defined by the IRC server for CONN."
- (with-temp-buffer
- (insert s)
- (let ((mapping (or (irc-isupport conn "CASEMAPPING")
- "rfc1459")))
- (cond
- ((equal mapping "rfc1459")
- (translate-region (point-min)
- (point-max)
- irc-isupport--rfc1459-table))
- ((equal mapping "ascii")
- (translate-region (point-min)
- (point-max)
- irc-isupport--ascii-table))
- ((equal mapping "rfc1459-strict")
- (translate-region (point-min)
- (point-max)
- irc-isupport--rfc1459-strict-table))))
- (buffer-string)))
-
-(defun irc-channel-name-p (conn string)
- "True iff STRING is a valid channel name for CONN.
-
-This depends on the CHANTYPES setting set by the server of CONN."
- (let ((chantypes (string-to-list
- (or (irc-isupport conn "CHANTYPES")
- "#"))))
- (if (and (> (length string) 0)
- (member (aref string 0) chantypes))
- t
- nil)))
-
-(defun irc-nick-without-prefix (conn nick)
- "Return NICK without any mode prefixes.
-
-For example, a user with op status might be shown as @Nick. This
-function would return Nick without the prefix. This uses the 005
-RPL_ISUPPORT setting of PREFIX set by the IRC server for CONN."
- (let ((prefixes (irc-connection-get conn :nick-prefixes)))
- (when (not prefixes)
- (let ((prefix-string (or (irc-isupport conn "PREFIX")
- "(qaohv)~&@%+")))
- (setq prefixes (string-to-list
- (if (string-match "(.*)\\(.*\\)" prefix-string)
- (match-string 1 prefix-string)
- "~&@%+")))
- (irc-connection-put conn :nick-prefixes prefixes)))
- (while (and (> (length nick) 0)
- (member (aref nick 0) prefixes))
- (setq nick (substring nick 1)))
- nick))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Handler: Initial nick acquisition
-
-(defun irc-handle-initial-nick-acquisition (table)
- "Track the current nick of the user.
-
-Connection options used:
-
-:nick-alternatives -- A list of nicks to try if the first attempt
- does not succeed."
- (irc-handler-add table "432" ;; ERR_ERRONEUSNICKNAME
- #'irc-handle-initial-nick-acquisition--get-initial-nick)
- (irc-handler-add table "433" ;; ERR_NICKNAMEINUSE
- #'irc-handle-initial-nick-acquisition--get-initial-nick)
- (irc-handler-add table "437" ;; ERR_UNAVAILRESOURCE
- #'irc-handle-initial-nick-acquisition--get-initial-nick))
-
-(defun irc-handle-initial-nick-acquisition--get-initial-nick
- (conn _event _sender current-nick _attempted-nick _reason)
- (when (equal current-nick "*")
- (let ((alternatives (irc-connection-get conn :nick-alternatives)))
- (if (not alternatives)
- (irc-send-NICK conn (irc-generate-nick))
- (irc-connection-put conn :nick-alternatives (cdr alternatives))
- (irc-send-NICK conn (car alternatives))))))
-
-(defun irc-generate-nick ()
- "Return a random, valid IRC nick name.
-
-Valid nick names are at least (RFC 1459):
-
-<nick> ::= <letter> { <letter> | <number> | <special> }
-<special> ::= '-' | '[' | ']' | '\' | '`' | '^' | '{' | '}'"
- (let ((chars "abcdefghijklmnopqrstuvwxyz"))
- (mapconcat (lambda (_)
- (make-string 1 (aref chars (random (length chars)))))
- (make-string 9 0)
- "")))
-
-;;;;;;;;;;;;;;;;;
-;;; Handler: CTCP
-
-(defun irc-handle-ctcp (table)
- "Add command handlers to TABLE to handle the CTCP protocol.
-
-Connection options used:
-
-:ctcp-version -- The response to a CTCP VERSION request.
-:ctcp-clientinfo -- The response to a CTCP CLIENTINFO request.
-:ctcp-source -- The response to a CTCP SOURCE request.
-
-Events emitted:
-
-\"irc.message\" sender target body -- A non-CTCP PRIVMSG
-\"irc.notice\" sender target body -- A non-CTCP NOTICE
-\"irc.ctcp\" sender target verb argument -- A CTCP request. ARGUMENT
- can be nil if there was no argument, or the empty string if the
- argument was empty.
-\"irc.ctcpreply\" sender target verb argument -- A CTCP reply.
- ARGUMENT is similar to above.
-\"irc.ctcp.VERB\" sender target argument -- A CTCP request of
- this specific type.
-\"irc.ctcpreply.VERB\" sender target argument -- A CTCP reply of
- this specific type."
- (irc-handler-add table "PRIVMSG"
- #'irc-handle-ctcp--privmsg)
- (irc-handler-add table "irc.ctcp"
- #'irc-handle-ctcp--ctcp)
- (irc-handler-add table "NOTICE"
- #'irc-handle-ctcp--notice)
- (irc-handler-add table "irc.ctcpreply"
- #'irc-handle-ctcp--ctcpreply)
- (irc-handler-add table "irc.ctcp.VERSION"
- #'irc-handle-ctcp--ctcp-version)
- (irc-handler-add table "irc.ctcp.CLIENTINFO"
- #'irc-handle-ctcp--ctcp-clientinfo)
- (irc-handler-add table "irc.ctcp.SOURCE"
- #'irc-handle-ctcp--ctcp-source)
- (irc-handler-add table "irc.ctcp.PING"
- #'irc-handle-ctcp--ctcp-ping)
- (irc-handler-add table "irc.ctcp.TIME"
- #'irc-handle-ctcp--ctcp-time)
- )
-
-(defun irc-handle-ctcp--privmsg (conn _event sender target body)
- (if (string-match "\\`\x01\\([^ ]+\\)\\(?: \\(.*\\)\\)?\x01\\'"
- body)
- (irc-event-emit conn "irc.ctcp" sender target
- (match-string 1 body)
- (match-string 2 body))
- (irc-event-emit conn "irc.message" sender target body)))
-
-(defun irc-handle-ctcp--ctcp (conn _event sender target verb argument)
- (irc-event-emit conn
- (format "irc.ctcp.%s" (upcase verb))
- sender
- target
- argument))
-
-(defun irc-handle-ctcp--notice (conn _event sender target body)
- (if (string-match "\\`\x01\\([^ ]+\\)\\(?: \\(.*\\)\\)?\x01\\'"
- body)
- (irc-event-emit conn "irc.ctcpreply" sender target
- (match-string 1 body)
- (match-string 2 body))
- (irc-event-emit conn "irc.notice" sender target body)))
-
-(defun irc-handle-ctcp--ctcpreply (conn _event sender target verb argument)
- (irc-event-emit conn
- (format "irc.ctcpreply.%s" (upcase verb))
- sender
- target
- argument))
-
-(defun irc-handle-ctcp--ctcp-version (conn _event sender _target _argument)
- (let ((version (irc-connection-get conn :ctcp-version)))
- (when version
- (irc-send-ctcpreply conn
- (irc-userstring-nick sender)
- "VERSION"
- version))))
-
-(defun irc-handle-ctcp--ctcp-clientinfo (conn _event sender _target _argument)
- (let ((clientinfo (irc-connection-get conn :ctcp-clientinfo)))
- (when clientinfo
- (irc-send-ctcpreply conn
- (irc-userstring-nick sender)
- "CLIENTINFO"
- clientinfo))))
-
-(defun irc-handle-ctcp--ctcp-source (conn _event sender _target _argument)
- (let ((source (irc-connection-get conn :ctcp-source)))
- (when source
- (irc-send-ctcpreply conn
- (irc-userstring-nick sender)
- "SOURCE"
- source))))
-
-(defun irc-handle-ctcp--ctcp-ping (conn _event sender _target argument)
- (when argument
- (irc-send-ctcpreply conn
- (irc-userstring-nick sender)
- "PING"
- argument)))
-
-(defun irc-handle-ctcp--ctcp-time (conn _event sender _target _argument)
- (irc-send-ctcpreply conn
- (irc-userstring-nick sender)
- "TIME"
- (current-time-string)))
-
-(defun irc-send-ctcp (conn target verb &optional argument)
- "Send a CTCP VERB request to TARGET, optionally with ARGUMENT."
- (irc-send-PRIVMSG conn
- target
- (format "\x01%s%s\x01"
- verb
- (if argument
- (concat " " argument)
- ""))))
-
-(defun irc-send-ctcpreply (conn target verb &optional argument)
- "Send a CTCP VERB reply to TARGET, optionally with ARGUMENT."
- (irc-send-raw conn
- (irc--format-command "NOTICE"
- target
- (format "\x01%s%s\x01"
- verb
- (if argument
- (concat " " argument)
- "")))
- :drop))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Handler: State tracking
-
-(defun irc-handle-state-tracking (table)
- "Add command handlers to TABLE to track the IRC state.
-
-Connection options used:
-
-:current-nick -- The current nick, or nil if not known/set yet.
-
-Use helper functions to access the information tracked by this
-handler:
-
-- `irc-current-nick'
-- `irc-current-nick-p'
-
-Events emitted:
-
-\"channel.quit\" sender channel reason -- A user quit IRC and
- left this channel that way."
- (irc-handler-add table "001" ;; RPL_WELCOME
- #'irc-handle-state-tracking--rpl-welcome)
- (irc-handler-add table "JOIN"
- #'irc-handle-state-tracking--JOIN)
- (irc-handler-add table "PART"
- #'irc-handle-state-tracking--PART)
- (irc-handler-add table "KICK"
- #'irc-handle-state-tracking--KICK)
- (irc-handler-add table "QUIT"
- #'irc-handle-state-tracking--QUIT)
- (irc-handler-add table "NICK"
- #'irc-handle-state-tracking--NICK)
- (irc-handler-add table "PRIVMSG"
- #'irc-handle-state-tracking--PRIVMSG)
- (irc-handler-add table "353" ;; RPL_NAMREPLY
- #'irc-handle-state-tracking--rpl-namreply)
- (irc-handler-add table "366" ;; RPL_ENDOFNAMES
- #'irc-handle-state-tracking--rpl-endofnames)
-
- (irc-handler-add table "TOPIC"
- #'irc-handle-state-tracking--TOPIC)
- (irc-handler-add table "331" ;; RPL_NOTOPIC
- #'irc-handle-state-tracking--rpl-notopic)
- (irc-handler-add table "332" ;; RPL_TOPIC
- #'irc-handle-state-tracking--rpl-topic)
- )
-
-(cl-defstruct irc-channel
- name
- topic
- last-topic
- folded-name
- users
- recent-users
- receiving-names
- connection)
-
-(defun irc-channel-from-name (conn name)
- "Create a new IRC channel object on CONN, named NAME."
- (make-irc-channel :name name
- :folded-name (irc-isupport--case-fold conn name)
- :users (make-hash-table :test 'equal)
- :recent-users (make-hash-table :test 'equal)
- :connection conn))
-
-(defun irc-connection-channel (conn channel-name)
- "Return the channel object for CHANNEL-NAME on CONN."
- (let ((channel-table (irc--connection-channel-table conn))
- (folded-name (irc-isupport--case-fold conn channel-name)))
- (gethash folded-name channel-table)))
-
-(defun irc-connection-channel-list (conn)
- "Return the list of channel object on CONN."
- (let ((channel-list nil))
- (maphash (lambda (_folded-name channel)
- (push channel channel-list))
- (irc--connection-channel-table conn))
- channel-list))
-
-(defun irc-connection-add-channel (conn channel-name)
- "Add CHANNEL-NAME to the channel table of CONN."
- (let* ((channel-table (irc--connection-channel-table conn))
- (channel (irc-channel-from-name conn channel-name))
- (folded-name (irc-channel-folded-name channel)))
- (when (not (gethash folded-name channel-table))
- (puthash folded-name channel channel-table))))
-
-(defun irc-connection-remove-channel (conn channel-name)
- "Remove CHANNEL-NAME from the channel table of CONN."
- (let* ((channel-table (irc--connection-channel-table conn))
- (folded-name (irc-isupport--case-fold conn channel-name)))
- (remhash folded-name channel-table)))
-
-(defun irc-current-nick (conn)
- "Return the current nick on IRC connection CONN, or nil if not set yet."
- (irc-connection-get conn :current-nick))
-
-(defun irc-current-nick-p (conn nick)
- "Return t if NICK is our current nick on IRC connection CONN."
- (let ((current-nick (irc-current-nick conn)))
- (if (and (stringp nick)
- (stringp current-nick))
- (irc-string-equal-p conn current-nick nick)
- nil)))
-
-(defun irc--connection-channel-table (conn)
- (let ((table (irc-connection-get conn :channel-table)))
- (when (not table)
- (setq table (make-hash-table :test 'equal))
- (irc-connection-put conn :channel-table table))
- table))
-
-(cl-defstruct irc-user
- nick
- folded-nick
- userhost
- join-time
- last-activity-time
- part-time
- connection)
-
-(defun irc-user-from-userstring (conn userstring)
- "Create an irc-user struct on CONN from USERSTRING.
-
-USERSTRING should be a s tring of the form \"nick!user@host\"."
- (let ((nick (irc-userstring-nick userstring)))
- (make-irc-user :nick nick
- :folded-nick (irc-isupport--case-fold conn nick)
- :userhost (let ((nick-len (length nick)))
- (if (>= nick-len (length userstring))
- nil
- (substring userstring (1+ nick-len))))
- :connection conn)))
-
-(defun irc-channel-user (channel nick)
- "Return a user named NICK on channel CHANNEL."
- (let ((user-table (irc-channel-users channel))
- (folded-nick (irc-isupport--case-fold (irc-channel-connection channel)
- nick)))
- (gethash folded-nick user-table)))
-
-(defun irc-channel-recent-user (channel nick)
- "Return a recent user named NICK on channel CHANNEL."
- (let ((user-table (irc-channel-recent-users channel))
- (folded-nick (irc-isupport--case-fold (irc-channel-connection channel)
- nick)))
- (gethash folded-nick user-table)))
-
-(defun irc-channel-add-user (channel userstring)
- "Add USER to CHANNEL."
- (let* ((user-table (irc-channel-users channel))
- (user (irc-user-from-userstring (irc-channel-connection channel)
- userstring))
- (folded-nick (irc-user-folded-nick user))
- (recent-user (irc-channel-recent-user channel (irc-user-nick user))))
- (when (not (gethash folded-nick user-table))
- (when (and recent-user
- (equal (irc-user-userhost recent-user)
- (irc-user-userhost user)))
- (setf (irc-user-last-activity-time user)
- (irc-user-last-activity-time recent-user)))
- (puthash folded-nick user user-table)
- user)))
-
-(defun irc-channel-remove-user (channel nick)
- "Remove NICK from CHANNEL."
- (let* ((user-table (irc-channel-users channel))
- (recent-user-table (irc-channel-recent-users channel))
- (folded-nick (irc-isupport--case-fold (irc-channel-connection channel)
- nick))
- (user (gethash folded-nick user-table)))
- (remhash folded-nick user-table)
- (when user
- (setf (irc-user-part-time user) (float-time))
- (puthash folded-nick user recent-user-table)
- (maphash (lambda (folded-nick user)
- (when (< (irc-user-part-time user)
- (- (float-time)
- (* 60 60)))
- (remhash folded-nick recent-user-table)))
- recent-user-table))))
-
-(defun irc-channel-rename-user (channel oldnick newnick)
- "Update CHANNEL so that the user with nick OLDNICK now has nick NEWNICK."
- (let ((user-table (irc-channel-users channel))
- (user (irc-channel-user channel oldnick))
- (newnick-folded (irc-isupport--case-fold
- (irc-channel-connection channel)
- newnick))
- (recent-user (irc-channel-recent-user channel newnick)))
- (when user
- (when (and recent-user
- (equal (irc-user-userhost recent-user)
- (irc-user-userhost user)))
- (setf (irc-user-last-activity-time user)
- (irc-user-last-activity-time recent-user)))
- (remhash (irc-user-folded-nick user) user-table)
- (setf (irc-user-nick user) newnick)
- (setf (irc-user-folded-nick user) newnick-folded)
- (puthash (irc-user-folded-nick user) user user-table))))
-
-(defun irc-handle-state-tracking--rpl-welcome (conn _event _sender target
- &rest ignored)
- (irc-connection-put conn :current-nick target))
-
-(defun irc-handle-state-tracking--JOIN (conn _event sender target
- &optional _account _realname)
- (let ((nick (irc-userstring-nick sender)))
- (cond
- ((irc-current-nick-p conn nick)
- (irc-connection-add-channel conn target))
- (t
- (let ((channel (irc-connection-channel conn target)))
- (when channel
- (let ((user (irc-channel-add-user channel sender)))
- (when user
- (setf (irc-user-join-time user) (float-time))))))))))
-
-(defun irc-handle-state-tracking--PART (conn _event sender target
- &optional _reason)
- (let ((nick (irc-userstring-nick sender)))
- (cond
- ((irc-current-nick-p conn nick)
- (irc-connection-remove-channel conn target))
- (t
- (let ((channel (irc-connection-channel conn target)))
- (when channel
- (irc-channel-remove-user channel nick)))))))
-
-(defun irc-handle-state-tracking--KICK (conn _event _sender target nick
- &optional _reason)
- (cond
- ((irc-current-nick-p conn nick)
- (irc-connection-remove-channel conn target))
- (t
- (let ((channel (irc-connection-channel conn target)))
- (when channel
- (irc-channel-remove-user channel nick))))))
-
-(defun irc-handle-state-tracking--QUIT (conn _event sender
- &optional reason)
- (let ((nick (irc-userstring-nick sender)))
- (if (irc-current-nick-p conn nick)
- (dolist (channel (irc-connection-channel-list conn))
- (irc-connection-remove-channel conn
- (irc-channel-folded-name channel)))
- (dolist (channel (irc-connection-channel-list conn))
- (when (irc-channel-user channel nick)
- (irc-event-emit conn "channel.quit"
- sender
- (irc-channel-name channel)
- reason))
- (irc-channel-remove-user channel nick)))))
-
-(defun irc-handle-state-tracking--NICK (conn _event sender new-nick)
- ;; Update channels
- (let ((nick (irc-userstring-nick sender)))
- (dolist (channel (irc-connection-channel-list conn))
- (irc-channel-rename-user channel nick new-nick)))
- ;; Update our own nick
- (when (irc-current-nick-p conn (irc-userstring-nick sender))
- (irc-connection-put conn :current-nick new-nick)))
-
-(defun irc-handle-state-tracking--PRIVMSG (conn _event sender target _message)
- (let ((channel (irc-connection-channel conn target))
- (nick (irc-userstring-nick sender)))
- (when channel
- (let ((user (irc-channel-user channel nick)))
- (when user
- (setf (irc-user-last-activity-time user) (float-time)))))))
-
-(defun irc-handle-state-tracking--rpl-namreply
- (conn _event _sender _current-nick _channel-type channel-name nicks)
- (let ((channel (irc-connection-channel conn channel-name)))
- (when channel
- (setf (irc-channel-receiving-names channel)
- (append (irc-channel-receiving-names channel)
- (mapcar (lambda (nick)
- (irc-nick-without-prefix
- conn
- (string-trim nick)))
- (split-string nicks)))))))
-
-(defun irc-handle-state-tracking--rpl-endofnames
- (conn _event _sender _current-nick channel-name _description)
- (let ((channel (irc-connection-channel conn channel-name)))
- (when channel
- (irc-channel--synchronize-nicks channel
- (irc-channel-receiving-names channel))
- (setf (irc-channel-receiving-names channel) nil))))
-
-(defun irc-channel--synchronize-nicks (channel nicks)
- "Update the user list of CHANNEL to match NICKS."
- (let ((have (irc-channel-users channel))
- (want (make-hash-table :test 'equal)))
- (dolist (nick nicks)
- (puthash (irc-isupport--case-fold (irc-channel-connection channel)
- nick)
- nick
- want))
- (maphash (lambda (nick-folded user)
- (when (not (gethash nick-folded want))
- (irc-channel-remove-user channel
- (irc-user-nick user))))
- have)
- (maphash (lambda (_nick-folded nick)
- (irc-channel-add-user channel nick))
- want)))
-
-(defun irc-handle-state-tracking--TOPIC (conn _event _sender channel new-topic)
- (let ((channel (irc-connection-channel conn channel)))
- (when channel
- (setf (irc-channel-last-topic channel)
- (irc-channel-topic channel))
- (setf (irc-channel-topic channel) new-topic))))
-
-(defun irc-handle-state-tracking--rpl-notopic (conn _event _sender
- _current-nick channel
- _no-topic-desc)
- (let ((channel (irc-connection-channel conn channel)))
- (when channel
- (setf (irc-channel-topic channel) nil))))
-
-(defun irc-handle-state-tracking--rpl-topic (conn _event _sender _current-nick
- channel topic)
- (let ((channel (irc-connection-channel conn channel)))
- (when channel
- (setf (irc-channel-topic channel) topic))))
-
-;;;;;;;;;;;;;;,;;;;;;
-;;; Handler: NickServ
-
-(defun irc-handle-nickserv (table)
- "Add command handlers to TABLE to deal with NickServ.
-
-Connection options used:
-
-:nickserv-nick -- The nick to register as
-
-:nickserv-password -- The password for nickserv; can be a function and
- is then called with the IRC connection as its sole argument
-
-:nickserv-mask -- A regular expression matching the correct NickServ's
- nick!user@host string to avoid fakes
-
-:nickserv-identify-challenge -- A regular expression matching the
- challenge sent by NickServ to request identification
-
-:nickserv-identify-command -- The raw IRC command to send to identify;
- expands {nick} and {password} when present
-
-:nickserv-identify-confirmation -- A regular expression matching the
- confirmation message from NickServ after successful identification
-
-:nickserv-ghost-command -- The raw IRC comment to ghost your
- original nick; expands {nick} and {password}. Set this to nil
- to disable ghosting and nick regaining.
-
-:nickserv-ghost-confirmation -- A regular expression matching the
- confirmation message that the nick was ghosted
-
-Events emitted:
-
-\"nickserv.identified\" -- We have successfully identified with nickserv.
-
-\"nickserv.ghosted\" -- We have ghosted a nick."
- (irc-handler-add table "irc.registered" #'irc-handle-nickserv--registered)
- (irc-handler-add table "NOTICE" #'irc-handle-nickserv--NOTICE)
- (irc-handler-add table "PRIVMSG" #'irc-handle-nickserv--NOTICE)
- (irc-handler-add table "NICK" #'irc-handle-nickserv--NICK))
-
-(defun irc-handle-nickserv--password (conn)
- (let ((password (irc-connection-get conn :nickserv-password)))
- (if (functionp password)
- (funcall password conn)
- password)))
-
-(defun irc-handle-nickserv--registered (conn _event current-nick)
- (let ((ghost-command (irc-connection-get conn :nickserv-ghost-command))
- (wanted-nick (irc-connection-get conn :nickserv-nick))
- (password (irc-handle-nickserv--password conn)))
- (when (and ghost-command
- wanted-nick
- password
- (not (irc-string-equal-p conn current-nick wanted-nick)))
- (irc-send-raw conn
- (irc-format ghost-command
- 'nick wanted-nick
- 'password password)))))
-
-(defun irc-handle-nickserv--NOTICE (conn _event sender _target message)
- (let ((nickserv-mask (irc-connection-get conn :nickserv-mask))
- identify-challenge identify-command identify-confirmation
- ghost-confirmation
- nickserv-nick nickserv-password)
- (when (and nickserv-mask (string-match nickserv-mask sender))
- (setq identify-challenge
- (irc-connection-get conn :nickserv-identify-challenge))
- (setq identify-command
- (irc-connection-get conn :nickserv-identify-command))
- (setq identify-confirmation
- (irc-connection-get conn :nickserv-identify-confirmation))
- (setq ghost-confirmation
- (irc-connection-get conn :nickserv-ghost-confirmation))
- (setq nickserv-nick (irc-connection-get conn :nickserv-nick))
- (setq nickserv-password (irc-handle-nickserv--password conn))
- (cond
- ;; Identify
- ((and identify-challenge
- identify-command
- nickserv-nick
- nickserv-password
- (string-match identify-challenge message))
- (irc-send-raw conn
- (irc-format identify-command
- 'nick nickserv-nick
- 'password nickserv-password)))
- ;; Identification confirmed
- ((and identify-confirmation
- (string-match identify-confirmation message))
- (irc-event-emit conn "nickserv.identified"))
- ;; Ghosting confirmed
- ((and ghost-confirmation
- (string-match ghost-confirmation message))
- (irc-event-emit conn "nickserv.ghosted")
- (irc-connection-put conn :nickserv-regaining-nick t)
- (when nickserv-nick
- (irc-send-NICK conn nickserv-nick)))))))
-
-(defun irc-handle-nickserv--NICK (conn _event _sender new-nick)
- (when (and (irc-connection-get conn :nickserv-regaining-nick)
- (irc-string-equal-p conn new-nick
- (irc-connection-get conn :nickserv-nick)))
- (irc-connection-put conn :nickserv-regaining-nick nil)
- (irc-event-emit conn "nickserv.regained")))
-
-(defun irc-format (format &rest args)
- "Return a formatted version of FORMAT, using substitutions from ARGS.
-
-The substitutions are identified by braces ('{' and '}')."
- (with-temp-buffer
- (insert format)
- (goto-char (point-min))
- (while (re-search-forward "{\\([^}]*\\)}" nil t)
- (replace-match (format "%s" (plist-get args (intern (match-string 1))))))
- (buffer-string)))
-
-;;;;;;;;;;;;;;;;;;;;;;
-;;; Handler: Auto-Join
-
-(defun irc-handle-auto-join (table)
- "Add command handlers to TABLE to deal with NickServ.
-
-Connection options used:
-
-:auto-join-after-registration -- List of channels to join
- immediately after registration with the server
-
-:auto-join-after-host-hiding -- List of channels to join
- after our host was hidden
-
-:auto-join-after-nick-acquisition -- List of channels to join
- after we gained our desired nick
-
-:auto-join-after-nickserv-identification -- List of channels
- to join after we identified successfully with NickServ"
- (irc-handler-add table "irc.registered" #'irc-handle-auto-join--registered)
- (irc-handler-add table "396" ;; RPL_HOSTHIDDEN
- #'irc-handle-auto-join--rpl-hosthidden)
- (irc-handler-add table "nickserv.regained"
- #'irc-handle-auto-join--nickserv-regained)
- (irc-handler-add table "nickserv.identified"
- #'irc-handle-auto-join--nickserv-identified)
- (irc-handler-add table "sasl.login"
- #'irc-handle-auto-join--sasl-login))
-
-(defun irc-handle-auto-join--registered (conn _event _current-nick)
- (dolist (channel (irc-connection-get conn :auto-join-after-registration))
- (irc-send-JOIN conn channel)))
-
-(defun irc-handle-auto-join--rpl-hosthidden (conn _event _sender _target _host
- _description)
- (dolist (channel (irc-connection-get conn :auto-join-after-host-hiding))
- (irc-send-JOIN conn channel)))
-
-(defun irc-handle-auto-join--nickserv-regained (conn _event)
- (dolist (channel (irc-connection-get
- conn :auto-join-after-nick-acquisition))
- (irc-send-JOIN conn channel)))
-
-(defun irc-handle-auto-join--nickserv-identified (conn event)
- (dolist (channel (irc-connection-get
- conn :auto-join-after-nickserv-identification))
- (irc-send-JOIN conn channel))
- (if (irc-string-equal-p conn
- (irc-connection-get conn :nick)
- (irc-connection-get conn :nickserv-nick))
- (irc-handle-auto-join--nickserv-regained conn event)))
-
-(defun irc-handle-auto-join--sasl-login (conn _event &rest ignored)
- (dolist (channel (irc-connection-get
- conn :auto-join-after-sasl-login))
- (irc-send-JOIN conn channel)))
-
-(provide 'irc)
-;;; irc.el ends here
+++ /dev/null
-;;; lcs.el --- find out the longest common sequence
-
-;; Copyright (c) 2002-2003 by Alex Shinn, All rights reserved.
-;; Copyright (c) 2002-2003 by Shiro Kawai, All rights reserved.
-;; Copyright (c) 2006, 2012 by Jorgen Schaefer, All rights reserved.
-
-;; Authors: Alex Shinn, Shiro Kawai
-;; Maintainer: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-;; URL: https://github.com/jorgenschaefer/circe/wiki/lcs
-
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions
-;; are met:
-
-;; 1. Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-
-;; 2. Redistributions in binary form must reproduce the above copyright
-;; notice, this list of conditions and the following disclaimer in the
-;; documentation and/or other materials provided with the distribution.
-
-;; 3. Neither the name of the authors nor the names of its contributors
-;; may be used to endorse or promote products derived from this
-;; software without specific prior written permission.
-
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
-;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-;;; Commentary:
-
-;; lcs.el is a library for other Emacs Lisp programs not useful by
-;; itself.
-
-;; This library provides functions to find the Longest Common Sequence
-;; (LCS) of two sequences. This is used to create a unified diff of to
-;; two lists. See `lcs-unified-diff' for a useful function to be
-;; called.
-
-;; The code is more or less a literal translation of (part of)
-;; Gauche's util/lcs.scm module to Emacs Lisp.
-
-;;; Code:
-
-(put 'lcs-for 'lisp-indent-function 4)
-(defmacro lcs-for (var from to step &rest body)
- "A simple FOR loop macro.
-Count VAR from FROM to TO by stepsize STEP. Evaluate BODY in each
-iteration."
- (let ((sto (make-symbol "to"))
- (sstep (make-symbol "step")))
- `(let ((,var ,from)
- (,sto ,to)
- (,sstep ,step))
- (while (<= ,var ,sto)
- (progn
- ,@body)
- (setq ,var (+ ,var ,sstep))))))
-
-(defun lcs-split-at (lis pos)
- "Return a cons cell of the first POS elements of LIS and the rest."
- (let ((head nil))
- (while (> pos 0)
- (setq head (cons (car lis)
- head)
- pos (- pos 1)
- lis (cdr lis)))
- (cons (reverse head)
- lis)))
-
-(defun lcs-finish (M+N V_l vl V_r vr)
- "Finalize the LCS algorithm.
-Should be used only by `lcs-with-positions'."
- (let ((maxl 0)
- (r '()))
- (lcs-for i (- M+N) M+N 1
- (when (> (funcall vl i)
- maxl)
- (setq maxl (funcall vl i)
- r (funcall vr i))))
- (list maxl (reverse r))))
-
-(defun lcs-with-positions (a-ls b-ls &optional equalp)
- "Return the longest common subsequence (LCS) of A-LS and B-LS.
-EQUALP can be any procedure which returns non-nil when two
-elements should be considered equal."
- (let* ((A (vconcat a-ls))
- (B (vconcat b-ls))
- (N (length A))
- (M (length B))
- (M+N (+ M N))
- (V_d (make-vector (+ 1 (* 2 M+N))
- 0))
- (V_r (make-vector (+ 1 (* 2 M+N))
- nil))
- (V_l (make-vector (+ 1 (* 2 M+N))
- 0))
- (vd (lambda (i &optional x)
- (if x
- (aset V_d (+ i M+N) x)
- (aref V_d (+ i M+N)))))
- (vr (lambda (i &optional x)
- (if x
- (aset V_r (+ i M+N) x)
- (aref V_r (+ i M+N)))))
- (vl (lambda (i &optional x)
- (if x
- (aset V_l (+ i M+N) x)
- (aref V_l (+ i M+N))))))
- (when (not equalp)
- (setq equalp 'equal))
- (catch 'return
- (if (= M+N 0)
- (throw 'return '(0 ()))
- (lcs-for d 0 M+N 1
- (lcs-for k (- d) d 2
- (let ((x nil)
- (y nil)
- (l nil)
- (r nil))
- (if (or (= k (- d))
- (and (not (= k d))
- (< (funcall vd (- k 1))
- (funcall vd (+ k 1)))))
- (setq x (funcall vd (+ k 1))
- l (funcall vl (+ k 1))
- r (funcall vr (+ k 1)))
- (setq x (+ 1 (funcall vd (- k 1)))
- l (funcall vl (- k 1))
- r (funcall vr (- k 1))))
- (setq y (- x k))
- (while (and (< x N)
- (< y M)
- (funcall equalp (aref A x) (aref B y)))
- (setq r (cons (list (aref A x) x y)
- r)
- x (+ x 1)
- y (+ y 1)
- l (+ l 1)))
- (funcall vd k x)
- (funcall vr k r)
- (funcall vl k l)
- (when (and (>= x N)
- (>= y M))
- (throw 'return(lcs-finish M+N V_l vl V_r vr)))))))
- (error "Can't happen"))))
-
-(defun lcs-unified-diff (a b &optional equalp)
- "Return a unified diff of the lists A and B.
-EQUALP should can be a procedure that returns non-nil when two
-elements of A and B should be considered equal. It's `equal' by
-default."
- (let ((common (cadr (lcs-with-positions a b equalp)))
- (a a)
- (a-pos 0)
- (b b)
- (b-pos 0)
- (diff '()))
- (while common
- (let* ((elt (car common))
- (a-off (nth 1 elt))
- (a-skip (- a-off a-pos))
- (b-off (nth 2 elt))
- (b-skip (- b-off b-pos))
- (a-split (lcs-split-at a a-skip))
- (a-head (car a-split))
- (a-tail (cdr a-split))
- (b-split (lcs-split-at b b-skip))
- (b-head (car b-split))
- (b-tail (cdr b-split)))
- (setq diff (append diff
- (mapcar (lambda (a)
- `(- ,a))
- a-head)
- (mapcar (lambda (b)
- `(+ ,b))
- b-head)
- `((! ,(car elt))))
-
- common (cdr common)
- a (cdr a-tail)
- a-pos (+ a-off 1)
- b (cdr b-tail)
- b-pos (+ b-off 1))))
- (append diff
- (mapcar (lambda (a)
- `(- ,a))
- a)
- (mapcar (lambda (b)
- `(+ ,b))
- b))))
-
-(provide 'lcs)
-;;; lcs.el ends here
+++ /dev/null
-;;; lui-autopaste.el --- Extension for lui for long text input
-
-;; Copyright (C) 2012 Jorgen Schaefer <forcerNOSPAMforcix.cx>
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-
-;; This file is part of Lui.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This extension for lui will intercept long input and replace it by
-;; an URL to a paste service.
-
-;; What is considered "long" is defined by `lui-autopaste-lines'. You
-;; can configure which paste service to use by changing
-;; `lui-autopaste-function'.
-
-;; Run `enable-lui-autopaste' to enable this.
-
-;;; Code:
-
-(defgroup lui-autopaste nil
- "The Lui autopaste extension."
- :prefix "lui-autopaste-"
- :group 'lui)
-
-(defcustom lui-autopaste-lines 3
- "Starting at this number of lines, Lui will ask to paste the input."
- :type 'integer
- :group 'lui-autopaste)
-
-(defcustom lui-autopaste-function 'lui-autopaste-service-ixio
- "Which paste service to use.
-
-This function will be called with some text as its only argument,
-and is expected to return an URL to view the contents."
- :type '(choice (const :tag "ix.io" lui-autopaste-service-ixio)
- (const :tag "ptpb.pw" lui-autopaste-service-ptpb-pw))
- :group 'lui-autopaste)
-
-;;;###autoload
-(defun enable-lui-autopaste ()
- "Enable the lui autopaste feature.
-
-If you enter more than `lui-autopaste-lines' at once, Lui will
-ask if you would prefer to use a paste service instead. If you
-agree, Lui will paste your input to `lui-autopaste-function' and
-replace it with the resulting URL."
- (interactive)
- (add-hook 'lui-pre-input-hook 'lui-autopaste))
-
-;;;###autoload
-(defun disable-lui-autopaste ()
- "Disable the lui autopaste feature."
- (interactive)
- (remove-hook 'lui-pre-input-hook 'lui-autopaste))
-
-(defun lui-autopaste ()
- "Check if the lui input is too large. If so, paste it instead."
- (when (and (>= (count-lines (point-min) (point-max))
- lui-autopaste-lines)
- (y-or-n-p "That's pretty long, would you like to use a paste service instead? "))
- (let ((url (funcall lui-autopaste-function
- (buffer-substring (point-min)
- (point-max)))))
- (delete-region (point-min) (point-max))
- (insert url))))
-
-(defun lui-autopaste-service-ptpb-pw (text)
- "Paste TEXT to ptpb.pw and return the paste url."
- (let ((url-request-method "POST")
- (url-request-extra-headers
- '(("Content-Type" . "application/x-www-form-urlencoded")))
- (url-request-data (format "c=%s" (url-hexify-string text)))
- (url-http-attempt-keepalives nil))
- (let ((buf (url-retrieve-synchronously "https://ptpb.pw/")))
- (unwind-protect
- (with-current-buffer buf
- (goto-char (point-min))
- (if (re-search-forward "^url: \\(.*\\)" nil t)
- (match-string 1)
- (error "Error during pasting to ptpb.pw")))
- (kill-buffer buf)))))
-
-(defun lui-autopaste-service-ixio (text)
- "Paste TEXT to ix.io and return the paste url."
- (let ((url-request-method "POST")
- (url-request-extra-headers
- '(("Content-Type" . "application/x-www-form-urlencoded")))
- (url-request-data (format "f:1=%s" (url-hexify-string text)))
- (url-http-attempt-keepalives nil))
- (let ((buf (url-retrieve-synchronously "http://ix.io/")))
- (unwind-protect
- (with-current-buffer buf
- (goto-char (point-min))
- (if (re-search-forward "\n\n" nil t)
- (buffer-substring (point) (point-at-eol))
- (error "Error during pasting to ix.io")))
- (kill-buffer buf)))))
-
-(provide 'lui-autopaste)
-;;; lui-autopaste.el ends here
+++ /dev/null
-;;; lui-format.el --- A formatting function for use with Lui
-
-;; Copyright (C) 2005, 2012 Jorgen Schaefer
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-
-;; This file is part of Lui.
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; An improved formatting function using named parameters.
-;;
-;; See the docstring of `lui-format' for more details.
-;;
-;; Most of the design is borrowed from Python's string.format.
-
-;;; Code:
-
-(require 'lui)
-
-(defun lui-display (format not-tracked-p &rest keywords)
- "Display a formatted string in the current Lui interface.
-
-The string is formatted using FORMAT and `lui-format'.
-
-If NOT-TRACKED-P is given, the inserted string won't trigger
-tracking. See `lui-insert' for a description.
-
-KEYWORDS are the keyword arguments passed to `lui-format'.
-
-See `lui-format' for a full description of the arguments."
- (lui-insert (lui-format format keywords)
- not-tracked-p))
-
-(defun lui-format (format &rest keywords)
- "Display FORMAT formatted with KEYWORDS.
-FORMAT should be a symbol whose value is taken. If the value is a
-procedure, the keyword list is passed as a single argument to it,
-and it should return the formatted string. If the value is a
-string, it is formatted according to the rules below.
-
-KEYWORDS is a plist of keywords and strings, or symbols and
-strings. They are used as format arguments.
-
-The string is taken verbatim, unless there is are opening or
-closing braces.
-
-Double opening or closing braces are replaced by single
-occurrences of those characters. Otherwise, the contents between
-opening and closing braces is a format description and replaced
-by a formatted string.
-
-The string between opening and closing braces is taken as a name
-of a keyword argument, and replaced by that argument's value. If
-there is a colon in the string, the keyword name is the part
-before the colon. The part after the colon is used to format the
-argument using standard `format'
-
-Example:
-
- (lui-format \"Hello {foo:.1f}\" :foo 3.1415)
-
-is equivalent to
-
- (format \"Hello %.1f\" 3.1415)
-
-If the name is either a number, a number followed by a dash, or
-two numbers with a dash in between them, this is taken as a
-special name that is looked up in the list given using the list
-argument to the :indexed-args keyword.
-
-{1} refers to the second element (element 1)
-{1-} refers to the second and all following elements
-{1-3} refers to the second through fourth element
-
-If more than one element is selected, the elements are separated
-by a single space character.
-
-All named arguments receive a property of `lui-format-argument'
-with the respective name as value. The whole string receives a
-`lui-format' property with FORMAT as a value, and a
-`lui-keywords' argument with KEYWORDS as a value."
- ;; If it's only a single argument, that argument is a list.
- (when (not (cdr keywords))
- (setq keywords (car keywords)))
- (cond
- ((functionp format)
- (apply format keywords))
- ((and (symbolp format)
- (functionp (symbol-value format)))
- (apply (symbol-value format) keywords))
- (t
- (let* ((format-string (if (symbolp format)
- (symbol-value format)
- format))
- (plist (mapcar (lambda (entry)
- (if (keywordp entry)
- ;; Keyword -> symbol
- (intern (substring (symbol-name entry)
- 1))
- entry))
- keywords)))
- (propertize (lui-format-internal format-string plist)
- 'lui-format format
- 'lui-keywords keywords)))))
-
-(defun lui-format-internal (fmt keywords)
- "Internal function for `lui-format'.
-
-FMT is the format string and KEYWORDS is the symbol-based plist.
-
-See `lui-format'."
- (with-temp-buffer
- (insert fmt)
- (goto-char (point-min))
- (while (re-search-forward "{{\\|}}\\|{\\([^}]*\\)}" nil t)
- (cond
- ((string-equal (match-string 0) "3.1")
- (replace-match "{"))
- ((string-equal (match-string 0) "}}")
- (replace-match "}"))
- (t ;; (match-string 1)
- (replace-match (save-match-data
- (lui-format-single (match-string 1) keywords))
- t t))))
- (buffer-string)))
-
-(defun lui-format-single (specifier keywords)
- "Format a single braced SPECIFIER according to KEYWORDS.
-See `lui-format' for details.
-
-This adds `lui-format-argument' as necessary."
- (let* ((split (split-string specifier ":"))
- (identifier (car split))
- (format (cadr split)))
- (when (not format)
- (setq format "s"))
- (propertize (format (concat "%" format)
- (lui-format-lookup identifier keywords))
- 'lui-format-argument (intern identifier))))
-
-(defun lui-format-lookup (identifier keywords)
- "Lookup the format IDENTIFIER in KEYWORDS.
-
-See `lui-format' for details."
- (cond
- ((string-match "^\\([0-9]+\\)\\(-\\([0-9]+\\)?\\)?$" identifier)
- (let ((from (match-string 1 identifier))
- (rangep (match-string 2 identifier))
- (to (match-string 3 identifier))
- (indexed-args (plist-get keywords 'indexed-args)))
- (if rangep
- (mapconcat (lambda (element)
- (if (stringp element)
- element
- (format "%s" element)))
- (lui-sublist indexed-args
- (string-to-number from)
- (when to (string-to-number to)))
- " ")
- (or (nth (string-to-number from)
- indexed-args)
- ""))))
- (t
- (or (plist-get keywords (intern identifier))
- (error "Unknown keyword argument %S" identifier)))))
-
-(defun lui-sublist (list from &optional to)
- "Return the sublist from LIST starting at FROM and ending at TO."
- (if (not to)
- (nthcdr from list)
- (let ((from-list (nthcdr from list))
- (i (- to from))
- (to-list nil))
- (while (>= i 0)
- (when (null from-list)
- (error "Argument out of range: %S" to))
- (setq to-list (cons (car from-list)
- to-list)
- i (- i 1)
- from-list (cdr from-list)))
- (nreverse to-list))))
-
-(provide 'lui-format)
-;;; lui-format.el ends here
+++ /dev/null
-;;; lui-irc-colors.el --- Add IRC color support to LUI
-
-;; Copyright (C) 2005 Jorgen Schaefer
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-
-;; This file is part of Lui.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This tells LUI how to display IRC colors:
-;; ^B - Bold
-;; ^_ - Underline
-;; ^V - Inverse
-;; ^] - Italic
-;; ^O - Return to normal
-;; ^C1,2 - Colors
-
-;; The colors are documented at http://www.mirc.co.uk/help/color.txt
-
-;;; Code:
-
-(require 'lui)
-
-(defgroup lui-irc-colors nil
- "LUI IRC colors faces."
- :group 'circe)
-
-(defface lui-irc-colors-inverse-face
- '((t (:inverse-video t)))
- "Face used for inverse video."
- :group 'lui-irc-colors)
-
-(defun lui-irc-defface (face property on-dark on-light rest doc)
- (custom-declare-face
- face
- `((((type graphic) (class color) (background dark))
- (,property ,on-dark))
- (((type graphic) (class color) (background light))
- (,property ,on-light))
- (t (,property ,rest)))
- doc
- :group 'lui-irc-colors))
-
-(defun lui-irc-defface-pair (number on-dark on-light rest name)
- (lui-irc-defface
- (intern (format "lui-irc-colors-fg-%d-face" number))
- :foreground
- on-dark on-light rest
- (concat "Face used for foreground IRC color "
- (number-to-string number) " (" name ")."))
- (lui-irc-defface
- (intern (format "lui-irc-colors-bg-%d-face" number))
- :background
- on-light on-dark rest
- (concat "Face used for background IRC color "
- (number-to-string number) " (" name ").")))
-
-(defun lui-irc-defface-bulk (colors)
- (dotimes (n (length colors))
- (apply 'lui-irc-defface-pair n (nth n colors))))
-
-(lui-irc-defface-bulk
- '(("#ffffff" "#585858" "white" "white")
- ("#a5a5a5" "#000000" "black" "black")
- ("#9b9bff" "#0000ff" "blue4" "blue")
- ("#40eb51" "#006600" "green4" "green")
- ("#ff9696" "#b60000" "red" "red")
- ("#d19999" "#8f3d3d" "red4" "brown")
- ("#d68fff" "#9c009c" "magenta4" "purple")
- ("#ffb812" "#7a4f00" "yellow4" "orange")
- ("#ffff00" "#5c5c00" "yellow" "yellow")
- ("#80ff95" "#286338" "green" "light green")
- ("#00b8b8" "#006078" "cyan4" "teal")
- ("#00ffff" "#006363" "cyan" "light cyan")
- ("#a8aeff" "#3f568c" "blue" "light blue")
- ("#ff8bff" "#853885" "magenta" "pink")
- ("#cfcfcf" "#171717" "dimgray" "grey")
- ("#e6e6e6" "#303030" "gray" "light grey")))
-
-(defvar lui-irc-colors-regex
- "\\(\x02\\|\x1F\\|\x16\\|\x1D\\|\x0F\\|\x03\\)"
- "A regular expression matching IRC control codes.")
-
-;;;###autoload
-(defun enable-lui-irc-colors ()
- "Enable IRC color interpretation for Lui."
- (interactive)
- (add-hook 'lui-pre-output-hook 'lui-irc-colors))
-
-(defun disable-lui-irc-colors ()
- "Disable IRC color interpretation for Lui."
- (interactive)
- (remove-hook 'lui-pre-output-hook 'lui-irc-colors))
-
-(defun lui-irc-colors ()
- "Add color faces for IRC colors.
-This is an appropriate function for `lui-pre-output-hook'."
- (goto-char (point-min))
- (let ((start (point))
- (boldp nil)
- (inversep nil)
- (italicp nil)
- (underlinep nil)
- (fg nil)
- (bg nil))
- (while (re-search-forward lui-irc-colors-regex nil t)
- (lui-irc-propertize start (point)
- boldp inversep italicp underlinep
- fg bg)
- (let ((code (match-string 1)))
- (replace-match "")
- (setq start (point))
- (cond
- ((string= code "\ 2")
- (setq boldp (not boldp)))
- ((string= code "\16")
- (setq inversep (not inversep)))
- ((string= code "\1d")
- (setq italicp (not italicp)))
- ((string= code "\1f")
- (setq underlinep (not underlinep)))
- ((string= code "\ f")
- (setq boldp nil
- inversep nil
- italicp nil
- underlinep nil
- fg nil
- bg nil))
- ((string= code "\ 3")
- (if (looking-at "\\([0-9][0-9]?\\)\\(,\\([0-9][0-9]?\\)\\)?")
- (progn
- (setq fg (string-to-number (match-string 1))
- bg (if (match-string 2)
- (string-to-number (match-string 3))
- bg))
- (setq fg (if (and fg (not (= fg 99))) (mod fg 16) nil)
- bg (if (and bg (not (= bg 99))) (mod bg 16) nil))
- (replace-match ""))
- (setq fg nil
- bg nil)))
- (t
- (error "lui-irc-colors: Can't happen!")))))
- (lui-irc-propertize (point) (point-max)
- boldp inversep italicp underlinep fg bg)))
-
-(defun lui-irc-propertize (start end boldp inversep italicp underlinep fg bg)
- "Propertize the region between START and END."
- (let ((faces (append (and boldp '(bold))
- (and inversep '(lui-irc-colors-inverse-face))
- (and italicp '(italic))
- (and underlinep '(underline))
- (and fg (list (lui-irc-colors-face 'fg fg)))
- (and bg (list (lui-irc-colors-face 'bg bg))))))
- (when faces
- (add-face-text-property start end faces))))
-
-(defun lui-irc-colors-face (type n)
- "Return a face appropriate for face number N.
-TYPE is either 'fg or 'bg."
- (if (and (<= 0 n)
- (<= n 15))
- (intern (format "lui-irc-colors-%s-%s-face" type n))
- 'default-face))
-
-(provide 'lui-irc-colors)
-;;; lui-irc-colors.el ends here
+++ /dev/null
-;;; lui-logging.el --- Logging support for lui
-
-;; Copyright (C) 2006 Jorgen Schaefer,
-;; 2012 Anthony Martinez
-
-;; Author: Anthony Martinez <pi+circeNOSPAMpihost.us>
-
-;; This file is part of Lui.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This lui module enables logging. Lui applications can change the
-;; values of `lui-logging-format-arguments' to provide further
-;; possibilities of customizing `lui-logging-file-format' for users.
-
-;;; Code:
-
-(require 'lui-format)
-(require 'url-util)
-
-(defgroup lui-logging nil
- "Logging support."
- :prefix "lui-logging-"
- :group 'lui)
-
-(defcustom lui-logging-format "[%T] {text}"
- "The format used for log file entries.
-This is first passed through `format-time-string' and then through
-`lui-format'. The following format strings exist:
-
- {text} - the text to be logged"
- :type 'string
- :group 'lui-logging)
-
-(defcustom lui-logging-directory "~/.logs"
- "The directory where log files are stored."
- :type 'directory
- :group 'lui-logging)
-
-(defcustom lui-logging-file-format "{buffer}_%Y-%m-%d.txt"
- "The format to be used for the log file name.
-This is first passed through `format-time-string', and then
-through `lui-format'. Possible lui format strings are:
-
- {buffer} - the buffer name where the logging happened.
-
-Lui applications can provide further format strings. See
-`lui-logging-format-arguments' in the appropriate buffer."
- :type 'string
- :group 'lui-logging)
-
-(defcustom lui-logging-flush-delay 0
- "The number of seconds to delay writing newly-received messages
-to disk. This can increase performance/decrease IO-wait at the
-cost of a little bit of safety."
- :type 'integer
- :group 'lui-logging)
-
-(defvar lui-logging-format-arguments nil
- "A list of arguments to be passed to `lui-format'.
-This can be used to extend the formatting possibilities of the
-file name for lui applications.")
-(make-variable-buffer-local 'lui-logging-format-arguments)
-
-(defvar lui-logging-file-name-unreserved-chars
- ;; All but '/' is fine actually, but also omit '%' because otherwise there's
- ;; ambiguity between one introduced by encoding and a literal one.
- '(?! ?\" ?# ?$ ?& ?` ?\( ?\) ?* ?+ ?,?: ?\; ?< ?= ?> ?? ?@?\[ ?\\ ?\] ?^ ?`
- ?\{ ?| ?\})
- "A list of characters that should not be percent-encoded by
-`url-hexify-string' while generating a logging file name.")
-
-(defvar lui-pending-logs
- (make-hash-table :test 'equal)
- "Storage for log messages awaiting write. It is structured as a
-hash table mapping filenames to a list-of-strings, which serves as
-a queue.")
-
-(defvar lui-logging-timer nil
- "The timer used to flush lui-logged buffers")
-
-(defun lui-logging-delayed-p ()
- (> lui-logging-flush-delay 0))
-
-(defun enable-lui-logging ()
- "Enable lui logging for this buffer. Also create the log
-file's directory, should it not exist."
- (interactive)
- (add-hook 'lui-pre-output-hook 'lui-logging
- nil t))
-
-(defun disable-lui-logging ()
- "Disable lui logging for this buffer, and flush any pending
-logs to disk."
- (interactive)
- (remove-hook 'lui-pre-output-hook 'lui-logging t)
- (lui-logging-flush))
-
-(defun enable-lui-logging-globally ()
- "Enable lui logging for all Lui buffers.
-
-This affects current as well as future buffers."
- (interactive)
- (add-hook 'lui-mode-hook 'enable-lui-logging)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when lui-input-marker
- (enable-lui-logging)))))
-
-(defun disable-lui-logging-globally ()
- "Disable logging in all future Lui buffers.
-
-This affects current as well as future buffers."
- (interactive)
- (remove-hook 'lui-mode-hook 'enable-lui-logging)
- (dolist (buf (buffer-list))
- (with-current-buffer buf
- (when lui-input-marker
- (disable-lui-logging)))))
-
-(defun lui-logging-file-name ()
- "Create the name of the log file based on `lui-logging-file-format'."
- (let* ((time-formatted (format-time-string lui-logging-file-format))
- (buffer (let ((url-unreserved-chars
- (append url-unreserved-chars
- lui-logging-file-name-unreserved-chars))
- (downcased (downcase (buffer-name (current-buffer)))))
- (url-hexify-string downcased)))
- (filename (apply 'lui-format
- time-formatted
- :buffer buffer
- lui-logging-format-arguments)))
- (concat lui-logging-directory "/" filename)))
-
-(defun lui-logging-flush ()
- "Flush out the lui-logging queue, and clear the timer set by
-`lui-logging'."
- (maphash #'lui-logging-flush-file lui-pending-logs)
- (clrhash lui-pending-logs)
- (cancel-timer lui-logging-timer)
- (setq lui-logging-timer nil))
-
-(defun lui-logging-write-to-log (file-name content)
- "Actually perform a write to the logfile."
- (let ((coding-system-for-write 'raw-text)
- (dir (file-name-directory file-name)))
- (when (not (file-directory-p dir))
- (make-directory dir t))
- (write-region content nil file-name t 'nomessage)))
-
-(defun lui-logging-flush-file (file-name queue)
- "Consume the logging queue and write the content to the log
-file."
- (let ((content (apply #'concat (nreverse queue))))
- (lui-logging-write-to-log file-name content)))
-
-(defun lui-logging-format-string (text)
- "Generate a string to be either directly written or enqueued."
- (substring-no-properties
- (lui-format
- (format-time-string lui-logging-format)
- :text text)))
-
-(defun lui-logging-enqueue (file-name text)
- "Given a filename, push text onto its queue, and tickle the
-timer, if necessary."
- (puthash file-name
- (cons text (gethash file-name lui-pending-logs))
- lui-pending-logs)
- (when (null lui-logging-timer)
- (setq lui-logging-timer
- (run-with-timer lui-logging-flush-delay nil
- #'lui-logging-flush))))
-
-(defun lui-logging ()
- "If output-queueing is enabled, append the to-be-logged string
-to the output queue. Otherwise, write directly to the logfile.
-This should be added to `lui-pre-output-hook' by way of
-`enable-lui-logging'."
- (let ((text (lui-logging-format-string (buffer-string))))
- (if (lui-logging-delayed-p)
- (lui-logging-enqueue (lui-logging-file-name) text)
- (lui-logging-write-to-log (lui-logging-file-name) text))))
-
-(provide 'lui-logging)
-;;; lui-logging.el ends here
+++ /dev/null
-;;; lui-track-bar.el --- Provides a bar to track the last read position
-
-;; Copyright (C) 2016 Vasilij Schneidermann <v.schneidermannNOSPAMgmail.com>
-
-;; Author: Vasilij Schneidermann <v.schneidermannNOSPAMgmail.com>
-
-;; This file is part of LUI.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Commentary:
-
-;; This allows you to track where you've last left off a buffer.
-
-;; Use (enable-lui-track-bar) to enable this mode globally. You can
-;; customize `lui-track-bar-behavior' to change when the track bar
-;; moves. You can also use M-x lui-track-bar-move to move the track
-;; bar manually.
-
-;;; Code:
-
-(require 'lui)
-(require 'tracking)
-
-(defgroup lui-track-bar nil
- "Last read position tracking for LUI"
- :prefix "lui-track-bar-"
- :group 'lui)
-
-(defcustom lui-track-bar-behavior 'before-switch-to-buffer
- "When to move the track bar.
-
-The following values are possible.
-
-before-switch-to-buffer (default)
- Move the bar to the bottom of the buffer when switching away
- from a buffer.
-
-before-tracking-next-buffer
- Move the bar when switching to the next buffer using
- \\[tracking-next-buffer].
-
-after-send
- Move the bar after sending a message."
- :type '(choice (const :tag "Before switching buffers"
- before-switch-to-buffer)
- (const :tag "Before tracking switch"
- before-tracking-next-buffer)
- (const :tag "After sending"
- after-send))
- :group 'lui-track-bar)
-
-(defface lui-track-bar
- '((((type graphic) (background light))
- :inherit default :background "dim gray" :height 0.1)
- (((type graphic) (background dark))
- :inherit default :background "light gray" :height 0.1)
- (((type tty))
- :inherit (font-lock-comment-face default) :underline t))
- "Track bar face"
- :group 'lui-track-bar)
-
-(defvar lui-track-bar-overlay nil)
-(make-variable-buffer-local 'lui-track-bar-overlay)
-
-;;;###autoload
-(defun enable-lui-track-bar ()
- "Enable a bar in Lui buffers that shows where you stopped reading."
- (interactive)
- (defadvice switch-to-buffer (before lui-track-bar activate)
- (when (and (eq lui-track-bar-behavior 'before-switch-to-buffer)
- ;; Do not move the bar if the buffer is displayed still
- (<= (length (get-buffer-window-list (current-buffer)))
- 1))
- (lui-track-bar-move)))
- (defadvice tracking-next-buffer (before lui-track-bar activate)
- (when (eq lui-track-bar-behavior 'before-tracking-next-buffer)
- (lui-track-bar-move)))
- (add-hook 'lui-pre-input-hook 'lui-track-bar--move-pre-input))
-
-(defun lui-track-bar--move-pre-input ()
- (when (eq lui-track-bar-behavior 'after-send)
- (lui-track-bar-move)))
-
-(defun lui-track-bar-move ()
- "Move the track bar down."
- (interactive)
- (when (derived-mode-p 'lui-mode)
- (when (not lui-track-bar-overlay)
- (setq lui-track-bar-overlay (make-overlay (point-min) (point-min)))
- (overlay-put lui-track-bar-overlay 'after-string
- (propertize "\n" 'face 'lui-track-bar)))
- (move-overlay lui-track-bar-overlay
- lui-output-marker lui-output-marker)))
-
-(provide 'lui-track-bar)
-;;; lui-track-bar.el ends here
+++ /dev/null
-;;; lui.el --- Linewise User Interface -*- lexical-binding: t -*-
-
-;; Copyright (C) 2005 - 2016 Jorgen Schaefer
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-;; URL: https://github.com/jorgenschaefer/circe/wiki/Lui
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Lui is a library for other Emacs Lisp programs and not useful by
-;; itself.
-
-;; This major mode provides a user interface for applications. The
-;; user interface is quite simple, consisting of an input line, a
-;; prompt, and some output area, but Lui includes a lot of common
-;; options, such as time stamps, filling, colorization, etc.
-
-;; Application programs should create modes derived from lui-mode.
-
-;; The application API consists of:
-
-;; lui-mode
-;; lui-set-prompt
-;; lui-insert
-;; lui-input-function
-;; lui-completion-function
-;; lui-time-stamp-time
-;; lui-time-stamp-zone
-;; and the 'lui-fool and 'lui-do-not-track text properties
-
-;;; Code:
-
-(require 'button)
-(require 'flyspell)
-(require 'help-mode)
-(require 'ispell)
-(require 'paren)
-(require 'ring)
-(require 'thingatpt)
-(require 'rx)
-
-(require 'tracking)
-
-\f
-;;;;;;;;;;;;;;;;;;;;;
-;;; Customization ;;;
-;;;;;;;;;;;;;;;;;;;;;
-
-(defgroup lui nil
- "The Linewise User Interface."
- :prefix "lui-"
- :group 'applications)
-
-(defcustom lui-scroll-behavior t
- "Set the behavior lui should exhibit for scrolling.
-
-The following values are possible. If in doubt, use post-output.
-
-nil
- Use default Emacs scrolling.
-
-post-command
- Keep the input line at the end of the window if point is
- after the input mark.
-
-post-output
- Keep the input line at the end of the window only after output.
-
-t
- Combine both post-command and post-output.
-
-post-scroll
- Keep the input line at the end of the window on every scroll
- event. Careful, this might interact badly with other functions
- on `window-scroll-functions'.
-
-
-It would be entirely sensible for Emacs to provide a setting to
-do this kind of scrolling by default in a buffer. It seems rather
-intuitive and sensible. But as noted on emacs-devel:
-
- [T]hose who know the code know that it's going to be a pain to
- implement, especially if you want acceptable performance. IOW,
- patches welcome
-
-The full discussion can be found here:
-
-https://lists.gnu.org/archive/html/emacs-devel/2012-10/msg00652.html
-
-These settings are all hacks that try to give the user the choice
-between most correct behavior (post-scroll) and most compliant
-behavior (post-output)."
- :type '(choice (const :tag "Post Command" t)
- (const :tag "Post Output" post-output)
- (const :tag "Post Scroll" post-scroll)
- (const :tag "Use default scrolling" nil))
- :group 'lui)
-(defvaralias 'lui-scroll-to-bottom-p 'lui-scroll-behavior)
-
-(defcustom lui-flyspell-p nil
- "Non-nil if Lui should spell-check your input.
-See the function `flyspell-mode' for more information."
- :type 'boolean
- :group 'lui)
-
-(defcustom lui-flyspell-alist nil
- "Alist of buffer dictionaries.
-
-This is a list of mappings from buffers to dictionaries to use
-for the function `flyspell-mode'. The appropriate dictionary is
-automatically used when Lui is activated in a buffer with a
-matching buffer name.
-
-The entries are of the form (REGEXP DICTIONARY), where REGEXP
-must match a buffer name, and DICTIONARY specifies an existing
-dictionary for the function `flyspell-mode'. See
-`ispell-local-dictionary-alist' and `ispell-dictionary-alist' for
-a valid list of dictionaries."
- :type 'string
- :group 'lui)
-
-(defcustom lui-highlight-keywords nil
- "A list of keywords to highlight.
-
-This specifies a list of keywords that Lui should highlight. Each
-entry is of one of the following forms (similar to
-`font-lock-keywords'):
-
- REGEXP
- Highlight every match in `lui-highlight-face'
- (REGEXP SUBMATCH)
- Highlight the SUBMATCH (a number) in REGEXP in
- `lui-highlight-face'
- (REGEXP FACE)
- Highlight everything matching REGEXP in FACE (a symbol)
- (REGEXP SUBMATCH FACE)
- Highlight the SUBMATCH in REGEXP in FACE
-
-In all of these cases, the FACE can also be a property list which
-is then associated with the match.
-
-All matches are run, which means later matches can override
-changes by earlier ones."
- :type '(repeat (choice
- (string :tag "Regular Expression")
- (list :tag "Submatch"
- (string :tag "Regular Expression")
- (integer :tag "Submatch"))
- (list :tag "Regular Expression in Specific Face"
- (string :tag "Regular Expression")
- (face :tag "Face"))
- (list :tag "Submatch in Specific Face"
- (string :tag "Regular Expression")
- (integer :tag "Submatch")
- (face :tag "Face"))))
- :group 'lui)
-
-(defface lui-strong-face
- '((t (:inherit bold)))
- "Face used for strong markup."
- :group 'lui-irc-colors)
-
-(defface lui-emphasis-face
- '((t (:inherit italic)))
- "Face for emphasis markup."
- :group 'lui-irc-colors)
-
-(defcustom lui-formatting-list nil
- "List of enabled formatting types.
-Each list item is a list consisting of a regular expression
-matching the highlighted text, an integer for the submatch and a
-face for highlighting the match."
- :type `(set
- (const :tag "*Strong* text"
- (,(rx (or bol whitespace)
- (group "*" (+? (not (any whitespace "*"))) "*")
- (or eol whitespace))
- 1 lui-strong-face))
- (const :tag "_Emphasized_ text"
- (,(rx (or bol whitespace)
- (group "_" (+? (not (any whitespace "_"))) "_")
- (or eol whitespace))
- 1 lui-emphasis-face)))
- :group 'lui)
-
-(defcustom lui-buttons-list
- `(("`\\([A-Za-z0-9+=*/-]+\\)'" 1
- lui-button-elisp-symbol 1)
- ("\\<debbugs[#:]\\([0-9]+\\)" 0
- "https://debbugs.gnu.org/cgi/bugreport.cgi?bug=%s" 1)
- ("\\<RFC ?\\([0-9]+\\)" 0
- "http://www.ietf.org/rfc/rfc%s.txt" 1)
- ("\\<CVE[- ]\\([0-9]+-[0-9]+\\)" 0
- "https://cve.mitre.org/cgi-bin/cvename.cgi?name=CVE-%s" 1)
- ("\\<SRFI[- ]?\\([0-9]+\\)" 0
- "http://srfi.schemers.org/srfi-%s/srfi-%s.html" 1 1)
- ("\\<PEP[- ]?\\([0-9]+\\)" 0 lui-button-pep 1)
- ("\\<xkcd[ #]*\\([0-9]+\\)" 0
- "https://xkcd.com/%s" 1)
- ("\\([0-9a-zA-Z_.-]+/[0-9a-zA-Z_.-]+\\)#\\([0-9]+\\)" 0
- "https://github.com/%s/issues/%s" 1 2))
- "The list of buttons to buttonize.
-This consists of lists of four elements each:
-
- (REGEXP SUBMATCH FUNCTION ARG-MATCH...)
-
-Whenever REGEXP is found, SUBMATCH is marked as a button. When
-that button is activated, FUNCTION is called with the matches
-specified in ARG-MATCHES as its arguments.
-
-If FUNCTION is a string, it is formatted with %s replaced by
-the matches in ARG-MATCHES."
- :type '(repeat (list (regexp :tag "Regular expression")
- (integer :tag "Submatch to buttonize")
- (function :tag "Function to call for this button")
- (integer :tag "Submatch to pass as an argument")))
- :group 'lui)
-
-(defcustom lui-button-issue-tracker nil
- "A tracker URL for the current channel.
-
-This will cause simple #123 links to highlight as issue links to
-the given repository. Use %s to insert the actual number."
- :type 'string
- :group 'lui)
-
-(defcustom lui-fill-type " "
- "How Lui should fill its output.
-This can be one of the following values:
-
- A string
- This is used as the fill prefix
- 'variable
- The first sequence of non-whitespace characters in the
- output is used as an alignment, and the rest is filled with
- spaces.
- A number
- The first sequence of non-whitespace characters is
- right-aligned at this column, and the rest is filled to
- this column.
- nil
- Turn filling off."
- :type '(choice (string :tag "Fill Prefix")
- (const :tag "Variable Fill Prefix" variable)
- (integer :tag "Fill Column")
- (const :tag "No filling" nil))
- :group 'lui)
-
-(defcustom lui-fill-column 70
- "The column at which Lui should break output.
-See `fill-column'."
- :type 'integer
- :group 'lui)
-
-(defcustom lui-fill-remove-face-from-newline t
- "Non-nil when filling should remove faces from newlines.
-Faces on a newline extend to the end of the displayed line, which
-is often not was is wanted."
- :type 'boolean
- :group 'lui)
-
-(defcustom lui-time-stamp-format "[%H:%M]"
- "The format of time stamps.
-See `format-time-string' for a full description of available
-formatting directives."
- :type 'string
- :group 'lui)
-
-(defcustom lui-time-stamp-position 'right
- "Where Lui should put time-stamps.
-This can be one of the following values:
-
- A number
- At this column of the first line of output
- 'right
- At a column just right to `lui-fill-column'
- 'left
- At the left side of the output. The output is thereby moved
- to the right.
- 'right-margin
- In the right margin. You will need to set `right-margin-width'
- in all circe buffers.
- 'left-margin
- In the left margin. You will need to set `left-margin-width'
- in all circe buffers.
- nil
- Do not add any time stamp."
- :type '(choice (const :tag "Right" right)
- (integer :tag "Column")
- (const :tag "Left" left)
- (const :tag "Right Margin" right-margin)
- (const :tag "Left Margin" left-margin)
- (const :tag "None" nil))
- :group 'lui)
-
-(defcustom lui-time-stamp-only-when-changed-p t
- "Non-nil if Lui should only add a time stamp when the time changes.
-If `lui-time-stamp-position' is 'left, this will still add the
-necessary whitespace."
- :type 'boolean
- :group 'lui)
-
-(defcustom lui-read-only-output-p t
- "Non-nil if Lui should make the output read-only.
-Switching this off makes copying (by killing) easier for some."
- :type 'boolean
- :group 'lui)
-
-(defcustom lui-max-buffer-size 102400
- "Non-nil if Lui should truncate the buffer if it grows too much.
-If the buffer size (in characters) exceeds this number, it is
-truncated at the top."
- :type '(choice (const :tag "Never Truncate" nil)
- (integer :tag "Maximum Buffer Size"))
- :group 'lui)
-
-(defcustom lui-input-ring-size 32
- "The size of the input history of Lui.
-This is the size of the input history used by
-\\[lui-previous-input] and \\[lui-next-input]."
- :type 'integer
- :group 'lui)
-
-(defcustom lui-mode-hook nil
- "The hook run when Lui is started."
- :type 'hook
- :group 'lui)
-
-(defcustom lui-pre-input-hook nil
- "A hook run before Lui interprets the user input.
-It is called with the buffer narrowed to the input line.
-Functions can modify the input if they really want to, but the
-user won't see the modifications, so that's a bad idea."
- :type 'hook
- :group 'lui)
-
-(defcustom lui-pre-output-hook nil
- "The hook run before output is formatted."
- :type 'hook
- :group 'lui)
-
-(defcustom lui-post-output-hook nil
- "The hook run after output has been formatted."
- :type 'hook
- :group 'lui)
-
-(defface lui-time-stamp-face
- '((t (:foreground "SlateBlue" :weight bold)))
- "Lui mode face used for time stamps."
- :group 'lui)
-
-(defface lui-highlight-face
- ;; Taken from `font-lock-keyword-face'
- '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold))
- (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
- (((class color) (background light)) (:foreground "Purple"))
- (((class color) (background dark)) (:foreground "Cyan1"))
- (t (:weight bold)))
- "Lui mode face used for highlighting."
- :group 'lui)
-
-(defface lui-button-face
- '((((class color) (background light)) (:foreground "Purple" :underline t))
- (((class color) (background dark)) (:foreground "Cyan" :underline t))
- (t (:underline t)))
- "Default face used for LUI buttons."
- :group 'lui)
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Client interface ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar lui-input-function nil
- "The function to be called for Lui input.
-This function is called with a single argument, the input
-string.")
-(make-variable-buffer-local 'lui-input-function)
-
-(defvar lui-completion-function 'completion-at-point
- "A function called to actually do completion.")
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Private variables ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar lui-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "RET") 'lui-send-input)
- (define-key map (kbd "TAB") 'lui-next-button-or-complete)
- (define-key map (kbd "<backtab>") 'lui-previous-button)
- (define-key map (kbd "<S-tab>") 'lui-previous-button)
- (define-key map (kbd "M-p") 'lui-previous-input)
- (define-key map (kbd "M-n") 'lui-next-input)
- (define-key map (kbd "C-c C-u") 'lui-kill-to-beginning-of-line)
- (define-key map (kbd "C-c C-i") 'lui-fool-toggle-display)
- map)
- "The key map used in Lui modes.")
-
-(defvar lui-input-marker nil
- "The marker where input should be inserted.")
-(make-variable-buffer-local 'lui-input-marker)
-
-(defvar lui-output-marker nil
- "The marker where output should be inserted.
-Use `lui-insert' instead of accessing this marker directly.")
-(make-variable-buffer-local 'lui-output-marker)
-
-(defvar lui-input-ring nil
- "The input history ring.")
-(make-variable-buffer-local 'lui-input-ring)
-
-(defvar lui-input-ring-index nil
- "The index to the current item in the input ring.")
-(make-variable-buffer-local 'lui-input-ring-index)
-
-\f
-;;;;;;;;;;;;;;
-;;; Macros ;;;
-;;;;;;;;;;;;;;
-
-(defmacro lui-save-undo-list (&rest body)
- "Run BODY without modifying the undo list."
- (let ((old-marker-sym (make-symbol "old-marker")))
- `(let ((,old-marker-sym (marker-position lui-input-marker))
- (val nil))
- ;; Don't modify the undo list. The undo list is for the user's
- ;; input only.
- (let ((buffer-undo-list t))
- (setq val (progn ,@body)))
- (when (consp buffer-undo-list)
- ;; Not t :-)
- (setq buffer-undo-list (lui-adjust-undo-list buffer-undo-list
- ,old-marker-sym
- (- lui-input-marker
- ,old-marker-sym))))
- val)))
-
-\f
-;;;;;;;;;;;;;;;;;;
-;;; Major Mode ;;;
-;;;;;;;;;;;;;;;;;;
-
-(define-derived-mode lui-mode nil "LUI"
- "The Linewise User Interface mode.
-This can be used as a user interface for various applications.
-Those should define derived modes of this, so this function
-should never be called directly.
-
-It can be customized for an application by specifying a
-`lui-input-function'."
- (setq lui-input-marker (make-marker)
- lui-output-marker (make-marker)
- lui-input-ring (make-ring lui-input-ring-size)
- lui-input-ring-index nil
- flyspell-generic-check-word-p 'lui-flyspell-check-word-p)
- (set-marker lui-input-marker (point-max))
- (set-marker lui-output-marker (point-max))
- (add-hook 'window-scroll-functions 'lui-scroll-window nil t)
- (add-hook 'post-command-hook 'lui-scroll-post-command)
- (add-hook 'change-major-mode-hook 'lui-change-major-mode nil t)
- (lui-paren-highlighting)
- (lui-time-stamp-enable-filtering)
- (tracking-mode 1)
- (auto-fill-mode 0)
- (when (fboundp 'cursor-intangible-mode)
- (cursor-intangible-mode 1))
- (when lui-flyspell-p
- (require 'flyspell)
- (lui-flyspell-change-dictionary)))
-
-(defun lui-change-major-mode ()
- "Assure that the user really wants to change the major mode.
-This is a good value for a buffer-local `change-major-mode-hook'."
- (when (not (y-or-n-p "Really change major mode in a Lui buffer? "))
- (error "User disallowed mode change")))
-
-(defun lui-scroll-window (window _display-start)
- "Scroll the input line to the bottom of the WINDOW.
-
-DISPLAY-START is passed by the hook `window-scroll-functions' and
-is ignored.
-
-See `lui-scroll-behavior' for how to customize this."
- (when (and (eq lui-scroll-behavior 'post-scroll)
- window
- (window-live-p window))
- (with-selected-window window
- (when (or (>= (point) lui-input-marker)
- (equal (point-max)
- (window-end nil t)))
- (let ((resize-mini-windows nil))
- (save-excursion
- (goto-char (point-max))
- (recenter -1)))))))
-
-(defun lui-scroll-post-command ()
- "Scroll the input line to the bottom of the window.
-
-This is called from `post-command-hook'.
-
-See `lui-scroll-behavior' for how to customize this."
- (condition-case err
- (dolist (w (window-list))
- (with-current-buffer (window-buffer w)
- (when (and lui-input-marker
- (memq lui-scroll-behavior '(t post-command)))
- ;; Code from ERC's erc-goodies.el. I think this was originally
- ;; mine anyhow, not sure though.
- (save-restriction
- (widen)
- (when (>= (point) lui-input-marker)
- (save-excursion
- (goto-char (point-max))
- (with-selected-window w
- (recenter -1))))))))
- (error
- (message "Error in lui-scroll-post-command: %S" err)
- )))
-
-(defun lui-scroll-post-output ()
- "Scroll the input line to the bottom of the window.
-
-This is called when lui output happens.
-
-See `lui-scroll-behavior' for how to customize this."
- (when (memq lui-scroll-behavior '(t post-output))
- (let ((resize-mini-windows nil))
- (dolist (window (get-buffer-window-list (current-buffer) nil t))
- (when (or (>= (point) lui-input-marker)
- (equal (point-max)
- (window-end window)))
- (with-selected-window window
- (save-excursion
- (goto-char (point-max))
- (recenter -1))))))))
-
-\f
-;;;;;;;;;;;;;
-;;; Input ;;;
-;;;;;;;;;;;;;
-
-(defun lui-send-input ()
- "Send the current input to the Lui application.
-If point is not in the input area, insert a newline."
- (interactive)
- (if (< (point) lui-input-marker)
- (newline)
- (save-restriction
- (narrow-to-region lui-input-marker (point-max))
- (run-hooks 'lui-pre-input-hook))
- (let ((input (buffer-substring lui-input-marker (point-max))))
- (delete-region lui-input-marker (point-max))
- (lui-add-input input)
- (if lui-input-function
- (funcall lui-input-function input)
- (error "No input function specified")))))
-
-(defun lui-add-input (input)
- "Add INPUT as if entered by the user."
- (ring-insert lui-input-ring input)
- (setq lui-input-ring-index nil))
-
-\f
-;;;;;;;;;;;;;;;
-;;; Buttons ;;;
-;;;;;;;;;;;;;;;
-
-(define-button-type 'lui-button
- 'supertype 'button
- 'follow-link t
- 'face 'lui-button-face)
-
-(defun lui-buttonize ()
- "Buttonize the current message."
- (lui-buttonize-urls)
- (lui-buttonize-custom)
- (lui-buttonize-issues))
-
-(defun lui-buttonize-custom ()
- "Add custom buttons to the current message.
-
-This uses `lui-buttons-list'."
- (dolist (entry lui-buttons-list)
- (let ((regex (nth 0 entry))
- (submatch (nth 1 entry))
- (function-or-url (nth 2 entry))
- (arg-matches (nthcdr 3 entry)))
- (goto-char (point-min))
- (while (re-search-forward regex nil t)
- ;; Ensure we're not inserting a button inside a URL button
- (when (not (button-at (match-beginning 0)))
- (let* ((function (if (functionp function-or-url)
- function-or-url
- 'browse-url))
- (matches (mapcar (lambda (n)
- (match-string-no-properties n))
- arg-matches))
- (arguments (if (functionp function-or-url)
- matches
- (list (apply #'format function-or-url
- matches)))))
- (make-button (match-beginning submatch)
- (match-end submatch)
- 'type 'lui-button
- 'action 'lui-button-activate
- 'lui-button-function function
- 'lui-button-arguments arguments)))))))
-
-(defun lui-buttonize-issues ()
- "Buttonize issue references in the current message, if configured."
- (when lui-button-issue-tracker
- (goto-char (point-min))
- (while (re-search-forward "\\(?:^\\|\\W\\)\\(#\\([0-9]+\\)\\)" nil t)
- ;; Ensure we're not inserting a button inside a URL button
- (when (not (button-at (point)))
- (make-button (match-beginning 1)
- (match-end 1)
- 'type 'lui-button
- 'action 'lui-button-activate
- 'lui-button-function 'browse-url
- 'lui-button-arguments
- (list (format lui-button-issue-tracker
- (match-string 2))))))))
-
-(defun lui-buttonize-urls ()
- "Buttonize URLs in the current message."
- (let ((regex (regexp-opt thing-at-point-uri-schemes)))
- (goto-char (point-min))
- (while (re-search-forward regex nil t)
- (let ((bounds (bounds-of-thing-at-point 'url)))
- (when bounds
- (make-button (car bounds)
- (cdr bounds)
- 'type 'lui-button
- 'action 'lui-button-activate
- 'lui-button-function 'browse-url
- 'lui-button-arguments
- (list (buffer-substring-no-properties
- (car bounds)
- (cdr bounds)))))))))
-
-(defun lui-button-activate (button)
- "Activate BUTTON.
-This calls the function stored in the `lui-button-function'
-property with the argument stored in `lui-button-arguments'."
- (apply (button-get button 'lui-button-function)
- (button-get button 'lui-button-arguments)))
-
-(defun lui-next-button-or-complete ()
- "Go to the next button, or complete at point.
-When point is in the input line, call `lui-completion-function'.
-Otherwise, we move to the next button."
- (interactive)
- (if (>= (point)
- lui-input-marker)
- (funcall lui-completion-function)
- (forward-button 1)))
-
-(defun lui-previous-button ()
- "Go to the previous button."
- (interactive)
- (backward-button 1))
-
-(defun lui-button-elisp-symbol (name)
- "Show the documentation for the symbol named NAME."
- (let ((sym (intern-soft name)))
- (cond
- ((not sym)
- (message "No such symbol %s" name)
- (ding))
- (t
- (help-xref-interned sym)))))
-
-(defun lui-button-pep (number)
- "Browse the PEP NUMBER."
- (browse-url (format "https://www.python.org/dev/peps/pep-%04i"
- (string-to-number number))))
-
-(defun lui-button-issue (issue)
- "Browse the issue tracker number ISSUE, if configured."
- (if lui-button-issue-tracker
- (browse-url (format lui-button-issue-tracker issue))
- (error "No issue tracker configured, see `lui-button-issue-tracker'")))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Input Line Killing ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun lui-kill-to-beginning-of-line ()
- "Kill the input from point to the beginning of the input."
- (interactive)
- (let* ((beg (point-at-bol))
- (end (point))
- (str (buffer-substring beg end)))
- (delete-region beg end)
- (kill-new str)))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;
-;;; Input History ;;;
-;;;;;;;;;;;;;;;;;;;;;
-
-;; FIXME!
-;; These need some better algorithm. They clobber input when it is not
-;; in the ring!
-(defun lui-previous-input ()
- "Cycle through the input history to the last input."
- (interactive)
- (when (> (ring-length lui-input-ring) 0)
- (if (and lui-input-ring-index
- (= (1- (ring-length lui-input-ring))
- lui-input-ring-index))
- ;; last item - insert a single empty line
- (progn
- (lui-replace-input "")
- (setq lui-input-ring-index nil))
- ;; If any input is left, store it in the input ring
- (when (and (null lui-input-ring-index)
- (> (point-max) lui-input-marker))
- (ring-insert lui-input-ring
- (buffer-substring lui-input-marker (point-max)))
- (setq lui-input-ring-index 0))
- ;; Increment the index
- (setq lui-input-ring-index
- (if lui-input-ring-index
- (ring-plus1 lui-input-ring-index (ring-length lui-input-ring))
- 0))
- ;; And insert the last input
- (lui-replace-input (ring-ref lui-input-ring lui-input-ring-index))
- (goto-char (point-max)))))
-
-(defun lui-next-input ()
- "Cycle through the input history to the next input."
- (interactive)
- (when (> (ring-length lui-input-ring) 0)
- (if (and lui-input-ring-index
- (= 0 lui-input-ring-index))
- ;; first item - insert a single empty line
- (progn
- (lui-replace-input "")
- (setq lui-input-ring-index nil))
- ;; If any input is left, store it in the input ring
- (when (and (null lui-input-ring-index)
- (> (point-max) lui-input-marker))
- (ring-insert lui-input-ring
- (buffer-substring lui-input-marker (point-max)))
- (setq lui-input-ring-index 0))
- ;; Decrement the index
- (setq lui-input-ring-index (ring-minus1 (or lui-input-ring-index 0)
- (ring-length lui-input-ring)))
- ;; And insert the next input
- (lui-replace-input (ring-ref lui-input-ring lui-input-ring-index))
- (goto-char (point-max)))))
-
-(defun lui-replace-input (str)
- "Replace input with STR."
- (save-excursion
- (goto-char lui-input-marker)
- (delete-region lui-input-marker (point-max))
- (insert str)))
-
-\f
-;;;;;;;;;;;;;
-;;; Fools ;;;
-;;;;;;;;;;;;;
-
-(defun lui-fools ()
- "Propertize the current narrowing according to foolhardiness.
-That is, if any part of it has the text property 'lui-fool set,
-make the whole thing invisible."
- (when (text-property-any (point-min)
- (point-max)
- 'lui-fool t)
- (add-text-properties (point-min)
- (point-max)
- '(invisible lui-fool))))
-
-(defun lui-fools-hidden-p ()
- "Return whether fools are currently hidden."
- (if (or (eq t buffer-invisibility-spec)
- (memq 'lui-fool buffer-invisibility-spec))
- t
- nil))
-
-(defun lui-fool-toggle-display ()
- "Display what fools have said."
- (interactive)
- (when (eq buffer-invisibility-spec t)
- (add-to-invisibility-spec 'lui-fool))
- (cond
- ((lui-fools-hidden-p)
- (message "Now showing the gibberish of fools")
- (remove-from-invisibility-spec 'lui-fool))
- (t
- (message "Now hiding fools again *phew*")
- (add-to-invisibility-spec 'lui-fool)))
- ;; For some reason, after this, the display does not always update
- ;; (issue #31). Force an update just in case.
- (force-mode-line-update t))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Blink Paren and Show Paren Mode ;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun lui-paren-highlighting ()
- "Enable sane parenthesis highlighting in this buffer."
- (set (make-local-variable 'blink-paren-function)
- 'lui-blink-paren-function)
- (when (boundp 'show-paren-data-function)
- (set (make-local-variable 'show-paren-data-function)
- 'lui-show-paren-data-function)))
-
-(defun lui-blink-paren-function ()
- "Do not blink opening parens outside of the lui input area.
-
-When point is within the lui input area, inserting a closing
-parenthesis should only blink parens within the input area, not
-outside of it.
-
-This is a suitable value for `blink-paren-function', which see."
- (if (> (point) lui-input-marker)
- (let ((blink-matching-paren-distance (- (point)
- lui-input-marker)))
- (blink-matching-open))
- (blink-matching-open)))
-
-(defun lui-show-paren-data-function ()
- "Show parens only within the input area.
-
-When `show-paren-mode' is enabled, and point is in the input
-area, parenthesis highlighting should only happen within the
-input area, not include the rest of the buffer.
-
-This is a suitable value for `show-paren-data-function', which see."
- (when (fboundp 'show-paren--default)
- (let ((range (show-paren--default)))
- (if (or (< (point) lui-input-marker)
- (not (elt range 2))
- (>= (elt range 2) lui-input-marker))
- range
- nil))))
-
-\f
-;;;;;;;;;;;;;;;;
-;;; Flyspell ;;;
-;;;;;;;;;;;;;;;;
-
-(defun lui-flyspell-change-dictionary (&optional dictionary)
- "*Change flyspell to DICTIONARY.
-If DICTIONARY is nil, set a default dictionary according to
-`lui-flyspell-alist'.
-If it is \"\", disable flyspell."
- (interactive (list (completing-read
- "Use new dictionary (RET for none, SPC to complete): "
- (and (fboundp 'ispell-valid-dictionary-list)
- (mapcar 'list (ispell-valid-dictionary-list)))
- nil t)))
- (let ((dictionary (or dictionary
- (lui-find-dictionary (buffer-name)))))
- (when flyspell-mode
- (flyspell-mode 0))
- (when (and dictionary
- (not (equal dictionary "")))
- (ispell-change-dictionary dictionary))
- (flyspell-mode 1)))
-
-
-(defun lui-find-dictionary (buffer-name)
- "Return a dictionary appropriate for BUFFER-NAME."
- (let ((lis lui-flyspell-alist)
- (result nil))
- (while lis
- (if (string-match (caar lis) buffer-name)
- (setq result (cadr (car lis))
- lis nil)
- (setq lis (cdr lis))))
- result))
-
-(defun lui-flyspell-check-word-p ()
- "Return non-nil when flyspell should verify at this position.
-This is the value of Lui for `flyspell-generic-check-word-p'."
- (>= (point)
- lui-input-marker))
-
-\f
-;;;;;;;;;;;;;;
-;;; Output ;;;
-;;;;;;;;;;;;;;
-
-(defun lui-insert (str &optional not-tracked-p)
- "Insert STR into the current Lui buffer.
-
-If NOT-TRACKED-P is given, this insertion won't trigger tracking
-of the buffer."
- (lui-save-undo-list
- (save-excursion
- (save-restriction
- (let ((inhibit-read-only t)
- (inhibit-point-motion-hooks t))
- (widen)
- (goto-char lui-output-marker)
- (let ((beg (point))
- (end nil))
- (insert str "\n")
- (setq end (point))
- (set-marker lui-output-marker (point))
- (narrow-to-region beg end))
- (goto-char (point-min))
- (add-text-properties (point-min)
- (point-max)
- `(lui-raw-text ,str))
- (run-hooks 'lui-pre-output-hook)
- (lui-apply-formatting)
- (lui-highlight-keywords)
- (lui-buttonize)
- (lui-fill)
- (lui-time-stamp)
- (goto-char (point-min))
- (run-hooks 'lui-post-output-hook)
- (lui-fools)
- (goto-char (point-min))
- (let ((faces (lui-faces-in-region (point-min)
- (point-max)))
- (foolish (text-property-any (point-min)
- (point-max)
- 'lui-fool t))
- (not-tracked-p
- (or not-tracked-p
- (text-property-any (point-min)
- (point-max)
- 'lui-do-not-track t))))
- (widen)
- (lui-truncate)
- (lui-read-only)
- (when (and (not not-tracked-p)
- (not foolish))
- (tracking-add-buffer (current-buffer)
- faces)))
- (lui-scroll-post-output))))))
-
-(defun lui-adjust-undo-list (list old-begin shift)
- "Adjust undo positions in list.
-LIST is in the format of `buffer-undo-list'.
-Only positions after OLD-BEGIN are affected.
-The positions are adjusted by SHIFT positions."
- ;; This is necessary because the undo-list keeps exact buffer
- ;; positions.
- ;; Thanks to ERC for the idea of the code.
- ;; ERC's code doesn't take care of an OLD-BEGIN value, which is
- ;; necessary if you allow modification of the buffer.
- (let* ((gc-cons-threshold most-positive-fixnum) ;; See debbugs#22120#47
- (adjust-position (lambda (pos)
- (if (and (numberp pos)
- ;; After the boundary: Adjust
- (>= (abs pos)
- old-begin))
- (* (if (< pos 0)
- -1
- 1)
- (+ (abs pos)
- shift))
- pos)))
- (adjust (lambda (entry)
- (cond
- ;; POSITION
- ((numberp entry)
- (funcall adjust-position entry))
- ((not (consp entry))
- entry)
- ;; (BEG . END)
- ((numberp (car entry))
- (cons (funcall adjust-position (car entry))
- (funcall adjust-position (cdr entry))))
- ;; (TEXT . POSITION)
- ((stringp (car entry))
- (cons (car entry)
- (funcall adjust-position (cdr entry))))
- ;; (nil PROPERTY VALUE BEG . END)
- ((not (car entry))
- `(nil ,(nth 1 entry)
- ,(nth 2 entry)
- ,(funcall adjust-position (nth 3 entry))
- .
- ,(funcall adjust-position (nthcdr 4 entry))))
- ;; (apply DELTA BEG END FUN-NAME . ARGS)
- ((and (eq 'apply (car entry))
- (numberp (cadr entry)))
- `(apply ,(nth 1 entry)
- ,(funcall adjust-position (nth 2 entry))
- ,(funcall adjust-position (nth 3 entry))
- ,(nth 4 entry)
- .
- ,(nthcdr 5 entry)))
- (t
- entry)))))
- (mapcar adjust list)))
-
-(defvar lui-prompt-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "<end>") 'lui-prompt-end-of-line)
- (define-key map (kbd "C-e") 'lui-prompt-end-of-line)
- map)
- "Keymap for Lui prompts.
-Since \\[end-of-line] can't move out of fields, this DTRT for an
-unexpecting user.")
-
-(defun lui-set-prompt (prompt)
- "Set PROMPT as the current Lui prompt."
- (let ((inhibit-read-only t))
- (lui-save-undo-list
- (save-excursion
- (goto-char lui-output-marker)
- (insert prompt)
- (if (> lui-input-marker (point))
- (delete-region (point) lui-input-marker)
- (set-marker lui-input-marker (point)))
- (add-text-properties lui-output-marker lui-input-marker
- `(read-only t
- rear-nonsticky t
- field lui-prompt
- keymap ,lui-prompt-map
- front-sticky t
- ))))))
-
-(defun lui-prompt-end-of-line (&optional _N)
- "Move past the prompt, and then to the end of the line.
-This uses `end-of-line'.
-
-The argument N is ignored."
- (interactive "p")
- (goto-char lui-input-marker)
- (call-interactively 'end-of-line))
-
-(defun lui-faces-in-region (beg end)
- "Return a face that describes the region between BEG and END."
- (goto-char beg)
- (let ((faces nil))
- (while (not (= (point) end))
- (let ((face (get-text-property (point) 'face)))
- (dolist (face (if (consp face)
- face
- (list face)))
- (when (and face
- (facep face)
- (face-differs-from-default-p face))
- (push face faces)))
- (goto-char (next-single-property-change (point) 'face
- nil end))))
- faces))
-
-
-\f
-;;;;;;;;;;;;;;;;;;;;
-;;; Highlighting ;;;
-;;;;;;;;;;;;;;;;;;;;
-
-(defun lui-highlight-keywords ()
- "Highlight the entries in the variable `lui-highlight-keywords'.
-
-This is called automatically when new text is inserted."
- (let ((regex (lambda (entry)
- (if (stringp entry)
- entry
- (car entry))))
- (submatch (lambda (entry)
- (if (and (consp entry)
- (numberp (cadr entry)))
- (cadr entry)
- 0)))
- (properties (lambda (entry)
- (let ((face (cond
- ;; REGEXP
- ((stringp entry)
- 'lui-highlight-face)
- ;; (REGEXP SUBMATCH)
- ((and (numberp (cadr entry))
- (null (cddr entry)))
- 'lui-highlight-face)
- ;; (REGEXP FACE)
- ((null (cddr entry))
- (cadr entry))
- ;; (REGEXP SUBMATCH FACE)
- (t
- (nth 2 entry)))))
- (if (facep face)
- `(face ,face)
- face)))))
- (dolist (entry lui-highlight-keywords)
- (goto-char (point-min))
- (while (re-search-forward (funcall regex entry) nil t)
- (let* ((exp (funcall submatch entry))
- (beg (match-beginning exp))
- (end (match-end exp)))
- (when (not (text-property-any beg end 'lui-highlight-fontified-p t))
- (add-text-properties beg end
- (append (funcall properties entry)
- '(lui-highlight-fontified-p t)))))))))
-
-(defun lui-apply-formatting ()
- "Highlight the entries in `lui-formatting-list'."
- (dolist (entry lui-formatting-list)
- (goto-char (point-min))
- (let ((re (car entry))
- (subgroup (cadr entry))
- (face (nth 2 entry)))
- (while (re-search-forward re nil t)
- (when face
- (add-face-text-property (match-beginning subgroup) (match-end subgroup)
- face nil (current-buffer)))))))
-
-\f
-;;;;;;;;;;;;;;;
-;;; Filling ;;;
-;;;;;;;;;;;;;;;
-
-(defun lui-fill ()
- "Fill the text in the buffer.
-This is called automatically when new text is inserted. See
-`lui-fill-type' and `lui-fill-column' on how to customize this
-function."
- (cond
- ((stringp lui-fill-type)
- (let ((fill-prefix lui-fill-type)
- (fill-column (or lui-fill-column
- fill-column)))
- (fill-region (point-min) (point-max)
- nil t)))
- ((eq lui-fill-type 'variable)
- (let ((fill-prefix (save-excursion
- (goto-char (point-min))
- (let ((beg (point)))
- (re-search-forward "\\s-" nil t)
- (make-string (- (point) beg) ? ))))
- (fill-column (or lui-fill-column
- fill-column)))
- (fill-region (point-min) (point-max)
- nil t)))
- ((numberp lui-fill-type)
- (let ((right-end (save-excursion
- (goto-char (point-min))
- (re-search-forward "\\s-" nil t)
- (- (point)
- (point-at-bol)))))
- (goto-char (point-min))
- (when (< right-end lui-fill-type)
- (insert (make-string (- lui-fill-type
- right-end)
- ? )))
- (let ((fill-prefix (make-string lui-fill-type ? ))
- (fill-column (or lui-fill-column
- fill-column)))
- (fill-region (point-min) (point-max)
- nil t)))))
- (when lui-fill-remove-face-from-newline
- (goto-char (point-min))
- (while (re-search-forward "\n" nil t)
- (put-text-property (match-beginning 0)
- (match-end 0)
- 'face
- nil))))
-
-\f
-;;;;;;;;;;;;;;;;;;;
-;;; Time Stamps ;;;
-;;;;;;;;;;;;;;;;;;;
-
-(defvar lui-time-stamp-last nil
- "The last time stamp.")
-(make-variable-buffer-local 'lui-time-stamp-last)
-
-(defvar lui-time-stamp-time nil
- "A custom time to use as the time stamp for `lui-insert'.
-
-This variable should be let-bound when you wish to provide a
-custom time to be printed by `lui-time-stamp'. If this variable
-is nil the current time is used. See the TIME argument to
-`format-time-string' for more information.")
-
-(defvar lui-time-stamp-zone nil
- "A custom timezone to use for the time stamp for `lui-insert'.
-
-This variable should be let-bound when you wish to provide a
-custom time zone when printing the time stamp with
-`lui-time-stamp'. If this variable is nil local time is used.
-See the ZONE argument to `format-time-string' for more
-information.")
-
-(defun lui-time-stamp ()
- "Add a time stamp to the current buffer."
- (let ((ts (format-time-string lui-time-stamp-format
- lui-time-stamp-time
- lui-time-stamp-zone)))
- (cond
- ;; Time stamps right
- ((or (numberp lui-time-stamp-position)
- (eq lui-time-stamp-position 'right))
- (when (or (not lui-time-stamp-only-when-changed-p)
- (not lui-time-stamp-last)
- (not (string= ts lui-time-stamp-last)))
- (goto-char (point-min))
- (goto-char (point-at-eol))
- (let* ((curcol (current-column))
- (col (if (numberp lui-time-stamp-position)
- lui-time-stamp-position
- (+ 2 (or lui-fill-column
- fill-column
- (point)))))
- (indent (if (> col curcol)
- (- col curcol)
- 1))
- (ts-string (propertize
- (concat (make-string indent ?\s)
- (propertize
- ts
- 'face 'lui-time-stamp-face))
- 'lui-time-stamp t))
- (start (point)))
- (insert ts-string)
- (add-text-properties start (1+ (point)) '(intangible t))
- (add-text-properties (1+ start) (point) '(cursor-intangible t)))))
- ;; Time stamps left
- ((eq lui-time-stamp-position 'left)
- (let ((indent-string (propertize (make-string (length ts) ?\s)
- 'lui-time-stamp t)))
- (goto-char (point-min))
- (cond
- ;; Time stamp
- ((or (not lui-time-stamp-only-when-changed-p)
- (not lui-time-stamp-last)
- (not (string= ts lui-time-stamp-last)))
- (insert (propertize ts
- 'face 'lui-time-stamp-face
- 'lui-time-stamp t)))
- ;; Just indentation
- (t
- (insert indent-string)))
- (forward-line 1)
- (while (< (point) (point-max))
- (insert indent-string)
- (forward-line 1))))
- ;; Time stamps in margin
- ((or (eq lui-time-stamp-position 'right-margin)
- (eq lui-time-stamp-position 'left-margin))
- (when (or (not lui-time-stamp-only-when-changed-p)
- (not lui-time-stamp-last)
- (not (string= ts lui-time-stamp-last)))
- (goto-char (point-min))
- (goto-char (point-at-eol))
- (let* ((ts (propertize ts 'face 'lui-time-stamp-face))
- (ts-margin (propertize
- " "
- 'display `((margin ,lui-time-stamp-position)
- ,ts)
- 'lui-time-stamp t)))
- (insert ts-margin)))))
- (setq lui-time-stamp-last ts)))
-
-(defun lui-time-stamp-enable-filtering ()
- "Enable filtering of timestamps from copied text."
- (set (make-local-variable 'filter-buffer-substring-functions)
- '(lui-filter-buffer-time-stamps)))
-
-(defun lui-filter-buffer-time-stamps (fun beg end delete)
- "Filter text from copied strings.
-
-This is meant for the variable `filter-buffer-substring-functions',
-which see for an explanation of the argument FUN, BEG, END and
-DELETE."
- (let ((string (funcall fun beg end delete))
- (inhibit-point-motion-hooks t)
- (inhibit-read-only t)
- ;; Emacs 24.4, 24.5
- deactivate-mark)
- (with-temp-buffer
- (insert string)
- (let ((start (text-property-any (point-min)
- (point-max)
- 'lui-time-stamp t)))
- (while start
- (let ((end (next-single-property-change start 'lui-time-stamp
- nil (point-max))))
- (delete-region start end)
- (setq start (text-property-any (point-min) (point-max)
- 'lui-time-stamp t))))
- (buffer-string)))))
-
-(defun lui-time-stamp-buffer-substring (buffer-string)
- "Filter text from copied strings.
-
-This is meant for the variable `buffer-substring-filters',
-which see for an explanation of the argument BUFFER-STRING."
- (lui-filter-buffer-time-stamps (lambda (_beg _end _delete)
- buffer-string)
- nil nil nil))
-
-\f
-;;;;;;;;;;;;;;;;;;
-;;; Truncating ;;;
-;;;;;;;;;;;;;;;;;;
-
-(defun lui-truncate ()
- "Truncate the current buffer if it exceeds `lui-max-buffer-size'."
- (when (and lui-max-buffer-size
- (> (point-max)
- lui-max-buffer-size))
- (goto-char (- (point-max)
- lui-max-buffer-size))
- (forward-line 0)
- (let ((inhibit-read-only t))
- (delete-region (point-min) (point)))))
-
-\f
-;;;;;;;;;;;;;;;;;
-;;; Read-Only ;;;
-;;;;;;;;;;;;;;;;;
-
-(defun lui-read-only ()
- "Make the current output read-only if `lui-read-only-output-p' is non-nil."
- (when lui-read-only-output-p
- (add-text-properties (point-min) lui-output-marker
- '(read-only t
- front-sticky t))))
-
-\f
-(provide 'lui)
-;;; lui.el ends here
+++ /dev/null
-;;; make-tls-process.el --- A non-blocking TLS connection function
-
-;; Copyright (C) 2015 Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
-
-;; Author: Jorgen Schaefer <contactNOSPAMjorgenschaefer.de>
-;; URL: https://github.com/jorgenschaefer/circe
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License
-;; as published by the Free Software Foundation; either version 3
-;; of the License, or (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; A `make-tls-process' function like `make-network-process', in
-;; particular supporting non-blocking connects.
-
-;;; Code:
-
-(require 'tls)
-
-(defcustom tls-connection-command
- (if (executable-find "gnutls-cli")
- "gnutls-cli --insecure -p %p %h"
- "openssl s_client -connect %h:%p -no_ssl2 -ign_eof")
- "The command to use to create a TLS connection.
-
-%h is replaced with server hostname, %p with port to connect to.
-The program should read input on stdin and write output to
-stdout.
-
-Also see `tls-success' for what the program should output after
-successful negotiation."
- :group 'tls
- :type 'string)
-
-(defvar tls-debug-output nil
- "Non-nil if you want to see lots of debug messages.")
-
-(defun tls--debug (format-string &rest args)
- "Display a message if debug output is enabled.
-
-If `tls-debug-output' is non-nil, this acts like `message'.
-Otherwise, it's a no-op."
- (when tls-debug-output
- (apply #'message format-string args)))
-
-(defun make-tls-process (&rest args)
- "Create a TLS client process.
-
-A TLS network process is a command process that runs a command
-line program like gnutls or openssl, not a full network process.
-Network communication should work as usual, but the sentinel
-might receive process-specific events.
-
-Different from a process sentinel, but like a network sentinel,
-the sentinel is called with an event \"open\\n\" when the
-connection is established.
-
-This function uses `tls-connection-command' to connect to a
-server.
-
-Do NOT use `set-process-filter' or `set-process-sentinel' on the
-return value of this function. The connection setup uses special
-sentinels and filters to be deal with the program output used
-here. Use the :sentinel and :filter keyword arguments to set them
-once the connection is fully established.
-
-Arguments are specified as keyword/argument pairs, similar to
-`make-network-process'. The following arguments are defined:
-
-:name NAME -- NAME is name for process. It is modified if necessary
-to make it unique.
-
-:buffer BUFFER -- BUFFER is the buffer (or buffer-name) to associate
-with the process. Process output goes at end of that buffer, unless
-you specify an output stream or filter function to handle the output.
-BUFFER may be also nil, meaning that this process is not associated
-with any buffer.
-
-:host HOST -- HOST is name of the host to connect to, or its IP
-address. The symbol `local' specifies the local host. If specified
-for a server process, it must be a valid name or address for the local
-host, and only clients connecting to that address will be accepted.
-
-:service SERVICE -- SERVICE is name of the service desired, or an
-integer specifying a port number to connect to. If SERVICE is t,
-a random port number is selected for the server. (If Emacs was
-compiled with getaddrinfo, a port number can also be specified as
-a string, e.g. \"80\", as well as an integer. This is not
-portable.)
-
-:coding CODING -- If CODING is a symbol, it specifies the coding
-system used for both reading and writing for this process. If CODING
-is a cons (DECODING . ENCODING), DECODING is used for reading, and
-ENCODING is used for writing.
-
-:noquery BOOL -- Query the user unless BOOL is non-nil, and process is
-running when Emacs is exited.
-
-:filter FILTER -- Install FILTER as the process filter.
-
-:sentinel SENTINEL -- Install SENTINEL as the process sentinel.
-
-:plist PLIST -- Install PLIST as the new process's initial plist."
- (let* ((name (plist-get args :name))
- (host (plist-get args :host))
- (service (plist-get args :service))
- (proc (tls--start-process name tls-connection-command host service)))
- (process-put proc :tls-args args)
- (set-process-sentinel proc #'tls--sentinel)
- (set-process-filter proc #'tls--filter)
- proc))
-
-(defun tls--sentinel (proc event)
- "The default sentinel for TLS connections.
-
-Try the next command in the list, or fail if there are none
-left."
- (tls--debug "tls--sentinel %S %S"
- (process-status proc)
- event)
- (tls--debug "Failed TLS output: %s"
- (process-get proc :tls-data))
- (if (eq (process-status proc)
- 'exit)
- (let ((sentinel (plist-get (process-get proc :tls-args)
- :sentinel)))
- (when sentinel
- (funcall sentinel proc (format "failed with %s\n" event))))
- (error "Unexpected event in tls sentinel: %S" event)))
-
-(defun tls--filter (proc data)
- "The default filter for TLS connections.
-
-We wait until both `tls-success' and `tls-end-of-info' have been
-received. Once that happens, we are done and we can switch over
-to the real connection."
- (let ((data (concat (or (process-get proc :tls-data)
- "")
- data)))
- (if (and (string-match tls-success data)
- (string-match tls-end-of-info data))
- (let* ((remaining-data (substring data (match-end 0)))
- (args (process-get proc :tls-args))
- (buffer (plist-get args :buffer))
- (coding (plist-get args :coding))
- (noquery (plist-get args :noquery))
- (filter (plist-get args :filter))
- (sentinel (plist-get args :sentinel))
- (plist (plist-get args :plist)))
- (set-process-plist proc plist)
- (set-process-sentinel proc sentinel)
- (set-process-filter proc filter)
- (set-process-buffer proc buffer)
- (if (consp coding)
- (set-process-coding-system proc (car coding) (cdr coding))
- (set-process-coding-system proc coding coding))
- (set-process-query-on-exit-flag proc (not noquery))
- (when sentinel
- (funcall sentinel proc "open\n"))
- (when (and (not (equal remaining-data ""))
- filter)
- (funcall filter proc remaining-data)))
- (process-put proc :tls-data data))))
-
-(defun tls--start-process (name cmd host port)
- "Start a single process for network communication.
-
-This code is mostly taken from tls.el."
- (let ((process-connection-type tls-process-connection-type)
- (formatted-cmd
- (format-spec
- cmd
- (format-spec-make
- ?h host
- ?p (if (integerp port)
- (int-to-string port)
- port)))))
- (tls--debug "TLS starting process: %s" formatted-cmd)
- (start-process name nil
- shell-file-name shell-command-switch
- formatted-cmd)))
-
-(provide 'make-tls-process)
-;;; make-tls-process.el ends here
+++ /dev/null
-;;; shorten.el --- component-wise string shortener
-
-;; Copyright (C) 2013 John J Foerch <jjfoerchNOSPAMearthlink.net>
-
-;; Keywords: extensions
-;; Author: John J Foerch <jjfoerchNOSPAMearthlink.net>
-;; URL: https://github.com/jorgenschaefer/circe/blob/master/shorten.el
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; This is a component-wise string shortener, meaning that, given a list
-;; of strings, it breaks each string into parts, then computes shortest
-;; prefix of each part with respect to others of the same 'depth', such
-;; that when joined back together, the shortened form of the whole string
-;; remains unique within the resulting list. Many styles of shortening
-;; are made possible via three functions that the caller may provide: the
-;; split function, the join function, and the validate-component function.
-;;
-;; Strings are broken with the value of `shorten-split-function' (a
-;; procedure string->list), and shortened components are rejoined with the
-;; value of `shorten-join-function' (a procedure list->string[*]). The
-;; default split and join functions break the string on word boundaries,
-;; and rejoin on the empty string. Potential shortened forms of
-;; components are tested with `shorten-validate-component-function'; its
-;; default value passes only if its argument contains at least one
-;; word-constituent character (regexp \w), meaning that by default,
-;; components consisting entirely of non-word characters will not be
-;; shortened, and components that start with non-word characters will only
-;; be shortened so much that they have at least one word-constituent
-;; character in them.
-;;
-;; The main entry point is `shorten-strings', which takes a list of strings
-;; as its argument and returns an alist ((STRING . SHORTENED-STRING) ...).
-;;
-;; [*] Also takes a second argument; see docstring of
-;; `shorten-join-function'.
-
-;;; History:
-
-;; - Version 0.1 (March 7, 2013): initial release
-
-;;; Code:
-
-;; Tree utils
-;;
-(defsubst shorten-make-tree-root ()
- (cons nil nil))
-
-(defsubst shorten-tree-make-entry (token short full)
- (list token short full nil))
-
-(defsubst shorten-tree-token (entry)
- (car entry))
-
-(defsubst shorten-tree-fullname (entry)
- (nth 2 entry))
-
-(defsubst shorten-tree-descendants (entry)
- (nthcdr 3 entry))
-
-(defsubst shorten-tree-set-shortened (entry short)
- (setcar (cdr entry) short))
-
-(defsubst shorten-tree-set-fullname (entry full)
- (setcar (nthcdr 2 entry) full))
-
-(defsubst shorten-tree-insert (node item)
- (when (car node)
- (setcdr node (cons (car node) (cdr node))))
- (setcar node item))
-
-
-;; Caller configuration
-;;
-(defun shorten-split (s)
- (split-string s "\\b" t))
-
-(defun shorten-join (lst &optional tail-count)
- (mapconcat #'identity lst ""))
-
-(defun shorten-join-sans-tail (lst tail-count)
- "A shorten-join that drops unnecessary tail components."
- (shorten-join (butlast lst tail-count)))
-
-(defun shorten-validate-component (str)
- (string-match-p "\\w" str))
-
-(defvar shorten-split-function #'shorten-split
- "Value should be a function of string->list that breaks a
-string into components. The default breaks on word-boundaries.
-To get simple prefix shortening, bind this to `list'.
-
-Users should not generally change the global value of this
-variable; instead, bind it dynamically around calls to
-`shorten-strings'.")
-
-(defvar shorten-join-function #'shorten-join
- "A function that takes a list of components and a tail-count,
-and returns a joined string. Tail-count is the number of
-components on the end of the list that are not needed to uniquify
-the result, and so may be safely dropped if aggressive shortening
-is desired. The default preserves tail components, and joins the
-list on the empty string.
-
-Users should not generally change the global value of this
-variable; instead, bind it dynamically around calls to
-`shorten-strings'.")
-
-(defvar shorten-validate-component-function #'shorten-validate-component
- "Predicate that returns t if a proposed shortened form of a
-single component is acceptable, nil if a longer one should be
-tried. The default validates only when the candidate contains at
-least one word-constituent character, thus strings consisting of
-punctuation will not be shortened. For aggressive shortening,
-bind to a procedure that always returns t.
-
-Users should not generally change the global value of this
-variable; instead, bind it dynamically around calls to
-`shorten-strings'.")
-
-
-;; Main procedures
-;;
-(defun shorten-one (str others)
- "Return shortest unique prefix of STR among OTHERS, or STR if
-it cannot be shortened. If STR is a member of OTHERS (tested
-with `eq') that entry is ignored. The value of
-`shorten-validate-component-function' will be used to validate
-any prefix."
- (let ((max (length str))
- (len 1))
- (or (catch 'return
- (while (< len max)
- (let ((prefix (substring str 0 len)))
- (when (funcall shorten-validate-component-function prefix)
- (when (catch 'return
- (dolist (other others t)
- (when (and (>= (length other) len)
- (string= (substring other 0 len) prefix)
- (not (eq other str)))
- (throw 'return nil))))
- (throw 'return prefix)))
- (setq len (1+ len)))))
- str)))
-
-(defun shorten-walk-internal (node path tail-count result-out)
- (let ((others (mapcar #'car node)))
- (setq tail-count (if (cdr node) 0 (1+ tail-count)))
- (dolist (entry node)
- (let* ((token (shorten-tree-token entry))
- (shortened (shorten-one token others))
- (path (cons shortened path))
- (fullname (shorten-tree-fullname entry))
- (descendants (shorten-tree-descendants entry))
- (have-descendants (not (equal '(nil) descendants))))
- (shorten-tree-set-shortened entry shortened)
- ;; if this entry has a fullname, add to result-out
- (when fullname
- (let ((joined (funcall shorten-join-function
- (reverse path)
- (if have-descendants 0 tail-count))))
- (shorten-tree-insert result-out (cons fullname joined))))
- ;; if this entry has descendants, recurse
- (when have-descendants
- (shorten-walk-internal descendants path
- (if fullname -1 tail-count)
- result-out))))))
-
-(defun shorten-walk (tree)
- "Takes a tree of the type made by `shorten-make-tree' and
-returns an alist ((STRING . SHORTENED-STRING) ...). Uses
-`shorten-join-function' to join shortened components back
-together into SHORTENED-STRING. See also
-`shorten-validate-component-function'."
- (let ((result-out (shorten-make-tree-root)))
- (shorten-walk-internal tree '() -1 result-out)
- (if (equal '(nil) result-out) nil result-out)))
-
-(defun shorten-make-tree (strings)
- "Takes a list of strings and returns a tree of the type used by
-`shorten-walk' to generate shortened strings. Uses
-`shorten-split-function' to split the strings."
- (let ((tree (shorten-make-tree-root)))
- (dolist (s strings)
- (let ((node tree)
- (tokens (funcall shorten-split-function s))
- (entry nil))
- ;; create a path in tree for tokens
- (dolist (token tokens)
- (setq entry (assoc token node))
- (when (not entry)
- (setq entry (shorten-tree-make-entry token nil nil))
- (shorten-tree-insert node entry))
- (setq node (shorten-tree-descendants entry)))
- ;; for the last token, set 'fullname'
- (shorten-tree-set-fullname entry s)))
- (if (equal tree '(nil)) nil tree)))
-
-;;;###autoload
-(defun shorten-strings (strings)
- "Takes a list of strings and returns an alist ((STRING
-. SHORTENED-STRING) ...). Uses `shorten-split-function' to split
-the strings, and `shorten-join-function' to join shortened
-components back together into SHORTENED-STRING. See also
-`shorten-validate-component-function'."
- (shorten-walk (shorten-make-tree strings)))
-
-
-(provide 'shorten)
-;;; shorten.el ends here
+++ /dev/null
-;;; tracking.el --- Buffer modification tracking
-
-;; Copyright (C) 2006, 2012 - 2015 Jorgen Schaefer
-
-;; Author: Jorgen Schaefer <forcerNOSPAMforcix.cx>
-;; URL: https://github.com/jorgenschaefer/circe/wiki/Tracking
-
-;; This program is free software: you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; tracking.el is a library for other Emacs Lisp programs not useful
-;; by itself.
-
-;; The library provides a way to globally register buffers as being
-;; modified and scheduled for user review. The user can cycle through
-;; the buffers using C-c C-SPC. This is especially useful for buffers
-;; that interact with external sources, such as chat clients and
-;; similar programs.
-
-;;; Code:
-
-(require 'easy-mmode)
-(require 'shorten)
-(require 'cl-lib)
-
-;;; User customization
-(defgroup tracking nil
- "Tracking of buffer activities."
- :prefix "tracking-"
- :group 'applications)
-
-(defcustom tracking-shorten-buffer-names-p t
- "Whether to shorten buffer names in the mode line.
-A non-nil value will cause tracked buffer names to be shortened
-as much as possible to stay unambiguous when displaying them in
-the mode line."
- :type 'boolean
- :group 'tracking)
-
-(defcustom tracking-frame-behavior 'visible
- "How to deal with frams to determine visibility of buffers.
-This is passed as the second argument to `get-buffer-window',
-see there for further explanation."
- :type '(choice (const :tag "All visible frames" visible)
- (const :tag "Visible and iconified frames" 0)
- (const :tag "All frames" t)
- (const :tag "Selected frame only" nil))
- :group 'tracking)
-
-(defcustom tracking-position 'before-modes
- "Where tracked buffers should appear in the mode line.
-
- 'before-modes
- Before the mode indicators
- 'after-modes
- After the mode indicators
- 'end
- At the end of the mode line"
- :type '(choice (const :tag "Before the Mode Indicators" before-modes)
- (const :tag "Afterthe Mode Indicators" after-modes)
- (const :tag "At the End of the Mode Line" end))
- :group 'tracking)
-
-(defcustom tracking-faces-priorities nil
- "A list of faces which should be shown by tracking in the mode line.
-The first face found in this list is used."
- :type '(repeat face)
- :group 'tracking)
-
-(defcustom tracking-ignored-buffers nil
- "A list of buffers that are never tracked.
-Each element of this list has one of the following forms:
-
- regexp - Any buffer matching won't be tracked.
- function - Any buffer matching won't be tracked.
- (regexp faces ...) - Any buffer matching won't be tracked,
- unless it has a face in FACES ... associated with it.
- If no faces are given, `tracking-faces-priorities' is
- used.
- (function faces ...) - As per above, but with a function
- as predicate instead of a regexp."
- :type '(repeat (choice regexp
- function
- (list (choice regexp function)
- (repeat face))))
- :group 'tracking)
-
-(defcustom tracking-most-recent-first nil
- "When non-nil, newly tracked buffers will go to the front of the
-list, rather than to the end."
- :type 'boolean
- :group 'tracking)
-
-(defcustom tracking-buffer-added-hook nil
- "Hook run when a buffer has some activity.
-
-The functions are run in the context of the buffer.
-
-This can also happen when the buffer is already tracked. Check if the
-buffer name is in `tracking-buffers' if you want to see if it was
-added before."
- :type 'hook
- :group 'tracking)
-
-(defcustom tracking-buffer-removed-hook nil
- "Hook run when a buffer becomes active and is removed.
-
-The functions are run in the context of the buffer."
- :type 'hook
- :group 'tracking)
-
-;;; Internal variables
-(defvar tracking-buffers nil
- "The list of currently tracked buffers.")
-
-(defvar tracking-mode-line-buffers ""
- "The entry to the mode line.")
-(put 'tracking-mode-line-buffers 'risky-local-variable t)
-
-(defvar tracking-start-buffer nil
- "The buffer we started from when cycling through the active buffers.")
-
-(defvar tracking-last-buffer nil
- "The buffer we last switched to with `tracking-next-buffer'.
-When this is not the current buffer when we continue switching, a
-new `tracking-start-buffer' is created.")
-
-(defvar tracking-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map (kbd "C-c C-SPC") 'tracking-next-buffer)
- (define-key map (kbd "C-c C-@") 'tracking-next-buffer)
- map)
- "The keymap used for tracking mode.")
-
-;;;###autoload
-(define-minor-mode tracking-mode
- "Allow cycling through modified buffers.
-This mode in itself does not track buffer modification, but
-provides an API for programs to add buffers as modified (using
-`tracking-add-buffer').
-
-Once this mode is active, modified buffers are shown in the mode
-line. The user can cycle through them using
-\\[tracking-next-buffer]."
- :group 'tracking
- :global t
- (cond
- (tracking-mode
- (cond
- ((eq tracking-position 'before-modes)
- (let ((head nil)
- (tail (default-value 'mode-line-format)))
- (when (not (memq 'tracking-mode-line-buffers tail))
- (catch 'return
- (while tail
- (if (not (eq (car tail)
- 'mode-line-modes))
- (setq head (cons (car tail)
- head)
- tail (cdr tail))
- (setq-default mode-line-format
- (append (reverse head)
- '(tracking-mode-line-buffers)
- tail))
- (throw 'return t)))))))
- ((eq tracking-position 'after-modes)
- (add-to-list 'mode-line-misc-info
- 'tracking-mode-line-buffers))
- ((eq tracking-position 'end)
- (add-to-list 'mode-line-misc-info
- 'tracking-mode-line-buffers
- t))
- (t
- (error "Invalid value for `tracking-position' (%s)" tracking-position)))
- (add-hook 'window-configuration-change-hook
- 'tracking-remove-visible-buffers))
- (t
- (setq mode-line-misc-info (delq 'tracking-mode-line-buffers
- mode-line-misc-info))
- (setq-default mode-line-format (delq 'tracking-mode-line-buffers
- (default-value 'mode-line-format)))
- (remove-hook 'window-configuration-change-hook
- 'tracking-remove-visible-buffers))))
-
-;;;###autoload
-(defun tracking-add-buffer (buffer &optional faces)
- "Add BUFFER as being modified with FACES.
-This does check whether BUFFER is currently visible.
-
-If FACES is given, it lists the faces that might be appropriate
-for BUFFER in the mode line. The highest-priority face of these
-and the current face of the buffer, if any, is used. Priority is
-decided according to `tracking-faces-priorities'."
- (when (and (not (get-buffer-window buffer tracking-frame-behavior))
- (not (tracking-ignored-p buffer faces)))
- (with-current-buffer buffer
- (run-hooks 'tracking-buffer-added-hook))
- (let* ((entry (member (buffer-name buffer)
- tracking-buffers)))
- (if entry
- (setcar entry (tracking-faces-merge (car entry)
- faces))
- (setq tracking-buffers
- (if tracking-most-recent-first
- (cons (tracking-faces-merge (buffer-name buffer)
- faces)
- tracking-buffers)
- (nconc tracking-buffers
- (list (tracking-faces-merge (buffer-name buffer)
- faces)))))))
- (setq tracking-mode-line-buffers (tracking-status))
- (force-mode-line-update t)
- ))
-
-;;;###autoload
-(defun tracking-remove-buffer (buffer)
- "Remove BUFFER from being tracked."
- (when (member (buffer-name buffer)
- tracking-buffers)
- (with-current-buffer buffer
- (run-hooks 'tracking-buffer-removed-hook)))
- (setq tracking-buffers (delete (buffer-name buffer)
- tracking-buffers))
- (setq tracking-mode-line-buffers (tracking-status))
- (sit-for 0) ;; Update mode line
- )
-
-;;;###autoload
-(defun tracking-next-buffer ()
- "Switch to the next active buffer."
- (interactive)
- (cond
- ((and (not tracking-buffers)
- tracking-start-buffer)
- (let ((buf tracking-start-buffer))
- (setq tracking-start-buffer nil)
- (if (buffer-live-p buf)
- (switch-to-buffer buf)
- (message "Original buffer does not exist anymore")
- (ding))))
- ((not tracking-buffers)
- nil)
- (t
- (when (not (eq tracking-last-buffer
- (current-buffer)))
- (setq tracking-start-buffer (current-buffer)))
- (let ((new (car tracking-buffers)))
- (when (buffer-live-p (get-buffer new))
- (with-current-buffer new
- (run-hooks 'tracking-buffer-removed-hook)))
- (setq tracking-buffers (cdr tracking-buffers)
- tracking-mode-line-buffers (tracking-status))
- (if (buffer-live-p (get-buffer new))
- (switch-to-buffer new)
- (message "Buffer %s does not exist anymore" new)
- (ding)
- (setq tracking-mode-line-buffers (tracking-status))))
- (setq tracking-last-buffer (current-buffer))
- ;; Update mode line. See `force-mode-line-update' for the idea for
- ;; this code. Using `sit-for' can be quite inefficient for larger
- ;; buffers.
- (dolist (w (window-list))
- (with-current-buffer (window-buffer w)))
- )))
-
-;;;###autoload
-(defun tracking-previous-buffer ()
- "Switch to the last active buffer."
- (interactive)
- (when tracking-buffers
- (switch-to-buffer (car (last tracking-buffers)))))
-
-(defun tracking-ignored-p (buffer faces)
- "Return non-nil when BUFFER with FACES shouldn't be tracked.
-This uses `tracking-ignored-buffers'. Actual returned value is
-the entry from tracking-ignored-buffers that causes this buffer
-to be ignored."
- (catch 'return
- (let ((buffer-name (buffer-name buffer)))
- (dolist (entry tracking-ignored-buffers)
- (cond
- ((stringp entry)
- (and (string-match entry buffer-name)
- (throw 'return entry)))
- ((functionp entry)
- (and (funcall entry buffer-name)
- (throw 'return entry)))
- ((or (and (stringp (car entry))
- (string-match (car entry) buffer-name))
- (and (functionp (car entry))
- (funcall (car entry) buffer-name)))
- (when (not (tracking-any-in (or (cdr entry)
- tracking-faces-priorities)
- faces))
- (throw 'return entry))))))
- nil))
-
-(defun tracking-status ()
- "Return the current track status.
-
-This returns a list suitable for `mode-line-format'."
- (if (not tracking-buffers)
- ""
- (let* ((buffer-names (cl-remove-if-not #'get-buffer tracking-buffers))
- (shortened-names (tracking-shorten tracking-buffers))
- (result (list " [")))
- (while buffer-names
- (push `(:propertize
- ,(car shortened-names)
- face ,(get-text-property 0 'face (car buffer-names))
- keymap ,(let ((map (make-sparse-keymap)))
- (define-key map [mode-line down-mouse-1]
- `(lambda ()
- (interactive)
- (pop-to-buffer ,(car buffer-names))))
- map)
- mouse-face mode-line-highlight
- help-echo ,(format (concat "New activity in %s\n"
- "mouse-1: pop to the buffer")
- (car buffer-names)))
- result)
- (setq buffer-names (cdr buffer-names)
- shortened-names (cdr shortened-names))
- (when buffer-names
- (push "," result)))
- (push "] " result)
- (nreverse result))))
-
-(defun tracking-remove-visible-buffers ()
- "Remove visible buffers from the tracked buffers.
-This is usually called via `window-configuration-changed-hook'."
- (interactive)
- (dolist (buffer-name tracking-buffers)
- (let ((buffer (get-buffer buffer-name)))
- (cond
- ((not buffer)
- (setq tracking-buffers (delete buffer-name tracking-buffers))
- (setq tracking-mode-line-buffers (tracking-status))
- (sit-for 0))
- ((get-buffer-window buffer tracking-frame-behavior)
- (tracking-remove-buffer buffer))))))
-
-;;; Helper functions
-(defun tracking-shorten (buffers)
- "Shorten BUFFERS according to `tracking-shorten-buffer-names-p'."
- (if tracking-shorten-buffer-names-p
- (let ((all (shorten-strings (mapcar #'buffer-name (buffer-list)))))
- (mapcar (lambda (buffer)
- (let ((short (cdr (assoc buffer all))))
- (set-text-properties
- 0 (length short)
- (text-properties-at 0 buffer)
- short)
- short))
- buffers))
- buffers))
-
-(defun tracking-any-in (lista listb)
- "Return non-nil when any element in LISTA is in LISTB"
- (catch 'return
- (dolist (entry lista)
- (when (memq entry listb)
- (throw 'return t)))
- nil))
-
-(defun tracking-faces-merge (string faces)
- "Merge faces into string, adhering to `tracking-faces-priorities'.
-This returns STRING with the new face."
- (let ((faces (cons (get-text-property 0 'face string)
- faces)))
- (catch 'return
- (dolist (candidate tracking-faces-priorities)
- (when (memq candidate faces)
- (throw 'return
- (propertize string 'face candidate))))
- string)))
-
-(provide 'tracking)
-;;; tracking.el ends here
projects / emacsconfig.git / commitdiff