comparison lisp/net/rcirc.el @ 67014:d3d8e2bcfa98

(rcirc-mangle-text): Add bold face property without replacing existing properties. (rcirc-my-nick, rcirc-other-nick, rcirc-server) (rcirc-nick-in-message, rcirc-prompt): Use min-colors and remove tty specs. (rcirc-server-prefix, rcirc-server): New faces. (rcirc-url-regexp): Generate with rx macro. (rcirc-last-server-message-time): New variable. (rcirc-filter): Record time of last message. (rcirc-keepalive): Kill processes that did not send a message since the last ping. (rcirc-mode): Give rcirc-topic a local binding here.

67013:f263dd2ed52d


(defvar rcirc-process-output nil)
(defvar rcirc-topic nil)
(defvar rcirc-keepalive-timer nil)
(make-variable-buffer-local 'rcirc-topic)
(defun rcirc-connect (server port nick user-name full-name startup-channels)
  "Return a connection to SERVER on PORT.

User will identify using the values of NICK, USER-NAME and
FULL-NAME.  The variable list of channel names in

      (setq rcirc-nick nick)
      (make-local-variable 'rcirc-process-output)
      (setq rcirc-process-output nil)
      (make-local-variable 'rcirc-startup-channels)
      (setq rcirc-startup-channels startup-channels)

      ;; identify
      (rcirc-send-string process (concat "NICK " nick))
      (rcirc-send-string process (concat "USER " user-name
                                      " hostname servername :"

  (declare (indent 1) (debug t))
  `(with-current-buffer (process-buffer ,process)
     ,@body))

(defun rcirc-keepalive ()
  "Send keep alive pings to active rcirc processes."
  (if (rcirc-process-list)
      (mapc (lambda (process)
              (with-rcirc-process-buffer process
                (rcirc-send-string process (concat "PING " rcirc-server))))
            (rcirc-process-list))
    (cancel-timer rcirc-keepalive-timer)
    (setq rcirc-keepalive-timer nil)))

(defvar rcirc-debug-buffer " *rcirc debug*")

Function is called with PROCESS COMMAND SENDER ARGS and LINE.")
(defun rcirc-filter (process output)
  "Called when PROCESS receives OUTPUT."
  (rcirc-debug process output)
  (with-rcirc-process-buffer process
    (setq rcirc-process-output (concat rcirc-process-output output))
    (when (= (aref rcirc-process-output
                   (1- (length rcirc-process-output))) ?\n)
      (mapc (lambda (line)
              (rcirc-process-server-response process line))

  (setq rcirc-input-ring (make-ring rcirc-input-ring-size))
  (make-local-variable 'rcirc-process)
  (setq rcirc-process process)
  (make-local-variable 'rcirc-target)
  (setq rcirc-target target)

  (make-local-variable 'rcirc-short-buffer-name)
  (setq rcirc-short-buffer-name nil)
  (make-local-variable 'rcirc-urls)
  (setq rcirc-urls nil)

		    (eq rcirc-process process))))
	buffer
      (process-buffer process))))

(defun rcirc-format-response-string (process sender response target text)
  (concat (when rcirc-time-format
            (format-time-string rcirc-time-format (current-time)))
          (cond ((or (string= response "PRIVMSG")
                     (string= response "NOTICE")
                     (string= response "ACTION"))
                 (let (first middle end)
                   (cond ((string= response "PRIVMSG")

                 (propertize (concat "!!! " text)
			     'face 'font-lock-warning-face))
                (t
                 (rcirc-mangle-text
                  process
                  (rcirc-facify
                   (concat "*** "
			   (when (not (string= sender (rcirc-server process)))
			     (concat (rcirc-user-nick sender) " "))
			   (when (zerop (string-to-number response))
			     (concat response " "))
                           text)
                   'rcirc-server))))))

(defvar rcirc-activity-type nil)
(make-variable-buffer-local 'rcirc-activity-type)
(defun rcirc-print (process sender response target text &optional activity)
  "Print TEXT in the buffer associated with TARGET.

(defun rcirc-facify (string face)
  "Return a copy of STRING with FACE property added."
  (propertize (or string "") 'face face 'rear-nonsticky t))

;; shy grouping must be used within this regexp
(defvar rcirc-url-regexp
  "\\b\\(?:\\(?:www\\.\\|\\(?:s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\
\\|wais\\|mailto\\):\\)\\(?://[-a-zA-Z0-9_.]+:[0-9]*\\)?\\(?:[-a-zA-Z0-9_=!?#$\
@~`%&*+|\\/:;.,]\\|\\w\\)+\\(?:[-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)"
  "Regexp matching URL's.  Set to nil to disable URL features in rcirc.")

(defun rcirc-browse-url (&optional arg)
  "Prompt for url to browse based on urls in buffer."
  (interactive)

(defun rcirc-mangle-text (process text)
  "Return TEXT with properties added based on various patterns."
  ;; ^B
  (setq text
        (rcirc-map-regexp (lambda (start end string)
                            (add-text-properties
                             start end
                             (list 'face 'bold 'rear-nonsticky t)
                             string))
                          ".*?"
                          text))
  (while (string-match "\\(.*\\)[
]\\(.*\\)" text) ; deal with 
    (setq text (concat (match-string 1 text)
                       (match-string 2 text))))
  ;; my nick
  (setq text
        (with-syntax-table rcirc-nick-syntax-table

  (setq text
        (rcirc-map-regexp
	 (lambda (start end string)
	   (let ((orig-face (get-text-property start 'face string)))
	     (add-text-properties start end
				  (list 'face (list orig-face 'bold)
					'rear-nonsticky t
					'mouse-face 'highlight
					'keymap rcirc-browse-url-map)
				  string))
	     (push (substring string start end) rcirc-urls))

(defgroup rcirc-faces nil
  "Faces for rcirc."
  :group 'rcirc
  :group 'faces)

(defface rcirc-my-nick
  '((((type tty) (class color)) (:foreground "blue" :weight bold))
    (((class color) (background light)) (:foreground "Blue"))
    (((class color) (background dark)) (:foreground "LightSkyBlue"))
    (t (:inverse-video t :bold t)))
  "The face used to highlight my messages."
  :group 'rcirc-faces)

(defface rcirc-other-nick
  '((((type tty) (class color)) (:foreground "yellow" :weight light))
    (((class grayscale) (background light))
     (:foreground "Gray90" :bold t :italic t))
    (((class grayscale) (background dark))
     (:foreground "DimGray" :bold t :italic t))
    (((class color) (background light)) (:foreground "DarkGoldenrod"))
    (((class color) (background dark)) (:foreground "LightGoldenrod"))
    (t (:bold t :italic t)))
  "The face used to highlight other messages."
  :group 'rcirc-faces)

(defface rcirc-server
  '((((type tty pc) (class color) (background light)) (:foreground "red"))
    (((type tty pc) (class color) (background dark)) (:foreground "red1"))
    (((class grayscale) (background light))
     (:foreground "DimGray" :bold t :italic t))
    (((class grayscale) (background dark))
     (:foreground "LightGray" :bold t :italic t))
    (((class color) (background light)) (:foreground "gray40"))
    (((class color) (background dark)) (:foreground "chocolate1"))
    (t (:bold t :italic t)))
  "The face used to highlight server messages."
  :group 'rcirc-faces)

(defface rcirc-nick-in-message
  '((((type tty) (class color)) (:foreground "cyan" :weight bold))
    (((class grayscale) (background light)) (:foreground "LightGray" :bold t))
    (((class grayscale) (background dark)) (:foreground "DimGray" :bold t))
    (((class color) (background light)) (:foreground "Purple"))
    (((class color) (background dark)) (:foreground "Cyan"))
    (t (:bold t)))
  "The face used to highlight instances of nick within messages."
  :group 'rcirc-faces)

(defface rcirc-prompt
  '((((background dark)) (:foreground "cyan"))
    (t (:foreground "dark blue")))
  "The face to use to highlight prompts."
  :group 'rcirc-faces)

(defface rcirc-mode-line-nick

67014:d3d8e2bcfa98


(defvar rcirc-process-output nil)
(defvar rcirc-topic nil)
(defvar rcirc-keepalive-timer nil)
(defvar rcirc-last-server-message-time nil)
(defun rcirc-connect (server port nick user-name full-name startup-channels)
  "Return a connection to SERVER on PORT.

User will identify using the values of NICK, USER-NAME and
FULL-NAME.  The variable list of channel names in

      (setq rcirc-nick nick)
      (make-local-variable 'rcirc-process-output)
      (setq rcirc-process-output nil)
      (make-local-variable 'rcirc-startup-channels)
      (setq rcirc-startup-channels startup-channels)
      (make-local-variable 'rcirc-last-server-message-time)
      (setq rcirc-last-server-message-time (current-time))

      ;; identify
      (rcirc-send-string process (concat "NICK " nick))
      (rcirc-send-string process (concat "USER " user-name
                                      " hostname servername :"

  (declare (indent 1) (debug t))
  `(with-current-buffer (process-buffer ,process)
     ,@body))

(defun rcirc-keepalive ()
  "Send keep alive pings to active rcirc processes.
Kill processes that have not received a server message since the
last ping."
  (if (rcirc-process-list)
      (mapc (lambda (process)
              (with-rcirc-process-buffer process
		(if (> (cadr (time-since rcirc-last-server-message-time))
		       rcirc-keepalive-seconds)
		    (kill-process process)
		  (rcirc-send-string process (concat "PING " rcirc-server)))))
            (rcirc-process-list))
    (cancel-timer rcirc-keepalive-timer)
    (setq rcirc-keepalive-timer nil)))

(defvar rcirc-debug-buffer " *rcirc debug*")

Function is called with PROCESS COMMAND SENDER ARGS and LINE.")
(defun rcirc-filter (process output)
  "Called when PROCESS receives OUTPUT."
  (rcirc-debug process output)
  (with-rcirc-process-buffer process
    (setq rcirc-last-server-message-time (current-time))
    (setq rcirc-process-output (concat rcirc-process-output output))
    (when (= (aref rcirc-process-output
                   (1- (length rcirc-process-output))) ?\n)
      (mapc (lambda (line)
              (rcirc-process-server-response process line))

  (setq rcirc-input-ring (make-ring rcirc-input-ring-size))
  (make-local-variable 'rcirc-process)
  (setq rcirc-process process)
  (make-local-variable 'rcirc-target)
  (setq rcirc-target target)
  (make-local-variable 'rcirc-topic)
  (setq rcirc-topic nil)

  (make-local-variable 'rcirc-short-buffer-name)
  (setq rcirc-short-buffer-name nil)
  (make-local-variable 'rcirc-urls)
  (setq rcirc-urls nil)

		    (eq rcirc-process process))))
	buffer
      (process-buffer process))))

(defun rcirc-format-response-string (process sender response target text)
  (concat (rcirc-facify (format-time-string rcirc-time-format (current-time))
			'rcirc-timestamp)
          (cond ((or (string= response "PRIVMSG")
                     (string= response "NOTICE")
                     (string= response "ACTION"))
                 (let (first middle end)
                   (cond ((string= response "PRIVMSG")

                 (propertize (concat "!!! " text)
			     'face 'font-lock-warning-face))
                (t
                 (rcirc-mangle-text
                  process
		  (concat (rcirc-facify "*** " 'rcirc-server-prefix)
			  (rcirc-facify
			   (concat
			    (when (not (string= sender (rcirc-server process)))
			      (concat (rcirc-user-nick sender) " "))
			    (when (zerop (string-to-number response))
			      (concat response " "))
			    text)
			   'rcirc-server)))))))

(defvar rcirc-activity-type nil)
(make-variable-buffer-local 'rcirc-activity-type)
(defun rcirc-print (process sender response target text &optional activity)
  "Print TEXT in the buffer associated with TARGET.

(defun rcirc-facify (string face)
  "Return a copy of STRING with FACE property added."
  (propertize (or string "") 'face face 'rear-nonsticky t))

(defvar rcirc-url-regexp
  (rx word-boundary 
      (or "www."
	  (and (or "http" "https" "ftp" "file" "gopher" "news" "telnet" "wais" 
		   "mailto")
	       "://"
	       (1+ (char "a-zA-Z0-9_."))
	       (optional ":" (1+ (char "0-9")))))
      (1+ (char "-a-zA-Z0-9_=!?#$\@~`%&*+|\\/:;.,"))
      (char "-a-zA-Z0-9_=!?#$\@~`%&*+|\\/:;"))
  "Regexp matching URL's.  Set to nil to disable URL features in rcirc.")

(defun rcirc-browse-url (&optional arg)
  "Prompt for url to browse based on urls in buffer."
  (interactive)

(defun rcirc-mangle-text (process text)
  "Return TEXT with properties added based on various patterns."
  ;; ^B
  (setq text
        (rcirc-map-regexp 
	 (lambda (start end string)
	   (let ((orig-face (get-text-property start 'face string)))
	       (add-text-properties
		start end
		(list 'face (if (listp orig-face)
				(append orig-face 
					(list 'bold))
			      (list orig-face 'bold))
		      'rear-nonsticky t)
		string)))
	   ".*?"
	   text))
  ;; TODO: deal with ^_ and ^C colors sequences
  (while (string-match "\\(.*\\)[
]\\(.*\\)" text) 
    (setq text (concat (match-string 1 text)
                       (match-string 2 text))))
  ;; my nick
  (setq text
        (with-syntax-table rcirc-nick-syntax-table

  (setq text
        (rcirc-map-regexp
	 (lambda (start end string)
	   (let ((orig-face (get-text-property start 'face string)))
	     (add-text-properties start end
				  (list 'face (if (listp orig-face)
						  (append orig-face 
							  (list 'bold))
						(list orig-face 'bold))
					'rear-nonsticky t
					'mouse-face 'highlight
					'keymap rcirc-browse-url-map)
				  string))
	     (push (substring string start end) rcirc-urls))

(defgroup rcirc-faces nil
  "Faces for rcirc."
  :group 'rcirc
  :group 'faces)

(defface rcirc-my-nick			; font-lock-function-name-face
  '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
    (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
    (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
    (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
    (((class color) (min-colors 8)) (:foreground "blue" :weight bold))
    (t (:inverse-video t :weight bold)))
  "The face used to highlight my messages."
  :group 'rcirc-faces)

(defface rcirc-other-nick	     ; font-lock-variable-name-face
  '((((class grayscale) (background light))
     (:foreground "Gray90" :weight bold :slant italic))
    (((class grayscale) (background dark))
     (:foreground "DimGray" :weight bold :slant italic))
    (((class color) (min-colors 88) (background light)) (:foreground "DarkGoldenrod"))
    (((class color) (min-colors 88) (background dark)) (:foreground "LightGoldenrod"))
    (((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
    (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
    (((class color) (min-colors 8)) (:foreground "yellow" :weight light))
    (t (:weight bold :slant italic)))
  "The face used to highlight other messages."
  :group 'rcirc-faces)

(defface rcirc-server			; font-lock-comment-face
  '((((class grayscale) (background light))
     (:foreground "DimGray" :weight bold :slant italic))
    (((class grayscale) (background dark))
     (:foreground "LightGray" :weight bold :slant italic))
    (((class color) (min-colors 88) (background light))
     (:foreground "Firebrick"))
    (((class color) (min-colors 88) (background dark))
     (:foreground "chocolate1"))
    (((class color) (min-colors 16) (background light))
     (:foreground "red"))
    (((class color) (min-colors 16) (background dark))
     (:foreground "red1"))
    (((class color) (min-colors 8) (background light))
     )
    (((class color) (min-colors 8) (background dark))
     )
    (t (:weight bold :slant italic)))
  "The face used to highlight server messages."
  :group 'rcirc-faces)

(defface rcirc-server-prefix	 ; font-lock-comment-delimiter-face
  '((default :inherit font-lock-comment-face)
    (((class grayscale)))
    (((class color) (min-colors 16)))
    (((class color) (min-colors 8) (background light))
     :foreground "red")
    (((class color) (min-colors 8) (background dark))
     :foreground "red1"))
  "The face used to highlight server prefixes."
  :group 'rcirc-faces)

(defface rcirc-timestamp
  '((t (:inherit default)))
  "The face used to highlight timestamps."
  :group 'rcirc-faces)

(defface rcirc-nick-in-message		; font-lock-keyword-face
  '((((class grayscale) (background light)) (:foreground "LightGray" :weight bold))
    (((class grayscale) (background dark)) (:foreground "DimGray" :weight bold))
    (((class color) (min-colors 88) (background light)) (:foreground "Purple"))
    (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1"))
    (((class color) (min-colors 16) (background light)) (:foreground "Purple"))
    (((class color) (min-colors 16) (background dark)) (:foreground "Cyan"))
    (((class color) (min-colors 8)) (:foreground "cyan" :weight bold))
    (t (:weight bold)))
  "The face used to highlight instances of nick within messages."
  :group 'rcirc-faces)

(defface rcirc-prompt			; comint-highlight-prompt
  '((((min-colors 88) (background dark)) (:foreground "cyan1"))
    (((background dark)) (:foreground "cyan"))
    (t (:foreground "dark blue")))
  "The face to use to highlight prompts."
  :group 'rcirc-faces)

(defface rcirc-mode-line-nick