diff options
Diffstat (limited to 'lisp/net')
| -rw-r--r-- | lisp/net/imap-hash.el | 373 | ||||
| -rw-r--r-- | lisp/net/netrc.el | 2 | ||||
| -rw-r--r-- | lisp/net/rcirc.el | 17 | ||||
| -rw-r--r-- | lisp/net/soap-client.el | 1741 | ||||
| -rw-r--r-- | lisp/net/soap-inspect.el | 357 | ||||
| -rw-r--r-- | lisp/net/tramp-imap.el | 844 | ||||
| -rw-r--r-- | lisp/net/tramp.el | 35 |
7 files changed, 2135 insertions, 1234 deletions
diff --git a/lisp/net/imap-hash.el b/lisp/net/imap-hash.el deleted file mode 100644 index d21b714d950..00000000000 --- a/lisp/net/imap-hash.el +++ /dev/null @@ -1,373 +0,0 @@ -;;; imap-hash.el --- Hashtable-like interface to an IMAP mailbox - -;; Copyright (C) 2009-2011 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov <tzz@lifelogs.com> -;; Keywords: mail - -;; This program 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 3 of the License, or -;; (at your option) any later version. - -;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This module provides hashtable-like functions on top of imap.el -;; functionality. All the authentication is handled by auth-source so -;; there are no authentication options here, only the server and -;; mailbox names are needed. - -;; Create a IHT (imap-hash table) object with `imap-hash-make'. Then -;; use it with `imap-hash-map' to map a function across all the -;; messages. Use `imap-hash-get' and `imap-hash-rem' to operate on -;; individual messages. See the tramp-imap.el library in Tramp if you -;; need to see practical examples. - -;; This only works with IMAP4r1. Sorry to everyone without it, but -;; the compatibility code is too annoying and it's 2009. - -;; TODO: Use SEARCH instead of FETCH when a test is specified. List -;; available mailboxes. Don't select an invalid mailbox. - -;;; Code: - -(require 'assoc) -(require 'imap) -(require 'sendmail) ; for mail-header-separator -(require 'message) -(autoload 'auth-source-user-or-password "auth-source") - -;; retrieve these headers -(defvar imap-hash-headers - (append '(Subject From Date Message-Id References In-Reply-To Xref))) - -;; from nnheader.el -(defsubst imap-hash-remove-cr-followed-by-lf () - (goto-char (point-max)) - (while (search-backward "\r\n" nil t) - (delete-char 1))) - -;; from nnheader.el -(defun imap-hash-ms-strip-cr (&optional string) - "Strip ^M from the end of all lines in current buffer or STRING." - (if string - (with-temp-buffer - (insert string) - (imap-hash-remove-cr-followed-by-lf) - (buffer-string)) - (save-excursion - (imap-hash-remove-cr-followed-by-lf)))) - -(defun imap-hash-make (server port mailbox &optional user password ssl) - "Make a new imap-hash object using SERVER, PORT, and MAILBOX. -USER, PASSWORD and SSL are optional. -The test is set to t, meaning all messages are considered." - (when (and server port mailbox) - (list :server server :port port :mailbox mailbox - :ssl ssl :user user :password password - :test t))) - -(defun imap-hash-p (iht) - "Check whether IHT is a valid imap-hash." - (and - (imap-hash-server iht) - (imap-hash-port iht) - (imap-hash-mailbox iht) - (imap-hash-test iht))) - -(defmacro imap-hash-gather (uid) - `(imap-message-get ,uid 'BODYDETAIL)) - -(defmacro imap-hash-data-body (details) - `(nth 2 (nth 1 ,details))) - -(defmacro imap-hash-data-headers (details) - `(nth 2 (nth 0 ,details))) - -(defun imap-hash-get (key iht &optional refetch) - "Get the value for KEY in the imap-hash IHT. -Requires either `imap-hash-fetch' to be called beforehand -\(e.g. by `imap-hash-map'), or REFETCH to be t. -Returns a list of the headers (an alist, see `imap-hash-map') and -the body of the message as a string. -Also see `imap-hash-test'." - (with-current-buffer (imap-hash-get-buffer iht) - (when refetch - (imap-hash-fetch iht nil key)) - (let ((details (imap-hash-gather key))) - (list - (imap-hash-get-headers - (imap-hash-data-headers details)) - (imap-hash-get-body - (imap-hash-data-body details)))))) - -(defun imap-hash-put (value iht &optional key) - "Put VALUE in the imap-hash IHT. Return the new key. -If KEY is given, removes it. -VALUE can be a list of the headers (an alist, see `imap-hash-map') -and the body of the message as a string. It can also be a uid, -in which case `imap-hash-get' will be called to get the value. -Also see `imap-hash-test'." - (let ((server-buffer (imap-hash-get-buffer iht)) - (value (if (listp value) value (imap-hash-get value iht))) - newuid) - (when value - (with-temp-buffer - (funcall 'imap-hash-make-message - (nth 0 value) - (nth 1 value) - nil) - (setq newuid (nth 1 (imap-message-append - (imap-hash-mailbox iht) - (current-buffer) nil nil server-buffer))) - (when key (imap-hash-rem key iht)))) - newuid)) - -(defun imap-hash-make-message (headers body &optional overrides) - "Make a message with HEADERS and BODY suitable for `imap-append', -using `message-setup'. -Look in the alist OVERRIDES for header overrides as per `imap-hash-headers'." - ;; don't insert a signature no matter what - (let (message-signature) - (message-setup - (append overrides headers)) - (message-generate-headers message-required-mail-headers) - (message-remove-header "X-Draft-From") - (message-goto-body) - (insert (or (aget overrides 'body) - body - "")) - (goto-char (point-min)) - ;; TODO: make this search better - (if (search-forward mail-header-separator nil t) - (delete-region (line-beginning-position) (line-end-position)) - (error "Could not find the body separator in the encoded message!")))) - -(defun imap-hash-rem (key iht) - "Remove KEY in the imap-hash IHT. -Also see `imap-hash-test'. Requires `imap-hash-fetch' to have -been called and the imap-hash server buffer to be current, -so it's best to use it inside `imap-hash-map'. -The key will not be found on the next `imap-hash-map' call." - (with-current-buffer (imap-hash-get-buffer iht) - (imap-message-flags-add - (imap-range-to-message-set (list key)) - "\\Deleted" 'silent) - (imap-mailbox-expunge t))) - -(defun imap-hash-clear (iht) - "Remove all keys in the imap-hash IHT. -Also see `imap-hash-test'." - (imap-hash-map (lambda (uid b c) (imap-hash-rem uid iht)) iht)) - -(defun imap-hash-get-headers (text-headers) - (with-temp-buffer - (insert (or text-headers "")) - (imap-hash-remove-cr-followed-by-lf) - (mapcar (lambda (header) - (cons header - (message-fetch-field (format "%s" header)))) - imap-hash-headers))) - -(defun imap-hash-get-body (text) - (with-temp-buffer - (insert (or text "")) - (imap-hash-remove-cr-followed-by-lf) - (buffer-string))) - -(defun imap-hash-map (function iht &optional headers-only &rest messages) - "Call FUNCTION for all entries in IHT and pass it the message uid, -the headers (an alist, see `imap-hash-headers'), and the body -contents as a string. If HEADERS-ONLY is not nil, the body will be nil. -Returns results of evaluating, as would `mapcar'. -If MESSAGES are given, iterate only over those UIDs. -Also see `imap-hash-test'." - (imap-hash-fetch iht headers-only) - (let ((test (imap-hash-test iht))) - (with-current-buffer (imap-hash-get-buffer iht) - (delq nil - (imap-message-map (lambda (message ignored-parameter) - (let* ((details (imap-hash-gather message)) - (headers (imap-hash-data-headers details)) - (hlist (imap-hash-get-headers headers)) - (runit (cond - ((stringp test) - (string-match - test - (format "%s" (aget hlist 'Subject)))) - ((functionp test) - (funcall test hlist)) - ;; otherwise, return test itself - (t test)))) - ;;(debug message headers) - (when runit - (funcall function - message - (imap-hash-get-headers - headers) - (imap-hash-get-body - (imap-hash-data-body details)))))) - "UID"))))) - -(defun imap-hash-count (iht) - "Count the number of messages in the imap-hash IHT. -Also see `imap-hash-test'. It uses `imap-hash-map' so just use that -function if you want to do more than count the elements." - (length (imap-hash-map (lambda (a b c)) iht t))) - -(defalias 'imap-hash-size 'imap-hash-count) - -(defun imap-hash-test (iht) - "Return the test used by `imap-hash-map' for IHT. -When the test is t, any key will be a candidate. -When the test is a string, messages will be filtered on that string as a -regexp against the subject. -When the test is a function, messages will be filtered with it. -The function is passed the message headers (see `imap-hash-get-headers')." - (plist-get iht :test)) - -(defun imap-hash-server (iht) - "Return the server used by the imap-hash IHT." - (plist-get iht :server)) - -(defun imap-hash-port (iht) - "Return the port used by the imap-hash IHT." - (plist-get iht :port)) - -(defun imap-hash-ssl (iht) - "Return the SSL need for the imap-hash IHT." - (plist-get iht :ssl)) - -(defun imap-hash-mailbox (iht) - "Return the mailbox used by the imap-hash IHT." - (plist-get iht :mailbox)) - -(defun imap-hash-user (iht) - "Return the username used by the imap-hash IHT." - (plist-get iht :user)) - -(defun imap-hash-password (iht) - "Return the password used by the imap-hash IHT." - (plist-get iht :password)) - -(defun imap-hash-open-connection (iht) - "Open the connection used for IMAP interactions with the imap-hash IHT." - (let* ((server (imap-hash-server iht)) - (port (imap-hash-port iht)) - (ssl-need (imap-hash-ssl iht)) - (auth-need (not (and (imap-hash-user iht) - (imap-hash-password iht)))) - ;; this will not be needed if auth-need is t - (auth-info (when auth-need - (auth-source-user-or-password - '("login" "password") - server port))) - (auth-user (or (imap-hash-user iht) - (nth 0 auth-info))) - (auth-passwd (or (imap-hash-password iht) - (nth 1 auth-info))) - (imap-logout-timeout nil)) - - ;; (debug "opening server: opened+state" (imap-opened) imap-state) - ;; this is the only place where IMAP vs IMAPS matters - (if (imap-open server port (if ssl-need 'ssl nil) nil (current-buffer)) - (progn - ;; (debug "after opening server: opened+state" (imap-opened (current-buffer)) imap-state) - ;; (debug "authenticating" auth-user auth-passwd) - (if (not (imap-capability 'IMAP4rev1)) - (error "IMAP server does not support IMAP4r1, it won't work, sorry") - (imap-authenticate auth-user auth-passwd) - (imap-id) - ;; (debug "after authenticating: opened+state" (imap-opened (current-buffer)) imap-state) - (imap-opened (current-buffer)))) - (error "Could not open the IMAP buffer")))) - -(defun imap-hash-get-buffer (iht) - "Get or create the connection buffer to be used for the imap-hash IHT." - (let* ((name (imap-hash-buffer-name iht)) - (buffer (get-buffer name))) - (if (and buffer (imap-opened buffer)) - buffer - (when buffer (kill-buffer buffer)) - (with-current-buffer (get-buffer-create name) - (setq buffer-undo-list t) - (when (imap-hash-open-connection iht) - (current-buffer)))))) - -(defun imap-hash-buffer-name (iht) - "Get the connection buffer to be used for the imap-hash IHT." - (when (imap-hash-p iht) - (let ((server (imap-hash-server iht)) - (port (imap-hash-port iht)) - (ssl-text (if (imap-hash-ssl iht) "SSL" "NoSSL"))) - (format "*imap-hash/%s:%s:%s*" server port ssl-text)))) - -(defun imap-hash-fetch (iht &optional headers-only &rest messages) - "Fetch all the messages for imap-hash IHT. -Get only the headers if HEADERS-ONLY is not nil." - (with-current-buffer (imap-hash-get-buffer iht) - (let ((range (if messages - (list - (imap-range-to-message-set messages) - (imap-range-to-message-set messages)) - '("1:*" . "1,*:*")))) - - ;; (with-current-buffer "*imap-debug*" - ;; (erase-buffer)) - (imap-mailbox-unselect) - (imap-mailbox-select (imap-hash-mailbox iht)) - ;; (debug "after selecting mailbox: opened+state" (imap-opened) imap-state) - ;; (setq imap-message-data (make-vector imap-message-prime 0) - (imap-fetch-safe range - (concat (format "(UID RFC822.SIZE BODY %s " - (if headers-only "" "BODY.PEEK[TEXT]")) - (format "BODY.PEEK[HEADER.FIELDS %s])" - imap-hash-headers)))))) - -(provide 'imap-hash) -;;; imap-hash.el ends here - -;; ignore, for testing only - -;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "INBOX.test")) -;;; (setq iht (imap-hash-make "yourhosthere.com" "imap" "test")) -;;; (imap-hash-make "server1" "INBOX.mailbox2") -;;; (imap-hash-p iht) -;;; (imap-hash-get 35 iht) -;;; (imap-hash-get 38 iht) -;;; (imap-hash-get 37 iht t) -;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) -;;; (imap-hash-put (imap-hash-get 5 iht) iht) -;;; (with-current-buffer (imap-hash-get-buffer iht) (let ((uid (imap-hash-put (imap-hash-get 5 iht) iht))) (imap-hash-put uid iht uid))) -;;; (imap-hash-put (imap-hash-get 35 iht) iht) -;;; (imap-hash-make-message '((Subject . "normal")) "normal body") -;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "new"))) -;;; (imap-hash-make-message '((Subject . "old")) "old body" '((body . "new body")) (lambda (subject) (concat "overwrite-" subject))) -;;; (imap-hash-make-message '((Subject . "old")) "old body" '((Subject . "change this")) (lambda (subject) (concat "overwrite-" subject))) -;;; (imap-hash-make-message '((Subject . "Twelcome")) "body here" nil) -;; (with-current-buffer (imap-hash-get-buffer iht) (imap-hash-rem (imap-hash-put (imap-hash-get 5 iht) iht) iht)) -;;; (kill-buffer (imap-hash-buffer-name iht)) -;;; (imap-hash-map 'debug iht) -;;; (imap-hash-map 'debug iht t) -;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") -;;;(imap-hash-count iht) -;;; (mapc (lambda (buffer) (with-current-buffer buffer (erase-buffer))) '("*imap-debug*" "*imap-log*")) -;;; (kill-buffer (imap-hash-buffer-name iht)) -;;; this should always return t if the server is up, automatically reopening if needed -;;; (imap-opened (imap-hash-get-buffer iht)) -;;; (imap-hash-buffer-name iht) -;;; (with-current-buffer (imap-hash-get-buffer iht) (debug "mailbox data, auth and state" imap-mailbox-data imap-auth imap-state)) -;;;(tramp-imap-handle-file-inode "/imap:yourhosthere.com:/test/welcome") -;;; (imap-hash-fetch iht nil) -;;; (imap-hash-fetch iht t) -;;; (imap-hash-fetch iht nil 1 2 3) -;;; (imap-hash-fetch iht t 1 2 3) - diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index 59e9eab5fc3..b04863b5fc0 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -63,10 +63,10 @@ alist elem result pair) (if (and netrc-cache (equal (car netrc-cache) (nth 5 (file-attributes file)))) - ;; Store the contents of the file heavily encrypted in memory. (insert (base64-decode-string (rot13-string (cdr netrc-cache)))) (insert-file-contents file) (when (string-match "\\.gpg\\'" file) + ;; Store the contents of the file heavily encrypted in memory. (setq netrc-cache (cons (nth 5 (file-attributes file)) (rot13-string (base64-encode-string diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 8657dc58bf4..1d419dbfa18 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -556,6 +556,11 @@ If ARG is non-nil, instead prompt for connection parameters." `(with-current-buffer rcirc-server-buffer ,@body)) +(defun rcirc-float-time () + (if (featurep 'xemacs) + (time-to-seconds (current-time)) + (float-time))) + (defun rcirc-keepalive () "Send keep alive pings to active rcirc processes. Kill processes that have not received a server message since the @@ -567,10 +572,7 @@ last ping." (rcirc-send-ctcp process rcirc-nick (format "KEEPALIVE %f" - (if (featurep 'xemacs) - (time-to-seconds - (current-time)) - (float-time))))))) + (rcirc-float-time)))))) (rcirc-process-list)) ;; no processes, clean up timer (cancel-timer rcirc-keepalive-timer) @@ -578,10 +580,7 @@ last ping." (defun rcirc-handler-ctcp-KEEPALIVE (process target sender message) (with-rcirc-process-buffer process - (setq header-line-format (format "%f" (- (if (featurep 'xemacs) - (time-to-seconds - (current-time)) - (float-time)) + (setq header-line-format (format "%f" (- (rcirc-float-time) (string-to-number message)))))) (defvar rcirc-debug-buffer " *rcirc debug*") @@ -2209,7 +2208,7 @@ With a prefix arg, prompt for new topic." (defun rcirc-ctcp-sender-PING (process target request) "Send a CTCP PING message to TARGET." - (let ((timestamp (format "%.0f" (float-time)))) + (let ((timestamp (format "%.0f" (rcirc-float-time)))) (rcirc-send-ctcp process target "PING" timestamp))) (defun rcirc-cmd-me (args &optional process target) diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el new file mode 100644 index 00000000000..b4307223ba8 --- /dev/null +++ b/lisp/net/soap-client.el @@ -0,0 +1,1741 @@ +;;;; soap-client.el -- Access SOAP web services from Emacs + +;; Copyright (C) 2009-2011 Free Software Foundation, Inc. + +;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) +;; Created: December, 2009 +;; Keywords: soap, web-services, comm, hypermedia +;; Homepage: http://code.google.com/p/emacs-soap-client + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; To use the SOAP client, you first need to load the WSDL document for the +;; service you want to access, using `soap-load-wsdl-from-url'. A WSDL +;; document describes the available operations of the SOAP service, how their +;; parameters and responses are encoded. To invoke operations, you use the +;; `soap-invoke' method passing it the WSDL, the service name, the operation +;; you wish to invoke and any required parameters. +;; +;; Idealy, the service you want to access will have some documentation about +;; the operations it supports. If it does not, you can try using +;; `soap-inspect' to browse the WSDL document and see the available operations +;; and their parameters. +;; + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'xml) +(require 'warnings) +(require 'url) +(require 'url-http) +(require 'url-util) +(require 'mm-decode) + +(defsubst soap-warning (message &rest args) + "Display a warning MESSAGE with ARGS, using the 'soap-client warning type." + (display-warning 'soap-client (apply 'format message args) :warning)) + +(defgroup soap-client nil + "Access SOAP web services from Emacs." + :group 'tools) + +;;;; Support for parsing XML documents with namespaces + +;; XML documents with namespaces are difficult to parse because the names of +;; the nodes depend on what "xmlns" aliases have been defined in the document. +;; To work with such documents, we introduce a translation layer between a +;; "well known" namespace tag and the local namespace tag in the document +;; being parsed. + +(defconst soap-well-known-xmlns + '(("apachesoap" . "http://xml.apache.org/xml-soap") + ("soapenc" . "http://schemas.xmlsoap.org/soap/encoding/") + ("wsdl" . "http://schemas.xmlsoap.org/wsdl/") + ("wsdlsoap" . "http://schemas.xmlsoap.org/wsdl/soap/") + ("xsd" . "http://www.w3.org/2001/XMLSchema") + ("xsi" . "http://www.w3.org/2001/XMLSchema-instance") + ("soap" . "http://schemas.xmlsoap.org/soap/envelope/") + ("soap12" . "http://schemas.xmlsoap.org/wsdl/soap12/") + ("http" . "http://schemas.xmlsoap.org/wsdl/http/") + ("mime" . "http://schemas.xmlsoap.org/wsdl/mime/")) + "A list of well known xml namespaces and their aliases.") + +(defvar soap-local-xmlns nil + "A list of local namespace aliases. +This is a dynamically bound variable, controlled by +`soap-with-local-xmlns'.") + +(defvar soap-default-xmlns nil + "The default XML namespaces. +Names in this namespace will be unqualified. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defvar soap-target-xmlns nil + "The target XML namespace. +New XSD elements will be defined in this namespace, unless they +are fully qualified for a different namespace. This is a +dynamically bound variable, controlled by +`soap-with-local-xmlns'") + +(defun soap-wk2l (well-known-name) + "Return local variant of WELL-KNOWN-NAME. +This is done by looking up the namespace in the +`soap-well-known-xmlns' table and resolving the namespace to +the local name based on the current local translation table +`soap-local-xmlns'. See also `soap-with-local-xmlns'." + (let ((wk-name-1 (if (symbolp well-known-name) + (symbol-name well-known-name) + well-known-name))) + (cond + ((string-match "^\\(.*\\):\\(.*\\)$" wk-name-1) + (let ((ns (match-string 1 wk-name-1)) + (name (match-string 2 wk-name-1))) + (let ((namespace (cdr (assoc ns soap-well-known-xmlns)))) + (cond ((equal namespace soap-default-xmlns) + ;; Name is unqualified in the default namespace + (if (symbolp well-known-name) + (intern name) + name)) + (t + (let* ((local-ns (car (rassoc namespace soap-local-xmlns))) + (local-name (concat local-ns ":" name))) + (if (symbolp well-known-name) + (intern local-name) + local-name))))))) + (t well-known-name)))) + +(defun soap-l2wk (local-name) + "Convert LOCAL-NAME into a well known name. +The namespace of LOCAL-NAME is looked up in the +`soap-well-known-xmlns' table and a well known namespace tag is +used in the name. + +nil is returned if there is no well-known namespace for the +namespace of LOCAL-NAME." + (let ((l-name-1 (if (symbolp local-name) + (symbol-name local-name) + local-name)) + namespace name) + (cond + ((string-match "^\\(.*\\):\\(.*\\)$" l-name-1) + (setq name (match-string 2 l-name-1)) + (let ((ns (match-string 1 l-name-1))) + (setq namespace (cdr (assoc ns soap-local-xmlns))) + (unless namespace + (error "Soap-l2wk(%s): no namespace for alias %s" local-name ns)))) + (t + (setq name l-name-1) + (setq namespace soap-default-xmlns))) + + (if namespace + (let ((well-known-ns (car (rassoc namespace soap-well-known-xmlns)))) + (if well-known-ns + (let ((well-known-name (concat well-known-ns ":" name))) + (if (symbol-name local-name) + (intern well-known-name) + well-known-name)) + (progn + ;; (soap-warning "soap-l2wk(%s): namespace %s has no well-known tag" + ;; local-name namespace) + nil))) + ;; if no namespace is defined, just return the unqualified name + name))) + + +(defun soap-l2fq (local-name &optional use-tns) + "Convert LOCAL-NAME into a fully qualified name. +A fully qualified name is a cons of the namespace name and the +name of the element itself. For example \"xsd:string\" is +converted to \(\"http://www.w3.org/2001/XMLSchema\" . \"string\"\). + +The USE-TNS argument specifies what to do when LOCAL-NAME has no +namespace tag. If USE-TNS is non-nil, the `soap-target-xmlns' +will be used as the element's namespace, otherwise +`soap-default-xmlns' will be used. + +This is needed because different parts of a WSDL document can use +different namespace aliases for the same element." + (let ((local-name-1 (if (symbolp local-name) + (symbol-name local-name) + local-name))) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" local-name-1) + (let ((ns (match-string 1 local-name-1)) + (name (match-string 2 local-name-1))) + (let ((namespace (cdr (assoc ns soap-local-xmlns)))) + (if namespace + (cons namespace name) + (error "Soap-l2fq(%s): unknown alias %s" local-name ns))))) + (t + (cons (if use-tns + soap-target-xmlns + soap-default-xmlns) + local-name))))) + +(defun soap-extract-xmlns (node &optional xmlns-table) + "Return a namespace alias table for NODE by extending XMLNS-TABLE." + (let (xmlns default-ns target-ns) + (dolist (a (xml-node-attributes node)) + (let ((name (symbol-name (car a))) + (value (cdr a))) + (cond ((string= name "targetNamespace") + (setq target-ns value)) + ((string= name "xmlns") + (setq default-ns value)) + ((string-match "^xmlns:\\(.*\\)$" name) + (push (cons (match-string 1 name) value) xmlns))))) + + (let ((tns (assoc "tns" xmlns))) + (cond ((and tns target-ns) + ;; If a tns alias is defined for this node, it must match + ;; the target namespace. + (unless (equal target-ns (cdr tns)) + (soap-warning + "soap-extract-xmlns(%s): tns alias and targetNamespace mismatch" + (xml-node-name node)))) + ((and tns (not target-ns)) + (setq target-ns (cdr tns))) + ((and (not tns) target-ns) + ;; a tns alias was not defined in this node. See if the node has + ;; a "targetNamespace" attribute and add an alias to this. Note + ;; that we might override an existing tns alias in XMLNS-TABLE, + ;; but that is intended. + (push (cons "tns" target-ns) xmlns)))) + + (list default-ns target-ns (append xmlns xmlns-table)))) + +(defmacro soap-with-local-xmlns (node &rest body) + "Install a local alias table from NODE and execute BODY." + (declare (debug (form &rest form)) (indent 1)) + (let ((xmlns (make-symbol "xmlns"))) + `(let ((,xmlns (soap-extract-xmlns ,node soap-local-xmlns))) + (let ((soap-default-xmlns (or (nth 0 ,xmlns) soap-default-xmlns)) + (soap-target-xmlns (or (nth 1 ,xmlns) soap-target-xmlns)) + (soap-local-xmlns (nth 2 ,xmlns))) + ,@body)))) + +(defun soap-get-target-namespace (node) + "Return the target namespace of NODE. +This is the namespace in which new elements will be defined." + (or (xml-get-attribute-or-nil node 'targetNamespace) + (cdr (assoc "tns" soap-local-xmlns)) + soap-target-xmlns)) + +(defun soap-xml-get-children1 (node child-name) + "Return the children of NODE named CHILD-NAME. +This is the same as `xml-get-children', but CHILD-NAME can have +namespace tag." + (let (result) + (dolist (c (xml-node-children node)) + (when (and (consp c) + (soap-with-local-xmlns c + ;; We use `ignore-errors' here because we want to silently + ;; skip nodes for which we cannot convert them to a + ;; well-known name. + (eq (ignore-errors (soap-l2wk (xml-node-name c))) + child-name))) + (push c result))) + (nreverse result))) + +(defun soap-xml-get-attribute-or-nil1 (node attribute) + "Return the NODE's ATTRIBUTE, or nil if it does not exist. +This is the same as `xml-get-attribute-or-nil', but ATTRIBUTE can +be tagged with a namespace tag." + (catch 'found + (soap-with-local-xmlns node + (dolist (a (xml-node-attributes node)) + ;; We use `ignore-errors' here because we want to silently skip + ;; attributes for which we cannot convert them to a well-known name. + (when (eq (ignore-errors (soap-l2wk (car a))) attribute) + (throw 'found (cdr a))))))) + + +;;;; XML namespaces + +;; An element in an XML namespace, "things" stored in soap-xml-namespaces will +;; be derived from this object. + +(defstruct soap-element + name + ;; The "well-known" namespace tag for the element. For example, while + ;; parsing XML documents, we can have different tags for the XMLSchema + ;; namespace, but internally all our XMLSchema elements will have the "xsd" + ;; tag. + namespace-tag) + +(defun soap-element-fq-name (element) + "Return a fully qualified name for ELEMENT. +A fq name is the concatenation of the namespace tag and the +element name." + (concat (soap-element-namespace-tag element) + ":" (soap-element-name element))) + +;; a namespace link stores an alias for an object in once namespace to a +;; "target" object possibly in a different namespace + +(defstruct (soap-namespace-link (:include soap-element)) + target) + +;; A namespace is a collection of soap-element objects under a name (the name +;; of the namespace). + +(defstruct soap-namespace + (name nil :read-only t) ; e.g "http://xml.apache.org/xml-soap" + (elements (make-hash-table :test 'equal) :read-only t)) + +(defun soap-namespace-put (element ns) + "Store ELEMENT in NS. +Multiple elements with the same name can be stored in a +namespace. When retrieving the element you can specify a +discriminant predicate to `soap-namespace-get'" + (let ((name (soap-element-name element))) + (push element (gethash name (soap-namespace-elements ns))))) + +(defun soap-namespace-put-link (name target ns &optional replace) + "Store a link from NAME to TARGET in NS. +An error will be signaled if an element by the same name is +already present in NS, unless REPLACE is non nil. + +TARGET can be either a SOAP-ELEMENT or a string denoting an +element name into another namespace. + +If NAME is nil, an element with the same name as TARGET will be +added to the namespace." + + (unless (and name (not (equal name ""))) + ;; if name is nil, use TARGET as a name... + (cond ((soap-element-p target) + (setq name (soap-element-name target))) + ((stringp target) + (cond ((string-match "^\\(.*\\):\\(.*\\)$" target) + (setq name (match-string 2 target))) + (t + (setq name target)))))) + + (assert name) ; by now, name should be valid + (push (make-soap-namespace-link :name name :target target) + (gethash name (soap-namespace-elements ns)))) + +(defun soap-namespace-get (name ns &optional discriminant-predicate) + "Retrieve an element with NAME from the namespace NS. +If multiple elements with the same name exist, +DISCRIMINANT-PREDICATE is used to pick one of them. This allows +storing elements of different types (like a message type and a +binding) but the same name." + (assert (stringp name)) + (let ((elements (gethash name (soap-namespace-elements ns)))) + (cond (discriminant-predicate + (catch 'found + (dolist (e elements) + (when (funcall discriminant-predicate e) + (throw 'found e))))) + ((= (length elements) 1) (car elements)) + ((> (length elements) 1) + (error + "Soap-namespace-get(%s): multiple elements, discriminant needed" + name)) + (t + nil)))) + + +;;;; WSDL documents +;;;;; WSDL document elements + +(defstruct (soap-basic-type (:include soap-element)) + kind ; a symbol of: string, dateTime, long, int + ) + +(defstruct soap-sequence-element + name type nillable? multiple?) + +(defstruct (soap-sequence-type (:include soap-element)) + parent ; OPTIONAL WSDL-TYPE name + elements ; LIST of SOAP-SEQUCENCE-ELEMENT + ) + +(defstruct (soap-array-type (:include soap-element)) + element-type ; WSDL-TYPE of the array elements + ) + +(defstruct (soap-message (:include soap-element)) + parts ; ALIST of NAME => WSDL-TYPE name + ) + +(defstruct (soap-operation (:include soap-element)) + parameter-order + input ; (NAME . MESSAGE) + output ; (NAME . MESSAGE) + faults) ; a list of (NAME . MESSAGE) + +(defstruct (soap-port-type (:include soap-element)) + operations) ; a namespace of operations + +;; A bound operation is an operation which has a soap action and a use +;; method attached -- these are attached as part of a binding and we +;; can have different bindings for the same operations. +(defstruct soap-bound-operation + operation ; SOAP-OPERATION + soap-action ; value for SOAPAction HTTP header + use ; 'literal or 'encoded, see + ; http://www.w3.org/TR/wsdl#_soap:body + ) + +(defstruct (soap-binding (:include soap-element)) + port-type + (operations (make-hash-table :test 'equal) :readonly t)) + +(defstruct (soap-port (:include soap-element)) + service-url + binding) + +(defun soap-default-xsd-types () + "Return a namespace containing some of the XMLSchema types." + (let ((ns (make-soap-namespace :name "http://www.w3.org/2001/XMLSchema"))) + (dolist (type '("string" "dateTime" "boolean" "long" "int" "float" + "base64Binary" "anyType" "Array" "byte[]")) + (soap-namespace-put + (make-soap-basic-type :name type :kind (intern type)) + ns)) + ns)) + +(defun soap-default-soapenc-types () + "Return a namespace containing some of the SOAPEnc types." + (let ((ns (make-soap-namespace + :name "http://schemas.xmlsoap.org/soap/encoding/"))) + (dolist (type '("string" "dateTime" "boolean" "long" "int" "float" + "base64Binary" "anyType" "Array" "byte[]")) + (soap-namespace-put + (make-soap-basic-type :name type :kind (intern type)) + ns)) + ns)) + +(defun soap-type-p (element) + "Return t if ELEMENT is a SOAP data type (basic or complex)." + (or (soap-basic-type-p element) + (soap-sequence-type-p element) + (soap-array-type-p element))) + + +;;;;; The WSDL document + +;; The WSDL data structure used for encoding/decoding SOAP messages +(defstruct soap-wsdl + origin ; file or URL from which this wsdl was loaded + ports ; a list of SOAP-PORT instances + alias-table ; a list of namespace aliases + namespaces ; a list of namespaces + ) + +(defun soap-wsdl-add-alias (alias name wsdl) + "Add a namespace ALIAS for NAME to the WSDL document." + (push (cons alias name) (soap-wsdl-alias-table wsdl))) + +(defun soap-wsdl-find-namespace (name wsdl) + "Find a namespace by NAME in the WSDL document." + (catch 'found + (dolist (ns (soap-wsdl-namespaces wsdl)) + (when (equal name (soap-namespace-name ns)) + (throw 'found ns))))) + +(defun soap-wsdl-add-namespace (ns wsdl) + "Add the namespace NS to the WSDL document. +If a namespace by this name already exists in WSDL, individual +elements will be added to it." + (let ((existing (soap-wsdl-find-namespace (soap-namespace-name ns) wsdl))) + (if existing + ;; Add elements from NS to EXISTING, replacing existing values. + (maphash (lambda (key value) + (dolist (v value) + (soap-namespace-put v existing))) + (soap-namespace-elements ns)) + (push ns (soap-wsdl-namespaces wsdl))))) + +(defun soap-wsdl-get (name wsdl &optional predicate use-local-alias-table) + "Retrieve element NAME from the WSDL document. + +PREDICATE is used to differentiate between elements when NAME +refers to multiple elements. A typical value for this would be a +structure predicate for the type of element you want to retrieve. +For example, to retrieve a message named \"foo\" when other +elements named \"foo\" exist in the WSDL you could use: + + (soap-wsdl-get \"foo\" WSDL 'soap-message-p) + +If USE-LOCAL-ALIAS-TABLE is not nil, `soap-local-xmlns` will be +used to resolve the namespace alias." + (let ((alias-table (soap-wsdl-alias-table wsdl)) + namespace element-name element) + + (when (symbolp name) + (setq name (symbol-name name))) + + (when use-local-alias-table + (setq alias-table (append soap-local-xmlns alias-table))) + + (cond ((consp name) ; a fully qualified name, as returned by `soap-l2fq' + (setq element-name (cdr name)) + (when (symbolp element-name) + (setq element-name (symbol-name element-name))) + (setq namespace (soap-wsdl-find-namespace (car name) wsdl)) + (unless namespace + (error "Soap-wsdl-get(%s): unknown namespace: %s" name namespace))) + + ((string-match "^\\(.*\\):\\(.*\\)$" name) + (setq element-name (match-string 2 name)) + + (let* ((ns-alias (match-string 1 name)) + (ns-name (cdr (assoc ns-alias alias-table)))) + (unless ns-name + (error "Soap-wsdl-get(%s): cannot find namespace alias %s" + name ns-alias)) + + (setq namespace (soap-wsdl-find-namespace ns-name wsdl)) + (unless namespace + (error + "Soap-wsdl-get(%s): unknown namespace %s, referenced by alias %s" + name ns-name ns-alias)))) + (t + (error "Soap-wsdl-get(%s): bad name" name))) + + (setq element (soap-namespace-get + element-name namespace + (if predicate + (lambda (e) + (or (funcall 'soap-namespace-link-p e) + (funcall predicate e))) + nil))) + + (unless element + (error "Soap-wsdl-get(%s): cannot find element" name)) + + (if (soap-namespace-link-p element) + ;; NOTE: don't use the local alias table here + (soap-wsdl-get (soap-namespace-link-target element) wsdl predicate) + element))) + +;;;;; Resolving references for wsdl types + +;; See `soap-wsdl-resolve-references', which is the main entry point for +;; resolving references + +(defun soap-resolve-references-for-element (element wsdl) + "Resolve references in ELEMENT using the WSDL document. +This is a generic function which invokes a specific function +depending on the element type. + +If ELEMENT has no resolver function, it is silently ignored. + +All references are resolved in-place, that is the ELEMENT is +updated." + (let ((resolver (get (aref element 0) 'soap-resolve-references))) + (when resolver + (funcall resolver element wsdl)))) + +(defun soap-resolve-references-for-sequence-type (type wsdl) + "Resolve references for a sequence TYPE using WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let ((parent (soap-sequence-type-parent type))) + (when (or (consp parent) (stringp parent)) + (setf (soap-sequence-type-parent type) + (soap-wsdl-get parent wsdl 'soap-type-p)))) + (dolist (element (soap-sequence-type-elements type)) + (let ((element-type (soap-sequence-element-type element))) + (cond ((or (consp element-type) (stringp element-type)) + (setf (soap-sequence-element-type element) + (soap-wsdl-get element-type wsdl 'soap-type-p))) + ((soap-element-p element-type) + ;; since the element already has a child element, it + ;; could be an inline structure. we must resolve + ;; references in it, because it might not be reached by + ;; scanning the wsdl names. + (soap-resolve-references-for-element element-type wsdl)))))) + +(defun soap-resolve-references-for-array-type (type wsdl) + "Resolve references for an array TYPE using WSDL. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let ((element-type (soap-array-type-element-type type))) + (when (or (consp element-type) (stringp element-type)) + (setf (soap-array-type-element-type type) + (soap-wsdl-get element-type wsdl 'soap-type-p))))) + +(defun soap-resolve-references-for-message (message wsdl) + "Resolve references for a MESSAGE type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let (resolved-parts) + (dolist (part (soap-message-parts message)) + (let ((name (car part)) + (type (cdr part))) + (when (stringp name) + (setq name (intern name))) + (when (or (consp type) (stringp type)) + (setq type (soap-wsdl-get type wsdl 'soap-type-p))) + (push (cons name type) resolved-parts))) + (setf (soap-message-parts message) (nreverse resolved-parts)))) + +(defun soap-resolve-references-for-operation (operation wsdl) + "Resolve references for an OPERATION type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (let ((input (soap-operation-input operation)) + (counter 0)) + (let ((name (car input)) + (message (cdr input))) + ;; Name this part if it was not named + (when (or (null name) (equal name "")) + (setq name (format "in%d" (incf counter)))) + (when (or (consp message) (stringp message)) + (setf (soap-operation-input operation) + (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((output (soap-operation-output operation)) + (counter 0)) + (let ((name (car output)) + (message (cdr output))) + (when (or (null name) (equal name "")) + (setq name (format "out%d" (incf counter)))) + (when (or (consp message) (stringp message)) + (setf (soap-operation-output operation) + (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)))))) + + (let ((resolved-faults nil) + (counter 0)) + (dolist (fault (soap-operation-faults operation)) + (let ((name (car fault)) + (message (cdr fault))) + (when (or (null name) (equal name "")) + (setq name (format "fault%d" (incf counter)))) + (if (or (consp message) (stringp message)) + (push (cons (intern name) + (soap-wsdl-get message wsdl 'soap-message-p)) + resolved-faults) + (push fault resolved-faults)))) + (setf (soap-operation-faults operation) resolved-faults)) + + (when (= (length (soap-operation-parameter-order operation)) 0) + (setf (soap-operation-parameter-order operation) + (mapcar 'car (soap-message-parts + (cdr (soap-operation-input operation)))))) + + (setf (soap-operation-parameter-order operation) + (mapcar (lambda (p) + (if (stringp p) + (intern p) + p)) + (soap-operation-parameter-order operation)))) + +(defun soap-resolve-references-for-binding (binding wsdl) + "Resolve references for a BINDING type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (when (or (consp (soap-binding-port-type binding)) + (stringp (soap-binding-port-type binding))) + (setf (soap-binding-port-type binding) + (soap-wsdl-get (soap-binding-port-type binding) + wsdl 'soap-port-type-p))) + + (let ((port-ops (soap-port-type-operations (soap-binding-port-type binding)))) + (maphash (lambda (k v) + (setf (soap-bound-operation-operation v) + (soap-namespace-get k port-ops 'soap-operation-p))) + (soap-binding-operations binding)))) + +(defun soap-resolve-references-for-port (port wsdl) + "Resolve references for a PORT type using the WSDL document. +See also `soap-resolve-references-for-element' and +`soap-wsdl-resolve-references'" + (when (or (consp (soap-port-binding port)) + (stringp (soap-port-binding port))) + (setf (soap-port-binding port) + (soap-wsdl-get (soap-port-binding port) wsdl 'soap-binding-p)))) + +;; Install resolvers for our types +(progn + (put (aref (make-soap-sequence-type) 0) 'soap-resolve-references + 'soap-resolve-references-for-sequence-type) + (put (aref (make-soap-array-type) 0) 'soap-resolve-references + 'soap-resolve-references-for-array-type) + (put (aref (make-soap-message) 0) 'soap-resolve-references + 'soap-resolve-references-for-message) + (put (aref (make-soap-operation) 0) 'soap-resolve-references + 'soap-resolve-references-for-operation) + (put (aref (make-soap-binding) 0) 'soap-resolve-references + 'soap-resolve-references-for-binding) + (put (aref (make-soap-port) 0) 'soap-resolve-references + 'soap-resolve-references-for-port)) + +(defun soap-wsdl-resolve-references (wsdl) + "Resolve all references inside the WSDL structure. + +When the WSDL elements are created from the XML document, they +refer to each other by name. For example, the ELEMENT-TYPE slot +of an SOAP-ARRAY-TYPE will contain the name of the element and +the user would have to call `soap-wsdl-get' to obtain the actual +element. + +After the entire document is loaded, we resolve all these +references to the actual elements they refer to so that at +runtime, we don't have to call `soap-wsdl-get' each time we +traverse an element tree." + (let ((nprocessed 0) + (nstag-id 0) + (alias-table (soap-wsdl-alias-table wsdl))) + (dolist (ns (soap-wsdl-namespaces wsdl)) + (let ((nstag (car-safe (rassoc (soap-namespace-name ns) alias-table)))) + (unless nstag + ;; If this namespace does not have an alias, create one for it. + (catch 'done + (while t + (setq nstag (format "ns%d" (incf nstag-id))) + (unless (assoc nstag alias-table) + (soap-wsdl-add-alias nstag (soap-namespace-name ns) wsdl) + (throw 'done t))))) + + (maphash (lambda (name element) + (cond ((soap-element-p element) ; skip links + (incf nprocessed) + (soap-resolve-references-for-element element wsdl) + (setf (soap-element-namespace-tag element) nstag)) + ((listp element) + (dolist (e element) + (when (soap-element-p e) + (incf nprocessed) + (soap-resolve-references-for-element e wsdl) + (setf (soap-element-namespace-tag e) nstag)))))) + (soap-namespace-elements ns)))) + + (message "Processed %d" nprocessed)) + wsdl) + +;;;;; Loading WSDL from XML documents + +(defun soap-load-wsdl-from-url (url) + "Load a WSDL document from URL and return it. +The returned WSDL document needs to be used for `soap-invoke' +calls." + (let ((url-request-method "GET") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-request-coding-system 'utf-8) + (url-http-attempt-keepalives nil)) + (let ((buffer (url-retrieve-synchronously url))) + (with-current-buffer buffer + (declare (special url-http-response-status)) + (if (> url-http-response-status 299) + (error "Error retrieving WSDL: %s" url-http-response-status)) + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (let ((wsdl-xml (car (xml-parse-region (point-min) (point-max))))) + (prog1 + (let ((wsdl (soap-parse-wsdl wsdl-xml))) + (setf (soap-wsdl-origin wsdl) url) + wsdl) + (kill-buffer buffer))))))))) + +(defun soap-load-wsdl (file) + "Load a WSDL document from FILE and return it." + (with-temp-buffer + (insert-file-contents file) + (let ((xml (car (xml-parse-region (point-min) (point-max))))) + (let ((wsdl (soap-parse-wsdl xml))) + (setf (soap-wsdl-origin wsdl) file) + wsdl)))) + +(defun soap-parse-wsdl (node) + "Construct a WSDL structure from NODE, which is an XML document." + (soap-with-local-xmlns node + + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:definitions) + nil + "soap-parse-wsdl: expecting wsdl:definitions node, got %s" + (soap-l2wk (xml-node-name node))) + + (let ((wsdl (make-soap-wsdl))) + + ;; Add the local alias table to the wsdl document -- it will be used for + ;; all types in this document even after we finish parsing it. + (setf (soap-wsdl-alias-table wsdl) soap-local-xmlns) + + ;; Add the XSD types to the wsdl document + (let ((ns (soap-default-xsd-types))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "xsd" (soap-namespace-name ns) wsdl)) + + ;; Add the soapenc types to the wsdl document + (let ((ns (soap-default-soapenc-types))) + (soap-wsdl-add-namespace ns wsdl) + (soap-wsdl-add-alias "soapenc" (soap-namespace-name ns) wsdl)) + + ;; Find all the 'xsd:schema nodes which are children of wsdl:types nodes + ;; and build our type-library + + (let ((types (car (soap-xml-get-children1 node 'wsdl:types)))) + (dolist (node (xml-node-children types)) + ;; We cannot use (xml-get-children node (soap-wk2l 'xsd:schema)) + ;; because each node can install its own alias type so the schema + ;; nodes might have a different prefix. + (when (consp node) + (soap-with-local-xmlns node + (when (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + (soap-wsdl-add-namespace (soap-parse-schema node) wsdl)))))) + + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + (dolist (node (soap-xml-get-children1 node 'wsdl:message)) + (soap-namespace-put (soap-parse-message node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:portType)) + (let ((port-type (soap-parse-port-type node))) + (soap-namespace-put port-type ns) + (soap-wsdl-add-namespace + (soap-port-type-operations port-type) wsdl))) + + (dolist (node (soap-xml-get-children1 node 'wsdl:binding)) + (soap-namespace-put (soap-parse-binding node) ns)) + + (dolist (node (soap-xml-get-children1 node 'wsdl:service)) + (dolist (node (soap-xml-get-children1 node 'wsdl:port)) + (let ((name (xml-get-attribute node 'name)) + (binding (xml-get-attribute node 'binding)) + (url (let ((n (car (soap-xml-get-children1 + node 'wsdlsoap:address)))) + (xml-get-attribute n 'location)))) + (let ((port (make-soap-port + :name name :binding (soap-l2fq binding 'tns) + :service-url url))) + (soap-namespace-put port ns) + (push port (soap-wsdl-ports wsdl)))))) + + (soap-wsdl-add-namespace ns wsdl)) + + (soap-wsdl-resolve-references wsdl) + + wsdl))) + +(defun soap-parse-schema (node) + "Parse a schema NODE. +Return a SOAP-NAMESPACE containing the elements." + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:schema) + nil + "soap-parse-schema: expecting an xsd:schema node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((ns (make-soap-namespace :name (soap-get-target-namespace node)))) + ;; NOTE: we only extract the complexTypes from the schema, we wouldn't + ;; know how to handle basic types beyond the built in ones anyway. + (dolist (node (soap-xml-get-children1 node 'xsd:complexType)) + (soap-namespace-put (soap-parse-complex-type node) ns)) + + (dolist (node (soap-xml-get-children1 node 'xsd:element)) + (soap-namespace-put (soap-parse-schema-element node) ns)) + + ns))) + +(defun soap-parse-schema-element (node) + "Parse NODE and construct a schema element from it." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:element) + nil + "soap-parse-schema-element: expecting xsd:element node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + type) + ;; A schema element that contains an inline complex type -- + ;; construct the actual complex type for it. + (let ((type-node (soap-xml-get-children1 node 'xsd:complexType))) + (when (> (length type-node) 0) + (assert (= (length type-node) 1)) ; only one complex type + ; definition per element + (setq type (soap-parse-complex-type (car type-node))))) + (setf (soap-element-name type) name) + type)) + +(defun soap-parse-complex-type (node) + "Parse NODE and construct a complex type from it." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexType) + nil + "soap-parse-complex-type: expecting xsd:complexType node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + ;; Use a dummy type for the complex type, it will be replaced + ;; with the real type below, except when the complex type node + ;; is empty... + (type (make-soap-sequence-type :elements nil))) + (dolist (c (xml-node-children node)) + (when (consp c) ; skip string nodes, which are whitespace + (let ((node-name (soap-l2wk (xml-node-name c)))) + (cond + ((eq node-name 'xsd:sequence) + (setq type (soap-parse-complex-type-sequence c))) + ((eq node-name 'xsd:complexContent) + (setq type (soap-parse-complex-type-complex-content c))) + ((eq node-name 'xsd:attribute) + ;; The name of this node comes from an attribute tag + (let ((n (xml-get-attribute-or-nil c 'name))) + (setq name n))) + (t + (error "Unknown node type %s" node-name)))))) + (setf (soap-element-name type) name) + type)) + +(defun soap-parse-sequence (node) + "Parse NODE and a list of sequence elements that it defines. +NODE is assumed to be an xsd:sequence node. In that case, each +of its children is assumed to be a sequence element. Each +sequence element is parsed constructing the corresponding type. +A list of these types is returned." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:sequence) + nil + "soap-parse-sequence: expecting xsd:sequence node, got %s" + (soap-l2wk (xml-node-name node))) + (let (elements) + (dolist (e (soap-xml-get-children1 node 'xsd:element)) + (let ((name (xml-get-attribute-or-nil e 'name)) + (type (xml-get-attribute-or-nil e 'type)) + (nillable? (or (equal (xml-get-attribute-or-nil e 'nillable) "true") + (let ((e (xml-get-attribute-or-nil e 'minOccurs))) + (and e (equal e "0"))))) + (multiple? (let ((e (xml-get-attribute-or-nil e 'maxOccurs))) + (and e (not (equal e "1")))))) + (if type + (setq type (soap-l2fq type 'tns)) + + ;; The node does not have a type, maybe it has a complexType + ;; defined inline... + (let ((type-node (soap-xml-get-children1 e 'xsd:complexType))) + (when (> (length type-node) 0) + (assert (= (length type-node) 1) + nil + "only one complex type definition per element supported") + (setq type (soap-parse-complex-type (car type-node)))))) + + (push (make-soap-sequence-element + :name (intern name) :type type :nillable? nillable? + :multiple? multiple?) + elements))) + (nreverse elements))) + +(defun soap-parse-complex-type-sequence (node) + "Parse NODE as a sequence type." + (let ((elements (soap-parse-sequence node))) + (make-soap-sequence-type :elements elements))) + +(defun soap-parse-complex-type-complex-content (node) + "Parse NODE as a xsd:complexContent node. +A sequence or an array type is returned depending on the actual +contents." + (assert (eq (soap-l2wk (xml-node-name node)) 'xsd:complexContent) + nil + "soap-parse-complex-type-complex-content: expecting xsd:complexContent node, got %s" + (soap-l2wk (xml-node-name node))) + (let (array? parent elements) + (let ((extension (car-safe (soap-xml-get-children1 node 'xsd:extension))) + (restriction (car-safe + (soap-xml-get-children1 node 'xsd:restriction)))) + ;; a complex content node is either an extension or a restriction + (cond (extension + (setq parent (xml-get-attribute-or-nil extension 'base)) + (setq elements (soap-parse-sequence + (car (soap-xml-get-children1 + extension 'xsd:sequence))))) + (restriction + (let ((base (xml-get-attribute-or-nil restriction 'base))) + (assert (equal base "soapenc:Array") + nil + "restrictions supported only for soapenc:Array types, this is a %s" + base)) + (setq array? t) + (let ((attribute (car (soap-xml-get-children1 + restriction 'xsd:attribute)))) + (let ((array-type (soap-xml-get-attribute-or-nil1 + attribute 'wsdl:arrayType))) + (when (string-match "^\\(.*\\)\\[\\]$" array-type) + (setq parent (match-string 1 array-type)))))) + + (t + (error "Unknown complex type")))) + + (if parent + (setq parent (soap-l2fq parent 'tns))) + + (if array? + (make-soap-array-type :element-type parent) + (make-soap-sequence-type :parent parent :elements elements)))) + +(defun soap-parse-message (node) + "Parse NODE as a wsdl:message and return the corresponding type." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:message) + nil + "soap-parse-message: expecting wsdl:message node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute-or-nil node 'name)) + parts) + (dolist (p (soap-xml-get-children1 node 'wsdl:part)) + (let ((name (xml-get-attribute-or-nil p 'name)) + (type (xml-get-attribute-or-nil p 'type)) + (element (xml-get-attribute-or-nil p 'element))) + + (when type + (setq type (soap-l2fq type 'tns))) + + (when element + (setq element (soap-l2fq element 'tns))) + + (push (cons name (or type element)) parts))) + (make-soap-message :name name :parts (nreverse parts)))) + +(defun soap-parse-port-type (node) + "Parse NODE as a wsdl:portType and return the corresponding port." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:portType) + nil + "soap-parse-port-type: expecting wsdl:portType node got %s" + (soap-l2wk (xml-node-name node))) + (let ((ns (make-soap-namespace + :name (concat "urn:" (xml-get-attribute node 'name))))) + (dolist (node (soap-xml-get-children1 node 'wsdl:operation)) + (let ((o (soap-parse-operation node))) + + (let ((other-operation (soap-namespace-get + (soap-element-name o) ns 'soap-operation-p))) + (if other-operation + ;; Unfortunately, the Confluence WSDL defines two operations + ;; named "search" which differ only in parameter names... + (soap-warning "Discarding duplicate operation: %s" + (soap-element-name o)) + + (progn + (soap-namespace-put o ns) + + ;; link all messages from this namespace, as this namespace + ;; will be used for decoding the response. + (destructuring-bind (name . message) (soap-operation-input o) + (soap-namespace-put-link name message ns)) + + (destructuring-bind (name . message) (soap-operation-output o) + (soap-namespace-put-link name message ns)) + + (dolist (fault (soap-operation-faults o)) + (destructuring-bind (name . message) fault + (soap-namespace-put-link name message ns 'replace))) + + ))))) + + (make-soap-port-type :name (xml-get-attribute node 'name) + :operations ns))) + +(defun soap-parse-operation (node) + "Parse NODE as a wsdl:operation and return the corresponding type." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:operation) + nil + "soap-parse-operation: expecting wsdl:operation node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute node 'name)) + (parameter-order (split-string + (xml-get-attribute node 'parameterOrder))) + input output faults) + (dolist (n (xml-node-children node)) + (when (consp n) ; skip string nodes which are whitespace + (let ((node-name (soap-l2wk (xml-node-name n)))) + (cond + ((eq node-name 'wsdl:input) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (setq input (cons name (soap-l2fq message 'tns))))) + ((eq node-name 'wsdl:output) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (setq output (cons name (soap-l2fq message 'tns))))) + ((eq node-name 'wsdl:fault) + (let ((message (xml-get-attribute n 'message)) + (name (xml-get-attribute n 'name))) + (push (cons name (soap-l2fq message 'tns)) faults))))))) + (make-soap-operation + :name name + :parameter-order parameter-order + :input input + :output output + :faults (nreverse faults)))) + +(defun soap-parse-binding (node) + "Parse NODE as a wsdl:binding and return the corresponding type." + (assert (eq (soap-l2wk (xml-node-name node)) 'wsdl:binding) + nil + "soap-parse-binding: expecting wsdl:binding node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((name (xml-get-attribute node 'name)) + (type (xml-get-attribute node 'type))) + (let ((binding (make-soap-binding :name name + :port-type (soap-l2fq type 'tns)))) + (dolist (wo (soap-xml-get-children1 node 'wsdl:operation)) + (let ((name (xml-get-attribute wo 'name)) + soap-action + use) + (dolist (so (soap-xml-get-children1 wo 'wsdlsoap:operation)) + (setq soap-action (xml-get-attribute-or-nil so 'soapAction))) + + ;; Search a wsdlsoap:body node and find a "use" tag. The + ;; same use tag is assumed to be present for both input and + ;; output types (although the WDSL spec allows separate + ;; "use"-s for each of them... + + (dolist (i (soap-xml-get-children1 wo 'wsdl:input)) + (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) + (setq use (or use + (xml-get-attribute-or-nil b 'use))))) + + (unless use + (dolist (i (soap-xml-get-children1 wo 'wsdl:output)) + (dolist (b (soap-xml-get-children1 i 'wsdlsoap:body)) + (setq use (or use + (xml-get-attribute-or-nil b 'use)))))) + + (puthash name (make-soap-bound-operation :operation name + :soap-action soap-action + :use (and use (intern use))) + (soap-binding-operations binding)))) + binding))) + +;;;; SOAP type decoding + +(defvar soap-multi-refs nil + "The list of multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defvar soap-decoded-multi-refs nil + "List of decoded multi-ref nodes in the current SOAP response. +This is a dynamically bound variable used during decoding the +SOAP response.") + +(defvar soap-current-wsdl nil + "The current WSDL document used when decoding the SOAP response. +This is a dynamically bound variable.") + +(defun soap-decode-type (type node) + "Use TYPE (an xsd type) to decode the contents of NODE. + +NODE is an XML node, representing some SOAP encoded value or a +reference to another XML node (a multiRef). This function will +resolve the multiRef reference, if any, than call a TYPE specific +decode function to perform the actual decoding." + (let ((href (xml-get-attribute-or-nil node 'href))) + (cond (href + (catch 'done + ;; NODE is actually a HREF, find the target and decode that. + ;; Check first if we already decoded this multiref. + + (let ((decoded (cdr (assoc href soap-decoded-multi-refs)))) + (when decoded + (throw 'done decoded))) + + (string-match "^#\\(.*\\)$" href) ; TODO: check that it matched + + (let ((id (match-string 1 href))) + (dolist (mr soap-multi-refs) + (let ((mrid (xml-get-attribute mr 'id))) + (when (equal id mrid) + ;; recurse here, in case there are multiple HREF's + (let ((decoded (soap-decode-type type mr))) + (push (cons href decoded) soap-decoded-multi-refs) + (throw 'done decoded))))) + (error "Cannot find href %s" href)))) + (t + (soap-with-local-xmlns node + (if (equal (soap-xml-get-attribute-or-nil1 node 'xsi:nil) "true") + nil + (let ((decoder (get (aref type 0) 'soap-decoder))) + (assert decoder nil "no soap-decoder for %s type" + (aref type 0)) + (funcall decoder type node)))))))) + +(defun soap-decode-any-type (node) + "Decode NODE using type information inside it." + ;; If the NODE has type information, we use that... + (let ((type (soap-xml-get-attribute-or-nil1 node 'xsi:type))) + (if type + (let ((wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p))) + (if wtype + (soap-decode-type wtype node) + ;; The node has type info encoded in it, but we don't know how + ;; to decode it... + (error "Soap-decode-any-type: node has unknown type: %s" type))) + + ;; No type info in the node... + + (let ((contents (xml-node-children node))) + (if (and (= (length contents) 1) (stringp (car contents))) + ;; contents is just a string + (car contents) + + ;; we assume the NODE is a sequence with every element a + ;; structure name + (let (result) + (dolist (element contents) + (let ((key (xml-node-name element)) + (value (soap-decode-any-type element))) + (push (cons key value) result))) + (nreverse result))))))) + +(defun soap-decode-array (node) + "Decode NODE as an Array using type information inside it." + (let ((type (soap-xml-get-attribute-or-nil1 node 'soapenc:arrayType)) + (wtype nil) + (contents (xml-node-children node)) + result) + (when type + ;; Type is in the format "someType[NUM]" where NUM is the number of + ;; elements in the array. We discard the [NUM] part. + (setq type (replace-regexp-in-string "\\[[0-9]+\\]\\'" "" type)) + (setq wtype (soap-wsdl-get type soap-current-wsdl 'soap-type-p)) + (unless wtype + ;; The node has type info encoded in it, but we don't know how to + ;; decode it... + (error "Soap-decode-array: node has unknown type: %s" type))) + (dolist (e contents) + (when (consp e) + (push (if wtype + (soap-decode-type wtype e) + (soap-decode-any-type e)) + result))) + (nreverse result))) + +(defun soap-decode-basic-type (type node) + "Use TYPE to decode the contents of NODE. +TYPE is a `soap-basic-type' struct, and NODE is an XML document. +A LISP value is returned based on the contents of NODE and the +type-info stored in TYPE." + (let ((contents (xml-node-children node)) + (type-kind (soap-basic-type-kind type))) + + (if (null contents) + nil + (ecase type-kind + (string (car contents)) + (dateTime (car contents)) ; TODO: convert to a date time + ((long int float) (string-to-number (car contents))) + (boolean (string= (downcase (car contents)) "true")) + (base64Binary (base64-decode-string (car contents))) + (anyType (soap-decode-any-type node)) + (Array (soap-decode-array node)))))) + +(defun soap-decode-sequence-type (type node) + "Use TYPE to decode the contents of NODE. +TYPE is assumed to be a sequence type and an ALIST with the +contents of the NODE is returned." + (let ((result nil) + (parent (soap-sequence-type-parent type))) + (when parent + (setq result (nreverse (soap-decode-type parent node)))) + (dolist (element (soap-sequence-type-elements type)) + (let ((instance-count 0) + (e-name (soap-sequence-element-name element)) + (e-type (soap-sequence-element-type element))) + (dolist (node (xml-get-children node e-name)) + (incf instance-count) + (push (cons e-name (soap-decode-type e-type node)) result)) + ;; Do some sanity checking + (cond ((and (= instance-count 0) + (not (soap-sequence-element-nillable? element))) + (soap-warning "While decoding %s: missing non-nillable slot %s" + (soap-element-name type) e-name)) + ((and (> instance-count 1) + (not (soap-sequence-element-multiple? element))) + (soap-warning "While decoding %s: multiple slots named %s" + (soap-element-name type) e-name))))) + (nreverse result))) + +(defun soap-decode-array-type (type node) + "Use TYPE to decode the contents of NODE. +TYPE is assumed to be an array type. Arrays are decoded as lists. +This is because it is easier to work with list results in LISP." + (let ((result nil) + (element-type (soap-array-type-element-type type))) + (dolist (node (xml-node-children node)) + (when (consp node) + (push (soap-decode-type element-type node) result))) + (nreverse result))) + +(progn + (put (aref (make-soap-basic-type) 0) + 'soap-decoder 'soap-decode-basic-type) + (put (aref (make-soap-sequence-type) 0) + 'soap-decoder 'soap-decode-sequence-type) + (put (aref (make-soap-array-type) 0) + 'soap-decoder 'soap-decode-array-type)) + +;;;; Soap Envelope parsing + +(put 'soap-error + 'error-conditions + '(error soap-error)) +(put 'soap-error 'error-message "SOAP error") + +(defun soap-parse-envelope (node operation wsdl) + "Parse the SOAP envelope in NODE and return the response. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE" + (soap-with-local-xmlns node + (assert (eq (soap-l2wk (xml-node-name node)) 'soap:Envelope) + nil + "soap-parse-envelope: expecting soap:Envelope node, got %s" + (soap-l2wk (xml-node-name node))) + (let ((body (car (soap-xml-get-children1 node 'soap:Body)))) + + (let ((fault (car (soap-xml-get-children1 body 'soap:Fault)))) + (when fault + (let ((fault-code (let ((n (car (xml-get-children + fault 'faultcode)))) + (car-safe (xml-node-children n)))) + (fault-string (let ((n (car (xml-get-children + fault 'faultstring)))) + (car-safe (xml-node-children n))))) + (while t + (signal 'soap-error (list fault-code fault-string)))))) + + ;; First (non string) element of the body is the root node of he + ;; response + (let ((response (if (eq (soap-bound-operation-use operation) 'literal) + ;; For 'literal uses, the response is the actual body + body + ;; ...otherwise the first non string element + ;; of the body is the response + (catch 'found + (dolist (n (xml-node-children body)) + (when (consp n) + (throw 'found n))))))) + (soap-parse-response response operation wsdl body))))) + +(defun soap-parse-response (response-node operation wsdl soap-body) + "Parse RESPONSE-NODE and return the result as a LISP value. +OPERATION is the WSDL operation for which we expect the response, +WSDL is used to decode the NODE. + +SOAP-BODY is the body of the SOAP envelope (of which +RESPONSE-NODE is a sub-node). It is used in case RESPONSE-NODE +reference multiRef parts which are external to RESPONSE-NODE." + (let* ((soap-current-wsdl wsdl) + (op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-output op)))) + + (soap-with-local-xmlns response-node + + (when (eq use 'encoded) + (let* ((received-message-name (soap-l2fq (xml-node-name response-node))) + (received-message (soap-wsdl-get + received-message-name wsdl 'soap-message-p))) + (unless (eq received-message message) + (error "Unexpected message: got %s, expecting %s" + received-message-name + (soap-element-name message))))) + + (let ((decoded-parts nil) + (soap-multi-refs (xml-get-children soap-body 'multiRef)) + (soap-decoded-multi-refs nil)) + + (dolist (part (soap-message-parts message)) + (let ((tag (car part)) + (type (cdr part)) + node) + + (setq node + (cond + ((eq use 'encoded) + (car (xml-get-children response-node tag))) + + ((eq use 'literal) + (catch 'found + (let* ((ns-aliases (soap-wsdl-alias-table wsdl)) + (ns-name (cdr (assoc + (soap-element-namespace-tag type) + ns-aliases))) + (fqname (cons ns-name (soap-element-name type)))) + (dolist (c (xml-node-children response-node)) + (when (consp c) + (soap-with-local-xmlns c + (when (equal (soap-l2fq (xml-node-name c)) + fqname) + (throw 'found c)))))))))) + + (unless node + (error "Soap-parse-response(%s): cannot find message part %s" + (soap-element-name op) tag)) + (push (soap-decode-type type node) decoded-parts))) + + decoded-parts)))) + +;;;; SOAP type encoding + +(defvar soap-encoded-namespaces nil + "A list of namespace tags used during encoding a message. +This list is populated by `soap-encode-value' and used by +`soap-create-envelope' to add aliases for these namespace to the +XML request. + +This variable is dynamically bound in `soap-create-envelope'.") + +(defun soap-encode-value (xml-tag value type) + "Encode inside an XML-TAG the VALUE using TYPE. +The resulting XML data is inserted in the current buffer +at (point)/ + +TYPE is one of the soap-*-type structures which defines how VALUE +is to be encoded. This is a generic function which finds an +encoder function based on TYPE and calls that encoder to do the +work." + (let ((encoder (get (aref type 0) 'soap-encoder))) + (assert encoder nil "no soap-encoder for %s type" (aref type 0)) + ;; XML-TAG can be a string or a symbol, but we pass only string's to the + ;; encoders + (when (symbolp xml-tag) + (setq xml-tag (symbol-name xml-tag))) + (funcall encoder xml-tag value type)) + (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag type))) + +(defun soap-encode-basic-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (let ((xsi-type (soap-element-fq-name type)) + (basic-type (soap-basic-type-kind type))) + + ;; try to classify the type based on the value type and use that type when + ;; encoding + (when (eq basic-type 'anyType) + (cond ((stringp value) + (setq xsi-type "xsd:string" basic-type 'string)) + ((integerp value) + (setq xsi-type "xsd:int" basic-type 'int)) + ((memq value '(t nil)) + (setq xsi-type "xsd:boolean" basic-type 'boolean)) + (t + (error + "Soap-encode-basic-type(%s, %s, %s): cannot classify anyType value" + xml-tag value xsi-type)))) + + (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") + + ;; We have some ambiguity here, as a nil value represents "false" when the + ;; type is boolean, we will never have a "nil" boolean type... + + (if (or value (eq basic-type 'boolean)) + (progn + (insert ">") + (case basic-type + (string + (unless (stringp value) + (error "Soap-encode-basic-type(%s, %s, %s): not a string value" + xml-tag value xsi-type)) + (insert (url-insert-entities-in-string value))) + + (dateTime + (cond ((and (consp value) ; is there a time-value-p ? + (>= (length value) 2) + (numberp (nth 0 value)) + (numberp (nth 1 value))) + ;; Value is a (current-time) style value, convert + ;; to a string + (insert (format-time-string "%Y-%m-%dT%H:%M:%S" value))) + ((stringp value) + (insert (url-insert-entities-in-string value))) + (t + (error + "Soap-encode-basic-type(%s, %s, %s): not a dateTime value" + xml-tag value xsi-type)))) + + (boolean + (unless (memq value '(t nil)) + (error "Soap-encode-basic-type(%s, %s, %s): not a boolean value" + xml-tag value xsi-type)) + (insert (if value "true" "false"))) + + ((long int) + (unless (integerp value) + (error "Soap-encode-basic-type(%s, %s, %s): not an integer value" + xml-tag value xsi-type)) + (insert (number-to-string value))) + + (base64Binary + (unless (stringp value) + (error "Soap-encode-basic-type(%s, %s, %s): not a string value" + xml-tag value xsi-type)) + (insert (base64-encode-string value))) + + (otherwise + (error + "Soap-encode-basic-type(%s, %s, %s): don't know how to encode" + xml-tag value xsi-type)))) + + (insert " xsi:nil=\"true\">")) + (insert "</" xml-tag ">\n"))) + +(defun soap-encode-sequence-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (let ((xsi-type (soap-element-fq-name type))) + (insert "<" xml-tag " xsi:type=\"" xsi-type "\"") + (if value + (progn + (insert ">\n") + (let ((parents (list type)) + (parent (soap-sequence-type-parent type))) + + (while parent + (push parent parents) + (setq parent (soap-sequence-type-parent parent))) + + (dolist (type parents) + (dolist (element (soap-sequence-type-elements type)) + (let ((instance-count 0) + (e-name (soap-sequence-element-name element)) + (e-type (soap-sequence-element-type element))) + (dolist (v value) + (when (equal (car v) e-name) + (incf instance-count) + (soap-encode-value e-name (cdr v) e-type))) + + ;; Do some sanity checking + (cond ((and (= instance-count 0) + (not (soap-sequence-element-nillable? element))) + (soap-warning + "While encoding %s: missing non-nillable slot %s" + (soap-element-name type) e-name)) + ((and (> instance-count 1) + (not (soap-sequence-element-multiple? element))) + (soap-warning + "While encoding %s: multiple slots named %s" + (soap-element-name type) e-name)))))))) + (insert " xsi:nil=\"true\">")) + (insert "</" xml-tag ">\n"))) + +(defun soap-encode-array-type (xml-tag value type) + "Encode inside XML-TAG the LISP VALUE according to TYPE. +Do not call this function directly, use `soap-encode-value' +instead." + (unless (vectorp value) + (error "Soap-encode: %s(%s) expects a vector, got: %s" + xml-tag (soap-element-fq-name type) value)) + (let* ((element-type (soap-array-type-element-type type)) + (array-type (concat (soap-element-fq-name element-type) + "[" (format "%s" (length value)) "]"))) + (insert "<" xml-tag + " soapenc:arrayType=\"" array-type "\" " + " xsi:type=\"soapenc:Array\">\n") + (loop for i below (length value) + do (soap-encode-value xml-tag (aref value i) element-type)) + (insert "</" xml-tag ">\n"))) + +(progn + (put (aref (make-soap-basic-type) 0) + 'soap-encoder 'soap-encode-basic-type) + (put (aref (make-soap-sequence-type) 0) + 'soap-encoder 'soap-encode-sequence-type) + (put (aref (make-soap-array-type) 0) + 'soap-encoder 'soap-encode-array-type)) + +(defun soap-encode-body (operation parameters wsdl) + "Create the body of a SOAP request for OPERATION in the current buffer. +PARAMETERS is a list of parameters supplied to the OPERATION. + +The OPERATION and PARAMETERS are encoded according to the WSDL +document." + (let* ((op (soap-bound-operation-operation operation)) + (use (soap-bound-operation-use operation)) + (message (cdr (soap-operation-input op))) + (parameter-order (soap-operation-parameter-order op))) + + (unless (= (length parameter-order) (length parameters)) + (error "Wrong number of parameters for %s: expected %d, got %s" + (soap-element-name op) + (length parameter-order) + (length parameters))) + + (insert "<soap:Body>\n") + (when (eq use 'encoded) + (add-to-list 'soap-encoded-namespaces (soap-element-namespace-tag op)) + (insert "<" (soap-element-fq-name op) ">\n")) + + (let ((param-table (loop for formal in parameter-order + for value in parameters + collect (cons formal value)))) + (dolist (part (soap-message-parts message)) + (let* ((param-name (car part)) + (type (cdr part)) + (tag-name (if (eq use 'encoded) + param-name + (soap-element-name type))) + (value (cdr (assoc param-name param-table))) + (start-pos (point))) + (soap-encode-value tag-name value type) + (when (eq use 'literal) + ;; hack: add the xmlns attribute to the tag, the only way + ;; ASP.NET web services recognize the namespace of the + ;; element itself... + (save-excursion + (goto-char start-pos) + (when (re-search-forward " ") + (let* ((ns (soap-element-namespace-tag type)) + (namespace (cdr (assoc ns + (soap-wsdl-alias-table wsdl))))) + (when namespace + (insert "xmlns=\"" namespace "\" "))))))))) + + (when (eq use 'encoded) + (insert "</" (soap-element-fq-name op) ">\n")) + (insert "</soap:Body>\n"))) + +(defun soap-create-envelope (operation parameters wsdl) + "Create a SOAP request envelope for OPERATION using PARAMETERS. +WSDL is the wsdl document used to encode the PARAMETERS." + (with-temp-buffer + (let ((soap-encoded-namespaces '("xsi" "soap" "soapenc")) + (use (soap-bound-operation-use operation))) + + ;; Create the request body + (soap-encode-body operation parameters wsdl) + + ;; Put the envelope around the body + (goto-char (point-min)) + (insert "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<soap:Envelope\n") + (when (eq use 'encoded) + (insert " soapenc:encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"\n")) + (dolist (nstag soap-encoded-namespaces) + (insert " xmlns:" nstag "=\"") + (let ((nsname (cdr (assoc nstag soap-well-known-xmlns)))) + (unless nsname + (setq nsname (cdr (assoc nstag (soap-wsdl-alias-table wsdl))))) + (insert nsname) + (insert "\"\n"))) + (insert ">\n") + (goto-char (point-max)) + (insert "</soap:Envelope>\n")) + + (buffer-string))) + +;;;; invoking soap methods + +(defcustom soap-debug nil + "When t, enable some debugging facilities." + :type 'boolean + :group 'soap-client) + +(defun soap-invoke (wsdl service operation-name &rest parameters) + "Invoke a SOAP operation and return the result. + +WSDL is used for encoding the request and decoding the response. +It also contains information about the WEB server address that +will service the request. + +SERVICE is the SOAP service to invoke. + +OPERATION-NAME is the operation to invoke. + +PARAMETERS -- the remaining parameters are used as parameters for +the SOAP request. + +NOTE: The SOAP service provider should document the available +operations and their parameters for the service. You can also +use the `soap-inspect' function to browse the available +operations in a WSDL document." + (let ((port (catch 'found + (dolist (p (soap-wsdl-ports wsdl)) + (when (equal service (soap-element-name p)) + (throw 'found p)))))) + (unless port + (error "Unknown SOAP service: %s" service)) + + (let* ((binding (soap-port-binding port)) + (operation (gethash operation-name + (soap-binding-operations binding)))) + (unless operation + (error "No operation %s for SOAP service %s" operation-name service)) + + (let ((url-request-method "POST") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-http-version "1.0") + (url-request-data (soap-create-envelope operation parameters wsdl)) + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-request-coding-system 'utf-8) + (url-http-attempt-keepalives t) + (url-request-extra-headers (list + (cons "SOAPAction" + (soap-bound-operation-soap-action + operation)) + (cons "Content-Type" + "text/xml; charset=utf-8")))) + (let ((buffer (url-retrieve-synchronously + (soap-port-service-url port)))) + (condition-case err + (with-current-buffer buffer + (declare (special url-http-response-status)) + (if (null url-http-response-status) + (error "No HTTP response from server")) + (if (and soap-debug (> url-http-response-status 299)) + ;; This is a warning because some SOAP errors come + ;; back with a HTTP response 500 (internal server + ;; error) + (warn "Error in SOAP response: HTTP code %s" + url-http-response-status)) + (when (> (buffer-size) 1000000) + (soap-warning + "Received large message: %s bytes" + (buffer-size))) + (let ((mime-part (mm-dissect-buffer t t))) + (unless mime-part + (error "Failed to decode response from server")) + (unless (equal (car (mm-handle-type mime-part)) "text/xml") + (error "Server response is not an XML document")) + (with-temp-buffer + (mm-insert-part mime-part) + (let ((response (car (xml-parse-region + (point-min) (point-max))))) + (prog1 + (soap-parse-envelope response operation wsdl) + (kill-buffer buffer) + (mm-destroy-part mime-part)))))) + (soap-error + ;; Propagate soap-errors -- they are error replies of the + ;; SOAP protocol and don't indicate a communication + ;; problem or a bug in this code. + (signal (car err) (cdr err))) + (error + (when soap-debug + (pop-to-buffer buffer)) + (error (error-message-string err))))))))) + +(provide 'soap-client) + + +;;; Local Variables: +;;; mode: outline-minor +;;; outline-regexp: ";;;;+" +;;; End: + +;;; soap-client.el ends here diff --git a/lisp/net/soap-inspect.el b/lisp/net/soap-inspect.el new file mode 100644 index 00000000000..7cce9844d76 --- /dev/null +++ b/lisp/net/soap-inspect.el @@ -0,0 +1,357 @@ +;;;; soap-inspect.el -- Interactive inspector for soap WSDL structures + +;; Copyright (C) 2010-2011 Free Software Foundation, Inc. + +;; Author: Alexandru Harsanyi (AlexHarsanyi@gmail.com) +;; Created: October 2010 +;; Keywords: soap, web-services, comm, hypermedia +;; Homepage: http://code.google.com/p/emacs-soap-client + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This package provides an inspector for a WSDL document loaded with +;; `soap-load-wsdl' or `soap-load-wsdl-from-url'. To use it, evaluate: +;; +;; (soap-inspect *wsdl*) +;; +;; This will pop-up the inspector buffer. You can click on ports, operations +;; and types to explore the structure of the wsdl document. +;; + + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'soap-client) + +;;; sample-value + +(defun soap-sample-value (type) + "Provide a sample value for TYPE, a WSDL type. +A sample value is a LISP value which soap-client.el will accept +for encoding it using TYPE when making SOAP requests. + +This is a generic function, depending on TYPE a specific function +will be called." + (let ((sample-value (get (aref type 0) 'soap-sample-value))) + (if sample-value + (funcall sample-value type) + (error "Cannot provide sample value for type %s" (aref type 0))))) + +(defun soap-sample-value-for-basic-type (type) + "Provide a sample value for TYPE which is a basic type. +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + (case (soap-basic-type-kind type) + (string "a string value") + (boolean t) ; could be nil as well + ((long int) (random 4200)) + ;; TODO: we need better sample values for more types. + (t (format "%s" (soap-basic-type-kind type))))) + +(defun soap-sample-value-for-seqence-type (type) + "Provide a sample value for TYPE which is a sequence type. +Values for sequence types are ALISTS of (slot-name . VALUE) for +each sequence element. + +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + (let ((sample-value nil)) + (dolist (element (soap-sequence-type-elements type)) + (push (cons (soap-sequence-element-name element) + (soap-sample-value (soap-sequence-element-type element))) + sample-value)) + (when (soap-sequence-type-parent type) + (setq sample-value + (append (soap-sample-value (soap-sequence-type-parent type)) + sample-value))) + sample-value)) + +(defun soap-sample-value-for-array-type (type) + "Provide a sample value for TYPE which is an array type. +Values for array types are LISP vectors of values which are +array's element type. + +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + (let* ((element-type (soap-array-type-element-type type)) + (sample1 (soap-sample-value element-type)) + (sample2 (soap-sample-value element-type))) + ;; Our sample value is a vector of two elements, but any number of + ;; elements are permissible + (vector sample1 sample2 '&etc))) + +(defun soap-sample-value-for-message (message) + "Provide a sample value for a WSDL MESSAGE. +This is a specific function which should not be called directly, +use `soap-sample-value' instead." + ;; NOTE: parameter order is not considered. + (let (sample-value) + (dolist (part (soap-message-parts message)) + (push (cons (car part) + (soap-sample-value (cdr part))) + sample-value)) + (nreverse sample-value))) + +(progn + ;; Install soap-sample-value methods for our types + (put (aref (make-soap-basic-type) 0) 'soap-sample-value + 'soap-sample-value-for-basic-type) + + (put (aref (make-soap-sequence-type) 0) 'soap-sample-value + 'soap-sample-value-for-seqence-type) + + (put (aref (make-soap-array-type) 0) 'soap-sample-value + 'soap-sample-value-for-array-type) + + (put (aref (make-soap-message) 0) 'soap-sample-value + 'soap-sample-value-for-message) ) + + + +;;; soap-inspect + +(defvar soap-inspect-previous-items nil + "A stack of previously inspected items in the *soap-inspect* buffer. +Used to implement the BACK button.") + +(defvar soap-inspect-current-item nil + "The current item being inspected in the *soap-inspect* buffer.") + +(progn + (make-variable-buffer-local 'soap-inspect-previous-items) + (make-variable-buffer-local 'soap-inspect-current-item)) + +(defun soap-inspect (element) + "Inspect a SOAP ELEMENT in the *soap-inspect* buffer. +The buffer is populated with information about ELEMENT with links +to its sub elements. If ELEMENT is the WSDL document itself, the +entire WSDL can be inspected." + (let ((inspect (get (aref element 0) 'soap-inspect))) + (unless inspect + (error "Soap-inspect: no inspector for element")) + + (with-current-buffer (get-buffer-create "*soap-inspect*") + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer) + + (when soap-inspect-current-item + (push soap-inspect-current-item + soap-inspect-previous-items)) + (setq soap-inspect-current-item element) + + (funcall inspect element) + + (unless (null soap-inspect-previous-items) + (insert "\n\n") + (insert-text-button + "[back]" + 'type 'soap-client-describe-back-link + 'item element) + (insert "\n")) + (goto-char (point-min)) + (pop-to-buffer (current-buffer)))))) + + +(define-button-type 'soap-client-describe-link + 'face 'italic + 'help-echo "mouse-2, RET: describe item" + 'follow-link t + 'action (lambda (button) + (let ((item (button-get button 'item))) + (soap-inspect item))) + 'skip t) + +(define-button-type 'soap-client-describe-back-link + 'face 'italic + 'help-echo "mouse-2, RET: browse the previous item" + 'follow-link t + 'action (lambda (button) + (let ((item (pop soap-inspect-previous-items))) + (when item + (setq soap-inspect-current-item nil) + (soap-inspect item)))) + 'skip t) + +(defun soap-insert-describe-button (element) + "Insert a button to inspect ELEMENT when pressed." + (insert-text-button + (soap-element-fq-name element) + 'type 'soap-client-describe-link + 'item element)) + +(defun soap-inspect-basic-type (basic-type) + "Insert information about BASIC-TYPE into the current buffer." + (insert "Basic type: " (soap-element-fq-name basic-type)) + (insert "\nSample value\n") + (pp (soap-sample-value basic-type) (current-buffer))) + +(defun soap-inspect-sequence-type (sequence) + "Insert information about SEQUENCE into the current buffer." + (insert "Sequence type: " (soap-element-fq-name sequence) "\n") + (when (soap-sequence-type-parent sequence) + (insert "Parent: ") + (soap-insert-describe-button + (soap-sequence-type-parent sequence)) + (insert "\n")) + (insert "Elements: \n") + (dolist (element (soap-sequence-type-elements sequence)) + (insert "\t" (symbol-name (soap-sequence-element-name element)) + "\t") + (soap-insert-describe-button + (soap-sequence-element-type element)) + (when (soap-sequence-element-multiple? element) + (insert " multiple")) + (when (soap-sequence-element-nillable? element) + (insert " optional")) + (insert "\n")) + (insert "Sample value:\n") + (pp (soap-sample-value sequence) (current-buffer))) + +(defun soap-inspect-array-type (array) + "Insert information about the ARRAY into the current buffer." + (insert "Array name: " (soap-element-fq-name array) "\n") + (insert "Element type: ") + (soap-insert-describe-button + (soap-array-type-element-type array)) + (insert "\nSample value:\n") + (pp (soap-sample-value array) (current-buffer))) + +(defun soap-inspect-message (message) + "Insert information about MESSAGE into the current buffer." + (insert "Message name: " (soap-element-fq-name message) "\n") + (insert "Parts:\n") + (dolist (part (soap-message-parts message)) + (insert "\t" (symbol-name (car part)) + " type: ") + (soap-insert-describe-button (cdr part)) + (insert "\n"))) + +(defun soap-inspect-operation (operation) + "Insert information about OPERATION into the current buffer." + (insert "Operation name: " (soap-element-fq-name operation) "\n") + (let ((input (soap-operation-input operation))) + (insert "\tInput: " (symbol-name (car input)) " (" ) + (soap-insert-describe-button (cdr input)) + (insert ")\n")) + (let ((output (soap-operation-output operation))) + (insert "\tOutput: " (symbol-name (car output)) " (") + (soap-insert-describe-button (cdr output)) + (insert ")\n")) + + (insert "\n\nSample invocation:\n") + (let ((sample-message-value + (soap-sample-value (cdr (soap-operation-input operation)))) + (funcall (list 'soap-invoke '*WSDL* "SomeService" (soap-element-name operation)))) + (let ((sample-invocation + (append funcall (mapcar 'cdr sample-message-value)))) + (pp sample-invocation (current-buffer))))) + +(defun soap-inspect-port-type (port-type) + "Insert information about PORT-TYPE into the current buffer." + (insert "Port-type name: " (soap-element-fq-name port-type) "\n") + (insert "Operations:\n") + (loop for o being the hash-values of + (soap-namespace-elements (soap-port-type-operations port-type)) + do (progn + (insert "\t") + (soap-insert-describe-button (car o))))) + +(defun soap-inspect-binding (binding) + "Insert information about BINDING into the current buffer." + (insert "Binding: " (soap-element-fq-name binding) "\n") + (insert "\n") + (insert "Bound operations:\n") + (let* ((ophash (soap-binding-operations binding)) + (operations (loop for o being the hash-keys of ophash + collect o)) + op-name-width) + + (setq operations (sort operations 'string<)) + + (setq op-name-width (loop for o in operations maximizing (length o))) + + (dolist (op operations) + (let* ((bound-op (gethash op ophash)) + (soap-action (soap-bound-operation-soap-action bound-op)) + (use (soap-bound-operation-use bound-op))) + (unless soap-action + (setq soap-action "")) + (insert "\t") + (soap-insert-describe-button (soap-bound-operation-operation bound-op)) + (when (or use (not (equal soap-action ""))) + (insert (make-string (- op-name-width (length op)) ?\s)) + (insert " (") + (insert soap-action) + (when use + (insert " " (symbol-name use))) + (insert ")")) + (insert "\n"))))) + +(defun soap-inspect-port (port) + "Insert information about PORT into the current buffer." + (insert "Port name: " (soap-element-name port) "\n" + "Service URL: " (soap-port-service-url port) "\n" + "Binding: ") + (soap-insert-describe-button (soap-port-binding port))) + +(defun soap-inspect-wsdl (wsdl) + "Insert information about WSDL into the current buffer." + (insert "WSDL Origin: " (soap-wsdl-origin wsdl) "\n") + (insert "Ports:") + (dolist (p (soap-wsdl-ports wsdl)) + (insert "\n--------------------\n") + ;; (soap-insert-describe-button p) + (soap-inspect-port p)) + (insert "\n--------------------\nNamespace alias table:\n") + (dolist (a (soap-wsdl-alias-table wsdl)) + (insert "\t" (car a) " => " (cdr a) "\n"))) + +(progn + ;; Install the soap-inspect methods for our types + + (put (aref (make-soap-basic-type) 0) 'soap-inspect + 'soap-inspect-basic-type) + + (put (aref (make-soap-sequence-type) 0) 'soap-inspect + 'soap-inspect-sequence-type) + + (put (aref (make-soap-array-type) 0) 'soap-inspect + 'soap-inspect-array-type) + + (put (aref (make-soap-message) 0) 'soap-inspect + 'soap-inspect-message) + (put (aref (make-soap-operation) 0) 'soap-inspect + 'soap-inspect-operation) + + (put (aref (make-soap-port-type) 0) 'soap-inspect + 'soap-inspect-port-type) + + (put (aref (make-soap-binding) 0) 'soap-inspect + 'soap-inspect-binding) + + (put (aref (make-soap-port) 0) 'soap-inspect + 'soap-inspect-port) + + (put (aref (make-soap-wsdl) 0) 'soap-inspect + 'soap-inspect-wsdl)) + +(provide 'soap-inspect) +;;; soap-inspect.el ends here diff --git a/lisp/net/tramp-imap.el b/lisp/net/tramp-imap.el deleted file mode 100644 index 3a536103c3d..00000000000 --- a/lisp/net/tramp-imap.el +++ /dev/null @@ -1,844 +0,0 @@ -;;; tramp-imap.el --- Tramp interface to IMAP through imap.el - -;; Copyright (C) 2009-2011 Free Software Foundation, Inc. - -;; Author: Teodor Zlatanov <tzz@lifelogs.com> -;; Keywords: mail, comm -;; Package: tramp - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Package to provide Tramp over IMAP - -;;; Setup: - -;; just load and open files, e.g. -;; /imaps:user@yourhosthere.com:/INBOX.test/1 -;; or -;; /imap:user@yourhosthere.com:/INBOX.test/1 - -;; where `imap' goes over IMAP, while `imaps' goes over IMAP+SSL - -;; This module will use imap-hash.el to access the IMAP mailbox. - -;; This module will use auth-source.el to authenticate against the -;; IMAP server, PLUS it will use auth-source.el to get your passphrase -;; for the symmetrically encrypted messages. For the former, use the -;; usual IMAP ports. For the latter, use the port "tramp-imap". - -;; example .authinfo / .netrc file: - -;; machine yourhosthere.com port tramp-imap login USER password SYMMETRIC-PASSPHRASE - -;; note above is the symmetric encryption passphrase for GPG -;; below is the regular password for IMAP itself and other things on that host - -;; machine yourhosthere.com login USER password NORMAL-PASSWORD - - -;;; Code: - -(require 'assoc) -(require 'tramp) - -(autoload 'auth-source-user-or-password "auth-source") -(autoload 'epg-context-operation "epg") -(autoload 'epg-context-set-armor "epg") -(autoload 'epg-context-set-passphrase-callback "epg") -(autoload 'epg-context-set-progress-callback "epg") -(autoload 'epg-decrypt-string "epg") -(autoload 'epg-encrypt-string "epg") -(autoload 'epg-make-context "epg") -(autoload 'imap-hash-get "imap-hash") -(autoload 'imap-hash-make "imap-hash") -(autoload 'imap-hash-map "imap-hash") -(autoload 'imap-hash-put "imap-hash") -(autoload 'imap-hash-rem "imap-hash") - -;; We use the additional header "X-Size" for encoding the size of a file. -(eval-after-load "imap-hash" - '(add-to-list 'imap-hash-headers 'X-Size 'append)) - -;; Define Tramp IMAP method ... -;;;###tramp-autoload -(defconst tramp-imap-method "imap" - "*Method to connect via IMAP protocol.") - -;;;###tramp-autoload -(when (and (locate-library "epa") (locate-library "imap-hash")) - (add-to-list 'tramp-methods - (list tramp-imap-method '(tramp-default-port 143)))) - -;; Define Tramp IMAPS method ... -;;;###tramp-autoload -(defconst tramp-imaps-method "imaps" - "*Method to connect via secure IMAP protocol.") - -;; ... and add it to the method list. -;;;###tramp-autoload -(when (and (locate-library "epa") (locate-library "imap-hash")) - (add-to-list 'tramp-methods - (list tramp-imaps-method '(tramp-default-port 993)))) - -;; Add a default for `tramp-default-user-alist'. Default is the local user. -;;;###tramp-autoload -(add-to-list - 'tramp-default-user-alist - (list (concat "\\`" - (regexp-opt (list tramp-imap-method tramp-imaps-method)) - "\\'") - nil (user-login-name))) - -;; Add completion function for IMAP method. -;; (tramp-set-completion-function -;; tramp-imap-method tramp-completion-function-alist-ssh) ; TODO: test this -;; tramp-imaps-method tramp-completion-function-alist-ssh) ; TODO: test this - -;; New handlers should be added here. -(defconst tramp-imap-file-name-handler-alist - '( - ;; `access-file' performed by default handler - (add-name-to-file . ignore) - ;; `byte-compiler-base-file-name' performed by default handler - ;; `copy-directory' performed by default handler - (copy-file . tramp-imap-handle-copy-file) - (delete-directory . ignore) ;; tramp-imap-handle-delete-directory) - (delete-file . tramp-imap-handle-delete-file) - ;; `diff-latest-backup-file' performed by default handler - (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-handle-directory-files) - (directory-files-and-attributes - . tramp-handle-directory-files-and-attributes) - (dired-call-process . ignore) - ;; `dired-compress-file' performed by default handler - ;; `dired-uncache' performed by default handler - (expand-file-name . tramp-imap-handle-expand-file-name) - ;; `file-accessible-directory-p' performed by default handler - (file-attributes . tramp-imap-handle-file-attributes) - (file-directory-p . tramp-imap-handle-file-directory-p) - (file-executable-p . ignore) - (file-exists-p . tramp-handle-file-exists-p) - (file-local-copy . tramp-imap-handle-file-local-copy) - (file-modes . tramp-handle-file-modes) - (file-name-all-completions . tramp-imap-handle-file-name-all-completions) - (file-name-as-directory . tramp-handle-file-name-as-directory) - (file-name-completion . tramp-handle-file-name-completion) - (file-name-directory . tramp-handle-file-name-directory) - (file-name-nondirectory . tramp-handle-file-name-nondirectory) - ;; `file-name-sans-versions' performed by default handler - (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) - (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-handle-file-exists-p) - (file-regular-p . tramp-handle-file-regular-p) - (file-remote-p . tramp-handle-file-remote-p) - ;; `file-selinux-context' performed by default handler. - (file-symlink-p . tramp-handle-file-symlink-p) - ;; `file-truename' performed by default handler - (file-writable-p . tramp-imap-handle-file-writable-p) - (find-backup-file-name . tramp-handle-find-backup-file-name) - ;; `find-file-noselect' performed by default handler - ;; `get-file-buffer' performed by default handler - (insert-directory . tramp-imap-handle-insert-directory) - (insert-file-contents . tramp-imap-handle-insert-file-contents) - (load . tramp-handle-load) - (make-directory . ignore) ;; tramp-imap-handle-make-directory) - (make-directory-internal . ignore) ;; tramp-imap-handle-make-directory-internal) - (make-symbolic-link . ignore) - (rename-file . tramp-imap-handle-rename-file) - (set-file-modes . ignore) - ;; `set-file-selinux-context' performed by default handler. - (set-file-times . ignore) ;; tramp-imap-handle-set-file-times) - (set-visited-file-modtime . ignore) - (shell-command . ignore) - (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) - (vc-registered . ignore) - (verify-visited-file-modtime . ignore) - (write-region . tramp-imap-handle-write-region) - (executable-find . ignore) - (start-file-process . ignore) - (process-file . ignore) -) - "Alist of handler functions for Tramp IMAP method. -Operations not mentioned here will be handled by the default Emacs primitives.") - -(defgroup tramp-imap nil - "Tramp over IMAP configuration." - :version "23.2" - :group 'tramp) - -(defcustom tramp-imap-subject-marker "tramp-imap-subject-marker" - "The subject marker that Tramp-IMAP will use." - :type 'string - :version "23.2" - :group 'tramp-imap) - -;; TODO: these will be defcustoms later. -(defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never -(defvar tramp-imap-passphrase nil) - -;;;###tramp-autoload -(defsubst tramp-imap-file-name-p (filename) - "Check if it's a filename for IMAP protocol." - (let ((v (tramp-dissect-file-name filename))) - (or - (string= (tramp-file-name-method v) tramp-imap-method) - (string= (tramp-file-name-method v) tramp-imaps-method)))) - -;;;###tramp-autoload -(defun tramp-imap-file-name-handler (operation &rest args) - "Invoke the IMAP related OPERATION. -First arg specifies the OPERATION, second arg is a list of arguments to -pass to the OPERATION." - (let ((fn (assoc operation tramp-imap-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) - -;;;###tramp-autoload -(when (and (locate-library "epa") (locate-library "imap-hash")) - (add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler))) - -(defun tramp-imap-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Like `copy-file' for Tramp files." - (tramp-imap-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid)) - -(defun tramp-imap-handle-rename-file - (filename newname &optional ok-if-already-exists) - "Like `rename-file' for Tramp files." - (tramp-imap-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t t)) - -(defun tramp-imap-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) - "Copy or rename a remote file. -OP must be `copy' or `rename' and indicates the operation to perform. -FILENAME specifies the file to copy or rename, NEWNAME is the name of -the new file (for copy) or the new name of the file (for rename). -OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. -KEEP-DATE means to make sure that NEWNAME has the same timestamp -as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep -the uid and gid if both files are on the same host. - -This function is invoked by `tramp-imap-handle-copy-file' and -`tramp-imap-handle-rename-file'. It is an error if OP is neither -of `copy' and `rename'." - (unless (memq op '(copy rename)) - (error "Unknown operation `%s', must be `copy' or `rename'" op)) - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - (when (file-directory-p newname) - (setq newname (expand-file-name (file-name-nondirectory filename) newname))) - - (let ((t1 (and (tramp-tramp-file-p filename) - (tramp-imap-file-name-p filename))) - (t2 (and (tramp-tramp-file-p newname) - (tramp-imap-file-name-p newname)))) - - (with-parsed-tramp-file-name (if t1 filename newname) nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) - - (with-progress-reporter - v 0 (format "%s %s to %s" - (if (eq op 'copy) "Copying" "Renaming") - filename newname) - - ;; We just make a local copy of FILENAME, and write it then to - ;; NEWNAME. This must be optimized when both files are - ;; located on the same IMAP server. - (with-temp-buffer - (if (and t1 t2) - ;; We don't encrypt. - (with-parsed-tramp-file-name newname v1 - (insert (tramp-imap-get-file filename nil)) - (tramp-imap-put-file - v1 (current-buffer) - (tramp-imap-file-name-name v1) - nil nil (nth 7 (file-attributes filename)))) - ;; One of them is not located on a IMAP mailbox. - (insert-file-contents filename) - (write-region (point-min) (point-max) newname))))) - - (when (eq op 'rename) (delete-file filename)))) - -;; TODO: revise this much -(defun tramp-imap-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files." - ;; If DIR is not given, use DEFAULT-DIRECTORY or "/". - (setq dir (or dir default-directory "/")) - ;; Unless NAME is absolute, concat DIR and NAME. - (unless (file-name-absolute-p name) - (setq name (concat (file-name-as-directory dir) name))) - ;; If NAME is not a Tramp file, run the real handler. - (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name))) - (tramp-drop-volume-letter - (tramp-run-real-handler 'expand-file-name (list name nil))) - ;; Dissect NAME. - (with-parsed-tramp-file-name name nil - (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) - (setq localname (concat "/" localname))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; Do normal `expand-file-name' (this does "/./" and "/../"). - ;; We bind `directory-sep-char' here for XEmacs on Windows, - ;; which would otherwise use backslash. `default-directory' is - ;; bound, because on Windows there would be problems with UNC - ;; shares or Cygwin mounts. - (let ((default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user host - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -;; This function should return "foo/" for directories and "bar" for -;; files. -(defun tramp-imap-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (save-match-data - (let ((entries - (tramp-imap-get-file-entries v localname))) - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 9 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - entries)))))) - -(defun tramp-imap-get-file-entries (vec localname &optional exact) - "Read entries returned by IMAP server. EXACT limits to exact matches. -Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME -SIZE MODE WEIRD INODE DEVICE)." - (tramp-message vec 5 "working on %s" localname) - (let* ((name (tramp-imap-file-name-name vec)) - (search-name (or name "")) - (search-name (if exact (concat search-name "$") search-name)) - (iht (tramp-imap-make-iht vec search-name))) -;; TODO: catch errors - ;; (tramp-error vec 'none "bad name %s or mailbox %s" name mbox)) - (imap-hash-map (lambda (uid headers body) - (let ((subject (substring - (aget headers 'Subject "") - (length tramp-imap-subject-marker))) - (from (aget headers 'From "")) - (date (date-to-time (aget headers 'Date ""))) - (size (string-to-number - (or (aget headers 'X-Size "0") "0")))) - (setq from - (if (string-match "<\\([^@]+\\)@" from) - (match-string 1 from) - "nobody")) - (list - subject - nil - -1 - from - "nogroup" - date - date - date - size - "-rw-rw-rw-" - nil - uid - (tramp-get-device vec)))) - iht t))) - -(defun tramp-imap-handle-write-region (start end filename &optional append visit lockname confirm) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - ;; XEmacs takes a coding system as the seventh argument, not `confirm'. - (when (and (not (featurep 'xemacs)) - confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " - filename)) - (tramp-error v 'file-error "File not overwritten"))) - (tramp-flush-file-property v localname) - (let* ((old-buffer (current-buffer)) - (inode (tramp-imap-get-file-inode filename)) - (min 1) - (max (point-max)) - ;; Make sure we have good start and end values. - (start (or start min)) - (end (or end max)) - temp-buffer) - (with-temp-buffer - (setq temp-buffer (if (and (eq start min) (eq end max)) - old-buffer - ;; If this is a region write, insert the substring. - (insert - (with-current-buffer old-buffer - (buffer-substring-no-properties start end))) - (current-buffer))) - (tramp-imap-put-file v - temp-buffer - (tramp-imap-file-name-name v) - inode - t))) - (when (eq visit t) - (set-visited-file-modtime)))) - -(defun tramp-imap-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - (setq filename (expand-file-name filename)) - (if full-directory-p - ;; Called from `dired-add-entry'. - (setq filename (file-name-as-directory filename)) - (setq filename (directory-file-name filename))) - (with-parsed-tramp-file-name filename nil - (save-match-data - (let ((base (file-name-nondirectory localname)) - (entries (copy-sequence - (tramp-imap-get-file-entries - v (file-name-directory localname))))) - - (when wildcard - (when (string-match "\\." base) - (setq base (replace-match "\\\\." nil nil base))) - (when (string-match "\\*" base) - (setq base (replace-match ".*" nil nil base))) - (when (string-match "\\?" base) - (setq base (replace-match ".?" nil nil base)))) - - ;; Filter entries. - (setq entries - (delq - nil - (if (or wildcard (zerop (length base))) - ;; Check for matching entries. - (mapcar - (lambda (x) - (when (string-match - (format "^%s" base) (nth 0 x)) - x)) - entries) - ;; We just need the only and only entry FILENAME. - (list (assoc base entries))))) - - ;; Sort entries. - (setq entries - (sort - entries - (lambda (x y) - (if (string-match "t" switches) - ;; Sort by date. - (tramp-time-less-p (nth 6 y) (nth 6 x)) - ;; Sort by name. - (string-lessp (nth 0 x) (nth 0 y)))))) - - ;; Handle "-F" switch. - (when (string-match "F" switches) - (mapc - (lambda (x) - (when (not (zerop (length (car x)))) - (cond - ((char-equal ?d (string-to-char (nth 9 x))) - (setcar x (concat (car x) "/"))) - ((char-equal ?x (string-to-char (nth 9 x))) - (setcar x (concat (car x) "*")))))) - entries)) - - ;; Print entries. - (mapcar - (lambda (x) - (when (not (zerop (length (nth 0 x)))) - (insert - (format - "%10s %3d %-8s %-8s %8s %s " - (nth 9 x) ; mode - (nth 11 x) ; inode - (nth 3 x) ; uid - (nth 4 x) ; gid - (nth 8 x) ; size - (format-time-string - (if (tramp-time-less-p - (tramp-time-subtract (current-time) (nth 6 x)) - tramp-half-a-year) - "%b %e %R" - "%b %e %Y") - (nth 6 x)))) ; date - ;; For the file name, we set the `dired-filename' - ;; property. This allows to handle file names with - ;; leading or trailing spaces as well. The inserted name - ;; could be from somewhere else, so we use the relative - ;; file name of `default-directory'. - (let ((pos (point))) - (insert - (format - "%s\n" - (file-relative-name - (expand-file-name (nth 0 x) (file-name-directory filename))))) - (put-text-property pos (1- (point)) 'dired-filename t)) - (forward-line) - (beginning-of-line))) - entries))))) - -(defun tramp-imap-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (when visit - (setq buffer-file-name (expand-file-name filename)) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - (with-parsed-tramp-file-name filename nil - (if (not (file-exists-p filename)) - (tramp-error - v 'file-error "File `%s' not found on remote host" filename) - (let ((point (point)) - size data) - (with-progress-reporter v 3 (format "Fetching file %s" filename) - (insert (tramp-imap-get-file filename t)) - (setq size (- (point) point)) -;;; TODO: handle ranges. -;;; (let ((beg (or beg (point-min))) -;;; (end (min (or end (point-max)) (point-max)))) -;;; (setq size (- end beg)) -;;; (buffer-substring beg end)) - (goto-char point) - (list (expand-file-name filename) size)))))) - -(defun tramp-imap-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp-IMAP files." - ;; We allow only mailboxes to be a directory. - (with-parsed-tramp-file-name (expand-file-name filename default-directory) nil - (and (string-match "^/[^/]*$" (directory-file-name localname)) t))) - -(defun tramp-imap-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp-IMAP FILENAME." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (let ((res (cdr-safe (nth 0 (tramp-imap-get-file-entries v localname))))) - (unless (or (null res) (eq id-format 'string)) - (setcar (nthcdr 2 res) 1) - (setcar (nthcdr 3 res) 1)) - res))) - -(defun tramp-imap-get-file-inode (filename &optional id-format) - "Get inode equivalent \(actually the UID) for Tramp-IMAP FILENAME." - (nth 10 (tramp-compat-file-attributes filename id-format))) - -(defun tramp-imap-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files. True for IMAP." - ;; `file-exists-p' does not work yet for directories. - ;; (file-exists-p (file-name-directory filename))) - (file-directory-p (file-name-directory filename))) - -(defun tramp-imap-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (cond - ((not (file-exists-p filename)) nil) - (t (with-parsed-tramp-file-name (expand-file-name filename) nil - (let ((iht (tramp-imap-make-iht v))) - (imap-hash-rem (tramp-imap-get-file-inode filename) iht)))))) - -(defun tramp-imap-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (unless (file-exists-p filename) - (tramp-error - v 'file-error - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (with-temp-buffer - (insert-file-contents filename) - (write-region (point-min) (point-max) tmpfile) - tmpfile))))) - -(defun tramp-imap-put-file - (vec filename-or-buffer &optional subject inode encode size) - "Write contents of FILENAME-OR-BUFFER to Tramp-IMAP file VEC with name SUBJECT. -When INODE is given, delete that old remote file after writing the new one -\(normally this is the old file with the same name). A non-nil ENCODE -forces the encoding of the buffer or file. SIZE, when available, indicates -the file size; this is needed, if the file or buffer is already encoded." - ;; `tramp-current-host' is used in `tramp-imap-passphrase-callback-function'. - (let ((tramp-current-host (tramp-file-name-real-host vec)) - (iht (tramp-imap-make-iht vec))) - (imap-hash-put (list - (list (cons - 'Subject - (format - "%s%s" - tramp-imap-subject-marker - (or subject "no subject"))) - (cons - 'X-Size - (number-to-string - (cond - ((numberp size) size) - ((bufferp filename-or-buffer) - (buffer-size filename-or-buffer)) - ((stringp filename-or-buffer) - (nth 7 (file-attributes filename-or-buffer))) - ;; We don't know the size. - (t -1))))) - (cond ((bufferp filename-or-buffer) - (with-current-buffer filename-or-buffer - (if encode - (tramp-imap-encode-buffer) - (buffer-string)))) - ;; TODO: allow file names. - (t "No body available"))) - iht - inode))) - -(defun tramp-imap-get-file (filename &optional decode) - ;; (debug (tramp-imap-get-file-inode filename)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (condition-case () - ;; `tramp-current-host' is used in - ;; `tramp-imap-passphrase-callback-function'. - (let* ((tramp-current-host (tramp-file-name-real-host v)) - (iht (tramp-imap-make-iht v)) - (inode (tramp-imap-get-file-inode filename)) - (data (imap-hash-get inode iht t))) - (if decode - (with-temp-buffer - (insert (nth 1 data)) - ;;(debug inode (buffer-string)) - (tramp-imap-decode-buffer)) - (nth 1 data))) - (error (tramp-error - v 'file-error "File `%s' could not be read" filename))))) - -(defun tramp-imap-passphrase-callback-function (context key-id handback) - "Called by EPG to get a passphrase for Tramp-IMAP. -CONTEXT is the encryption/decryption EPG context. -HANDBACK is just carried through. -KEY-ID can be 'SYM or 'PIN among others." - (let* ((server tramp-current-host) - (port "tramp-imap") ; this is NOT the server password! - (auth-passwd - (auth-source-user-or-password "password" server port))) - (or - (copy-sequence auth-passwd) - ;; If we cache the passphrase and we have one. - (if (and (eq tramp-imap-passphrase-cache t) - tramp-imap-passphrase) - ;; Do we reuse it? - (if (y-or-n-p "Reuse the passphrase? ") - (copy-sequence tramp-imap-passphrase) - ;; Don't reuse: revert caching behavior to nil, erase passphrase, - ;; call ourselves again. - (setq tramp-imap-passphrase-cache nil) - (setq tramp-imap-passphrase nil) - (tramp-imap-passphrase-callback-function context key-id handback)) - (let ((p (if (eq key-id 'SYM) - (read-passwd - "Tramp-IMAP passphrase for symmetric encryption: " - (eq (epg-context-operation context) 'encrypt) - tramp-imap-passphrase) - (read-passwd - (if (eq key-id 'PIN) - "Tramp-IMAP passphrase for PIN: " - (let ((entry (assoc key-id - (symbol-value 'epg-user-id-alist)))) - (if entry - (format "Tramp-IMAP passphrase for %s %s: " - key-id (cdr entry)) - (format "Tramp-IMAP passphrase for %s: " key-id)))) - nil - tramp-imap-passphrase)))) - - ;; If we have an answer, the passphrase has changed, - ;; the user hasn't declined keeping the passphrase, - ;; and they answer yes to keep it now... - (when (and - p - (not (equal tramp-imap-passphrase p)) - (not (eq tramp-imap-passphrase-cache 'never)) - (y-or-n-p "Keep the passphrase? ")) - (setq tramp-imap-passphrase (copy-sequence p)) - (setq tramp-imap-passphrase-cache t)) - - ;; If we still don't have a passphrase, the user didn't want - ;; to keep it. - (when (and - p - (not tramp-imap-passphrase)) - (setq tramp-imap-passphrase-cache 'never)) - - p))))) - -(defun tramp-imap-encode-buffer () - (let ((context (epg-make-context 'OpenPGP)) - cipher) - (epg-context-set-armor context t) - (epg-context-set-passphrase-callback context - #'tramp-imap-passphrase-callback-function) - (epg-context-set-progress-callback context - (cons #'epa-progress-callback-function - "Encrypting...")) - (message "Encrypting...") - (setq cipher (epg-encrypt-string - context - (encode-coding-string (buffer-string) 'utf-8) - nil)) - (message "Encrypting...done") - cipher)) - -(defun tramp-imap-decode-buffer () - (let ((context (epg-make-context 'OpenPGP)) - plain) - (epg-context-set-passphrase-callback context - #'tramp-imap-passphrase-callback-function) - (epg-context-set-progress-callback context - (cons #'epa-progress-callback-function - "Decrypting...")) - (message "Decrypting...") - (setq plain (decode-coding-string - (epg-decrypt-string context (buffer-string)) - 'utf-8)) - (message "Decrypting...done") - plain)) - -(defun tramp-imap-file-name-mailbox (vec) - (nth 0 (tramp-imap-file-name-parse vec))) - -(defun tramp-imap-file-name-name (vec) - (nth 1 (tramp-imap-file-name-parse vec))) - -(defun tramp-imap-file-name-localname (vec) - (nth 1 (tramp-imap-file-name-parse vec))) - -(defun tramp-imap-file-name-parse (vec) - (let ((name (substring-no-properties (tramp-file-name-localname vec)))) - (if (string-match "^/\\([^/]+\\)/?\\(.*\\)$" name) - (list (match-string 1 name) - (match-string 2 name)) - nil))) - -(defun tramp-imap-make-iht (vec &optional needed-subject) - "Translate the Tramp vector VEC to the imap-hash structure. -With NEEDED-SUBJECT, alters the imap-hash test accordingly." - (let* ((mbox (tramp-imap-file-name-mailbox vec)) - (server (tramp-file-name-real-host vec)) - (method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (ssl (string-equal method tramp-imaps-method)) - (port (tramp-file-name-port vec)) - (result (imap-hash-make server port mbox user nil ssl))) - ;; Return the IHT with a test override to look for the subject - ;; marker. - (plist-put - result - :test (format "^%s%s" - tramp-imap-subject-marker - (if needed-subject needed-subject ""))))) - -(add-hook 'tramp-unload-hook - (lambda () - (unload-feature 'tramp-imap 'force))) - -;;; TODO: - -;; * Implement `tramp-imap-handle-delete-directory', -;; `tramp-imap-handle-make-directory', -;; `tramp-imap-handle-make-directory-internal', -;; `tramp-imap-handle-set-file-times'. - -;; * Encode the subject. If the filename has trailing spaces (like -;; "test "), those characters get lost, for example in dired listings. - -;; * When opening a dired buffer, like "/imap::INBOX.test", there are -;; several error messages: -;; "Buffer has a running process; kill it? (yes or no) " -;; "error in process filter: Internal error, tag 6 status BAD code nil text No mailbox selected." -;; Afterwards, everything seems to be fine. - -;; * imaps works for local IMAP servers. Accessing -;; "/imaps:imap.gmail.com:/INBOX.test/" results in error -;; "error in process filter: Internal error, tag 5 status BAD code nil text UNSELECT not allowed now." - -;; * Improve `tramp-imap-handle-file-attributes' for directories. - -;; * Saving a file creates a second one, instead of overwriting. - -;; * Backup files: just *one* is kept. - -;; * Password requests shall have a descriptive prompt. - -;; * Exiting Emacs, there are running IMAP processes. Make them quiet -;; by `set-process-query-on-exit-flag'. - -(provide 'tramp-imap) -;;; tramp-imap.el ends here - -;; Ignore, for testing only. - -;;; (setq tramp-imap-subject-marker "T") -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t) -;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t t) -;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome") -;;; (dired-copy-file "/etc/fstab" "/imap:yourhosthere.com:/test/welcome" t) -;;; (write-region 1 100 "/imap:yourhosthere.com:/test/welcome") -;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t) -;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome")) -;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome2")) -;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2") -;;(file-name-directory "/imap:yourhosthere.com:/test/welcome2") -;;(with-temp-buffer (insert "hello") (delete-file "/tmp/hellotest") (write-file "/tmp/hellotest") (write-file "/imap:yourhosthere.com:/test/welcome2")) -;;;(file-exists-p "/imap:yourhosthere.com:/INBOX.test/4") -;;;(file-attributes "/imap:yourhosthere.com:/INBOX.test/4") -;;;(setq vec (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4")) -;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/INBOX.test/4") -;;; (tramp-imap-handle-insert-file-contents "/imap:user@yourhosthere.com:/INBOX.test/4" nil nil nil nil) -;;;(insert-file-contents "/imap:yourhosthere.com:/INBOX.test/4") -;;;(file-attributes "/imap:yourhosthere.com:/test/welcommen") -;;;(insert-file-contents "/imap:yourhosthere.com:/test/welcome") -;;;(file-exists-p "/imap:yourhosthere.com:/test/welcome2") -;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/test/welcome") -;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcommen") -;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome") -;;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2") -;;; (delete-file "/imap:yourhosthere.com:/test/welcome") -;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcommen" t) -;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t) -;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test")) -;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/old")) -;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new")) -;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/two")) -;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/one")) -;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) -;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) -;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) -;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4")) -;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") "extra") diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8584d4ddc92..fc167d6e62e 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -297,6 +297,7 @@ shouldn't return t when it isn't." (executable-find "pscp")) (if (or (fboundp 'password-read) (fboundp 'auth-source-user-or-password) + (fboundp 'auth-source-search) ;; Pageant is running. (tramp-compat-process-running-p "Pageant")) "pscp" @@ -307,6 +308,7 @@ shouldn't return t when it isn't." ((tramp-detect-ssh-controlmaster) "scpc") ((or (fboundp 'password-read) (fboundp 'auth-source-user-or-password) + (fboundp 'auth-source-search) ;; ssh-agent is running. (getenv "SSH_AUTH_SOCK") (getenv "SSH_AGENT_PID")) @@ -1572,8 +1574,12 @@ special handling of `substitute-in-file-name'." (let ((props (tramp-compat-funcall 'overlay-properties (symbol-value 'rfn-eshadow-overlay)))) (while props - (tramp-compat-funcall - 'overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props)))))) + ;; The `field' property prevents correct minibuffer + ;; completion; we exclude it. + (if (not (eq (car props) 'field)) + (tramp-compat-funcall + 'overlay-put tramp-rfn-eshadow-overlay (pop props) (pop props)) + (pop props) (pop props)))))) (when (boundp 'rfn-eshadow-setup-minibuffer-hook) (add-hook 'rfn-eshadow-setup-minibuffer-hook @@ -3519,17 +3525,32 @@ Invokes `password-read' if available, `read-passwd' else." (or prompt (with-current-buffer (process-buffer proc) (tramp-check-for-regexp proc tramp-password-prompt-regexp) - (format "%s for %s " (capitalize (match-string 1)) key))))) + (format "%s for %s " (capitalize (match-string 1)) key)))) + auth-info auth-passwd) (with-parsed-tramp-file-name key nil (prog1 (or - ;; See if auth-sources contains something useful, if it's bound. + ;; See if auth-sources contains something useful, if it's + ;; bound. `auth-source-user-or-password' is an obsoleted + ;; function, it has been replaced by `auth-source-search'. (and (boundp 'auth-sources) (tramp-get-connection-property v "first-password-request" nil) ;; Try with Tramp's current method. - (tramp-compat-funcall - 'auth-source-user-or-password - "password" tramp-current-host tramp-current-method)) + (if (fboundp 'auth-source-search) + (setq auth-info + (tramp-compat-funcall + 'auth-source-search + :max 1 + :user (or tramp-current-user t) + :host tramp-current-host + :port tramp-current-method) + auth-passwd (plist-get (nth 0 auth-info) :secret) + auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (tramp-compat-funcall + 'auth-source-user-or-password + "password" tramp-current-host tramp-current-method))) ;; Try the password cache. (when (functionp 'password-read) (unless (tramp-get-connection-property |