cgit.sxemacs.org Git - emchat/blob - emchat-world.el

   1 ;;; emchat-world.el --- EMchat contact list management
   2
   3 ;; Copyright (C) 2002 - 2007 Steve Youngs
   4
   5 ;; Author:        Steve Youngs <steve@emchat.org>
   6 ;; Maintainer:    Steve Youngs <steve@emchat.org>
   7 ;; Created:       2002-10-01
   8 ;; Homepage:      http://www.emchat.org/
   9 ;; Keywords:      comm ICQ
  10
  11 ;; This file is part of EMchat.
  12
  13 ;; Redistribution and use in source and binary forms, with or without
  14 ;; modification, are permitted provided that the following conditions
  15 ;; are met:
  16 ;;
  17 ;; 1. Redistributions of source code must retain the above copyright
  18 ;;    notice, this list of conditions and the following disclaimer.
  19 ;;
  20 ;; 2. Redistributions in binary form must reproduce the above copyright
  21 ;;    notice, this list of conditions and the following disclaimer in the
  22 ;;    documentation and/or other materials provided with the distribution.
  23 ;;
  24 ;; 3. Neither the name of the author nor the names of any contributors
  25 ;;    may be used to endorse or promote products derived from this
  26 ;;    software without specific prior written permission.
  27 ;;
  28 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  29 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  30 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  31 ;; DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  32 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  33 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  34 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  35 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  36 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  37 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  38 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  39
  40 ;;; Commentary:
  41 ;;
  42
  43 (eval-and-compile
  44   (require 'emchat-meta)
  45   (require 'emchat-menu))
  46
  47 (autoload 'emchat-search-by-uin "emchat" nil t)
  48 (autoload 'emchat-buddy-show-buffer "emchat-buddy" nil t)
  49 (autoload 'emchat-process-alias-input "emchat")
  50 (autoload 'emchat-buddy-update-face "emchat-buddy")
  51 (autoload 'emchat-completing-aliases "emchat")
  52 (autoload 'emchat-valid-uin-p "emchat")
  53
  54 (eval-when-compile
  55   (require 'font-lock)
  56   (require 'sort))
  57
  58 (defcustom emchat-world-rc-filename (expand-file-name "world" emchat-directory)
  59   "*Filename for resource file."
  60   :type 'file
  61   :group 'emchat-info)
  62
  63 (defcustom emchat-recently-added-by-filename
  64   (expand-file-name "recent-adds" emchat-directory)
  65   "*File containing UIN's of people who have added you to their list."
  66   :type 'file
  67   :group 'emchat-info)
  68
  69 (defcustom emchat-world-track-all-adds nil
  70   "*When non-nil, every UIN of people adding you is tracked.
  71
  72 The default, nil, means that only people who are not in your contact
  73 list will be tracked."
  74   :type 'boolean
  75   :group 'emchat-info)
  76
  77 (defvar emchat-world-recently-added-by nil
  78   "Contains the UIN's of anyone who adds you to their list.
  79
  80 This is for the current session only.  But these people are saved in
  81 `emchat-recently-added-by-filename' for future reference.")
  82
  83 ;;; Internal variables
  84
  85 (defcustom emchat-user-alias "me"
  86   "*Your alias in `emchat-world'.
  87 Run `emchat-world-update' after modifying this variable."
  88   :group 'emchat-info)
  89
  90 (defvar emchat-user-bin nil
  91   "User alias in binary string.
  92 The mere purpose is to speed up operations.
  93 Updated by `emchat-world-update'.")
  94
  95 (defvar emchat-all-uin nil
  96   "All uin in `emchat-world'.
  97 The mere purpose is to speed up operations.
  98 Updated by `emchat-world-update'.")
  99
 100 (defvar emchat-world nil
 101   "List of alias, uin, and plist.")
 102
 103 (defvar emchat-all-aliases nil
 104   "All aliases in `emchat-world'.
 105 The mere purpose is to speed up operations.
 106 Updated by `emchat-world-update'.")
 107
 108 (defvar emchat-add-user-p nil)
 109 (defvar emchat-new-buddy nil)
 110 (defvar emchat-world-new-user-hash nil)
 111
 112 (eval-and-compile
 113   (unless (featurep 'sxemacs)
 114     (defalias #'defregexp #'defconst)))
 115
 116 (defregexp emchat-world-ssi-LastUpdateTime-regexp
 117   (if (featurep '(or sxemacs raw-strings))
 118       #r"^::LastUpdateTime:\s-(\([0-9]+\)\s-.\s-\([0-9]+\))$"
 119     "^::LastUpdateTime:\\s-(\\([0-9]+\\)\\s-.\\s-\\([0-9]+\\))$")
 120   "Regular expression to match the last update time in world.")
 121
 122 (defregexp emchat-world-ssi-count-regexp
 123   (if (featurep '(or sxemacs raw-strings))
 124       #r"^::Count:\s-\(.*\)$"
 125     "^::Count:\\s-\\(.*\\)$")
 126   "Regular expression to match the entries count in world.")
 127
 128 (defregexp emchat-world-ssi-id-regexp
 129   (if (featurep '(or sxemacs raw-strings))
 130       #r"\(?:[  ]{SSIgrp=\([0-9]+\)[    ]SSIid=\([0-9]+\)}\)"
 131     "\\(?:[     ]{SSIgrp=\\([0-9]+\\)[  ]SSIid=\\([0-9]+\\)}\\)")
 132   "Regular expression matching SSI id numbers in world.")
 133
 134 (defregexp emchat-world-rc-regexp
 135   (if (featurep '(or sxemacs raw-strings))
 136       #r"^:icq[         ]+\([0-9]+\)[   ]+\([^:]+?\)[   ]?\(:.*\)*$"
 137     "^:icq[     ]+\\([0-9]+\\)[         ]+\\([^:]+?\\)[         ]?\\(:.*\\)*$")
 138   "Regular expression for rc file.
 139 Format: :icq uin alias group(s)
 140 Group is prefixed by a colon :.  Anything between uin and group including
 141 white spaces is alias.  For example,
 142
 143 :icq 409533 fire :linux :emchat
 144 :icq 123456 the hatter :unreal
 145
 146 The regexp paren groupings are as follows:
 147
 148   1 -- UIN
 149   2 -- Alias
 150   3 -- groups \(local, not SSI\)")
 151
 152 (defun emchat-world-ssi-mod-time ()
 153   "Extract and return the last update time from local copy of SSI.
 154
 155 This time is kept in `emchat-world-rc-filename', if it doesn't exist,
 156 return zero."
 157   (let ((modt (cons 0 0)))
 158     (with-current-buffer (find-file-noselect emchat-world-rc-filename)
 159       (goto-char (point-max))
 160       (when (re-search-backward emchat-world-ssi-LastUpdateTime-regexp nil t)
 161         (setq modt (cons (string-to-number (match-string 1))
 162                          (string-to-number (match-string 2)))))
 163       modt)))
 164
 165 (defun emchat-world-ssi-count ()
 166   "Extract and return the item count from local copy of SSI.
 167
 168 This count is kept in `emchat-world-rc-filename', if it doesn't exist,
 169 return zero."
 170   (let ((count 0))
 171     (with-current-buffer (find-file-noselect emchat-world-rc-filename)
 172       (goto-char (point-max))
 173       (when (re-search-backward emchat-world-ssi-count-regexp nil t)
 174         (setq count (string-to-number (match-string 1))))
 175       count)))
 176
 177 (defun emchat-world-update-world-count (count time)
 178   "Update the entries COUNT and LastUpdateTime TIME in world."
 179   (with-current-buffer (find-file-noselect emchat-world-rc-filename)
 180     (goto-char (point-max))
 181     (condition-case nil
 182         (progn
 183           (save-excursion
 184             (re-search-backward emchat-world-ssi-LastUpdateTime-regexp)
 185             (replace-string
 186              (substring (match-string 0)
 187                         (- (+ 5 (length (match-string 1))
 188                               (length (match-string 2)))))
 189              (format "%S" time)))
 190           (re-search-backward emchat-world-ssi-count-regexp)
 191           (replace-string (match-string 1) (format "%d" count)))
 192       ;; count/time markers don't exist, add em.
 193       (t
 194        (goto-char (point-at-bol))
 195        (insert (format "::Count: %d\n" count)
 196                (format "::LastUpdateTime: %S" time))))
 197     (save-buffer)
 198     (kill-buffer nil)))
 199
 200 (defun emchat-world-ssi-grp ()
 201   "Return the first non-zero SSI group ID to use for new contacts."
 202   (let ((buf (find-file-noselect emchat-world-rc-filename))
 203         (id nil))
 204     (with-current-buffer buf
 205       (goto-char (point-min))
 206       (while (not id)
 207         (re-search-forward emchat-world-ssi-id-regexp nil t)
 208         (unless (zerop (string-to-number (match-string 1)))
 209           (setq id (string-to-number (match-string 1))))))
 210     id))
 211
 212 (defun emchat-world-next-ssi-id ()
 213   "Return the next server side contact ID number."
 214   (let ((buf (find-file-noselect emchat-world-rc-filename))
 215         (idlist nil))
 216     (with-current-buffer buf
 217       (goto-char (point-min))
 218       (while (re-search-forward emchat-world-ssi-id-regexp nil t)
 219         (push (string-to-number (match-string 2)) idlist)))
 220     (1+ (apply #'max idlist))))
 221
 222 (defun emchat-world-sync-ssi-maybe (uin grpid id alias)
 223   "Possibly synchronise entries from SSI to local world.
 224
 225 UIN is the UIN of the contact.
 226 GRPID is the SSI group id number \(needed for modifying/deleting\).
 227 ID is the SSI id of this contact \(needed for modifying/deleting\).
 228 ALIAS is the \"nick\" of the contact as listed in your SSI.
 229
 230 Note that you shouldn't call this function directly, it doesn't
 231 save any changes it makes to your world file.  That is done by
 232 `emchat-v8-snac-srv-ssi-reply', which calls this."
 233   (let ((world (find-file-noselect emchat-world-rc-filename))
 234         (known-uin (member (emchat-stringular-uin uin) emchat-all-uin)))
 235     (with-current-buffer world
 236       (goto-char (point-min))
 237       (if known-uin
 238           (when (re-search-forward (regexp-quote (emchat-stringular-uin uin)))
 239             (if (re-search-forward emchat-world-ssi-id-regexp (point-at-eol) t)
 240                 (progn
 241                   (or (= grpid (string-to-number (match-string 1)))
 242                       (replace-match (match-string 1) (format "%s" grpid)))
 243                   (or (= id (string-to-number (match-string 2)))
 244                       (replace-match (match-string 2) (format "%s" id))))
 245               (goto-char (point-at-eol))
 246               (insert (format " {SSIgrp=%s SSIid=%s}" grpid id))))
 247         (or (and (re-search-forward emchat-world-ssi-count-regexp nil t)
 248                  (forward-line -1))
 249             (goto-char (point-max)))
 250         (insert (format "\n:icq %s %s {SSIgrp=%s SSIid=%s}\n"
 251                         uin (aref alias 0) grpid id))
 252         (emchat-add-new-user-to-buddy-buffer
 253          (emchat-stringular-uin uin) (aref alias 0))))))
 254
 255 (defun emchat-world-add-new-user ()
 256   "Add a new user to world."
 257   (let ((uin (gethash :uin emchat-world-new-user-hash))
 258         (nick (gethash :nick emchat-world-new-user-hash))
 259         (ssi-grp (gethash :ssi-grp emchat-world-new-user-hash))
 260         (id (gethash :id emchat-world-new-user-hash))
 261         (egrps (gethash :egrps emchat-world-new-user-hash))
 262         (status (gethash :status emchat-world-new-user-hash)))
 263     (set-buffer
 264      (find-file-noselect (expand-file-name emchat-world-rc-filename)))
 265     (goto-char (point-max))
 266     (if (re-search-backward emchat-world-ssi-count-regexp nil t)
 267         (progn
 268           (insert (format ":icq %d %s %s {SSIgrp=%d SSIid=%d}\n\n"
 269                           uin nick egrps ssi-grp id))
 270           (save-buffer (current-buffer))
 271           (kill-buffer (current-buffer))
 272           ;; Inform the user in the log.
 273           (emchat-log-info
 274            (emchat-decode-string
 275             (format "Alias: %s, UIN: %d added to contact list."
 276                     nick uin)))
 277           (emchat-add-new-user-to-buddy-buffer
 278            (emchat-stringular-uin uin) nick status))
 279       (emchat-log-error "Malformed world file"))))
 280
 281 (defun emchat-add-new-user-to-buddy-buffer (uin nick &optional status)
 282   "Push the nick name from `emchat-add-user' into the buddy buffer.
 283 Sort of a cut-down version or `emchat-world-update'"
 284   (if (member uin emchat-all-uin)
 285       (emchat-log-error "%s is already in your contact list" nick)
 286     (if (or (null status)
 287             (and (eq status 'online)
 288                  (not (eq emchat-buddy-view 'emchat-active-aliases)))
 289             (and (eq status 'offline)
 290                  (eq emchat-buddy-view 'emchat-all-aliases)))
 291         (add-to-list (symbol-value 'emchat-buddy-view) nick))
 292
 293     (let* ((bhelp (format "%s (%s)\n\n Status: %s\n Groups: %s\nHistory: %s\n"
 294                           nick
 295                           uin
 296                           (or (emchat-world-getf nick 'status) "offline")
 297                           (or (emchat-world-getf nick 'group) "none")
 298                           (or (emchat-world-getf nick 'history) "none"))))
 299       (set-extent-properties
 300        (make-extent 0 (length nick) nick)
 301        `(highlight t duplicable t start-open t keymap ,emchat-alias-map
 302                    balloon-help ,bhelp)))
 303     (save-excursion
 304       (set-buffer (find-file-noselect emchat-world-rc-filename))
 305       (goto-char (point-max))
 306       (search-backward-regexp emchat-world-rc-regexp nil t)
 307       (let* ((buddy (list nick uin 'rc-index (point))))
 308         (push buddy emchat-world)))
 309     (setq emchat-all-aliases (mapcar 'first emchat-world))
 310     (setq emchat-all-uin (mapcar 'second emchat-world))
 311     (emchat-buddy-show-buffer 'new 'no-select)
 312     (setq emchat-add-user-p nil)))
 313
 314 ;;; Code - group:
 315
 316 (defun emchat-group-put (group name)
 317   "Put something into GROUP.
 318 NAME can be either an alias or another group name."
 319   (let ((list (assoc group emchat-world)))
 320     (cond
 321      (list
 322       (setcdr list (list (pushnew name (cadr list) :test 'equal))))
 323      (t
 324       (push (list group (list name)) emchat-world)))))
 325
 326 (defun emchat-group-get (group)
 327   "Get members from GROUP."
 328   (cadr (assoc group emchat-world)))
 329
 330 (defun emchat-group-get-all-aliases (group)
 331   "Recursively get all aliases from GROUP."
 332   (loop for x in (emchat-group-get group)
 333     as expanded-x = (emchat-group-get x)
 334     if (atom expanded-x) collect x
 335     else append (emchat-group-get-all-aliases x)))
 336
 337 (defun emchat-group-select-aliases (state &rest aliases)
 338   "Select aliases and update buddy buffer.
 339 Nil STATE means deselect, 'toggle means invert current state, and other
 340 non-nil means select.
 341
 342 See `emchat-process-alias-input'."
 343   (interactive '(select))
 344   (emchat-process-alias-input 'aliases)
 345   (loop for x in aliases
 346     do (when (eq state 'toggle)
 347          (setq state (not (emchat-world-getf x 'selected))))
 348     do (emchat-world-putf x 'selected state)
 349     do (emchat-buddy-update-face x))
 350   (emchat-buddy-show-buffer 'new 'noselect))
 351
 352 (defun emchat-world-getf (alias tag)
 353   "For ALIAS get property of TAG.
 354 If TAG is 'all, return the plist."
 355   (let ((plist (cddr (assoc alias emchat-world))))
 356     (if (eq tag 'all)
 357         plist
 358       (getf plist tag))))
 359
 360 (defun emchat-world-putf (alias tag value)
 361   "For ALIAS put property of TAG with VALUE."
 362   (let* ((buddy (assoc alias emchat-world))
 363          (plist (cddr buddy)))
 364     (if buddy (setcdr (cdr buddy) (putf plist tag value)))))
 365
 366 (defun emchat-alias-uin (alias)
 367   "Return an uin from an ALIAS in `emchat-world'.
 368 Return uin if ALIAS is already an uin.
 369 Return 0 if no corresponding uin or invalid uin.
 370 If called interactively, display and push uin into `kill-ring'."
 371   (interactive (emchat-completing-aliases "UIN from alias: " 'single))
 372   (let ((uin (second (assoc alias emchat-world))))
 373     (unless uin
 374       (when (emchat-valid-uin-p alias)
 375         (setq uin alias)))
 376     (when (interactive-p)
 377       (message uin)
 378       (kill-new uin))
 379     uin))
 380
 381 (defun emchat-uin-alias (uin)
 382   "Return an alias from an UIN in `emchat-world'.
 383 Return UIN if no corresponding ALIAS.
 384 If called interactively, display and push alias into `kill-ring'."
 385   (interactive (list (read-string "alias from uin: ")))
 386   (let ((alias (or (first (find uin emchat-world :key 'second :test 'string=))
 387                    ;; not found, return uin
 388                    uin)))
 389     (when (interactive-p)
 390       (message alias)
 391       (kill-new alias))
 392     alias))
 393
 394 ;;;###autoload
 395 (defun emchat-world-update ()
 396   "Read `emchat-world-rc-filename' and update various user variables.
 397 Need to call this whenever RC is modified and to be updated.
 398 RC file is not closed if it is the buffer of current window or it is modified."
 399   (interactive)
 400   (save-excursion
 401     (let (no-killing-at-last)
 402       (setq emchat-world nil)
 403       (set-buffer (find-file-noselect emchat-world-rc-filename))
 404       ;; don't kill if rc file is buffer in current window
 405       (setq no-killing-at-last
 406             (or (buffer-modified-p)
 407                 (eq (window-buffer) (current-buffer))))
 408       (goto-char (point-min))
 409       (while (search-forward-regexp emchat-world-rc-regexp nil t)
 410         (let* ((uin (match-string 1))
 411                (alias (replace-regexp-in-string
 412                        emchat-world-ssi-id-regexp ""
 413                        (match-string 2)))
 414                (group (replace-regexp-in-string
 415                        emchat-world-ssi-id-regexp ""
 416                        (or (match-string 3) "")))
 417                buddy)
 418
 419           ;; idea from Erik Arneson <erik@starseed.com>
 420           (set-extent-properties
 421            ;; We may consider moving to emchat-uin-alias or somewhere else, if
 422            ;; we don't want to waste enourmous unused extents.
 423            (make-extent 0 (length alias) alias)
 424            `(highlight t duplicable t start-open t keymap ,emchat-alias-map))
 425
 426           (setq buddy (list alias uin 'rc-index (point)))
 427
 428           ;; group stuff not used yet
 429           (if group
 430               (setq buddy
 431                     (append buddy (read (format "(group (%s))" group)))))
 432           (push buddy emchat-world)))
 433       (setq emchat-world (nreverse emchat-world))
 434       (unless no-killing-at-last
 435         (kill-buffer (current-buffer)))))
 436
 437   (setq emchat-all-aliases (mapcar 'first emchat-world))
 438   (setq emchat-all-uin (mapcar 'second emchat-world))
 439   ;; Add history files to emchat-world if enabled
 440   (when emchat-history-enabled-flag
 441     (mapcar
 442      #'(lambda (alias)
 443          (emchat-world-putf alias 'history
 444                             (expand-file-name alias emchat-history-directory)))
 445      emchat-all-aliases)))
 446
 447 (defun emchat-world-info (alias)
 448   "Return local info of buddy ALIAS."
 449   ;; TODO
 450   (assoc alias emchat-world))
 451
 452 ;;; FIXME: Putting the rc file into `outline-minor-mode' is throwing a
 453 ;;; "keymapp nil" error.
 454 (defun world-mode ()
 455   "emchat resource file mode.
 456 Quick hack for font-lock. Each record is separated by \"==== \" at the
 457 beginning of the line."
 458   (interactive)
 459   (kill-all-local-variables)
 460   (setq mode-name "world")
 461   (setq major-mode 'world-mode)
 462   (setq fill-column 100)
 463   (auto-fill-mode 1)
 464   ;; hiding details for privacy
 465   ;(outline-minor-mode)
 466   ;(set (make-local-variable 'outline-regexp)
 467   ;     "==== ")
 468   (setq font-lock-keywords
 469         ;; highlight separator
 470         '(("^==== " 0 font-lock-warning-face t)
 471           ;; highlight keyword prefixed with :
 472           (":\\(\\w\\|-\\)+" 0 font-lock-reference-face t)))
 473   (font-lock-mode 1))
 474
 475 (defun world-sort ()
 476   (interactive)
 477   (beginning-of-buffer)
 478   (sort-subr nil 'world-next-friend 'world-end-friend))
 479
 480 (defun world-next-friend ()
 481   (interactive)
 482   (let ((result (search-forward "====" nil t)))
 483     ;; go back before ====
 484     (if result (backward-char 4)
 485       ;; required by sort-subr
 486       (end-of-buffer))))
 487
 488 (defun world-end-friend ()
 489   (interactive)
 490   ;; skip current friend
 491   (forward-char 1)
 492   (let ((result (search-forward "====" nil t)))
 493     ;; go back before ====
 494     (if result (backward-char 5)
 495       (end-of-buffer))))
 496
 497 (defun world-find (alias)
 498   "Goto a friend record of ALIAS in `emchat-world-rc-filename'.
 499 Prefix argument means do not use (load) emchat completing alias feature."
 500   (interactive
 501    (if current-prefix-arg
 502        (list (read-string "find: "))
 503      (progn
 504        (require 'emchat)
 505        (emchat-completing-aliases "find: " 'single))))
 506   (find-file emchat-world-rc-filename)
 507   (goto-char (point-min))
 508   (re-search-forward
 509    (concat "^:icq.*?"
 510            (regexp-quote alias)
 511            "\\b.*$")))
 512
 513 (provide 'emchat-world)
 514
 515 ;;; emchat-world.el ends here