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