;;; jabber-export.el --- export Jabber roster to file -*- lexical-binding: t; -*- ;; Copyright (C) 2005, 2007 Magnus Henoch ;; Author: Magnus Henoch ;; This file is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This file is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. (require 'cl-lib) (defvar jabber-export-roster-widget nil) (defvar jabber-import-subscription-p-widget nil) ;;;###autoload (defun jabber-export-roster (jc) "Export roster for connection JC." (interactive (list (jabber-read-account))) (let ((state-data (fsm-get-state-data jc))) (jabber-export-roster-do-it (jabber-roster-to-sexp (plist-get state-data :roster))))) (defun jabber-export-roster-do-it (roster) "Create buffer from which ROSTER can be exported to a file." (interactive) (with-current-buffer (get-buffer-create "Export roster") (jabber-init-widget-buffer nil) (widget-insert (jabber-propertize "Export roster\n" 'face 'jabber-title-large)) (widget-insert "You are about to save your roster to a file. Here you can edit it before saving. Changes done here will not affect your actual roster. ") (widget-create 'push-button :notify #'jabber-export-save "Save to file") (widget-insert " ") (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp") (widget-insert "\n\n") (make-local-variable 'jabber-export-roster-widget) (jabber-export-display roster) (widget-setup) (widget-minor-mode 1) (goto-char (point-min)) (switch-to-buffer (current-buffer)))) ;;;###autoload (defun jabber-import-roster (jc file) "Create buffer for roster import for connection JC from FILE." (interactive (list (jabber-read-account) (read-file-name "Import roster from file: "))) (let ((roster (with-temp-buffer (let ((coding-system-for-read 'utf-8)) (jabber-roster-xml-to-sexp (car (xml-parse-file file))))))) (with-current-buffer (get-buffer-create "Import roster") (setq jabber-buffer-connection jc) (jabber-init-widget-buffer nil) (widget-insert (jabber-propertize "Import roster\n" 'face 'jabber-title-large)) (widget-insert "You are about to import the contacts below to your roster. ") (make-local-variable 'jabber-import-subscription-p-widget) (setq jabber-import-subscription-p-widget (widget-create 'checkbox)) (widget-insert " Adjust subscriptions\n") (widget-create 'push-button :notify #'jabber-import-doit "Import to roster") (widget-insert " ") (widget-create 'push-button :notify #'jabber-export-remove-regexp "Remove by regexp") (widget-insert "\n\n") (make-local-variable 'jabber-export-roster-widget) (jabber-export-display roster) (widget-setup) (widget-minor-mode 1) (goto-char (point-min)) (switch-to-buffer (current-buffer))))) (defun jabber-export-remove-regexp (&rest _ignore) (let* ((value (widget-value jabber-export-roster-widget)) (length-before (length value)) (regexp (read-string "Remove JIDs matching regexp: "))) (setq value (cl-delete-if #'(lambda (a) (string-match regexp (nth 0 a))) value)) (widget-value-set jabber-export-roster-widget value) (widget-setup) (message "%d items removed" (- length-before (length value))))) (defun jabber-export-save (&rest _ignore) "Export roster to file." (let ((items (mapcar #'jabber-roster-sexp-to-xml (widget-value jabber-export-roster-widget))) (coding-system-for-write 'utf-8)) (with-temp-file (read-file-name "Export roster to file: ") (insert "\n") (dolist (item items) (insert (jabber-sexp2xml item) "\n")) (insert "\n")) (message "Roster saved"))) (defun jabber-import-doit (&rest _ignore) "Import roster being edited in widget." (let* ((state-data (fsm-get-state-data jabber-buffer-connection)) (jabber-roster (plist-get state-data :roster)) roster-delta) (dolist (n (widget-value jabber-export-roster-widget)) (let* ((jid (nth 0 n)) (name (and (not (zerop (length (nth 1 n)))) (nth 1 n))) (subscription (nth 2 n)) (groups (nth 3 n)) (jid-symbol (jabber-jid-symbol jid)) (in-roster-p (memq jid-symbol jabber-roster)) (jid-name (and in-roster-p (get jid-symbol 'name))) (jid-subscription (and in-roster-p (get jid-symbol 'subscription))) (jid-groups (and in-roster-p (get jid-symbol 'groups)))) ;; Do we need to change the roster? (when (or ;; If the contact is not in the roster already, (not in-roster-p) ;; or if the import introduces a name, (and name (not jid-name)) ;; or changes a name, (and name jid-name (not (string= name jid-name))) ;; or introduces new groups. (cl-set-difference groups jid-groups :test #'string=)) (push (jabber-roster-sexp-to-xml (list jid (or name jid-name) nil (cl-union groups jid-groups :test #'string=)) t) roster-delta)) ;; And adujst subscription. (when (widget-value jabber-import-subscription-p-widget) (let ((want-to (member subscription '("to" "both"))) (want-from (member subscription '("from" "both"))) (have-to (member jid-subscription '("to" "both"))) (have-from (member jid-subscription '("from" "both")))) (cl-flet ((request-subscription (type) (jabber-send-sexp jabber-buffer-connection `(presence ((to . ,jid) (type . ,type)))))) (cond ((and want-to (not have-to)) (request-subscription "subscribe")) ((and have-to (not want-to)) (request-subscription "unsubscribe"))) (cond ((and want-from (not have-from)) ;; not much to do here ) ((and have-from (not want-from)) (request-subscription "unsubscribed")))))))) (when roster-delta (jabber-send-iq jabber-buffer-connection nil "set" `(query ((xmlns . "jabber:iq:roster")) ,@roster-delta) #'jabber-report-success "Roster import" #'jabber-report-success "Roster import")))) (defun jabber-roster-to-sexp (roster) "Convert ROSTER to simpler sexp format. Return a list, where each item is a vector: \[jid name subscription groups] where groups is a list of strings." (mapcar #'(lambda (n) (list (symbol-name n) (or (get n 'name) "") (get n 'subscription) (get n 'groups))) roster)) (defun jabber-roster-sexp-to-xml (sexp &optional omit-subscription) "Convert SEXP to XML format. Return an XML node." `(item ((jid . ,(nth 0 sexp)) ,@(let ((name (nth 1 sexp))) (unless (zerop (length name)) `((name . ,name)))) ,@(unless omit-subscription `((subscription . ,(nth 2 sexp))))) ,@(mapcar #'(lambda (g) (list 'group nil g)) (nth 3 sexp)))) (defun jabber-roster-xml-to-sexp (xml-data) "Convert XML-DATA to simpler sexp format. XML-DATA is an node with a child. See `jabber-roster-to-sexp' for description of output format." (cl-assert (eq (jabber-xml-node-name xml-data) 'iq)) (let ((query (car (jabber-xml-get-children xml-data 'query)))) (cl-assert query) (mapcar #'(lambda (n) (list (jabber-xml-get-attribute n 'jid) (or (jabber-xml-get-attribute n 'name) "") (jabber-xml-get-attribute n 'subscription) (mapcar #'(lambda (g) (car (jabber-xml-node-children g))) (jabber-xml-get-children n 'group)))) (jabber-xml-get-children query 'item)))) (defun jabber-export-display (roster) (setq jabber-export-roster-widget (widget-create '(repeat :tag "Roster" (list :format "%v" (string :tag "JID") (string :tag "Name") (choice :tag "Subscription" (const "none") (const "both") (const "to") (const "from")) (repeat :tag "Groups" (string :tag "Group")))) :value roster))) (provide 'jabber-export) ;;; arch-tag: 9c6b94a9-290a-4c0f-9286-72bd9c1fb8a3