lisp/liece-misc.el

   1 ;;; liece-misc.el --- Miscellaneous routines.
   2 ;; Copyright (C) 1998-2000 Daiki Ueno
   3
   4 ;; Author: Daiki Ueno <ueno@unixuser.org>
   5 ;; Created: 1998-09-28
   6 ;; Revised: 1998-11-25
   7 ;; Keywords: IRC, liece
   8
   9 ;; This file is part of Liece.
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26
  27 ;;; Commentary:
  28 ;;
  29
  30 ;;; Code:
  31
  32 (eval-and-compile
  33   (require 'broken)
  34   (require 'pccl)
  35   (require 'invisible)
  36   (require 'liece-inlines)
  37   (require 'liece-coding))
  38
  39 (eval-when-compile
  40   (autoload '_ "liece-intl" nil nil 'macro))
  41
  42 (defun liece-toggle-command-buffer-mode (&optional mode)
  43   "Toggle command buffer MODE."
  44   (let ((mode
  45          (or mode
  46              (if (eq liece-command-buffer-mode 'chat)
  47                  'channel
  48                'chat)))
  49         (hide (get 'liece-nick-buffer-mode 'hide)))
  50     (cond
  51      ((eq mode 'chat)
  52       (put 'liece-nick-buffer-mode 'hide t)
  53       (setq liece-private-indicator "P"))
  54      (t
  55       (put 'liece-nick-buffer-mode 'hide nil)
  56       (setq liece-private-indicator "-")))
  57     (and (not (eq liece-command-buffer-mode mode))
  58          (not (eq hide (get 'liece-nick-buffer-mode 'hide)))
  59          liece-nick-window-auto-hide
  60          (liece-configure-windows))
  61     (setq liece-command-buffer-mode mode)
  62     liece-command-buffer-mode))
  63
  64 (defsubst liece-set-frame-title-format ()
  65   "Inline function for modifying `frame-title-format'."
  66   (let ((frame-indicator liece-channel-indicator))
  67     (when (eq liece-command-buffer-mode 'channel)
  68       (if liece-display-status-on-channel-indicator
  69           (setq frame-indicator liece-channel-indicator)
  70         (setq frame-indicator
  71               (format "%s: %s [%s]"
  72                       liece-channel-indicator
  73                       (or (and liece-current-channel
  74                                (liece-channel-get-topic))
  75                           "")
  76                       (or (and liece-current-channel
  77                                (liece-channel-get-modes))
  78                           "")))))
  79     (setq liece-channel-status-indicator frame-indicator)))
  80
  81 (defsubst liece-set-channel-indicator ()
  82   "Inline-function for modifying `liece-channel-indicator'."
  83   (if (eq liece-command-buffer-mode 'chat)
  84       (setq liece-channel-indicator
  85             (if liece-current-chat-partner
  86                 (format (_ "Chatting with %s")
  87                         liece-current-chat-partner)
  88               (_ "No partner")))
  89     (setq liece-channel-indicator
  90           (if liece-current-channel
  91               (concat liece-current-channel
  92                       (if liece-display-status-on-channel-indicator
  93                           (format ": %s [%s]"
  94                                   (or (and liece-current-channel
  95                                            (liece-channel-get-topic))
  96                                       "")
  97                                   (or (and liece-current-channel
  98                                            (liece-channel-get-modes))
  99                                       ""))
 100                         ""))
 101             (_ "No channel"))))
 102   (with-current-buffer liece-command-buffer
 103     (force-mode-line-update))
 104   (if liece-display-frame-title
 105       (liece-set-frame-title-format)))
 106
 107 (defun liece-freeze (buffer &optional arg)
 108   (with-current-buffer buffer
 109     (setq liece-freeze (if arg (plusp arg) (not liece-freeze))
 110           liece-freeze-indicator (if liece-freeze "F" "-"))
 111     (force-mode-line-update)))
 112
 113 (defmacro liece-frozen (buffer)
 114   (list 'with-current-buffer buffer 'liece-freeze))
 115
 116 (defun liece-own-freeze (buffer &optional arg)
 117   (with-current-buffer buffer
 118     (setq liece-own-freeze (if arg (plusp arg) (not liece-own-freeze))
 119           liece-own-freeze-indicator (if liece-own-freeze "M" "-"))
 120     (force-mode-line-update)))
 121
 122 (defmacro liece-own-frozen (buffer)
 123   (list 'with-current-buffer buffer 'liece-own-freeze))
 124
 125 (defun liece-ignore-this-p (nick user-at-host)
 126   ;; Remove entries which are expired.
 127   (let ((time (current-time)) expire-time)
 128     (dolist (kill liece-kill-nickname)
 129       (setq expire-time (if (cdr kill)
 130                             (liece-time-difference time (cdr kill))
 131                           1))
 132       (when (< expire-time 0)
 133         (if (zerop (cadddr kill))
 134             (liece-insert-info liece-D-buffer
 135                                (format (_ "Ignore timeout for %s expired.\n")
 136                                        (car kill))))
 137         (when (setq kill (string-assoc-ignore-case
 138                           (car kill) liece-kill-nickname))
 139           (setq liece-kill-nickname (delq kill liece-kill-nickname)
 140                 liece-save-variables-are-dirty t)))))
 141   ;; Search on `liece-kill-nickname' and return non-nil if matches.
 142   (unless (run-hook-with-args-until-success
 143            'liece-custom-ignore-this-p nick user-at-host)
 144     (let ((case-fold-search t))
 145       (member-if
 146        (lambda (kill)
 147          (or (liece-nick-equal (car kill) nick)
 148              (string-match (concat "\\<" (car kill) "\\>") nick)
 149              (and (string-match "@" (car kill))
 150                   (or (string-equal-ignore-case
 151                        (car kill) user-at-host)
 152                       (string-match (concat "^" (car kill) "$")
 153                                     user-at-host)))))
 154        liece-kill-nickname))))
 155
 156 (defun liece-split-line (line)
 157   (cond
 158    ((eq ?: (aref line 0))
 159     (list (substring line 1)))
 160    (t
 161     (let (args)
 162       (catch 'done
 163         (while (string-match "^\\([^ ]+\\) +" line)
 164           (setq args (nconc args (list (match-string 1 line)))
 165                 line (substring line (match-end 0)))
 166           (and (not (string= "" line)) (eq ?: (aref line 0))
 167                (setq line (substring line 1))
 168                (throw 'done nil))))
 169       (or (string= "" line)
 170           (setq args (nconc args (list line))))
 171       args))))
 172
 173 (defmacro liece-message (&rest msg)
 174   `(message "%s: %s"
 175             (product-name (product-find 'liece-version))
 176             (format ,@msg)))
 177
 178 (defmacro liece-insert-change (buffer msg)
 179   `(liece-insert ,buffer (concat liece-change-prefix ,msg)))
 180
 181 (defmacro liece-insert-notice (buffer msg)
 182   `(liece-insert ,buffer (concat liece-notice-prefix ,msg)))
 183
 184 (defmacro liece-insert-broadcast (buffer msg)
 185   `(liece-insert ,buffer (concat liece-broadcast-prefix ,msg)))
 186
 187 (defmacro liece-insert-wallops (buffer msg)
 188   `(liece-insert ,buffer (concat liece-wallops-prefix ,msg)))
 189
 190 (defmacro liece-insert-error (buffer msg)
 191   `(liece-insert ,buffer (concat liece-error-prefix ,msg)))
 192
 193 (defmacro liece-insert-info (buffer msg)
 194   `(liece-insert ,buffer (concat liece-info-prefix ,msg)))
 195
 196 (defmacro liece-insert-timestamp (buffer msg)
 197   `(liece-insert ,buffer (concat liece-timestamp-prefix ,msg)))
 198
 199 (defmacro liece-insert-dcc (buffer msg)
 200   `(liece-insert ,buffer (concat liece-dcc-prefix ,msg)))
 201
 202 (defmacro liece-insert-client (buffer msg)
 203   `(liece-insert ,buffer (concat liece-client-prefix ,msg)))
 204
 205 (defmacro liece-own-message (message)
 206   `(if (eq liece-command-buffer-mode 'channel)
 207        (liece-own-channel-message ,message)
 208      (liece-own-channel-message ,message)))
 209
 210 (defmacro liece-own-channel-message (message &optional chnl)
 211   `(let* ((chnl (or ,chnl (liece-current-channel)))
 212           (liece-message-target chnl)
 213           (liece-message-speaker (liece-current-nickname))
 214           (liece-message-direction 'outgoing))
 215      (liece-display-message ,message)))
 216
 217 (defmacro liece-own-private-message (message &optional partner)
 218   `(let* ((partner (or ,partner liece-current-chat-partner))
 219           (liece-message-target partner)
 220           (liece-message-speaker (liece-current-nickname))
 221           (liece-message-direction 'outgoing))
 222      (liece-display-message ,message)))
 223
 224 (defmacro liece-convert-received-input (input)
 225   "Convert input before it is processed"
 226   `(let ((conv-list liece-receive-convert-list)
 227          (input ,input)
 228          i f s s1 s2)
 229      (while (and conv-list (not liece-polling))
 230        (setq i (car conv-list)
 231              f (car i)
 232              s (cadr i)
 233              s1 (if (stringp f) f (funcall f input))
 234              s2 (if (stringp s) s (funcall s s1))
 235              input (replace-in-string input s1 s2)
 236              conv-list (cdr conv-list)))
 237      input))
 238
 239 (defun liece-send (&rest args)
 240   "Send message to IRC server."
 241   (liece-reset-idle)
 242   (let ((string (apply #'format args)) send-string len)
 243     (dolist (convert liece-send-convert-list)
 244       (setq string (apply #'replace-in-string string convert)))
 245     (with-current-buffer liece-command-buffer
 246       (setq send-string (liece-coding-encode-charset-string string)
 247             send-string (if (string-match "\r$" send-string) send-string
 248                           (concat send-string "\r\n"))
 249             len (length send-string)))
 250     (if (< len 512)
 251         (process-send-string liece-server-process send-string)
 252       (message "Protocol message too long (%d).  Truncated." len)
 253       (if liece-beep-on-bells (beep)))
 254     (if (string-match "^list\\s-*" (setq string (downcase string)))
 255         (setq liece-channel-filter (substring string (match-end 0))))))
 256
 257 (defmacro liece-send-pong ()
 258   '(liece-send "PONG :%s" liece-tmp-server-name))
 259
 260 (defmacro liece-increment-long-reply-count ()
 261   '(incf liece-long-reply-count))
 262
 263 (defmacro liece-reset-long-reply-count ()
 264   '(setq liece-long-reply-count 0))
 265
 266 (defmacro liece-check-long-reply-count ()
 267   '(when (> liece-long-reply-count liece-long-reply-max)
 268      (liece-reset-long-reply-count)
 269      (liece-send-pong)))
 270
 271 (defmacro liece-server-host ()
 272   '(if (listp liece-server)
 273        (plist-get liece-server ':host)
 274      liece-server))
 275
 276 (defmacro liece-clean-hostname (hostname)
 277   "Return the arg HOSTNAME, but if is a dotted-quad, put brackets around it."
 278   `(save-match-data
 279      (if (string-match "[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+" ,hostname)
 280          (concat "[" ,hostname "]")
 281        ,hostname)))
 282
 283 (defmacro liece-current-nickname ()
 284   "Our current nickname."
 285   'liece-real-nickname)
 286
 287 (defmacro liece-current-channel ()
 288   "Out current channel."
 289   'liece-current-channel)
 290
 291 (defmacro liece-current-channels ()
 292   "Out current channels."
 293   'liece-current-channels)
 294
 295 (defmacro liece-current-chat-partner ()
 296   "Out current chat partner."
 297   'liece-current-chat-partner)
 298
 299 (defmacro liece-current-chat-partners ()
 300   "Out current chat partners."
 301   'liece-current-chat-partners)
 302
 303 (defmacro liece-scroll-if-visible (window)
 304   `(if ,window (set-window-point ,window (point-max))))
 305
 306 (defmacro liece-pick-buffer-1 (chnl)
 307   `(cdr (string-assoc-ignore-case ,chnl liece-channel-buffer-alist)))
 308
 309 (defun liece-pick-buffer (chnl)
 310   (cond
 311    ((stringp chnl)
 312     (let ((buf (liece-pick-buffer-1 chnl)))
 313       (if buf (list buf))))
 314    ((and chnl (listp chnl))
 315     (let ((buf (liece-pick-buffer-1 (car chnl))))
 316       (if buf (cons buf (liece-pick-buffer (cdr chnl))))))
 317    (t nil)))
 318
 319 \f
 320 ;;; Date and time handling functions
 321 (defun liece-compose-time-string (time)
 322   (format-time-string "%A %B %e %Y %R" time))
 323
 324 (defun liece-convert-seconds (time)
 325   "Convert seconds to printable string."
 326   (let* ((seconds (string-to-int time))
 327          (minutes (/ seconds 60))
 328          (seconds (if minutes (% seconds 60) seconds))
 329          (hours (/ minutes 60))
 330          (minutes (if hours (% minutes 60) minutes))
 331          (days (/ hours 24))
 332          (hours (if days (% hours 24) hours))
 333          (ds (and (/= 0 days)
 334                   (format "%d day%s, " days
 335                           (if (> days 1) "s" ""))))
 336          (hs (and (/= 0 hours)
 337                   (format "%d hour%s, " hours
 338                           (if (> hours 1) "s" ""))))
 339          (ms (and (/= 0 minutes)
 340                   (format "%d minute%s " minutes
 341                           (if (> minutes 1) "s" ""))))
 342          (ss (format "%d seconds" seconds)))
 343     (concat ds hs ms (if seconds ss ""))))
 344
 345 (defmacro liece-insert-time-string ()
 346   '(insert (substring (current-time-string) 11 16) " "))
 347
 348 (defvar liece-idle-point nil "Timestamp of last idle reset.")
 349
 350 (defmacro liece-reset-idle ()
 351   "Reset idle counter and return last idle."
 352   '(prog1 (liece-idle) (setq liece-idle-point (current-time))))
 353
 354 (defmacro liece-idle ()
 355   "How long has liece been idle."
 356   '(if liece-idle-point
 357        (liece-time-difference liece-idle-point (current-time))
 358      9999999))
 359
 360 (defmacro liece-ping-if-idle (&optional limit)
 361   `(if (<= (liece-idle) (or ,limit 120))
 362        nil
 363      (liece-command-ping)
 364      t))
 365
 366 (defmacro liece-maybe-poll ()
 367   '(liece-send "PING %s" (system-name)))
 368
 369 (defun liece-get-buffer-create (name)
 370   "Get or create buffer, keep track on its NAME so we can kill it."
 371   (let ((buffer (get-buffer-create name)))
 372     (or (memq buffer liece-buffer-list)
 373         (push buffer liece-buffer-list))
 374     buffer))
 375
 376 (defmacro liece-message-from-ignored (prefix rest)
 377   `(save-excursion
 378      (liece-insert liece-I-buffer (concat ,prefix "::" ,rest "\n"))
 379      t))
 380
 381 (defmacro liece-is-message-ignored (string buffer)
 382   `(let (found (case-fold-search t) msg str msgstr who)
 383      (catch 'ignore
 384        (when (member ,buffer liece-no-ignore-buffers)
 385          (throw 'ignore t))
 386        (dolist (ignore-entry liece-ignore-list)
 387          ;; Check message type
 388          (cond
 389           ((consp (car ignore-entry))
 390            (setq msg (caar ignore-entry)
 391                  str (cdar ignore-entry)))
 392           ((fboundp (car ignore-entry))
 393            (setq msgstr (apply (car ignore-entry) (list ,string))
 394                  msg (car msgstr)
 395                  str (cdr msgstr)))
 396           (t
 397            (liece-message
 398             (_ "Malformed ignore-list, no msg+str function."))))
 399          ;; Check message from whom
 400          (cond
 401           ((listp (cadr ignore-entry))
 402            (setq who (cadr ignore-entry)))
 403           ((fboundp (cadr ignore-entry))
 404            (setq who (apply (cadr ignore-entry) (list ,string))))
 405           ((not (cadr ignore-entry))
 406            (liece-message
 407             (_ "Malformed ignore-list, no user function."))))
 408          ;; Handle regexp
 409          (save-match-data
 410            (when (and (or msg str)
 411                       (and msg
 412                            (string-match
 413                             msg (cadr liece-current-function)))
 414                       (and str (string-match str ,string)))
 415              (while who
 416                (when (string-match (car who) (car liece-current-function))
 417                  (setq found t)
 418                  (throw 'ignore t))
 419                (setq who (cdr who)))))))
 420      found))
 421
 422 (defmacro liece-time-difference (t0 t1)
 423   "Difference in seconds between T0 and T1.
 424 Both T0 and T1 are in the encoded time format."
 425   `(+ (* (- (car ,t1) (car ,t0)) 65536)
 426       (- (cadr ,t1)) (cadr ,t0)))
 427
 428 (defmacro liece-time-add (t0 t1)
 429   "Add T0 seconds to time T1.
 430 t0 is in `three integer lists'-format  returned by `current-time' function."
 431   `(list (+ (car ,t0) (/ (+ (cadr ,t0) ,t1) 65536))
 432          (% (+ (cadr ,t0) ,t1) 65536)
 433          0))
 434
 435 (defun liece-seconds-to-time (seconds)
 436   "Convert SECONDS (a floating point number) to an Emacs time structure."
 437   (list (floor seconds 65536)
 438         (floor (mod seconds 65536))
 439         (floor (* (- seconds (ffloor seconds)) 1000000))))
 440
 441 (defmacro liece-generate-hex-timestamp (&optional time)
 442   "Generate timestamp string as hexadecimal.
 443 If optional argument TIME is nil, calculate timestamp using current time."
 444   `(let ((time (or ,time (current-time))))
 445      (format "%04x%04x" (car time) (cadr time))))
 446
 447 (defmacro liece-hex-timestamp-valid (timestamp limit)
 448   "Is TIMESTAMP valid within LIMIT?"
 449   `(let (t1 t2 diff (timestamp ,timestamp))
 450      (if (not (and (stringp timestamp)
 451                    (string-match
 452                     "^[0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f][0-9a-f]$" timestamp)))
 453          nil
 454        (setq t1 (liece-hex-string-to-integer (substring timestamp 0 4))
 455              t2 (liece-hex-string-to-integer (substring timestamp 4 8))
 456              diff (liece-time-difference
 457                    (list t1 t2 0) (current-time)))
 458        (or (>= ,limit 0)
 459            (and (< diff ,limit) (> diff (- 0 ,limit)))))))
 460
 461 (defmacro liece-hex-char-to-integer (character)
 462   "Convert single hex digit CHARACTER to integer."
 463   `(if (and (>= ,character ?0) (<= ,character ?9))
 464        (- ,character ?0)
 465      (let ((ch (logior ,character 32)))
 466        (if (and (>= ch ?a) (<= ch ?f))
 467            (- ch (- ?a 10))
 468          (error "Invalid hex digit `%c'" ch)))))
 469
 470 (defmacro liece-hex-string-to-integer (hex-string)
 471   "Convert a HEX-STRING like ffff to the decimal integer."
 472   `(let ((hex-string ,hex-string) (hex-num 0))
 473      (while (not (equal hex-string ""))
 474        (setq hex-num (+ (* hex-num 16)
 475                         (liece-hex-char-to-integer
 476                          (string-to-char hex-string))))
 477        (setq hex-string (substring hex-string 1)))
 478      hex-num))
 479
 480 (defmacro liece-remove-properties-region (start end)
 481   (unless (fboundp 'make-extent)
 482     `(save-excursion
 483        (save-restriction
 484          (narrow-to-region ,start ,end)
 485          (goto-char (point-min))
 486          (let (start)
 487            (while (setq start (next-single-property-change
 488                                (point) 'invisible))
 489              (when (invisible-p start)
 490                (delete-region start (next-visible-point start))
 491                (goto-char start))
 492              (remove-text-properties (point-min)(point-max) '(face))))))))
 493
 494 (provide 'liece-misc)
 495
 496 ;;; liece-misc.el ends here