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