cgit.sxemacs.org Git - riece/blob - lisp/riece-misc.el

   1 ;;; riece-misc.el --- miscellaneous functions (not inlined) -*- lexical-binding: t -*-
   2 ;; Copyright (C) 1998-2003 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Keywords: IRC, riece
   7
   8 ;; This file is part of Riece.
   9
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Code:
  26
  27 (require 'riece-options)
  28 (require 'riece-coding)
  29 (require 'riece-identity)
  30 (require 'riece-version)
  31 (require 'riece-channel)
  32 (require 'riece-server)
  33 (require 'riece-user)
  34 (require 'riece-mode)
  35 (require 'riece-cache)
  36
  37 (defun riece-get-buffer-create (name &optional init-major-mode)
  38   (let ((buffer (get-buffer name)))
  39     (unless (and buffer
  40                  (or (null init-major-mode)
  41                      (eq (with-current-buffer buffer
  42                            major-mode)
  43                          init-major-mode)))
  44       (setq buffer (generate-new-buffer name)))
  45     (unless (memq buffer riece-buffer-list)
  46       (setq riece-buffer-list (cons buffer riece-buffer-list)))
  47     buffer))
  48
  49 (defun riece-scan-property-region (property start end function)
  50   (catch 'done
  51     (while t
  52       ;; Search for the beginning of the property region.
  53       (unless (get-text-property start property)
  54         (setq start (next-single-property-change start property nil end)))
  55       (if (= start end)
  56           (throw 'done nil))
  57       ;; Search for the end of the property region.
  58       (let ((region-end (next-single-property-change start property nil end)))
  59         (if (= region-end end)
  60             (throw 'done nil))
  61         (funcall function start region-end)
  62         (setq start region-end)))))
  63
  64 (defun riece-insert (buffers string)
  65   (unless (listp buffers)
  66     (setq buffers (list buffers)))
  67   (while buffers
  68     (run-hooks 'riece-before-insert-functions)
  69     (with-current-buffer (car buffers)
  70       (let ((inhibit-read-only t)
  71             buffer-read-only
  72             start
  73             window
  74             point)
  75         ;; Save the current for the case when (car buffers) is the
  76         ;; currently selected buffer.
  77         (save-excursion
  78           (setq start (goto-char (point-max)))
  79           (insert (format-time-string "%H:%M") " " string)
  80           (setq point (point)))
  81         (if (and (not (riece-frozen (current-buffer)))
  82                  (setq window (get-buffer-window (current-buffer)))
  83                  (not (pos-visible-in-window-p point window)))
  84             (save-excursion             ;save-selected-window changes
  85                                         ;current buffer
  86               (save-selected-window
  87                 (select-window window)
  88                 (goto-char point)       ;select-window changes current point
  89                 (recenter riece-window-center-line))))
  90         (run-hook-with-args 'riece-after-insert-functions start point)))
  91     (setq buffers (cdr buffers))))
  92
  93 (defun riece-insert-change (buffer message)
  94   (riece-insert buffer (concat riece-change-prefix message)))
  95
  96 (defun riece-insert-notice (buffer message)
  97   (riece-insert buffer (concat riece-notice-prefix message)))
  98
  99 (defun riece-insert-wallops (buffer message)
 100   (riece-insert buffer (concat riece-wallops-prefix message)))
 101
 102 (defun riece-insert-error (buffer message)
 103   (riece-insert buffer (concat riece-error-prefix message)))
 104
 105 (defun riece-insert-info (buffer message)
 106   (riece-insert buffer (concat riece-info-prefix message)))
 107
 108 (defun riece-frozen (buffer)
 109   (with-current-buffer buffer
 110     riece-freeze))
 111
 112 (defun riece-own-frozen (buffer)
 113   (with-current-buffer buffer
 114     (eq riece-freeze 'own)))
 115
 116 (defun riece-channel-p (string)
 117   "Return t if STRING is a channel.
 118 \(i.e. it matches `riece-channel-regexp')"
 119   (string-match (concat "^" riece-channel-regexp) string))
 120
 121 (defun riece-user-p (string)
 122   "Return t if STRING is a user.
 123 \(i.e. it matches `riece-user-regexp')"
 124   (string-match (concat "^" riece-user-regexp) string))
 125
 126 (defun riece-current-nickname ()
 127   "Return the current nickname."
 128   (riece-with-server-buffer (riece-current-server-name)
 129     (if riece-real-nickname
 130         (riece-make-identity riece-real-nickname riece-server-name))))
 131
 132 (defun riece-split-parameters (string)
 133   (if (eq ?: (aref string 0))
 134       (list (substring string 1))
 135     (let (parameters)
 136       (catch 'done
 137         (while (string-match "^\\([^ ]+\\) +" string)
 138           (setq parameters (nconc parameters (list (match-string 1 string)))
 139                 string (substring string (match-end 0)))
 140           (when (and (not (equal "" string)) (eq ?: (aref string 0)))
 141             (setq string (substring string 1)
 142                   parameters (nconc parameters (list string)))
 143             (throw 'done nil)))
 144         (or (equal "" string)
 145             (setq parameters (nconc parameters (list string)))))
 146       parameters)))
 147
 148 (defun riece-concat-channel-topic (target string)
 149   (riece-with-server-buffer (riece-identity-server target)
 150     (let ((topic (riece-channel-get-topic (riece-identity-prefix target))))
 151       (if (or (null topic)
 152               (equal topic ""))
 153           string
 154         (concat string ": " topic)))))
 155
 156 (defun riece-concat-channel-modes (target string)
 157   (riece-with-server-buffer (riece-identity-server target)
 158     (let ((modes (riece-channel-get-modes (riece-identity-prefix target))))
 159       (if modes
 160           (concat string " ["
 161                   (mapconcat
 162                    (lambda (mode)
 163                      (if (riece-mode-parameter mode)
 164                          (format "%c(%s)"
 165                                  (riece-mode-flag mode)
 166                                  (riece-mode-parameter mode))
 167                        (char-to-string (riece-mode-flag mode))))
 168                    modes "")
 169                   "]")
 170         string))))
 171
 172 (defun riece-concat-message (string message)
 173   (if (or (null message)
 174           (equal message ""))
 175       string
 176     (concat string " (" message ")")))
 177
 178 (defun riece-concat-server-name (string)
 179   (if (equal riece-server-name "")
 180       string
 181     (let ((server-name (concat " (from " riece-server-name ")")))
 182       (put-text-property 0 (length server-name)
 183                          'riece-server-name riece-server-name
 184                          server-name)
 185       (concat string server-name))))
 186
 187 (defun riece-concat-user-status (status string)
 188   (if status
 189       (concat string " [" (mapconcat #'identity status ", ") "]")
 190     string))
 191
 192 (defun riece-prefix-user-at-host (prefix)
 193   (if (string-match "!" prefix)
 194       (substring prefix (match-end 0))
 195     prefix))
 196
 197 (defun riece-prefix-nickname (prefix)
 198   (if (string-match "!" prefix)
 199       (substring prefix 0 (match-beginning 0))
 200     prefix))
 201
 202 (defun riece-parse-user-at-host (user-at-host)
 203   (if (memq (aref user-at-host 0) '(?^ ?= ?~ ?- ?+))
 204       (progn
 205         (if (memq (aref user-at-host 0) '(?^ ?=))
 206             (setq riece-user-at-host-type 'fake)
 207           (if (memq (aref user-at-host 0) '(?~ ?-))
 208               (setq riece-user-at-host-type 'not-verified)
 209             (if (eq (aref user-at-host 0) ?+)
 210                 (setq riece-user-at-host-type 'ok))))
 211         (substring user-at-host 1))
 212     (setq riece-user-at-host-type 'ok)
 213     user-at-host))
 214
 215 (defun riece-strip-user-at-host (user-at-host)
 216   (if (memq (aref user-at-host 0) '(?^ ?= ?~ ?- ?+))
 217       (substring user-at-host 1)
 218     user-at-host))
 219
 220 (defun riece-get-users-on-server (server-name)
 221   (riece-with-server-buffer server-name
 222     (let (identities)
 223       (mapatoms
 224        (lambda (user)
 225          (setq identities
 226                (cons (riece-make-identity (symbol-name user) server-name)
 227                      identities)))
 228        (riece-cache-hash-obarray riece-user-cache))
 229       identities)))
 230
 231 (defun riece-get-channels-on-server (server-name)
 232   (riece-with-server-buffer server-name
 233     (let (identities)
 234       (mapatoms
 235        (lambda (channel)
 236          (setq identities
 237                (cons (riece-make-identity (symbol-name channel) server-name)
 238                      identities)))
 239        (riece-cache-hash-obarray riece-channel-cache))
 240       identities)))
 241
 242 (defun riece-get-identities-on-server (server-name)
 243   (nconc (riece-get-channels-on-server server-name)
 244          (riece-get-users-on-server server-name)))
 245
 246 (defun riece-check-channel-commands-are-usable (&optional channel)
 247    (unless riece-current-channel
 248      (error (substitute-command-keys
 249              "Type \\[riece-command-join] to join a channel")))
 250    (if (and channel
 251             (not (riece-channel-p (riece-identity-prefix
 252                                    riece-current-channel))))
 253        (error "Not on a channel")))
 254
 255 (provide 'riece-misc)
 256
 257 ;;; riece-misc.el ends here