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

   1 ;;; riece-misc.el --- miscellaneous functions (not inlined)
   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 (goto-char (point-max)))
  73             window
  74             point)
  75         (insert (format-time-string "%H:%M") " " string)
  76         (setq point (point))
  77         (if (and (not (riece-frozen (current-buffer)))
  78                  (setq window (get-buffer-window (current-buffer)))
  79                  (not (pos-visible-in-window-p point window)))
  80             (save-excursion             ;save-selected-window changes
  81                                         ;current buffer
  82               (save-selected-window
  83                 (select-window window)
  84                 (goto-char point)       ;select-window changes current point
  85                 (recenter riece-window-center-line))))
  86         (run-hook-with-args 'riece-after-insert-functions start (point))))
  87     (setq buffers (cdr buffers))))
  88
  89 (defun riece-insert-change (buffer message)
  90   (riece-insert buffer (concat riece-change-prefix message)))
  91
  92 (defun riece-insert-notice (buffer message)
  93   (riece-insert buffer (concat riece-notice-prefix message)))
  94
  95 (defun riece-insert-wallops (buffer message)
  96   (riece-insert buffer (concat riece-wallops-prefix message)))
  97
  98 (defun riece-insert-error (buffer message)
  99   (riece-insert buffer (concat riece-error-prefix message)))
 100
 101 (defun riece-insert-info (buffer message)
 102   (riece-insert buffer (concat riece-info-prefix message)))
 103
 104 (defun riece-frozen (buffer)
 105   (with-current-buffer buffer
 106     riece-freeze))
 107
 108 (defun riece-own-frozen (buffer)
 109   (with-current-buffer buffer
 110     (eq riece-freeze 'own)))
 111
 112 (defun riece-channel-p (string)
 113   "Return t if STRING is a channel.
 114 \(i.e. it matches `riece-channel-regexp')"
 115   (string-match (concat "^" riece-channel-regexp) string))
 116
 117 (defun riece-user-p (string)
 118   "Return t if STRING is a user.
 119 \(i.e. it matches `riece-user-regexp')"
 120   (string-match (concat "^" riece-user-regexp) string))
 121
 122 (defun riece-current-nickname ()
 123   "Return the current nickname."
 124   (riece-with-server-buffer (riece-current-server-name)
 125     (if riece-real-nickname
 126         (riece-make-identity riece-real-nickname riece-server-name))))
 127
 128 (defun riece-split-parameters (string)
 129   (if (eq ?: (aref string 0))
 130       (list (substring string 1))
 131     (let (parameters)
 132       (catch 'done
 133         (while (string-match "^\\([^ ]+\\) +" string)
 134           (setq parameters (nconc parameters (list (match-string 1 string)))
 135                 string (substring string (match-end 0)))
 136           (when (and (not (equal "" string)) (eq ?: (aref string 0)))
 137             (setq string (substring string 1)
 138                   parameters (nconc parameters (list string)))
 139             (throw 'done nil)))
 140         (or (equal "" string)
 141             (setq parameters (nconc parameters (list string)))))
 142       parameters)))
 143
 144 (defun riece-concat-channel-topic (target string)
 145   (riece-with-server-buffer (riece-identity-server target)
 146     (let ((topic (riece-channel-get-topic (riece-identity-prefix target))))
 147       (if (or (null topic)
 148               (equal topic ""))
 149           string
 150         (concat string ": " topic)))))
 151
 152 (defun riece-concat-channel-modes (target string)
 153   (riece-with-server-buffer (riece-identity-server target)
 154     (let ((modes (riece-channel-get-modes (riece-identity-prefix target))))
 155       (if modes
 156           (concat string " ["
 157                   (mapconcat
 158                    (lambda (mode)
 159                      (if (riece-mode-parameter mode)
 160                          (format "%c(%s)"
 161                                  (riece-mode-flag mode)
 162                                  (riece-mode-parameter mode))
 163                        (char-to-string (riece-mode-flag mode))))
 164                    modes "")
 165                   "]")
 166         string))))
 167
 168 (defun riece-concat-message (string message)
 169   (if (or (null message)
 170           (equal message ""))
 171       string
 172     (concat string " (" message ")")))
 173
 174 (defun riece-concat-server-name (string)
 175   (if (equal riece-server-name "")
 176       string
 177     (let ((server-name (concat " (from " riece-server-name ")")))
 178       (put-text-property 0 (length server-name)
 179                          'riece-server-name riece-server-name
 180                          server-name)
 181       (concat string server-name))))
 182
 183 (defun riece-concat-user-status (status string)
 184   (if status
 185       (concat string " [" (mapconcat #'identity status ", ") "]")
 186     string))
 187
 188 (defun riece-prefix-user-at-host (prefix)
 189   (if (string-match "!" prefix)
 190       (substring prefix (match-end 0))
 191     prefix))
 192
 193 (defun riece-prefix-nickname (prefix)
 194   (if (string-match "!" prefix)
 195       (substring prefix 0 (match-beginning 0))
 196     prefix))
 197
 198 (defun riece-parse-user-at-host (user-at-host)
 199   (if (memq (aref user-at-host 0) '(?^ ?= ?~ ?- ?+))
 200       (progn
 201         (if (memq (aref user-at-host 0) '(?^ ?=))
 202             (setq riece-user-at-host-type 'fake)
 203           (if (memq (aref user-at-host 0) '(?~ ?-))
 204               (setq riece-user-at-host-type 'not-verified)
 205             (if (eq (aref user-at-host 0) ?+)
 206                 (setq riece-user-at-host-type 'ok))))
 207         (substring user-at-host 1))
 208     (setq riece-user-at-host-type 'ok)
 209     user-at-host))
 210
 211 (defun riece-strip-user-at-host (user-at-host)
 212   (if (memq (aref user-at-host 0) '(?^ ?= ?~ ?- ?+))
 213       (substring user-at-host 1)
 214     user-at-host))
 215
 216 (defun riece-get-users-on-server (server-name)
 217   (riece-with-server-buffer server-name
 218     (let (identities)
 219       (mapatoms
 220        (lambda (user)
 221          (setq identities
 222                (cons (riece-make-identity (symbol-name user) server-name)
 223                      identities)))
 224        (riece-cache-hash-obarray riece-user-cache))
 225       identities)))
 226
 227 (defun riece-get-channels-on-server (server-name)
 228   (riece-with-server-buffer server-name
 229     (let (identities)
 230       (mapatoms
 231        (lambda (channel)
 232          (setq identities
 233                (cons (riece-make-identity (symbol-name channel) server-name)
 234                      identities)))
 235        (riece-cache-hash-obarray riece-channel-cache))
 236       identities)))
 237
 238 (defun riece-get-identities-on-server (server-name)
 239   (nconc (riece-get-channels-on-server server-name)
 240          (riece-get-users-on-server server-name)))
 241
 242 (defun riece-check-channel-commands-are-usable (&optional channel)
 243    (unless riece-current-channel
 244      (error (substitute-command-keys
 245              "Type \\[riece-command-join] to join a channel")))
 246    (if (and channel
 247             (not (riece-channel-p (riece-identity-prefix
 248                                    riece-current-channel))))
 249        (error "Not on a channel")))
 250
 251 (provide 'riece-misc)
 252
 253 ;;; riece-misc.el ends here