djavu-asus/elpa/jabber-20230715.456/jabber-chat.el

   1 ;; jabber-chat.el - one-to-one chats  -*- lexical-binding: t; -*-
   2
   3 ;; Copyright (C) 2005, 2007, 2008 - Magnus Henoch - mange@freemail.hu
   4
   5 ;; This file is a part of jabber.el.
   6
   7 ;; This program is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation; either version 2 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; This program is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program; if not, write to the Free Software
  19 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  20
  21 (require 'jabber-core)
  22 (require 'jabber-chatbuffer)
  23 (require 'jabber-history)
  24 (require 'jabber-menu)                  ;we need jabber-jid-chat-menu
  25 (require 'ewoc)
  26 (eval-when-compile (require 'cl-lib))
  27
  28 (defgroup jabber-chat nil "chat display options"
  29   :group 'jabber)
  30
  31 (defcustom jabber-chat-buffer-format "*-jabber-chat-%n-*"
  32   "The format specification for the name of chat buffers.
  33
  34 These fields are available (all are about the person you are chatting
  35 with):
  36
  37 %n   Nickname, or JID if no nickname set
  38 %j   Bare JID (without resource)
  39 %r   Resource"
  40   :type 'string
  41   :group 'jabber-chat)
  42
  43 (defcustom jabber-chat-header-line-format
  44   '("" (jabber-chat-buffer-show-avatar
  45         (:eval
  46          (let ((buddy (jabber-jid-symbol jabber-chatting-with)))
  47            (jabber-propertize " "
  48                               'display (get buddy 'avatar)))))
  49     (:eval (jabber-jid-displayname jabber-chatting-with))
  50     "\t" (:eval (let ((buddy (jabber-jid-symbol jabber-chatting-with)))
  51                   (propertize
  52                    (or
  53                     (cdr (assoc (get buddy 'show) jabber-presence-strings))
  54                     (get buddy 'show))
  55                    'face
  56                    (or (cdr (assoc (get buddy 'show) jabber-presence-faces))
  57                        'jabber-roster-user-online))))
  58     "\t" (:eval (jabber-fix-status (get (jabber-jid-symbol jabber-chatting-with) 'status)))
  59     "\t" jabber-events-message          ;see jabber-events.el
  60     "\t" jabber-chatstates-message)             ;see jabber-chatstates.el
  61   "The specification for the header line of chat buffers.
  62
  63 The format is that of `mode-line-format' and `header-line-format'."
  64   :type 'sexp
  65   :group 'jabber-chat)
  66
  67 (defcustom jabber-chat-buffer-show-avatar t
  68   "Show avatars in header line of chat buffer?
  69 This variable might not take effect if you have changed
  70 `jabber-chat-header-line-format'."
  71   :type 'boolean
  72   :group 'jabber-chat)
  73
  74 (defcustom jabber-chat-time-format "%H:%M"
  75   "The format specification for instant messages in the chat buffer.
  76 See also `jabber-chat-delayed-time-format'.
  77
  78 See `format-time-string' for valid values."
  79   :type 'string
  80   :group 'jabber-chat)
  81
  82 (defcustom jabber-chat-delayed-time-format "%Y-%m-%d %H:%M"
  83   "The format specification for delayed messages in the chat buffer.
  84 See also `jabber-chat-time-format'.
  85
  86 See `format-time-string' for valid values."
  87   :type 'string
  88   :group 'jabber-chat)
  89
  90 (defcustom jabber-print-rare-time t
  91   "Non-nil means to print \"rare time\" indications in chat buffers.
  92 The default settings tell every new hour."
  93   :type 'boolean
  94   :group 'jabber-chat)
  95
  96 (defcustom jabber-rare-time-format "%a %e %b %Y %H:00"
  97   "The format specification for the rare time information.
  98 Rare time information will be printed whenever the current time,
  99 formatted according to this string, is different to the last
 100 rare time printed."
 101   :type 'string
 102   :group 'jabber-chat)
 103
 104 (defface jabber-rare-time-face
 105   '((t (:foreground "darkgreen" :underline t)))
 106   "face for displaying the rare time info"
 107   :group 'jabber-chat)
 108
 109 (defcustom jabber-chat-local-prompt-format "[%t] %n> "
 110   "The format specification for lines you type in the chat buffer.
 111
 112 These fields are available:
 113
 114 %t   Time, formatted according to `jabber-chat-time-format'
 115      or `jabber-chat-delayed-time-format'
 116 %u   Username
 117 %n   Nickname (obsolete, same as username)
 118 %r   Resource
 119 %j   Bare JID (without resource)"
 120   :type 'string
 121   :group 'jabber-chat)
 122
 123 (defcustom jabber-chat-foreign-prompt-format "[%t] %n> "
 124   "The format specification for lines others type in the chat buffer.
 125
 126 These fields are available:
 127
 128 %t   Time, formatted according to `jabber-chat-time-format'
 129      or `jabber-chat-delayed-time-format'
 130 %n   Nickname, or JID if no nickname set
 131 %u   Username
 132 %r   Resource
 133 %j   Bare JID (without resource)"
 134   :type 'string
 135   :group 'jabber-chat)
 136
 137 (defcustom jabber-chat-system-prompt-format "[%t] *** "
 138   "The format specification for lines from the system or special chat.
 139 The format specification for lines from the system or that are special in the
 140 chat buffer."
 141   :type 'string
 142   :group 'jabber-chat)
 143
 144 (defface jabber-chat-prompt-local
 145   '((t (:foreground "blue" :weight bold)))
 146   "face for displaying the chat prompt for what you type in"
 147   :group 'jabber-chat)
 148
 149 (defface jabber-chat-prompt-foreign
 150   '((t (:foreground "red" :weight bold)))
 151   "face for displaying the chat prompt for what they send"
 152   :group 'jabber-chat)
 153
 154 (defface jabber-chat-prompt-system
 155   '((t (:foreground "green" :weight bold)))
 156   "face used for system and special messages"
 157   :group 'jabber-chat)
 158
 159 (defface jabber-chat-text-local '((t ()))
 160   "Face used for text you write"
 161   :group 'jabber-chat)
 162
 163 (defface jabber-chat-text-foreign '((t ()))
 164   "Face used for text others write"
 165   :group 'jabber-chat)
 166
 167 (defface jabber-chat-error
 168   '((t (:foreground "red" :weight bold)))
 169   "Face used for error messages"
 170   :group 'jabber-chat)
 171
 172 ;;;###autoload
 173 (defvar jabber-chatting-with nil
 174   "JID of the person you are chatting with.")
 175
 176 (defvar jabber-chat-printers '(jabber-chat-print-subject
 177                          jabber-chat-print-body
 178                          jabber-chat-print-url
 179                          jabber-chat-goto-address)
 180   "List of functions that may be able to print part of a message.
 181 Each function receives these arguments:
 182
 183 XML-DATA   The entire message stanza
 184 WHO        :local or :foreign, for sent or received stanza, respectively
 185 MODE       :insert or :printp.  For :insert, insert text at point.
 186            For :printp, return non-nil if function would insert text.")
 187
 188 (defvar jabber-body-printers '(jabber-chat-normal-body)
 189   "List of functions that may be able to print a body for a message.
 190 Each function receives these arguments:
 191
 192 XML-DATA   The entire message stanza
 193 WHO        :local, :foreign or :error
 194 MODE       :insert or :printp.  For :insert, insert text at point.
 195            For :printp, return non-nil if function would insert text.
 196
 197 These functions are called in order, until one of them returns
 198 non-nil.
 199
 200 Add a function to the beginning of this list if the tag it handles
 201 replaces the contents of the <body/> tag.")
 202
 203 (defvar jabber-chat-send-hooks nil
 204   "List of functions called when a chat message is sent.
 205 The arguments are the text to send, and the id attribute of the
 206 message.
 207
 208 The functions should return a list of XML nodes they want to be
 209 added to the outgoing message.")
 210
 211 (defvar jabber-chat-earliest-backlog nil
 212   "Float-time of earliest backlog entry inserted into buffer.
 213 nil if no backlog has been inserted.")
 214
 215 ;;;###autoload
 216 (defun jabber-chat-get-buffer (chat-with)
 217   "Return the chat buffer for chatting with CHAT-WITH (bare or full JID).
 218 Either a string or a buffer is returned, so use `get-buffer' or
 219 `get-buffer-create'."
 220   (format-spec jabber-chat-buffer-format
 221                (list
 222                 (cons ?n (jabber-jid-displayname chat-with))
 223                 (cons ?j (jabber-jid-user chat-with))
 224                 (cons ?r (or (jabber-jid-resource chat-with) "")))))
 225
 226 (defun jabber-chat-create-buffer (jc chat-with)
 227   "Prepare a buffer for chatting with CHAT-WITH.
 228 This function is idempotent.
 229 JC is the Jabber connection."
 230   (with-current-buffer (get-buffer-create (jabber-chat-get-buffer chat-with))
 231     (unless (eq major-mode 'jabber-chat-mode)
 232       (jabber-chat-mode jc #'jabber-chat-pp)
 233
 234       (make-local-variable 'jabber-chatting-with)
 235       (setq jabber-chatting-with chat-with)
 236       (setq jabber-send-function 'jabber-chat-send)
 237       (setq header-line-format jabber-chat-header-line-format)
 238
 239       (make-local-variable 'jabber-chat-earliest-backlog)
 240
 241       ;; insert backlog
 242       (when (null jabber-chat-earliest-backlog)
 243         (let ((backlog-entries (jabber-history-backlog chat-with)))
 244           (if (null backlog-entries)
 245               (setq jabber-chat-earliest-backlog (jabber-float-time))
 246             (setq jabber-chat-earliest-backlog
 247                   (jabber-float-time (jabber-parse-time
 248                                       (aref (car backlog-entries) 0))))
 249             (mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
 250
 251     ;; Make sure the connection variable is up to date.
 252     (setq jabber-buffer-connection jc)
 253
 254     (current-buffer)))
 255
 256 (defun jabber-chat-insert-backlog-entry (msg)
 257   "Insert backlog entry MSG at beginning of buffer."
 258   ;; Rare timestamps are especially important in backlog.  We risk
 259   ;; having superfluous timestamps if we just add before each backlog
 260   ;; entry.
 261   (let* ((message-time (jabber-parse-time (aref msg 0)))
 262          (fake-stanza `(message ((from . ,(aref msg 2)))
 263                                 (body nil ,(aref msg 4))
 264                                 (x ((xmlns . "jabber:x:delay")
 265                                     (stamp . ,(jabber-encode-legacy-time message-time))))))
 266          (node-data (list (if (string= (aref msg 1) "in") :foreign :local)
 267                           fake-stanza :delayed t)))
 268
 269     ;; Insert after existing rare timestamp?
 270     (if (and jabber-print-rare-time
 271              (ewoc-nth jabber-chat-ewoc 0)
 272              (eq (car (ewoc-data (ewoc-nth jabber-chat-ewoc 0))) :rare-time)
 273              (not (jabber-rare-time-needed message-time (cadr (ewoc-data (ewoc-nth jabber-chat-ewoc 0))))))
 274         (ewoc-enter-after jabber-chat-ewoc (ewoc-nth jabber-chat-ewoc 0) node-data)
 275       ;; Insert first.
 276       (ewoc-enter-first jabber-chat-ewoc node-data)
 277       (when jabber-print-rare-time
 278         (ewoc-enter-first jabber-chat-ewoc (list :rare-time message-time))))))
 279
 280 (add-to-list 'jabber-jid-chat-menu
 281              (cons "Display more context" 'jabber-chat-display-more-backlog))
 282
 283 (defun jabber-chat-display-more-backlog (how-many)
 284   "Display more context.
 285 The HOW-MANY argument is number of messages.
 286 Specify 0 to display all messages."
 287   (interactive "nHow many more messages (Specify 0 to display all)? ")
 288   (let* ((inhibit-read-only t)
 289          (jabber-backlog-days nil)
 290          (jabber-backlog-number (if (= how-many 0) t how-many))
 291          (backlog-entries (jabber-history-backlog
 292                            (or jabber-chatting-with jabber-group) jabber-chat-earliest-backlog)))
 293     (when backlog-entries
 294       (setq jabber-chat-earliest-backlog
 295             (jabber-float-time (jabber-parse-time
 296                                 (aref (car backlog-entries) 0))))
 297       (save-excursion
 298         (goto-char (point-min))
 299         (mapc 'jabber-chat-insert-backlog-entry (nreverse backlog-entries))))))
 300
 301 (add-to-list 'jabber-message-chain 'jabber-process-chat)
 302
 303 (defun jabber-get-forwarded-message (xml-data)
 304   (let* ((sent (car (jabber-xml-get-children xml-data 'sent)))
 305          (forwarded (car (jabber-xml-get-children sent 'forwarded)))
 306          (forwarded-message (car (jabber-xml-get-children forwarded 'message))))
 307     (when forwarded-message
 308       forwarded-message)))
 309
 310 (defun jabber-process-chat (jc xml-data)
 311   "If XML-DATA is a one-to-one chat message, handle it as such.
 312 JC is the Jabber connection."
 313   ;; For now, everything that is not a public MUC message is
 314   ;; potentially a 1to1 chat message.
 315   (when (not (jabber-muc-message-p xml-data))
 316     ;; Note that we handle private MUC messages here.
 317     (cl-destructuring-bind (xml-data chat-buffer)
 318         (if (car (jabber-xml-get-children xml-data 'sent))
 319             (let* ((fwd-msg (jabber-get-forwarded-message xml-data))
 320                    (to (jabber-xml-get-attribute fwd-msg 'to)))
 321               (list fwd-msg
 322                     (jabber-chat-create-buffer jc to)))
 323           (list xml-data nil))
 324       (let ((from (jabber-xml-get-attribute xml-data 'from))
 325             (error-p (jabber-xml-get-children xml-data 'error))
 326             (body-text (car (jabber-xml-node-children
 327                              (car (jabber-xml-get-children
 328                                    xml-data 'body))))))
 329         ;; First check if we would output anything for this stanza.
 330         (when (or error-p
 331                   (run-hook-with-args-until-success 'jabber-chat-printers
 332                                                     xml-data
 333                                                     :foreign :printp))
 334           ;; If so, create chat buffer, if necessary...
 335           (with-current-buffer (if (jabber-muc-sender-p from)
 336                                    (jabber-muc-private-create-buffer
 337                                     jc
 338                                     (jabber-jid-user from)
 339                                     (jabber-jid-resource from))
 340                                  (or chat-buffer
 341                                      (jabber-chat-create-buffer jc from)))
 342             ;; ...add the message to the ewoc...
 343             (let ((node (ewoc-enter-last jabber-chat-ewoc
 344                                          (list (if error-p :error :foreign)
 345                                                xml-data
 346                                                :time
 347                                                (current-time)))))
 348               (jabber-maybe-print-rare-time node))
 349
 350             ;; ...and call alert hooks.
 351             (dolist (hook '(jabber-message-hooks jabber-alert-message-hooks))
 352               (run-hook-with-args hook
 353                                   from (current-buffer) body-text
 354                                   (funcall jabber-alert-message-function
 355                                            from (current-buffer) body-text)))))))))
 356
 357 (defun jabber-chat-send (jc body)
 358   "Send BODY through connection JC, and display it in chat buffer.
 359 JC is the Jabber connection."
 360   ;; Build the stanza...
 361   (let* ((id (apply 'format "emacs-msg-%d.%d.%d" (current-time)))
 362          (stanza-to-send `(message
 363                            ((to . ,jabber-chatting-with)
 364                             (type . "chat")
 365                             (id . ,id))
 366                            (body () ,body))))
 367     ;; ...add additional elements...
 368     ;; TODO: Once we require Emacs 24.1, use `run-hook-wrapped' instead.
 369     ;; That way we don't need to eliminate the "local hook" functionality
 370     ;; here.
 371     (dolist (hook jabber-chat-send-hooks)
 372       (if (eq hook t)
 373           ;; Local hook referring to global...
 374           (when (local-variable-p 'jabber-chat-send-hooks)
 375             (dolist (global-hook (default-value 'jabber-chat-send-hooks))
 376               (nconc stanza-to-send (funcall global-hook body id))))
 377       (nconc stanza-to-send (funcall hook body id))))
 378     ;; ...display it, if it would be displayed.
 379     (when (run-hook-with-args-until-success 'jabber-chat-printers stanza-to-send :local :printp)
 380       (jabber-maybe-print-rare-time
 381        (ewoc-enter-last jabber-chat-ewoc (list :local stanza-to-send :time (current-time)))))
 382     ;; ...and send it...
 383     (jabber-send-sexp jc stanza-to-send)))
 384
 385 (defun jabber-chat-pp (data)
 386   "Pretty-print a <message/> stanza.
 387 \(car data) is either :local, :foreign, :error or :notice.
 388 \(cadr data) is the <message/> stanza.
 389 This function is used as an ewoc prettyprinter."
 390   (let* ((beg (point))
 391          (original-timestamp (when (listp (cadr data))
 392                                (jabber-message-timestamp (cadr data))))
 393          (internal-time
 394           (plist-get (cddr data) :time))
 395          (body (ignore-errors (car
 396                (jabber-xml-node-children
 397                 (car
 398                  (jabber-xml-get-children (cadr data) 'body))))))
 399          (/me-p
 400           (and (> (length body) 4)
 401                (string= (substring body 0 4) "/me "))))
 402
 403     ;; Print prompt...
 404     (let ((delayed (or original-timestamp (plist-get (cddr data) :delayed)))
 405           (prompt-start (point)))
 406       (cl-case (car data)
 407         (:local
 408          (jabber-chat-self-prompt (or original-timestamp internal-time)
 409                                   delayed
 410                                   /me-p))
 411         (:foreign
 412          (if (and (listp (cadr data))
 413                   (jabber-muc-private-message-p (cadr data)))
 414              (jabber-muc-private-print-prompt (cadr data))
 415            ;; For :error and :notice, this might be a string... beware
 416            (jabber-chat-print-prompt (when (listp (cadr data)) (cadr data))
 417                                      (or original-timestamp internal-time)
 418                                      delayed
 419                                      /me-p)))
 420         ((:error :notice :subscription-request)
 421          (jabber-chat-system-prompt (or original-timestamp internal-time)))
 422         (:muc-local
 423          (jabber-muc-print-prompt (cadr data) t /me-p))
 424         (:muc-foreign
 425          (jabber-muc-print-prompt (cadr data) nil /me-p))
 426         ((:muc-notice :muc-error)
 427          (jabber-muc-system-prompt)))
 428       (put-text-property prompt-start (point) 'field 'jabber-prompt))
 429
 430     ;; ...and body
 431     (cl-case (car data)
 432       ((:local :foreign)
 433        (run-hook-with-args 'jabber-chat-printers (cadr data) (car data) :insert))
 434       ((:muc-local :muc-foreign)
 435        (dolist (hook '(jabber-muc-printers jabber-chat-printers))
 436          (run-hook-with-args hook (cadr data) (car data) :insert)))
 437       ((:error :muc-error)
 438        (if (stringp (cadr data))
 439             (insert (jabber-propertize (cadr data) 'face 'jabber-chat-error))
 440          (jabber-chat-print-error (cadr data))))
 441       ((:notice :muc-notice)
 442        (insert (cadr data)))
 443       (:rare-time
 444        (insert (jabber-propertize (format-time-string jabber-rare-time-format (cadr data))
 445                                   'face 'jabber-rare-time-face)))
 446       (:subscription-request
 447        (insert "This user requests subscription to your presence.\n")
 448        (when (and (stringp (cadr data)) (not (zerop (length (cadr data)))))
 449          (insert "Message: " (cadr data) "\n"))
 450        (insert "Accept?\n\n")
 451        (cl-flet ((button
 452                (text action)
 453                (if (fboundp 'insert-button)
 454                    (insert-button text 'action action)
 455                  ;; simple button replacement
 456                  (let ((keymap (make-keymap)))
 457                    (define-key keymap "\r" action)
 458                    (insert (jabber-propertize text 'keymap keymap 'face 'highlight))))
 459                (insert "\t")))
 460          (button "Mutual" 'jabber-subscription-accept-mutual)
 461          (button "One-way" 'jabber-subscription-accept-one-way)
 462          (button "Decline" 'jabber-subscription-decline))))
 463
 464     (when jabber-chat-fill-long-lines
 465       (save-restriction
 466         (narrow-to-region beg (point))
 467         (jabber-chat-buffer-fill-long-lines)))
 468
 469     (put-text-property beg (point) 'read-only t)
 470     (put-text-property beg (point) 'front-sticky t)
 471     (put-text-property beg (point) 'rear-nonsticky t)))
 472
 473 (defun jabber-rare-time-needed (time1 time2)
 474   "Return non-nil if a timestamp should be printed between TIME1 and TIME2."
 475   (not (string= (format-time-string jabber-rare-time-format time1)
 476                 (format-time-string jabber-rare-time-format time2))))
 477
 478 (defun jabber-maybe-print-rare-time (node)
 479   "Print rare time before NODE, if appropriate."
 480   (let* ((prev (ewoc-prev jabber-chat-ewoc node))
 481          (data (ewoc-data node))
 482          (prev-data (when prev (ewoc-data prev))))
 483     (cl-flet ((entry-time (entry)
 484                        (or (when (listp (cadr entry))
 485                              (jabber-message-timestamp (cadr entry)))
 486                            (plist-get (cddr entry) :time))))
 487       (when (and jabber-print-rare-time
 488                  (or (null prev)
 489                      (jabber-rare-time-needed (entry-time prev-data)
 490                                               (entry-time data))))
 491         (ewoc-enter-before jabber-chat-ewoc node
 492                            (list :rare-time (entry-time data)))))))
 493
 494 (defun jabber-chat-print-prompt (xml-data timestamp delayed dont-print-nick-p)
 495   "Print prompt for received message in XML-DATA.
 496 TIMESTAMP is the timestamp to print, or nil to get it
 497 from a jabber:x:delay element.
 498 If DELAYED is non-nil, print long timestamp
 499 \(`jabber-chat-delayed-time-format' as opposed to
 500 `jabber-chat-time-format').
 501 If DONT-PRINT-NICK-P is non-nil, don't include nickname."
 502   (let ((from (jabber-xml-get-attribute xml-data 'from))
 503         (timestamp (or timestamp (jabber-message-timestamp xml-data))))
 504     (insert (jabber-propertize
 505              (format-spec jabber-chat-foreign-prompt-format
 506                           (list
 507                            (cons ?t (format-time-string
 508                                      (if delayed
 509                                          jabber-chat-delayed-time-format
 510                                        jabber-chat-time-format)
 511                                      timestamp))
 512                            (cons ?n (if dont-print-nick-p "" (jabber-jid-displayname from)))
 513                            (cons ?u (or (jabber-jid-username from) from))
 514                            (cons ?r (jabber-jid-resource from))
 515                            (cons ?j (jabber-jid-user from))))
 516              'face 'jabber-chat-prompt-foreign
 517              'help-echo
 518              (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from " from)))))
 519
 520 (defun jabber-chat-system-prompt (timestamp)
 521   (insert (jabber-propertize
 522            (format-spec jabber-chat-foreign-prompt-format
 523                         (list
 524                          (cons ?t (format-time-string jabber-chat-time-format
 525                                                       timestamp))
 526                          (cons ?n "")
 527                          (cons ?u "")
 528                          (cons ?r "")
 529                          (cons ?j "")))
 530            'face 'jabber-chat-prompt-system
 531            'help-echo
 532            (concat (format-time-string "System message on %Y-%m-%d %H:%M:%S" timestamp)))))
 533
 534 (defun jabber-chat-self-prompt (timestamp delayed dont-print-nick-p)
 535   "Print prompt for sent message.
 536 TIMESTAMP is the timestamp to print, or nil for now.
 537 If DELAYED is non-nil, print long timestamp
 538 \(`jabber-chat-delayed-time-format' as opposed to
 539 `jabber-chat-time-format').
 540 If DONT-PRINT-NICK-P is non-nil, don't include nickname."
 541   (let* ((state-data (fsm-get-state-data jabber-buffer-connection))
 542          (username (plist-get state-data :username))
 543          (server (plist-get state-data :server))
 544          (resource (plist-get state-data :resource))
 545          (nickname username))
 546     (insert (jabber-propertize
 547              (format-spec jabber-chat-local-prompt-format
 548                           (list
 549                            (cons ?t (format-time-string
 550                                      (if delayed
 551                                          jabber-chat-delayed-time-format
 552                                        jabber-chat-time-format)
 553                                      timestamp))
 554                            (cons ?n (if dont-print-nick-p "" nickname))
 555                            (cons ?u username)
 556                            (cons ?r resource)
 557                            (cons ?j (concat username "@" server))))
 558              'face 'jabber-chat-prompt-local
 559              'help-echo
 560              (concat (format-time-string "On %Y-%m-%d %H:%M:%S" timestamp) " from you")))))
 561
 562 (defun jabber-chat-print-error (xml-data)
 563   "Print error in given <message/> in a readable way.
 564
 565 XML-DATA is the parsed tree data from the stream (stanzas)
 566 obtained from `xml-parse-region'."
 567   (let ((the-error (car (jabber-xml-get-children xml-data 'error))))
 568     (insert
 569      (jabber-propertize
 570       (concat "Error: " (jabber-parse-error the-error))
 571       'face 'jabber-chat-error))))
 572
 573 (defun jabber-chat-print-subject (xml-data who mode)
 574   "Print subject of given <message/>, if any.
 575
 576 XML-DATA is the parsed tree data from the stream (stanzas)
 577 obtained from `xml-parse-region'."
 578   (let ((subject (car
 579                   (jabber-xml-node-children
 580                    (car
 581                     (jabber-xml-get-children xml-data 'subject))))))
 582     (when (not (zerop (length subject)))
 583       (cl-case mode
 584         (:printp
 585          t)
 586         (:insert
 587          (insert (jabber-propertize
 588                   "Subject: " 'face 'jabber-chat-prompt-system)
 589                  (jabber-propertize
 590                   subject
 591                   'face 'jabber-chat-text-foreign)
 592                  "\n"))))))
 593
 594 (defun jabber-chat-print-body (xml-data who mode)
 595   (run-hook-with-args-until-success 'jabber-body-printers xml-data who mode))
 596
 597 (defun jabber-chat-normal-body (xml-data who mode)
 598   "Print body for received message in XML-DATA."
 599   (let ((body (car
 600                (jabber-xml-node-children
 601                 (car
 602                  (jabber-xml-get-children xml-data 'body))))))
 603     (when body
 604
 605       (when (eql mode :insert)
 606         (if (and (> (length body) 4)
 607                  (string= (substring body 0 4) "/me "))
 608             (let ((action (substring body 4))
 609                   (nick (cond
 610                          ((eq who :local)
 611                           (plist-get (fsm-get-state-data jabber-buffer-connection) :username))
 612                          ((or (jabber-muc-message-p xml-data)
 613                               (jabber-muc-private-message-p xml-data))
 614                           (jabber-jid-resource (jabber-xml-get-attribute xml-data 'from)))
 615                          (t
 616                           (jabber-jid-displayname (jabber-xml-get-attribute xml-data 'from))))))
 617               (insert (jabber-propertize
 618                        (concat nick
 619                                " "
 620                                action)
 621                        'face 'jabber-chat-prompt-system)))
 622           (insert (jabber-propertize
 623                    body
 624                    'face (cl-case who
 625                            ((:foreign :muc-foreign) 'jabber-chat-text-foreign)
 626                            ((:local :muc-local) 'jabber-chat-text-local))))))
 627       t)))
 628
 629 (defun jabber-chat-print-url (xml-data who mode)
 630   "Print URLs provided in jabber:x:oob namespace.
 631
 632 XML-DATA is the parsed tree data from the stream (stanzas)
 633 obtained from `xml-parse-region'."
 634   (let ((foundp nil))
 635     (dolist (x (jabber-xml-node-children xml-data))
 636       (when (and (listp x) (eq (jabber-xml-node-name x) 'x)
 637                  (string= (jabber-xml-get-attribute x 'xmlns) "jabber:x:oob"))
 638         (setq foundp t)
 639
 640         (when (eql mode :insert)
 641           (let ((url (car (jabber-xml-node-children
 642                            (car (jabber-xml-get-children x 'url)))))
 643                 (desc (car (jabber-xml-node-children
 644                             (car (jabber-xml-get-children x 'desc))))))
 645             (insert "\n"
 646                     (jabber-propertize
 647                      "URL: " 'face 'jabber-chat-prompt-system)
 648                     (format "%s <%s>" desc url))))))
 649     foundp))
 650
 651 (defun jabber-chat-goto-address (xml-data who mode)
 652   "Call `goto-address' on the newly written text.
 653
 654 XML-DATA is the parsed tree data from the stream (stanzas)
 655 obtained from `xml-parse-region'."
 656   (when (eq mode :insert)
 657     (ignore-errors
 658       (let ((end (point))
 659             (limit (max (- (point) 1000) (1+ (point-min)))))
 660         ;; We only need to fontify the text written since the last
 661         ;; prompt.  The prompt has a field property, so we can find it
 662         ;; using `field-beginning'.
 663         (goto-address-fontify (field-beginning nil nil limit) end)))))
 664
 665 ;; jabber-compose is autoloaded in jabber.el
 666 (add-to-list 'jabber-jid-chat-menu
 667              (cons "Compose message" 'jabber-compose))
 668
 669 (defun jabber-send-message (jc to subject body type)
 670   "Send a message tag to the server.
 671 JC is the Jabber connection."
 672   (interactive (list (jabber-read-account)
 673                      (jabber-read-jid-completing "to: ")
 674                      (jabber-read-with-input-method "subject: ")
 675                      (jabber-read-with-input-method "body: ")
 676                      (read-string "type: ")))
 677   (jabber-send-sexp jc
 678                     `(message ((to . ,to)
 679                                ,(if (> (length type) 0)
 680                                     `(type . ,type)))
 681                               ,(if (> (length subject) 0)
 682                                    `(subject () ,subject))
 683                               ,(if (> (length body) 0)
 684                                    `(body () ,body))))
 685   (if (and jabber-history-enabled (not (string= type "groupchat")))
 686       (jabber-history-log-message "out" nil to body (current-time))))
 687
 688 (add-to-list 'jabber-jid-chat-menu
 689              (cons "Start chat" 'jabber-chat-with))
 690
 691 (defun jabber-chat-with (jc jid &optional other-window)
 692   "Open an empty chat window for chatting with JID.
 693 With a prefix argument, open buffer in other window.
 694 Returns the chat buffer.
 695 JC is the Jabber connection."
 696   (interactive (let* ((jid
 697                       (jabber-read-jid-completing "chat with:"))
 698                       (account
 699                        (jabber-read-account nil jid)))
 700                  (list
 701                   account jid current-prefix-arg)))
 702   (let ((buffer (jabber-chat-create-buffer jc jid)))
 703     (if other-window
 704         (switch-to-buffer-other-window buffer)
 705       (switch-to-buffer buffer))))
 706
 707 (defun jabber-chat-with-jid-at-point (&optional other-window)
 708   "Start chat with JID at point.
 709 Signal an error if there is no JID at point.
 710 With a prefix argument, open buffer in other window."
 711   (interactive "P")
 712   (let ((jid-at-point (get-text-property (point)
 713                                          'jabber-jid))
 714         (account (get-text-property (point)
 715                                     'jabber-account)))
 716     (if (and jid-at-point account)
 717         (jabber-chat-with account jid-at-point other-window)
 718       (error "No contact at point"))))
 719
 720 (provide 'jabber-chat)
 721
 722 ;; arch-tag: f423eb92-aa87-475b-b590-48c93ccba9be