diff options
Diffstat (limited to 'lisp/net')
| -rw-r--r-- | lisp/net/eudc.el | 19 | ||||
| -rw-r--r-- | lisp/net/eww.el | 56 | ||||
| -rw-r--r-- | lisp/net/gnutls.el | 154 | ||||
| -rw-r--r-- | lisp/net/html2text.el | 461 | ||||
| -rw-r--r-- | lisp/net/mailcap.el | 1127 | ||||
| -rw-r--r-- | lisp/net/net-utils.el | 2 | ||||
| -rw-r--r-- | lisp/net/network-stream.el | 87 | ||||
| -rw-r--r-- | lisp/net/newst-backend.el | 7 | ||||
| -rw-r--r-- | lisp/net/nsm.el | 46 | ||||
| -rw-r--r-- | lisp/net/pop3.el | 914 | ||||
| -rw-r--r-- | lisp/net/puny.el | 248 | ||||
| -rw-r--r-- | lisp/net/rcirc.el | 47 | ||||
| -rw-r--r-- | lisp/net/shr.el | 326 | ||||
| -rw-r--r-- | lisp/net/sieve-manage.el | 575 | ||||
| -rw-r--r-- | lisp/net/sieve-mode.el | 236 | ||||
| -rw-r--r-- | lisp/net/sieve.el | 372 | ||||
| -rw-r--r-- | lisp/net/soap-client.el | 122 | ||||
| -rw-r--r-- | lisp/net/starttls.el | 304 | ||||
| -rw-r--r-- | lisp/net/tramp-adb.el | 70 | ||||
| -rw-r--r-- | lisp/net/tramp-cache.el | 65 | ||||
| -rw-r--r-- | lisp/net/tramp-cmds.el | 37 | ||||
| -rw-r--r-- | lisp/net/tramp-compat.el | 499 | ||||
| -rw-r--r-- | lisp/net/tramp-ftp.el | 29 | ||||
| -rw-r--r-- | lisp/net/tramp-gvfs.el | 64 | ||||
| -rw-r--r-- | lisp/net/tramp-gw.el | 10 | ||||
| -rw-r--r-- | lisp/net/tramp-sh.el | 499 | ||||
| -rw-r--r-- | lisp/net/tramp-smb.el | 68 | ||||
| -rw-r--r-- | lisp/net/tramp.el | 804 | ||||
| -rw-r--r-- | lisp/net/trampver.el | 47 |
29 files changed, 5527 insertions, 1768 deletions
diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index 867bea98e77..22e48dbd3d3 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -1146,7 +1146,7 @@ queries the server for the existing fields and displays a corresponding form." (defun eudc-menu () (let (command) - (append '("Directory Search") + (append '("Directory Servers") (list (append '("Server") @@ -1186,8 +1186,8 @@ queries the server for the existing fields and displays a corresponding form." (define-key global-map [menu-bar tools directory-search] - (cons "Directory Search" - (easy-menu-create-menu "Directory Search" (cdr (eudc-menu)))))) + (cons "Directory Servers" + (easy-menu-create-menu "Directory Servers" (cdr (eudc-menu)))))) ((fboundp 'easy-menu-add-item) (let ((menu (eudc-menu))) (easy-menu-add-item nil '("tools") (easy-menu-create-menu (car menu) @@ -1197,8 +1197,9 @@ queries the server for the existing fields and displays a corresponding form." (define-key global-map [menu-bar tools eudc] - (cons "Directory Search" - (easy-menu-create-keymaps "Directory Search" (cdr (eudc-menu)))))) + (cons "Directory Servers" + (easy-menu-create-keymaps "Directory Servers" + (cdr (eudc-menu)))))) (t (error "Unknown version of easymenu")))) )) @@ -1231,7 +1232,7 @@ This does nothing except loading eudc by autoload side-effect." (cond ((not (featurep 'xemacs)) (defvar eudc-tools-menu - (let ((map (make-sparse-keymap "Directory Search"))) + (let ((map (make-sparse-keymap "Directory Servers"))) (define-key map [phone] `(menu-item ,(purecopy "Get Phone") eudc-get-phone :help ,(purecopy "Get the phone field of name from the directory server"))) @@ -1255,7 +1256,7 @@ This does nothing except loading eudc by autoload side-effect." map)) (fset 'eudc-tools-menu (symbol-value 'eudc-tools-menu))) (t - (let ((menu '("Directory Search" + (let ((menu '("Directory Servers" ["Load Hotlist of Servers" eudc-load-eudc t] ["New Server" eudc-set-server t] ["---" nil nil] @@ -1279,8 +1280,8 @@ This does nothing except loading eudc by autoload side-effect." (define-key global-map [menu-bar tools eudc] - (cons "Directory Search" - (easy-menu-create-keymaps "Directory Search" + (cons "Directory Servers" + (easy-menu-create-keymaps "Directory Servers" (cdr menu))))))))))) ;;}}} diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 620a8a5f9ac..6a8400320c2 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -31,6 +31,7 @@ (require 'url-queue) (require 'url-util) ; for url-get-url-at-point (require 'mm-url) +(require 'puny) (eval-when-compile (require 'subr-x)) ;; for string-trim (defgroup eww nil @@ -222,7 +223,7 @@ See also `eww-form-checkbox-selected-symbol'." "When this regex is found in the URL, it's not a keyword but an address.") (defvar eww-link-keymap - (let ((map (copy-keymap shr-map))) + (let ((map (copy-keymap shr-image-map))) (define-key map "\r" 'eww-follow-link) map)) @@ -279,6 +280,13 @@ word(s) will be searched for via `eww-search-prefix'." (current-buffer) (get-buffer-create "*eww*"))) (eww-setup-buffer) + ;; Check whether the domain only uses "Highly Restricted" Unicode + ;; IDNA characters. If not, transform to punycode to indicate that + ;; there may be funny business going on. + (let ((parsed (url-generic-parse-url url))) + (unless (puny-highly-restrictive-domain-p (url-host parsed)) + (setf (url-host parsed) (puny-encode-domain (url-host parsed))) + (setq url (url-recreate-url parsed)))) (plist-put eww-data :url url) (plist-put eww-data :title "") (eww-update-header-line-format) @@ -410,7 +418,7 @@ Currently this means either text/html or application/xhtml+xml." (source (and (null document) (buffer-substring (point) (point-max))))) (with-current-buffer buffer - (setq bidi-paragraph-direction 'left-to-right) + (setq bidi-paragraph-direction nil) (plist-put eww-data :source source) (plist-put eww-data :dom document) (let ((inhibit-read-only t) @@ -418,9 +426,11 @@ Currently this means either text/html or application/xhtml+xml." (shr-target-id (url-target (url-generic-parse-url url))) (shr-external-rendering-functions (append + shr-external-rendering-functions '((title . eww-tag-title) (form . eww-tag-form) (input . eww-tag-input) + (button . eww-form-submit) (textarea . eww-tag-textarea) (select . eww-tag-select) (link . eww-tag-link) @@ -570,7 +580,7 @@ Currently this means either text/html or application/xhtml+xml." (let ((inhibit-read-only t)) (remove-overlays) (erase-buffer)) - (setq bidi-paragraph-direction 'left-to-right) + (setq bidi-paragraph-direction nil) (unless (eq major-mode 'eww-mode) (eww-mode))) @@ -659,11 +669,13 @@ the like." (setq score (- (length (split-string (dom-text node)))))) (t (dolist (elem (dom-children node)) - (if (stringp elem) - (setq score (+ score (length (split-string elem)))) + (cond + ((stringp elem) + (setq score (+ score (length (split-string elem))))) + ((consp elem) (setq score (+ score (or (cdr (assoc :eww-readability-score (cdr elem))) - (eww-score-readability elem)))))))) + (eww-score-readability elem))))))))) ;; Cache the score of the node to avoid recomputing all the time. (dom-set-attribute node :eww-readability-score score) score)) @@ -703,9 +715,11 @@ the like." (define-key map "R" 'eww-readable) (define-key map "H" 'eww-list-histories) (define-key map "E" 'eww-set-character-encoding) + (define-key map "s" 'eww-switch-to-buffer) (define-key map "S" 'eww-list-buffers) (define-key map "F" 'eww-toggle-fonts) (define-key map "D" 'eww-toggle-paragraph-direction) + (define-key map [(meta C)] 'eww-toggle-colors) (define-key map "b" 'eww-add-bookmark) (define-key map "B" 'eww-list-bookmarks) @@ -726,10 +740,13 @@ the like." ["View page source" eww-view-source] ["Copy page URL" eww-copy-page-url t] ["List histories" eww-list-histories t] + ["Switch to buffer" eww-switch-to-buffer t] ["List buffers" eww-list-buffers t] ["Add bookmark" eww-add-bookmark t] ["List bookmarks" eww-list-bookmarks t] ["List cookies" url-cookie-list t] + ["Toggle fonts" eww-toggle-fonts t] + ["Toggle colors" eww-toggle-colors t] ["Character Encoding" eww-set-character-encoding] ["Toggle Paragraph Direction" eww-toggle-paragraph-direction])) map)) @@ -1516,6 +1533,24 @@ If CHARSET is nil then use UTF-8." (eww-reload nil 'utf-8) (eww-reload nil charset))) +(defun eww-switch-to-buffer () + "Prompt for an EWW buffer to display in the selected window." + (interactive) + (let ((completion-extra-properties + '(:annotation-function (lambda (buf) + (with-current-buffer buf + (format " %s" (eww-current-url))))))) + (pop-to-buffer-same-window + (read-buffer "Switch to EWW buffer: " + (cl-loop for buf in (nreverse (buffer-list)) + if (with-current-buffer buf (derived-mode-p 'eww-mode)) + return buf) + t + (lambda (bufn) + (with-current-buffer + (if (consp bufn) (cdr bufn) (get-buffer bufn)) + (derived-mode-p 'eww-mode))))))) + (defun eww-toggle-fonts () "Toggle whether to use monospaced or font-enabled layouts." (interactive) @@ -1524,6 +1559,15 @@ If CHARSET is nil then use UTF-8." (message "Proportional fonts are now %s" (if shr-use-fonts "on" "off"))) +(defun eww-toggle-colors () + "Toggle whether to use HTML-specified colors or not." + (interactive) + (message "Colors are now %s" + (if (setq shr-use-colors (not shr-use-colors)) + "on" + "off")) + (eww-reload)) + ;;; Bookmarks code (defvar eww-bookmarks nil) diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index ce44c032231..9ed1c8b8305 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -26,7 +26,7 @@ ;; This package provides language bindings for the GnuTLS library ;; using the corresponding core functions in gnutls.c. It should NOT -;; be used directly, only through open-protocol-stream. +;; be used directly, only through open-network-stream. ;; Simple test: ;; @@ -95,7 +95,7 @@ A value of nil says to use the default GnuTLS value." (integer :tag "Number of bits" 512)) :group 'gnutls) -(defun open-gnutls-stream (name buffer host service) +(defun open-gnutls-stream (name buffer host service &optional nowait) "Open a SSL/TLS connection for a service to a host. Returns a subprocess-object to represent the connection. Input and output work as for subprocesses; `delete-process' closes it. @@ -109,6 +109,9 @@ BUFFER is the buffer (or `buffer-name') to associate with the process. Third arg is name of the host to connect to, or its IP address. Fourth arg SERVICE is name of the service desired, or an integer specifying a port number to connect to. +Fifth arg NOWAIT (which is optional) means that the socket should +be opened asynchronously. The connection process will be +returned to the caller before TLS negotiation has happened. Usage example: @@ -122,9 +125,20 @@ This is a very simple wrapper around `gnutls-negotiate'. See its documentation for the specific parameters you can use to open a GnuTLS connection, including specifying the credential type, trust and key files, and priority string." - (gnutls-negotiate :process (open-network-stream name buffer host service) - :type 'gnutls-x509pki - :hostname host)) + (let ((process (open-network-stream + name buffer host service + :nowait nowait + :tls-parameters + (and nowait + (cons 'gnutls-x509pki + (gnutls-boot-parameters + :type 'gnutls-x509pki + :hostname host)))))) + (if nowait + process + (gnutls-negotiate :process process + :type 'gnutls-x509pki + :hostname host)))) (define-error 'gnutls-error "GnuTLS error") @@ -140,10 +154,47 @@ trust and key files, and priority string." &allow-other-keys) "Negotiate a SSL/TLS connection. Returns proc. Signals gnutls-error. -Note arguments are passed CL style, :type TYPE instead of just TYPE. +Note that arguments are passed CL style, :type TYPE instead of just TYPE. -TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default. PROCESS is a process returned by `open-network-stream'. +For the meaning of the rest of the parameters, see `gnutls-boot-parameters'." + (let* ((type (or type 'gnutls-x509pki)) + ;; The gnutls library doesn't understand files delivered via + ;; the special handlers, so ignore all files found via those. + (file-name-handler-alist nil) + (params (gnutls-boot-parameters + :type type + :hostname hostname + :priority-string priority-string + :trustfiles trustfiles + :crlfiles crlfiles + :keylist keylist + :min-prime-bits min-prime-bits + :verify-flags verify-flags + :verify-error verify-error + :verify-hostname-error verify-hostname-error)) + ret) + (gnutls-message-maybe + (setq ret (gnutls-boot process type + (append (list :complete-negotiation t) + params))) + "boot: %s" params) + + (when (gnutls-errorp ret) + ;; This is a error from the underlying C code. + (signal 'gnutls-error (list process ret))) + + process)) + +(cl-defun gnutls-boot-parameters + (&rest spec + &key type hostname priority-string + trustfiles crlfiles keylist min-prime-bits + verify-flags verify-error verify-hostname-error + &allow-other-keys) + "Return a keyword list of parameters suitable for passing to `gnutls-boot'. + +TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default. HOSTNAME is the remote hostname. It must be a valid string. PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\". TRUSTFILES is a list of CA bundles. It defaults to `gnutls-trustfiles'. @@ -189,62 +240,47 @@ here's a recent version of the list. It must be omitted, a number, or nil; if omitted or nil it defaults to GNUTLS_VERIFY_ALLOW_X509_V1_CA_CRT." - (let* ((type (or type 'gnutls-x509pki)) - ;; The gnutls library doesn't understand files delivered via - ;; the special handlers, so ignore all files found via those. - (file-name-handler-alist nil) - (trustfiles (or trustfiles (gnutls-trustfiles))) - (priority-string (or priority-string - (cond - ((eq type 'gnutls-anon) - "NORMAL:+ANON-DH:!ARCFOUR-128") - ((eq type 'gnutls-x509pki) - (if gnutls-algorithm-priority - (upcase gnutls-algorithm-priority) - "NORMAL"))))) - (verify-error (or verify-error - ;; this uses the value of `gnutls-verify-error' - (cond - ;; if t, pass it on - ((eq gnutls-verify-error t) - t) - ;; if a list, look for hostname matches - ((listp gnutls-verify-error) - (apply 'append - (mapcar - (lambda (check) - (when (string-match (nth 0 check) - hostname) - (nth 1 check))) - gnutls-verify-error))) - ;; else it's nil - (t nil)))) - (min-prime-bits (or min-prime-bits gnutls-min-prime-bits)) - params ret) + (let ((trustfiles (or trustfiles (gnutls-trustfiles))) + (priority-string (or priority-string + (cond + ((eq type 'gnutls-anon) + "NORMAL:+ANON-DH:!ARCFOUR-128") + ((eq type 'gnutls-x509pki) + (if gnutls-algorithm-priority + (upcase gnutls-algorithm-priority) + "NORMAL"))))) + (verify-error (or verify-error + ;; this uses the value of `gnutls-verify-error' + (cond + ;; if t, pass it on + ((eq gnutls-verify-error t) + t) + ;; if a list, look for hostname matches + ((listp gnutls-verify-error) + (apply 'append + (mapcar + (lambda (check) + (when (string-match (nth 0 check) + hostname) + (nth 1 check))) + gnutls-verify-error))) + ;; else it's nil + (t nil)))) + (min-prime-bits (or min-prime-bits gnutls-min-prime-bits))) (when verify-hostname-error (push :hostname verify-error)) - (setq params `(:priority ,priority-string - :hostname ,hostname - :loglevel ,gnutls-log-level - :min-prime-bits ,min-prime-bits - :trustfiles ,trustfiles - :crlfiles ,crlfiles - :keylist ,keylist - :verify-flags ,verify-flags - :verify-error ,verify-error - :callbacks nil)) - - (gnutls-message-maybe - (setq ret (gnutls-boot process type params)) - "boot: %s" params) - - (when (gnutls-errorp ret) - ;; This is a error from the underlying C code. - (signal 'gnutls-error (list process ret))) - - process)) + `(:priority ,priority-string + :hostname ,hostname + :loglevel ,gnutls-log-level + :min-prime-bits ,min-prime-bits + :trustfiles ,trustfiles + :crlfiles ,crlfiles + :keylist ,keylist + :verify-flags ,verify-flags + :verify-error ,verify-error + :callbacks nil))) (defun gnutls-trustfiles () "Return a list of usable trustfiles." diff --git a/lisp/net/html2text.el b/lisp/net/html2text.el new file mode 100644 index 00000000000..2b1c2057bb4 --- /dev/null +++ b/lisp/net/html2text.el @@ -0,0 +1,461 @@ +;;; html2text.el --- a simple html to plain text converter -*- coding: utf-8 -*- + +;; Copyright (C) 2002-2016 Free Software Foundation, Inc. + +;; Author: Joakim Hove <hove@phys.ntnu.no> + +;; 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: + +;; These functions provide a simple way to wash/clean html infected +;; mails. Definitely do not work in all cases, but some improvement +;; in readability is generally obtained. Formatting is only done in +;; the buffer, so the next time you enter the article it will be +;; "re-htmlized". +;; +;; The main function is `html2text'. + +;;; Code: + +;; +;; <Global variables> +;; + +(eval-when-compile + (require 'cl)) + +(defvar html2text-format-single-element-list '(("hr" . html2text-clean-hr))) + +(defvar html2text-replace-list + '(("´" . "`") + ("&" . "&") + ("'" . "'") + ("¦" . "|") + ("¢" . "c") + ("ˆ" . "^") + ("©" . "(C)") + ("¤" . "(#)") + ("°" . "degree") + ("÷" . "/") + ("€" . "e") + ("½" . "1/2") + (">" . ">") + ("¿" . "?") + ("«" . "<<") + ("&ldquo" . "\"") + ("‹" . "(") + ("‘" . "`") + ("<" . "<") + ("—" . "--") + (" " . " ") + ("–" . "-") + ("‰" . "%%") + ("±" . "+-") + ("£" . "£") + (""" . "\"") + ("»" . ">>") + ("&rdquo" . "\"") + ("®" . "(R)") + ("›" . ")") + ("’" . "'") + ("§" . "§") + ("¹" . "^1") + ("²" . "^2") + ("³" . "^3") + ("˜" . "~")) + "The map of entity to text. + +This is an alist were each element is a dotted pair consisting of an +old string, and a replacement string. This replacement is done by the +function `html2text-substitute' which basically performs a +`replace-string' operation for every element in the list. This is +completely verbatim - without any use of REGEXP.") + +(defvar html2text-remove-tag-list + '("html" "body" "p" "img" "dir" "head" "div" "br" "font" "title" "meta") + "A list of removable tags. + +This is a list of tags which should be removed, without any +formatting. Note that tags in the list are presented *without* +any \"<\" or \">\". All occurrences of a tag appearing in this +list are removed, irrespective of whether it is a closing or +opening tag, or if the tag has additional attributes. The +deletion is done by the function `html2text-remove-tags'. + +For instance the text: + +\"Here comes something <font size\"+3\" face=\"Helvetica\"> big </font>.\" + +will be reduced to: + +\"Here comes something big.\" + +If this list contains the element \"font\".") + +(defvar html2text-format-tag-list + '(("b" . html2text-clean-bold) + ("strong" . html2text-clean-bold) + ("u" . html2text-clean-underline) + ("i" . html2text-clean-italic) + ("em" . html2text-clean-italic) + ("blockquote" . html2text-clean-blockquote) + ("a" . html2text-clean-anchor) + ("ul" . html2text-clean-ul) + ("ol" . html2text-clean-ol) + ("dl" . html2text-clean-dl) + ("center" . html2text-clean-center)) + "An alist of tags and processing functions. + +This is an alist where each dotted pair consists of a tag, and then +the name of a function to be called when this tag is found. The +function is called with the arguments p1, p2, p3 and p4. These are +demonstrated below: + +\"<b> This is bold text </b>\" + ^ ^ ^ ^ + | | | | +p1 p2 p3 p4 + +Then the called function will typically format the text somewhat and +remove the tags.") + +(defvar html2text-remove-tag-list2 '("li" "dt" "dd" "meta") + "Another list of removable tags. + +This is a list of tags which are removed similarly to the list +`html2text-remove-tag-list' - but these tags are retained for the +formatting, and then moved afterward.") + +;; +;; </Global variables> +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; <Utility functions> +;; + + +(defun html2text-replace-string (from-string to-string min max) + "Replace FROM-STRING with TO-STRING in region from MIN to MAX." + (goto-char min) + (let ((delta (- (string-width to-string) (string-width from-string))) + (change 0)) + (while (search-forward from-string max t) + (replace-match to-string) + (setq change (+ change delta))) + change)) + +;; +;; </Utility functions> +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; <Functions related to attributes> i.e. <font size=+3> +;; + +(defun html2text-attr-value (list attribute) + "Get value of ATTRIBUTE from LIST." + (nth 1 (assoc attribute list))) + +(defun html2text-get-attr (p1 p2) + (goto-char p1) + (re-search-forward "\\s-+" p2 t) + (let (attr-list) + (while (re-search-forward "[-a-z0-9._]+" p2 t) + (setq attr-list + (cons + (list (match-string 0) + (when (looking-at "\\s-*=") + (goto-char (match-end 0)) + (skip-chars-forward "[:space:]") + (when (or (looking-at "\"[^\"]*\"\\|'[^']*'") + (looking-at "[-a-z0-9._:]+")) + (goto-char (match-end 0)) + (match-string 0)))) + attr-list))) + attr-list)) + +;; +;; </Functions related to attributes> +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; <Functions to be called to format a tag-pair> +;; +(defun html2text-clean-list-items (p1 p2 list-type) + (goto-char p1) + (let ((item-nr 0) + (items 0)) + (while (search-forward "<li>" p2 t) + (setq items (1+ items))) + (goto-char p1) + (while (< item-nr items) + (setq item-nr (1+ item-nr)) + (search-forward "<li>" (point-max) t) + (cond + ((string= list-type "ul") (insert " o ")) + ((string= list-type "ol") (insert (format " %s: " item-nr))) + (t (insert " x ")))))) + +(defun html2text-clean-dtdd (p1 p2) + (goto-char p1) + (let ((items 0) + (item-nr 0)) + (while (search-forward "<dt>" p2 t) + (setq items (1+ items))) + (goto-char p1) + (while (< item-nr items) + (setq item-nr (1+ item-nr)) + (re-search-forward "<dt>\\([ ]*\\)" (point-max) t) + (when (match-string 1) + (delete-region (point) (- (point) (string-width (match-string 1))))) + (let ((def-p1 (point)) + (def-p2 0)) + (re-search-forward "\\([ ]*\\)\\(</dt>\\|<dd>\\)" (point-max) t) + (if (match-string 1) + (progn + (let* ((mw1 (string-width (match-string 1))) + (mw2 (string-width (match-string 2))) + (mw (+ mw1 mw2))) + (goto-char (- (point) mw)) + (delete-region (point) (+ (point) mw1)) + (setq def-p2 (point)))) + (setq def-p2 (- (point) (string-width (match-string 2))))) + (put-text-property def-p1 def-p2 'face 'bold))))) + +(defun html2text-delete-tags (p1 p2 p3 p4) + (delete-region p1 p2) + (delete-region (- p3 (- p2 p1)) (- p4 (- p2 p1)))) + +(defun html2text-delete-single-tag (p1 p2) + (delete-region p1 p2)) + +(defun html2text-clean-hr (p1 p2) + (html2text-delete-single-tag p1 p2) + (goto-char p1) + (newline 1) + (insert (make-string fill-column ?-))) + +(defun html2text-clean-ul (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ul")) + +(defun html2text-clean-ol (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (html2text-clean-list-items p1 (- p3 (- p1 p2)) "ol")) + +(defun html2text-clean-dl (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (html2text-clean-dtdd p1 (- p3 (- p1 p2)))) + +(defun html2text-clean-center (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4) + (center-region p1 (- p3 (- p2 p1)))) + +(defun html2text-clean-bold (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'bold) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-title (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'bold) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-underline (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'underline) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-italic (p1 p2 p3 p4) + (put-text-property p2 p3 'face 'italic) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-font (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-blockquote (p1 p2 p3 p4) + (html2text-delete-tags p1 p2 p3 p4)) + +(defun html2text-clean-anchor (p1 p2 p3 p4) + ;; If someone can explain how to make the URL clickable I will surely + ;; improve upon this. + ;; Maybe `goto-addr.el' can be used here. + (let* ((attr-list (html2text-get-attr p1 p2)) + (href (html2text-attr-value attr-list "href"))) + (delete-region p1 p4) + (when href + (goto-char p1) + (insert (if (string-match "\\`['\"].*['\"]\\'" href) + (substring href 1 -1) href)) + (put-text-property p1 (point) 'face 'bold)))) + +;; +;; </Functions to be called to format a tag-pair> +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; <Functions to be called to fix up paragraphs> +;; + +(defun html2text-fix-paragraph (p1 p2) + (goto-char p1) + (let ((refill-start) + (refill-stop)) + (when (re-search-forward "<br>$" p2 t) + (goto-char p1) + (when (re-search-forward ".+[^<][^b][^r][^>]$" p2 t) + (beginning-of-line) + (setq refill-start (point)) + (goto-char p2) + (re-search-backward ".+[^<][^b][^r][^>]$" refill-start t) + (forward-line 1) + (end-of-line) + ;; refill-stop should ideally be adjusted to + ;; accommodate the "<br>" strings which are removed + ;; between refill-start and refill-stop. Can simply + ;; be returned from my-replace-string + (setq refill-stop (+ (point) + (html2text-replace-string + "<br>" "" + refill-start (point)))) + ;; (message "Point = %s refill-stop = %s" (point) refill-stop) + ;; (sleep-for 4) + (fill-region refill-start refill-stop)))) + (html2text-replace-string "<br>" "" p1 p2)) + +;; +;; This one is interactive ... +;; +(defun html2text-fix-paragraphs () + "This _tries_ to fix up the paragraphs - this is done in quite a ad-hook +fashion, quite close to pure guess-work. It does work in some cases though." + (interactive) + (goto-char (point-min)) + (while (re-search-forward "^<br>$" nil t) + (delete-region (match-beginning 0) (match-end 0))) + ;; Removing lonely <br> on a single line, if they are left intact we + ;; don't have any paragraphs at all. + (goto-char (point-min)) + (while (not (eobp)) + (let ((p1 (point))) + (forward-paragraph 1) + ;;(message "Kaller fix med p1=%s p2=%s " p1 (1- (point))) (sleep-for 5) + (html2text-fix-paragraph p1 (1- (point))) + (goto-char p1) + (when (not (eobp)) + (forward-paragraph 1))))) + +;; +;; </Functions to be called to fix up paragraphs> +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; +;; <Interactive functions> +;; + +(defun html2text-remove-tags (tag-list) + "Removes the tags listed in the list `html2text-remove-tag-list'. +See the documentation for that variable." + (interactive) + (dolist (tag tag-list) + (goto-char (point-min)) + (while (re-search-forward (format "\\(</?%s[^>]*>\\)" tag) (point-max) t) + (delete-region (match-beginning 0) (match-end 0))))) + +(defun html2text-format-tags () + "See the variable `html2text-format-tag-list' for documentation." + (interactive) + (dolist (tag-and-function html2text-format-tag-list) + (let ((tag (car tag-and-function)) + (function (cdr tag-and-function))) + (goto-char (point-min)) + (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) + (point-max) t) + (let ((p1) + (p2 (point)) + (p3) (p4)) + (search-backward "<" (point-min) t) + (setq p1 (point)) + (unless (search-forward (format "</%s>" tag) (point-max) t) + (goto-char p2) + (insert (format "</%s>" tag))) + (setq p4 (point)) + (search-backward "</" (point-min) t) + (setq p3 (point)) + (funcall function p1 p2 p3 p4) + (goto-char p1)))))) + +(defun html2text-substitute () + "See the variable `html2text-replace-list' for documentation." + (interactive) + (dolist (e html2text-replace-list) + (goto-char (point-min)) + (let ((old-string (car e)) + (new-string (cdr e))) + (html2text-replace-string old-string new-string (point-min) (point-max))))) + +(defun html2text-format-single-elements () + (interactive) + (dolist (tag-and-function html2text-format-single-element-list) + (let ((tag (car tag-and-function)) + (function (cdr tag-and-function))) + (goto-char (point-min)) + (while (re-search-forward (format "\\(<%s\\( [^>]*\\)?>\\)" tag) + (point-max) t) + (let ((p1) + (p2 (point))) + (search-backward "<" (point-min) t) + (setq p1 (point)) + (funcall function p1 p2)))))) + +;; +;; Main function +;; + +;;;###autoload +(defun html2text () + "Convert HTML to plain text in the current buffer." + (interactive) + (save-excursion + (let ((case-fold-search t) + (buffer-read-only)) + (html2text-remove-tags html2text-remove-tag-list) + (html2text-format-tags) + (html2text-remove-tags html2text-remove-tag-list2) + (html2text-substitute) + (html2text-format-single-elements) + (html2text-fix-paragraphs)))) + +;; +;; </Interactive functions> +;; +(provide 'html2text) + +;;; html2text.el ends here diff --git a/lisp/net/mailcap.el b/lisp/net/mailcap.el new file mode 100644 index 00000000000..ae49972f5bf --- /dev/null +++ b/lisp/net/mailcap.el @@ -0,0 +1,1127 @@ +;;; mailcap.el --- MIME media types configuration + +;; Copyright (C) 1998-2016 Free Software Foundation, Inc. + +;; Author: William M. Perry <wmperry@aventail.com> +;; Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: news, mail, multimedia + +;; 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: + +;; Provides configuration of MIME media types from directly from Lisp +;; and via the usual mailcap mechanism (RFC 1524). Deals with +;; mime.types similarly. + +;;; Code: + +(eval-when-compile (require 'cl)) +(autoload 'mail-header-parse-content-type "mail-parse") + +(defgroup mailcap nil + "Definition of viewers for MIME types." + :version "21.1" + :group 'mime) + +(defvar mailcap-parse-args-syntax-table + (let ((table (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?' "\"" table) + (modify-syntax-entry ?` "\"" table) + (modify-syntax-entry ?{ "(" table) + (modify-syntax-entry ?} ")" table) + table) + "A syntax table for parsing SGML attributes.") + +(defvar mailcap-print-command + (mapconcat 'identity + (cons (if (boundp 'lpr-command) + lpr-command + "lpr") + (when (boundp 'lpr-switches) + (if (stringp lpr-switches) + (list lpr-switches) + lpr-switches))) + " ") + "Shell command (including switches) used to print PostScript files.") + +(defun mailcap--get-user-mime-data (sym) + (let ((val (default-value sym)) + res) + (dolist (entry val) + (setq res (cons (list (cdr (assq 'viewer entry)) + (cdr (assq 'type entry)) + (cdr (assq 'test entry))) + res))) + (nreverse res))) + +(defun mailcap--set-user-mime-data (sym val) + (let (res) + (dolist (entry val) + (setq res (cons `((viewer . ,(car entry)) + (type . ,(cadr entry)) + ,@(when (caddr entry) + `((test . ,(caddr entry))))) + res))) + (set-default sym (nreverse res)))) + +(defcustom mailcap-user-mime-data nil + "A list of viewers preferred for different MIME types. +The elements of the list are alists of the following structure + + ((viewer . VIEWER) + (type . MIME-TYPE) + (test . TEST)) + +where VIEWER is either a lisp command, e.g., a major-mode, or a +string containing a shell command for viewing files of the +defined MIME-TYPE. In case of a shell command, %s will be +replaced with the file. + +MIME-TYPE is a regular expression being matched against the +actual MIME type. It is implicitly surrounded with ^ and $. + +TEST is an lisp form which is evaluated in order to test if the +entry should be chosen. The `test' entry is optional. + +When selecting a viewer for a given MIME type, the first viewer +in this list with a matching MIME-TYPE and successful TEST is +selected. Only if none matches, the standard `mailcap-mime-data' +is consulted." + :type '(repeat + (list + (choice (function :tag "Function or mode") + (string :tag "Shell command")) + (regexp :tag "MIME Type") + (sexp :tag "Test (optional)"))) + :get #'mailcap--get-user-mime-data + :set #'mailcap--set-user-mime-data + :group 'mailcap) + +;; Postpone using defcustom for this as it's so big and we essentially +;; have to have two copies of the data around then. Perhaps just +;; customize the Lisp viewers and rely on the normal configuration +;; files for the rest? -- fx +(defvar mailcap-mime-data + `(("application" + ("vnd\\.ms-excel" + (viewer . "gnumeric %s") + (test . (getenv "DISPLAY")) + (type . "application/vnd.ms-excel")) + ("x-x509-ca-cert" + (viewer . ssl-view-site-cert) + (type . "application/x-x509-ca-cert")) + ("x-x509-user-cert" + (viewer . ssl-view-user-cert) + (type . "application/x-x509-user-cert")) + ("octet-stream" + (viewer . mailcap-save-binary-file) + (non-viewer . t) + (type . "application/octet-stream")) + ("dvi" + (viewer . "xdvi -safer %s") + (test . (eq window-system 'x)) + ("needsx11") + (type . "application/dvi") + ("print" . "dvips -qRP %s")) + ("dvi" + (viewer . "dvitty %s") + (test . (not (getenv "DISPLAY"))) + (type . "application/dvi") + ("print" . "dvips -qRP %s")) + ("emacs-lisp" + (viewer . mailcap-maybe-eval) + (type . "application/emacs-lisp")) + ("x-emacs-lisp" + (viewer . mailcap-maybe-eval) + (type . "application/x-emacs-lisp")) + ("x-tar" + (viewer . mailcap-save-binary-file) + (non-viewer . t) + (type . "application/x-tar")) + ("x-latex" + (viewer . tex-mode) + (type . "application/x-latex")) + ("x-tex" + (viewer . tex-mode) + (type . "application/x-tex")) + ("latex" + (viewer . tex-mode) + (type . "application/latex")) + ("tex" + (viewer . tex-mode) + (type . "application/tex")) + ("texinfo" + (viewer . texinfo-mode) + (type . "application/tex")) + ("zip" + (viewer . mailcap-save-binary-file) + (non-viewer . t) + (type . "application/zip") + ("copiousoutput")) + ("pdf" + (viewer . pdf-view-mode) + (type . "application/pdf") + (test . (eq window-system 'x))) + ("pdf" + (viewer . doc-view-mode) + (type . "application/pdf") + (test . (eq window-system 'x))) + ("pdf" + (viewer . "gv -safer %s") + (type . "application/pdf") + (test . window-system) + ("print" . ,(concat "pdf2ps %s - | " mailcap-print-command))) + ("pdf" + (viewer . "gpdf %s") + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + (test . (eq window-system 'x))) + ("pdf" + (viewer . "xpdf %s") + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + (test . (eq window-system 'x))) + ("pdf" + (viewer . ,(concat "pdftotext %s -")) + (type . "application/pdf") + ("print" . ,(concat "pdftops %s - | " mailcap-print-command)) + ("copiousoutput")) + ("postscript" + (viewer . "gv -safer %s") + (type . "application/postscript") + (test . window-system) + ("print" . ,(concat mailcap-print-command " %s")) + ("needsx11")) + ("postscript" + (viewer . "ghostview -dSAFER %s") + (type . "application/postscript") + (test . (eq window-system 'x)) + ("print" . ,(concat mailcap-print-command " %s")) + ("needsx11")) + ("postscript" + (viewer . "ps2ascii %s") + (type . "application/postscript") + (test . (not (getenv "DISPLAY"))) + ("print" . ,(concat mailcap-print-command " %s")) + ("copiousoutput")) + ("sieve" + (viewer . sieve-mode) + (type . "application/sieve")) + ("pgp-keys" + (viewer . "gpg --import --interactive --verbose") + (type . "application/pgp-keys") + ("needsterminal"))) + ("audio" + ("x-mpeg" + (viewer . "maplay %s") + (type . "audio/x-mpeg")) + (".*" + (viewer . "showaudio") + (type . "audio/*"))) + ("message" + ("rfc-*822" + (viewer . mm-view-message) + (test . (and (featurep 'gnus) + (gnus-alive-p))) + (type . "message/rfc822")) + ("rfc-*822" + (viewer . vm-mode) + (type . "message/rfc822")) + ("rfc-*822" + (viewer . view-mode) + (type . "message/rfc822"))) + ("image" + ("x-xwd" + (viewer . "xwud -in %s") + (type . "image/x-xwd") + ("compose" . "xwd -frame > %s") + (test . (eq window-system 'x)) + ("needsx11")) + ("x11-dump" + (viewer . "xwud -in %s") + (type . "image/x-xwd") + ("compose" . "xwd -frame > %s") + (test . (eq window-system 'x)) + ("needsx11")) + ("windowdump" + (viewer . "xwud -in %s") + (type . "image/x-xwd") + ("compose" . "xwd -frame > %s") + (test . (eq window-system 'x)) + ("needsx11")) + (".*" + (viewer . "display %s") + (type . "image/*") + (test . (eq window-system 'x)) + ("needsx11")) + (".*" + (viewer . "ee %s") + (type . "image/*") + (test . (eq window-system 'x)) + ("needsx11"))) + ("text" + ("plain" + (viewer . view-mode) + (type . "text/plain")) + ("plain" + (viewer . fundamental-mode) + (type . "text/plain")) + ("enriched" + (viewer . enriched-decode) + (type . "text/enriched")) + ("dns" + (viewer . dns-mode) + (type . "text/dns"))) + ("video" + ("mpeg" + (viewer . "mpeg_play %s") + (type . "video/mpeg") + (test . (eq window-system 'x)) + ("needsx11"))) + ("x-world" + ("x-vrml" + (viewer . "webspace -remote %s -URL %u") + (type . "x-world/x-vrml") + ("description" + "VRML document"))) + ("archive" + ("tar" + (viewer . tar-mode) + (type . "archive/tar")))) + "The mailcap structure is an assoc list of assoc lists. +1st assoc list is keyed on the major content-type +2nd assoc list is keyed on the minor content-type (which can be a regexp) + +Which looks like: +----------------- + ((\"application\" + (\"postscript\" . <info>)) + (\"text\" + (\"plain\" . <info>))) + +Where <info> is another assoc list of the various information +related to the mailcap RFC 1524. This is keyed on the lowercase +attribute name (viewer, test, etc). This looks like: + ((viewer . VIEWERINFO) + (test . TESTINFO) + (xxxx . \"STRING\") + FLAG) + +Where VIEWERINFO specifies how the content-type is viewed. Can be +a string, in which case it is run through a shell, with appropriate +parameters, or a symbol, in which case the symbol is `funcall'ed if +and only if it exists as a function, with the buffer as an argument. + +TESTINFO is a test for the viewer's applicability, or nil. If nil, it +means the viewer is always valid. If it is a Lisp function, it is +called with a list of items from any extra fields from the +Content-Type header as argument to return a boolean value for the +validity. Otherwise, if it is a non-function Lisp symbol or list +whose car is a symbol, it is `eval'led to yield the validity. If it +is a string or list of strings, it represents a shell command to run +to return a true or false shell value for the validity.") +(put 'mailcap-mime-data 'risky-local-variable t) + +(defcustom mailcap-download-directory nil + "*Directory to which `mailcap-save-binary-file' downloads files by default. +nil means your home directory." + :type '(choice (const :tag "Home directory" nil) + directory) + :group 'mailcap) + +(defvar mailcap-poor-system-types + '(ms-dos windows-nt) + "Systems that don't have a Unix-like directory hierarchy.") + +;;; +;;; Utility functions +;;; + +(defun mailcap-save-binary-file () + (goto-char (point-min)) + (unwind-protect + (let ((file (read-file-name + "Filename to save as: " + (or mailcap-download-directory "~/"))) + (require-final-newline nil)) + (write-region (point-min) (point-max) file)) + (kill-buffer (current-buffer)))) + +(defvar mailcap-maybe-eval-warning + "*** WARNING *** + +This MIME part contains untrusted and possibly harmful content. +If you evaluate the Emacs Lisp code contained in it, a lot of nasty +things can happen. Please examine the code very carefully before you +instruct Emacs to evaluate it. You can browse the buffer containing +the code using \\[scroll-other-window]. + +If you are unsure what to do, please answer \"no\"." + "Text of warning message displayed by `mailcap-maybe-eval'. +Make sure that this text consists only of few text lines. Otherwise, +Gnus might fail to display all of it.") + +(defun mailcap-maybe-eval () + "Maybe evaluate a buffer of Emacs Lisp code." + (let ((lisp-buffer (current-buffer))) + (goto-char (point-min)) + (when + (save-window-excursion + (delete-other-windows) + (let ((buffer (get-buffer-create (generate-new-buffer-name + "*Warning*")))) + (unwind-protect + (with-current-buffer buffer + (insert (substitute-command-keys + mailcap-maybe-eval-warning)) + (goto-char (point-min)) + (display-buffer buffer) + (yes-or-no-p "This is potentially dangerous emacs-lisp code, evaluate it? ")) + (kill-buffer buffer)))) + (eval-buffer (current-buffer))) + (when (buffer-live-p lisp-buffer) + (with-current-buffer lisp-buffer + (emacs-lisp-mode))))) + + +;;; +;;; The mailcap parser +;;; + +(defun mailcap-replace-regexp (regexp to-string) + ;; Quiet replace-regexp. + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (replace-match to-string t nil))) + +(defvar mailcap-parsed-p nil) + +(defun mailcap-parse-mailcaps (&optional path force) + "Parse out all the mailcaps specified in a path string PATH. +Components of PATH are separated by the `path-separator' character +appropriate for this system. If FORCE, re-parse even if already +parsed. If PATH is omitted, use the value of environment variable +MAILCAPS if set; otherwise (on Unix) use the path from RFC 1524, plus +/usr/local/etc/mailcap." + (interactive (list nil t)) + (when (or (not mailcap-parsed-p) + force) + (cond + (path nil) + ((getenv "MAILCAPS") (setq path (getenv "MAILCAPS"))) + ((memq system-type mailcap-poor-system-types) + (setq path '("~/.mailcap" "~/mail.cap" "~/etc/mail.cap"))) + (t (setq path + ;; This is per RFC 1524, specifically + ;; with /usr before /usr/local. + '("~/.mailcap" "/etc/mailcap" "/usr/etc/mailcap" + "/usr/local/etc/mailcap")))) + (let ((fnames (reverse + (if (stringp path) + (split-string path path-separator t) + path))) + fname) + (while fnames + (setq fname (car fnames)) + (if (and (file-readable-p fname) + (file-regular-p fname)) + (mailcap-parse-mailcap fname)) + (setq fnames (cdr fnames)))) + (setq mailcap-parsed-p t))) + +(defun mailcap-parse-mailcap (fname) + "Parse out the mailcap file specified by FNAME." + (let (major ; The major mime type (image/audio/etc) + minor ; The minor mime type (gif, basic, etc) + save-pos ; Misc saved positions used in parsing + viewer ; How to view this mime type + info ; Misc info about this mime type + ) + (with-temp-buffer + (insert-file-contents fname) + (set-syntax-table mailcap-parse-args-syntax-table) + (mailcap-replace-regexp "#.*" "") ; Remove all comments + (mailcap-replace-regexp "\\\\[ \t]*\n" " ") ; And collapse spaces + (mailcap-replace-regexp "\n+" "\n") ; And blank lines + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (delete-region (point) (point-max)) + (while (not (bobp)) + (skip-chars-backward " \t\n") + (beginning-of-line) + (setq save-pos (point) + info nil) + (skip-chars-forward "^/; \t\n") + (downcase-region save-pos (point)) + (setq major (buffer-substring save-pos (point))) + (skip-chars-forward " \t") + (setq minor "") + (when (eq (char-after) ?/) + (forward-char) + (skip-chars-forward " \t") + (setq save-pos (point)) + (skip-chars-forward "^; \t\n") + (downcase-region save-pos (point)) + (setq minor + (cond + ((eq ?* (or (char-after save-pos) 0)) ".*") + ((= (point) save-pos) ".*") + (t (regexp-quote (buffer-substring save-pos (point))))))) + (skip-chars-forward " \t") + ;;; Got the major/minor chunks, now for the viewers/etc + ;;; The first item _must_ be a viewer, according to the + ;;; RFC for mailcap files (#1524) + (setq viewer "") + (when (eq (char-after) ?\;) + (forward-char) + (skip-chars-forward " \t") + (setq save-pos (point)) + (skip-chars-forward "^;\n") + ;; skip \; + (while (eq (char-before) ?\\) + (backward-delete-char 1) + (forward-char) + (skip-chars-forward "^;\n")) + (if (eq (or (char-after save-pos) 0) ?') + (setq viewer (progn + (narrow-to-region (1+ save-pos) (point)) + (goto-char (point-min)) + (prog1 + (read (current-buffer)) + (goto-char (point-max)) + (widen)))) + (setq viewer (buffer-substring save-pos (point))))) + (setq save-pos (point)) + (end-of-line) + (unless (equal viewer "") + (setq info (nconc (list (cons 'viewer viewer) + (cons 'type (concat major "/" + (if (string= minor ".*") + "*" minor)))) + (mailcap-parse-mailcap-extras save-pos (point)))) + (mailcap-mailcap-entry-passes-test info) + (mailcap-add-mailcap-entry major minor info)) + (beginning-of-line))))) + +(defun mailcap-parse-mailcap-extras (st nd) + "Grab all the extra stuff from a mailcap entry." + (let ( + name ; From name= + value ; its value + results ; Assoc list of results + name-pos ; Start of XXXX= position + val-pos ; Start of value position + done ; Found end of \'d ;s? + ) + (save-restriction + (narrow-to-region st nd) + (goto-char (point-min)) + (skip-chars-forward " \n\t;") + (while (not (eobp)) + (setq done nil) + (setq name-pos (point)) + (skip-chars-forward "^ \n\t=;") + (downcase-region name-pos (point)) + (setq name (buffer-substring name-pos (point))) + (skip-chars-forward " \t\n") + (if (not (eq (char-after (point)) ?=)) ; There is no value + (setq value t) + (skip-chars-forward " \t\n=") + (setq val-pos (point)) + (if (memq (char-after val-pos) '(?\" ?')) + (progn + (setq val-pos (1+ val-pos)) + (condition-case nil + (progn + (forward-sexp 1) + (backward-char 1)) + (error (goto-char (point-max))))) + (while (not done) + (skip-chars-forward "^;") + (if (eq (char-after (1- (point))) ?\\ ) + (progn + (subst-char-in-region (1- (point)) (point) ?\\ ? ) + (skip-chars-forward ";")) + (setq done t)))) + (setq value (buffer-substring val-pos (point)))) + ;; `test' as symbol, others like "copiousoutput" and "needsx11" as + ;; strings + (setq results (cons (cons (if (string-equal name "test") + 'test + name) + value) results)) + (skip-chars-forward " \";\n\t")) + results))) + +(defun mailcap-mailcap-entry-passes-test (info) + "Replace the test clause of INFO itself with a boolean for some cases. +This function supports only `test -n $DISPLAY' and `test -z $DISPLAY', +replaces them with t or nil. As for others or if INFO has a interactive +spec (needsterm, needsterminal, or needsx11) but DISPLAY is not set, +the test clause will be unchanged." + (let ((test (assq 'test info)) ; The test clause + status) + (setq status (and test (split-string (cdr test) " "))) + (if (and (or (assoc "needsterm" info) + (assoc "needsterminal" info) + (assoc "needsx11" info)) + (not (getenv "DISPLAY"))) + (setq status nil) + (cond + ((and (equal (nth 0 status) "test") + (equal (nth 1 status) "-n") + (or (equal (nth 2 status) "$DISPLAY") + (equal (nth 2 status) "\"$DISPLAY\""))) + (setq status (if (getenv "DISPLAY") t nil))) + ((and (equal (nth 0 status) "test") + (equal (nth 1 status) "-z") + (or (equal (nth 2 status) "$DISPLAY") + (equal (nth 2 status) "\"$DISPLAY\""))) + (setq status (if (getenv "DISPLAY") nil t))) + (test nil) + (t nil))) + (and test (listp test) (setcdr test status)))) + +;;; +;;; The action routines. +;;; + +(defun mailcap-possible-viewers (major minor) + "Return a list of possible viewers from MAJOR for minor type MINOR." + (let ((exact '()) + (wildcard '())) + (while major + (cond + ((equal (car (car major)) minor) + (setq exact (cons (cdr (car major)) exact))) + ((and minor (string-match (concat "^" (car (car major)) "$") minor)) + (setq wildcard (cons (cdr (car major)) wildcard)))) + (setq major (cdr major))) + (nconc exact wildcard))) + +(defun mailcap-unescape-mime-test (test type-info) + (let (save-pos save-chr subst) + (cond + ((symbolp test) test) + ((and (listp test) (symbolp (car test))) test) + ((or (stringp test) + (and (listp test) (stringp (car test)) + (setq test (mapconcat 'identity test " ")))) + (with-temp-buffer + (insert test) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward "^%") + (if (/= (- (point) + (progn (skip-chars-backward "\\\\") + (point))) + 0) ; It is an escaped % + (progn + (delete-char 1) + (skip-chars-forward "%.")) + (setq save-pos (point)) + (skip-chars-forward "%") + (setq save-chr (char-after (point))) + ;; Escapes: + ;; %s: name of a file for the body data + ;; %t: content-type + ;; %{<parameter name}: value of parameter in mailcap entry + ;; %n: number of sub-parts for multipart content-type + ;; %F: a set of content-type/filename pairs for multiparts + (cond + ((null save-chr) nil) + ((= save-chr ?t) + (delete-region save-pos (progn (forward-char 1) (point))) + (insert (or (cdr (assq 'type type-info)) "\"\""))) + ((memq save-chr '(?M ?n ?F)) + (delete-region save-pos (progn (forward-char 1) (point))) + (insert "\"\"")) + ((= save-chr ?{) + (forward-char 1) + (skip-chars-forward "^}") + (downcase-region (+ 2 save-pos) (point)) + (setq subst (buffer-substring (+ 2 save-pos) (point))) + (delete-region save-pos (1+ (point))) + (insert (or (cdr (assoc subst type-info)) "\"\""))) + (t nil)))) + (buffer-string))) + (t (error "Bad value to mailcap-unescape-mime-test: %s" test))))) + +(defvar mailcap-viewer-test-cache nil) + +(defun mailcap-viewer-passes-test (viewer-info type-info) + "Return non-nil if viewer specified by VIEWER-INFO passes its test clause. +Also return non-nil if it has no test clause. TYPE-INFO is an argument +to supply to the test." + (let* ((test-info (assq 'test viewer-info)) + (test (cdr test-info)) + (otest test) + (viewer (cdr (assq 'viewer viewer-info))) + (default-directory (expand-file-name "~/")) + status parsed-test cache result) + (cond ((not (or (stringp viewer) (fboundp viewer))) + nil) ; Non-existent Lisp function + ((setq cache (assoc test mailcap-viewer-test-cache)) + (cadr cache)) + ((not test-info) t) ; No test clause + (t + (setq + result + (cond + ((not test) nil) ; Already failed test + ((eq test t) t) ; Already passed test + ((functionp test) ; Lisp function as test + (funcall test type-info)) + ((and (symbolp test) ; Lisp variable as test + (boundp test)) + (symbol-value test)) + ((and (listp test) ; List to be eval'd + (symbolp (car test))) + (eval test)) + (t + (setq test (mailcap-unescape-mime-test test type-info) + test (list shell-file-name nil nil nil + shell-command-switch test) + status (apply 'call-process test)) + (eq 0 status)))) + (push (list otest result) mailcap-viewer-test-cache) + result)))) + +(defun mailcap-add-mailcap-entry (major minor info) + (let ((old-major (assoc major mailcap-mime-data))) + (if (null old-major) ; New major area + (setq mailcap-mime-data + (cons (cons major (list (cons minor info))) + mailcap-mime-data)) + (let ((cur-minor (assoc minor old-major))) + (cond + ((or (null cur-minor) ; New minor area, or + (assq 'test info)) ; Has a test, insert at beginning + (setcdr old-major (cons (cons minor info) (cdr old-major)))) + ((and (not (assq 'test info)) ; No test info, replace completely + (not (assq 'test cur-minor)) + (equal (assq 'viewer info) ; Keep alternative viewer + (assq 'viewer cur-minor))) + (setcdr cur-minor info)) + (t + (setcdr old-major (cons (cons minor info) (cdr old-major)))))) + ))) + +(defun mailcap-add (type viewer &optional test) + "Add VIEWER as a handler for TYPE. +If TEST is not given, it defaults to t." + (let ((tl (split-string type "/"))) + (when (or (not (car tl)) + (not (cadr tl))) + (error "%s is not a valid MIME type" type)) + (mailcap-add-mailcap-entry + (car tl) (cadr tl) + `((viewer . ,viewer) + (test . ,(if test test t)) + (type . ,type))))) + +;;; +;;; The main whabbo +;;; + +(defun mailcap-viewer-lessp (x y) + "Return t if viewer X is more desirable than viewer Y." + (let ((x-wild (string-match "[*?]" (or (cdr-safe (assq 'type x)) ""))) + (y-wild (string-match "[*?]" (or (cdr-safe (assq 'type y)) ""))) + (x-lisp (not (stringp (or (cdr-safe (assq 'viewer x)) "")))) + (y-lisp (not (stringp (or (cdr-safe (assq 'viewer y)) ""))))) + (cond + ((and x-wild (not y-wild)) + nil) + ((and (not x-wild) y-wild) + t) + ((and (not y-lisp) x-lisp) + t) + (t nil)))) + +(defun mailcap-select-preferred-viewer (type-info) + "Return an applicable viewer entry from `mailcap-user-mime-data'." + (let ((info (mapcar (lambda (a) (cons (symbol-name (car a)) + (cdr a))) + (cdr type-info))) + viewer) + (dolist (entry mailcap-user-mime-data) + (when (and (null viewer) + (string-match (concat "^" (cdr (assq 'type entry)) "$") + (car type-info)) + (mailcap-viewer-passes-test entry info)) + (setq viewer entry))) + viewer)) + +(defun mailcap-mime-info (string &optional request no-decode) + "Get the MIME viewer command for STRING, return nil if none found. +Expects a complete content-type header line as its argument. + +Second argument REQUEST specifies what information to return. If it is +nil or the empty string, the viewer (second field of the mailcap +entry) will be returned. If it is a string, then the mailcap field +corresponding to that string will be returned (print, description, +whatever). If a number, then all the information for this specific +viewer is returned. If `all', then all possible viewers for +this type is returned. + +If NO-DECODE is non-nil, don't decode STRING." + ;; NO-DECODE avoids calling `mail-header-parse-content-type' from + ;; `mail-parse.el' + (let ( + major ; Major encoding (text, etc) + minor ; Minor encoding (html, etc) + info ; Other info + save-pos ; Misc. position during parse + major-info ; (assoc major mailcap-mime-data) + minor-info ; (assoc minor major-info) + test ; current test proc. + viewers ; Possible viewers + passed ; Viewers that passed the test + viewer ; The one and only viewer + ctl) + (save-excursion + (setq ctl + (if no-decode + (list (or string "text/plain")) + (mail-header-parse-content-type (or string "text/plain")))) + ;; Check if there's a user-defined viewer from `mailcap-user-mime-data'. + (setq viewer (mailcap-select-preferred-viewer ctl)) + (if viewer + (setq passed (list viewer)) + ;; None found, so heuristically select some applicable viewer + ;; from `mailcap-mime-data'. + (setq major (split-string (car ctl) "/")) + (setq minor (cadr major) + major (car major)) + (when (setq major-info (cdr (assoc major mailcap-mime-data))) + (when (setq viewers (mailcap-possible-viewers major-info minor)) + (setq info (mapcar (lambda (a) (cons (symbol-name (car a)) + (cdr a))) + (cdr ctl))) + (while viewers + (if (mailcap-viewer-passes-test (car viewers) info) + (setq passed (cons (car viewers) passed))) + (setq viewers (cdr viewers))) + (setq passed (sort passed 'mailcap-viewer-lessp)) + (setq viewer (car passed)))) + (when (and (stringp (cdr (assq 'viewer viewer))) + passed) + (setq viewer (car passed)))) + (cond + ((and (null viewer) (not (equal major "default")) request) + (mailcap-mime-info "default" request no-decode)) + ((or (null request) (equal request "")) + (mailcap-unescape-mime-test (cdr (assq 'viewer viewer)) info)) + ((stringp request) + (mailcap-unescape-mime-test + (cdr-safe (assoc request viewer)) info)) + ((eq request 'all) + passed) + (t + ;; MUST make a copy *sigh*, else we modify mailcap-mime-data + (setq viewer (copy-sequence viewer)) + (let ((view (assq 'viewer viewer)) + (test (assq 'test viewer))) + (if view (setcdr view (mailcap-unescape-mime-test (cdr view) info))) + (if test (setcdr test (mailcap-unescape-mime-test (cdr test) info)))) + viewer))))) + +;;; +;;; Experimental MIME-types parsing +;;; + +(defvar mailcap-mime-extensions + '(("" . "text/plain") + (".1" . "text/plain") ;; Manual pages + (".3" . "text/plain") + (".8" . "text/plain") + (".abs" . "audio/x-mpeg") + (".aif" . "audio/aiff") + (".aifc" . "audio/aiff") + (".aiff" . "audio/aiff") + (".ano" . "application/x-annotator") + (".au" . "audio/ulaw") + (".avi" . "video/x-msvideo") + (".bcpio" . "application/x-bcpio") + (".bin" . "application/octet-stream") + (".cdf" . "application/x-netcdr") + (".cpio" . "application/x-cpio") + (".csh" . "application/x-csh") + (".css" . "text/css") + (".dvi" . "application/x-dvi") + (".diff" . "text/x-patch") + (".dpatch". "test/x-patch") + (".el" . "application/emacs-lisp") + (".eps" . "application/postscript") + (".etx" . "text/x-setext") + (".exe" . "application/octet-stream") + (".fax" . "image/x-fax") + (".gif" . "image/gif") + (".hdf" . "application/x-hdf") + (".hqx" . "application/mac-binhex40") + (".htm" . "text/html") + (".html" . "text/html") + (".icon" . "image/x-icon") + (".ief" . "image/ief") + (".jpg" . "image/jpeg") + (".macp" . "image/x-macpaint") + (".man" . "application/x-troff-man") + (".me" . "application/x-troff-me") + (".mif" . "application/mif") + (".mov" . "video/quicktime") + (".movie" . "video/x-sgi-movie") + (".mp2" . "audio/x-mpeg") + (".mp3" . "audio/x-mpeg") + (".mp2a" . "audio/x-mpeg2") + (".mpa" . "audio/x-mpeg") + (".mpa2" . "audio/x-mpeg2") + (".mpe" . "video/mpeg") + (".mpeg" . "video/mpeg") + (".mpega" . "audio/x-mpeg") + (".mpegv" . "video/mpeg") + (".mpg" . "video/mpeg") + (".mpv" . "video/mpeg") + (".ms" . "application/x-troff-ms") + (".nc" . "application/x-netcdf") + (".nc" . "application/x-netcdf") + (".oda" . "application/oda") + (".patch" . "text/x-patch") + (".pbm" . "image/x-portable-bitmap") + (".pdf" . "application/pdf") + (".pgm" . "image/portable-graymap") + (".pict" . "image/pict") + (".png" . "image/png") + (".pnm" . "image/x-portable-anymap") + (".pod" . "text/plain") + (".ppm" . "image/portable-pixmap") + (".ps" . "application/postscript") + (".qt" . "video/quicktime") + (".ras" . "image/x-raster") + (".rgb" . "image/x-rgb") + (".rtf" . "application/rtf") + (".rtx" . "text/richtext") + (".sh" . "application/x-sh") + (".sit" . "application/x-stuffit") + (".siv" . "application/sieve") + (".snd" . "audio/basic") + (".soa" . "text/dns") + (".src" . "application/x-wais-source") + (".tar" . "archive/tar") + (".tcl" . "application/x-tcl") + (".tex" . "application/x-tex") + (".texi" . "application/texinfo") + (".tga" . "image/x-targa") + (".tif" . "image/tiff") + (".tiff" . "image/tiff") + (".tr" . "application/x-troff") + (".troff" . "application/x-troff") + (".tsv" . "text/tab-separated-values") + (".txt" . "text/plain") + (".vbs" . "video/mpeg") + (".vox" . "audio/basic") + (".vrml" . "x-world/x-vrml") + (".wav" . "audio/x-wav") + (".xls" . "application/vnd.ms-excel") + (".wrl" . "x-world/x-vrml") + (".xbm" . "image/xbm") + (".xpm" . "image/xpm") + (".xwd" . "image/windowdump") + (".zip" . "application/zip") + (".ai" . "application/postscript") + (".jpe" . "image/jpeg") + (".jpeg" . "image/jpeg") + (".org" . "text/x-org")) + "An alist of file extensions and corresponding MIME content-types. +This exists for you to customize the information in Lisp. It is +merged with values from mailcap files by `mailcap-parse-mimetypes'.") + +(defvar mailcap-mimetypes-parsed-p nil) + +(defun mailcap-parse-mimetypes (&optional path force) + "Parse out all the mimetypes specified in a Unix-style path string PATH. +Components of PATH are separated by the `path-separator' character +appropriate for this system. If PATH is omitted, use the value of +environment variable MIMETYPES if set; otherwise use a default path. +If FORCE, re-parse even if already parsed." + (interactive (list nil t)) + (when (or (not mailcap-mimetypes-parsed-p) + force) + (cond + (path nil) + ((getenv "MIMETYPES") (setq path (getenv "MIMETYPES"))) + ((memq system-type mailcap-poor-system-types) + (setq path '("~/mime.typ" "~/etc/mime.typ"))) + (t (setq path + ;; mime.types seems to be the normal name, definitely so + ;; on current GNUish systems. The search order follows + ;; that for mailcap. + '("~/.mime.types" + "/etc/mime.types" + "/usr/etc/mime.types" + "/usr/local/etc/mime.types" + "/usr/local/www/conf/mime.types" + "~/.mime-types" + "/etc/mime-types" + "/usr/etc/mime-types" + "/usr/local/etc/mime-types" + "/usr/local/www/conf/mime-types")))) + (let ((fnames (reverse (if (stringp path) + (split-string path path-separator t) + path))) + fname) + (while fnames + (setq fname (car fnames)) + (if (and (file-readable-p fname)) + (mailcap-parse-mimetype-file fname)) + (setq fnames (cdr fnames)))) + (setq mailcap-mimetypes-parsed-p t))) + +(defun mailcap-parse-mimetype-file (fname) + "Parse out a mime-types file FNAME." + (let (type ; The MIME type for this line + extns ; The extensions for this line + save-pos ; Misc. saved buffer positions + ) + (with-temp-buffer + (insert-file-contents fname) + (mailcap-replace-regexp "#.*" "") + (mailcap-replace-regexp "\n+" "\n") + (mailcap-replace-regexp "[ \t]+$" "") + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (delete-region (point) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n") + (setq save-pos (point)) + (skip-chars-forward "^ \t\n") + (downcase-region save-pos (point)) + (setq type (buffer-substring save-pos (point))) + (while (not (eolp)) + (skip-chars-forward " \t") + (setq save-pos (point)) + (skip-chars-forward "^ \t\n") + (setq extns (cons (buffer-substring save-pos (point)) extns))) + (while extns + (setq mailcap-mime-extensions + (cons + (cons (if (= (string-to-char (car extns)) ?.) + (car extns) + (concat "." (car extns))) type) + mailcap-mime-extensions) + extns (cdr extns))))))) + +(defun mailcap-extension-to-mime (extn) + "Return the MIME content type of the file extensions EXTN." + (mailcap-parse-mimetypes) + (if (and (stringp extn) + (not (eq (string-to-char extn) ?.))) + (setq extn (concat "." extn))) + (cdr (assoc (downcase extn) mailcap-mime-extensions))) + +;; Unused? +(defalias 'mailcap-command-p 'executable-find) + +(defun mailcap-mime-types () + "Return a list of MIME media types." + (mailcap-parse-mimetypes) + (delete-dups + (nconc + (mapcar 'cdr mailcap-mime-extensions) + (apply + 'nconc + (mapcar + (lambda (l) + (delq nil + (mapcar + (lambda (m) + (let ((type (cdr (assq 'type (cdr m))))) + (if (equal (cadr (split-string type "/")) + "*") + nil + type))) + (cdr l)))) + mailcap-mime-data))))) + +;;; +;;; Useful supplementary functions +;;; + +(defun mailcap-file-default-commands (files) + "Return a list of default commands for FILES." + (mailcap-parse-mailcaps) + (mailcap-parse-mimetypes) + (let* ((all-mime-type + ;; All unique MIME types from file extensions + (delete-dups + (mapcar (lambda (file) + (mailcap-extension-to-mime + (file-name-extension file t))) + files))) + (all-mime-info + ;; All MIME info lists + (delete-dups + (mapcar (lambda (mime-type) + (mailcap-mime-info mime-type 'all)) + all-mime-type))) + (common-mime-info + ;; Intersection of mime-infos from different mime-types; + ;; or just the first MIME info for a single MIME type + (if (cdr all-mime-info) + (delq nil (mapcar (lambda (mi1) + (unless (memq nil (mapcar + (lambda (mi2) + (member mi1 mi2)) + (cdr all-mime-info))) + mi1)) + (car all-mime-info))) + (car all-mime-info))) + (commands + ;; Command strings from `viewer' field of the MIME info + (delete-dups + (delq nil (mapcar + (lambda (mime-info) + (let ((command (cdr (assoc 'viewer mime-info)))) + (if (stringp command) + (replace-regexp-in-string + ;; Replace mailcap's `%s' placeholder + ;; with dired's `?' placeholder + "%s" "?" + (replace-regexp-in-string + ;; Remove the final filename placeholder + "[ \t\n]*\\('\\)?%s\\1?[ \t\n]*\\'" "" + command nil t) + nil t)))) + common-mime-info))))) + commands)) + +(defun mailcap-view-mime (type) + "View the data in the current buffer that has MIME type TYPE. +`mailcap-mime-data' determines the method to use." + (let ((method (mailcap-mime-info type))) + (if (stringp method) + (shell-command-on-region (point-min) (point-max) + ;; Use stdin as the "%s". + (format method "-") + (current-buffer) + t) + (funcall method)))) + +(provide 'mailcap) + +;;; mailcap.el ends here diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index 8029e2ca70a..b13bece3912 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -79,7 +79,7 @@ ;; On GNU/Linux and Irix, the system's ping program seems to send packets ;; indefinitely unless told otherwise (defcustom ping-program-options - (and (memq system-type '(gnu/linux irix)) + (and (eq system-type 'gnu/linux) (list "-c" "4")) "Options for the ping program. These options can be used to limit how many ICMP packets are emitted." diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index 11885987ba5..c2845d96a5d 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -46,6 +46,7 @@ (require 'starttls) (require 'auth-source) (require 'nsm) +(require 'puny) (autoload 'gnutls-negotiate "gnutls") (autoload 'open-gnutls-stream "gnutls") @@ -64,8 +65,8 @@ BUFFER is a buffer or buffer name to associate with the process. Process output goes at end of that buffer. BUFFER may be nil, meaning that the process is not associated with any buffer. HOST is the name or IP address of the host to connect to. -SERVICE is the name of the service desired, or an integer specifying - a port number to connect to. +SERVICE is the name of the service desired, or an integer or + integer string specifying a port number to connect to. The remaining PARAMETERS should be a sequence of keywords and values: @@ -135,8 +136,14 @@ non-nil, is used warn the user if the connection isn't encrypted. :nogreeting is a boolean that can be used to inhibit waiting for a greeting from the server. -:nowait is a boolean that says the connection should be made -asynchronously, if possible." +:nowait, if non-nil, says the connection should be made +asynchronously, if possible. + +:tls-parameters is a list that should be supplied if you're +opening a TLS connection. The first element is the TLS +type (either `gnutls-x509pki' or `gnutls-anon'), and the +remaining elements should be a keyword list accepted by +gnutls-boot (as returned by `gnutls-boot-parameters')." (unless (featurep 'make-network-process) (error "Emacs was compiled without networking support")) (let ((type (plist-get parameters :type)) @@ -148,8 +155,10 @@ asynchronously, if possible." (plist-get parameters :capability-command)))))) ;; The simplest case: wrapper around `make-network-process'. (make-network-process :name name :buffer buffer - :host host :service service - :nowait (plist-get parameters :nowait)) + :host (puny-encode-domain host) :service service + :nowait (plist-get parameters :nowait) + :tls-parameters + (plist-get parameters :tls-parameters)) (let ((work-buffer (or buffer (generate-new-buffer " *stream buffer*"))) (fun (cond ((and (eq type 'plain) @@ -194,11 +203,14 @@ asynchronously, if possible." ;;;###autoload (defalias 'open-protocol-stream 'open-network-stream) +(define-obsolete-function-alias 'open-protocol-stream 'open-network-stream + "25.2") (defun network-stream-open-plain (name buffer host service parameters) (let ((start (with-current-buffer buffer (point))) (stream (make-network-process :name name :buffer buffer - :host host :service service + :host (puny-encode-domain host) + :service service :nowait (plist-get parameters :nowait)))) (when (plist-get parameters :warn-unless-encrypted) (setq stream (nsm-verify-connection stream host service nil t))) @@ -219,7 +231,8 @@ asynchronously, if possible." eoc)) ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) (stream (make-network-process :name name :buffer buffer - :host host :service service)) + :host (puny-encode-domain host) + :service service)) (greeting (and (not (plist-get parameters :nogreeting)) (network-stream-get-response stream start eoc))) (capabilities (network-stream-command stream capability-command @@ -296,8 +309,12 @@ asynchronously, if possible." (unless require-tls (setq stream (make-network-process :name name :buffer buffer - :host host :service service)) + :host (puny-encode-domain host) + :service service)) (network-stream-get-response stream start eoc))) + (unless (process-live-p stream) + (error "Unable to negotiate a TLS connection with %s/%s" + host service)) ;; Re-get the capabilities, which may have now changed. (setq capabilities (network-stream-command stream capability-command eo-capa)))) @@ -355,32 +372,34 @@ asynchronously, if possible." (with-current-buffer buffer (let* ((start (point-max)) (stream - (funcall (if (gnutls-available-p) - 'open-gnutls-stream - 'open-tls-stream) - name buffer host service)) + (if (gnutls-available-p) + (open-gnutls-stream name buffer host service + (plist-get parameters :nowait)) + (open-tls-stream name buffer host service))) (eoc (plist-get parameters :end-of-command))) - ;; Check certificate validity etc. - (when (and (gnutls-available-p) stream) - (setq stream (nsm-verify-connection stream host service))) - (if (null stream) - (list nil nil nil 'plain) - ;; If we're using tls.el, we have to delete the output from - ;; openssl/gnutls-cli. - (when (and (not (gnutls-available-p)) - eoc) - (network-stream-get-response stream start eoc) - (goto-char (point-min)) - (when (re-search-forward eoc nil t) - (goto-char (match-beginning 0)) - (delete-region (point-min) (line-beginning-position)))) - (let ((capability-command (plist-get parameters :capability-command)) - (eo-capa (or (plist-get parameters :end-of-capability) - eoc))) - (list stream - (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eo-capa) - 'tls)))))) + (if (plist-get parameters :nowait) + (list stream nil nil 'tls) + ;; Check certificate validity etc. + (when (and (gnutls-available-p) stream) + (setq stream (nsm-verify-connection stream host service))) + (if (null stream) + (list nil nil nil 'plain) + ;; If we're using tls.el, we have to delete the output from + ;; openssl/gnutls-cli. + (when (and (not (gnutls-available-p)) + eoc) + (network-stream-get-response stream start eoc) + (goto-char (point-min)) + (when (re-search-forward eoc nil t) + (goto-char (match-beginning 0)) + (delete-region (point-min) (line-beginning-position)))) + (let ((capability-command (plist-get parameters :capability-command)) + (eo-capa (or (plist-get parameters :end-of-capability) + eoc))) + (list stream + (network-stream-get-response stream start eoc) + (network-stream-command stream capability-command eo-capa) + 'tls))))))) (defun network-stream-open-shell (name buffer host service parameters) (require 'format-spec) diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 2596e56aa47..41b21722723 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -442,13 +442,6 @@ buffers *newsticker-wget-<feed>* will not be closed." ;; FIXME It is bad practice to define compat functions with such generic names. -;; This is not needed in Emacs >= 22.1. -(unless (fboundp 'time-add) - (require 'time-date);;FIXME - (defun time-add (t1 t2) - (with-no-warnings ; don't warn about obsolete time-to-seconds in 23.2 - (seconds-to-time (+ (time-to-seconds t1) (time-to-seconds t2)))))) - (unless (fboundp 'match-string-no-properties) (defalias 'match-string-no-properties 'match-string)) diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index d0b55437732..72bff66c381 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -297,19 +297,30 @@ unencrypted." nil (let ((response (condition-case nil - (nsm-query-user message args (nsm-format-certificate status)) + (intern + (car (split-string + (nsm-query-user message args + (nsm-format-certificate status)))) + obarray) ;; Make sure we manage to close the process if the user hits ;; `C-g'. (quit 'no) (error 'no)))) (if (eq response 'no) - nil + (progn + (message "Aborting connection to %s:%s" host port) + nil) + (message (if (eq response 'session) + "Accepting certificate for %s:%s this session only" + "Permanently accepting certificate for %s:%s") + host port) (nsm-save-host host port status what response) t)))) (defun nsm-query-user (message args cert) (let ((buffer (get-buffer-create "*Network Security Manager*"))) (save-window-excursion + ;; First format the certificate and warnings. (with-help-window buffer (with-current-buffer buffer (erase-buffer) @@ -321,28 +332,15 @@ unencrypted." ;; Fill the first line of the message, which usually ;; contains lots of explanatory text. (fill-region (point) (line-end-position))))) - (let ((responses '((?n . no) - (?s . session) - (?a . always))) - (prefix "") - (cursor-in-echo-area t) - response) - (while (not response) - (setq response - (cdr - (assq (downcase - (read-char - (concat prefix - "Continue connecting? (No, Session only, Always) "))) - responses))) - (unless response - (ding) - (setq prefix "Invalid choice. "))) - (kill-buffer buffer) - ;; If called from a callback, `read-char' will insert things - ;; into the pending input. Clear that. - (clear-this-command-keys) - response)))) + ;; Then ask the user what to do about it. + (unwind-protect + (cadr + (read-multiple-choice + "Continue connecting?" + '((?a "always" "Accept this certificate this session and for all future sessions.") + (?s "session only" "Accept this certificate this session only.") + (?n "no" "Refuse to use this certificate, and close the connection.")))) + (kill-buffer buffer))))) (defun nsm-save-host (host port status what permanency) (let* ((id (nsm-id host port)) diff --git a/lisp/net/pop3.el b/lisp/net/pop3.el new file mode 100644 index 00000000000..1695bbd3a40 --- /dev/null +++ b/lisp/net/pop3.el @@ -0,0 +1,914 @@ +;;; pop3.el --- Post Office Protocol (RFC 1460) interface + +;; Copyright (C) 1996-2016 Free Software Foundation, Inc. + +;; Author: Richard L. Pieri <ratinox@peorth.gweep.net> +;; Maintainer: emacs-devel@gnu.org +;; Keywords: mail + +;; 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: + +;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands +;; are implemented. The LIST command has not been implemented due to lack +;; of actual usefulness. +;; The optional POP3 command TOP has not been implemented. + +;; This program was inspired by Kyle E. Jones's vm-pop program. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'mail-utils) +(defvar parse-time-months) + +(defgroup pop3 nil + "Post Office Protocol." + :group 'mail + :group 'mail-source) + +(defcustom pop3-maildrop (or (user-login-name) + (getenv "LOGNAME") + (getenv "USER")) + "*POP3 maildrop." + :version "22.1" ;; Oort Gnus + :type 'string + :group 'pop3) + +(defcustom pop3-mailhost (or (getenv "MAILHOST") ;; nil -> mismatch + "pop3") + "*POP3 mailhost." + :version "22.1" ;; Oort Gnus + :type 'string + :group 'pop3) + +(defcustom pop3-port 110 + "*POP3 port." + :version "22.1" ;; Oort Gnus + :type 'number + :group 'pop3) + +(defcustom pop3-password-required t + "*Non-nil if a password is required when connecting to POP server." + :version "22.1" ;; Oort Gnus + :type 'boolean + :group 'pop3) + +;; Should this be customizable? +(defvar pop3-password nil + "*Password to use when connecting to POP server.") + +(defcustom pop3-authentication-scheme 'pass + "*POP3 authentication scheme. +Defaults to `pass', for the standard USER/PASS authentication. The other +valid value is `apop'." + :type '(choice (const :tag "Normal user/password" pass) + (const :tag "APOP" apop)) + :version "22.1" ;; Oort Gnus + :group 'pop3) + +(defcustom pop3-stream-length 100 + "How many messages should be requested at one time. +The lower the number, the more latency-sensitive the fetching +will be. If your pop3 server doesn't support streaming at all, +set this to 1." + :type 'number + :version "24.1" + :group 'pop3) + +(defcustom pop3-leave-mail-on-server nil + "Non-nil if the mail is to be left on the POP server after fetching. +Mails once fetched will never be fetched again by the UIDL control. + +If this is neither nil nor a number, all mails will be left on the +server. If this is a number, leave mails on the server for this many +days since you first checked new mails. If this is nil, mails will be +deleted on the server right after fetching. + +Gnus users should use the `:leave' keyword in a mail source to direct +the behavior per server, rather than directly modifying this value. + +Note that POP servers maintain no state information between sessions, +so what the client believes is there and what is actually there may +not match up. If they do not, then you may get duplicate mails or +the whole thing can fall apart and leave you with a corrupt mailbox." + :version "24.4" + :type '(choice (const :tag "Don't leave mails" nil) + (const :tag "Leave all mails" t) + (number :tag "Leave mails for this many days" :value 14)) + :group 'pop3) + +(defcustom pop3-uidl-file "~/.pop3-uidl" + "File used to save UIDL." + :version "24.4" + :type 'file + :group 'pop3) + +(defcustom pop3-uidl-file-backup '(0 9) + "How to backup the UIDL file `pop3-uidl-file' when updating. +If it is a list of numbers, the first one binds `kept-old-versions' and +the other binds `kept-new-versions' to keep number of oldest and newest +versions. Otherwise, the value binds `version-control' (which see). + +Note: Backup will take place whenever you check new mails on a server. +So, you may lose the backup files having been saved before a trouble +if you set it so as to make too few backups whereas you have access to +many servers." + :version "24.4" + :type '(choice (group :tag "Keep versions" :format "\n%v" :indent 3 + (number :tag "oldest") + (number :tag "newest")) + (sexp :format "%v" + :match (lambda (widget value) + (condition-case nil + (not (and (numberp (car value)) + (numberp (car (cdr value))))) + (error t))))) + :group 'pop3) + +(defvar pop3-timestamp nil + "Timestamp returned when initially connected to the POP server. +Used for APOP authentication.") + +(defvar pop3-read-point nil) +(defvar pop3-debug nil) + +;; Borrowed from nnheader-accept-process-output in nnheader.el. See the +;; comments there for explanations about the values. + +(eval-and-compile + (if (and (fboundp 'nnheader-accept-process-output) + (boundp 'nnheader-read-timeout)) + (defalias 'pop3-accept-process-output 'nnheader-accept-process-output) + ;; Borrowed from `nnheader.el': + (defvar pop3-read-timeout + (if (string-match "windows-nt\\|os/2\\|cygwin" + (symbol-name system-type)) + 1.0 + 0.01) + "How long pop3 should wait between checking for the end of output. +Shorter values mean quicker response, but are more CPU intensive.") + (defun pop3-accept-process-output (process) + (accept-process-output + process + (truncate pop3-read-timeout) + (truncate (* (- pop3-read-timeout + (truncate pop3-read-timeout)) + 1000)))))) + +(defvar pop3-uidl) +;; List of UIDLs of existing messages at present in the server: +;; ("UIDL1" "UIDL2" "UIDL3"...) + +(defvar pop3-uidl-saved) +;; Locally saved UIDL data; an alist of the server, the user, and the UIDL +;; and timestamp pairs: +;; (("SERVER_A" ("USER_A1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ("USER_A2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ...) +;; ("SERVER_B" ("USER_B1" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ("USER_B2" "UIDL1" TIMESTAMP1 "UIDL2" TIMESTAMP2...) +;; ...)) +;; Where TIMESTAMP is the most significant two digits of an Emacs time, +;; i.e. the return value of `current-time'. + +;;;###autoload +(defun pop3-movemail (file) + "Transfer contents of a maildrop to the specified FILE. +Use streaming commands." + (let ((process (pop3-open-server pop3-mailhost pop3-port)) + messages total-size + pop3-uidl + pop3-uidl-saved) + (pop3-logon process) + (if pop3-leave-mail-on-server + (setq messages (pop3-uidl-stat process) + total-size (cadr messages) + messages (car messages)) + (let ((size (pop3-stat process))) + (dotimes (i (car size)) (push (1+ i) messages)) + (setq messages (nreverse messages) + total-size (cadr size)))) + (when messages + (with-current-buffer (process-buffer process) + (pop3-send-streaming-command process "RETR" messages total-size) + (pop3-write-to-file file messages) + (unless pop3-leave-mail-on-server + (pop3-send-streaming-command process "DELE" messages nil)))) + (if pop3-leave-mail-on-server + (when (prog1 (pop3-uidl-dele process) (pop3-quit process)) + (pop3-uidl-save)) + (pop3-quit process) + ;; Remove UIDL data for the account that got not to leave mails. + (setq pop3-uidl-saved (pop3-uidl-load)) + (let ((elt (assoc pop3-maildrop + (cdr (assoc pop3-mailhost pop3-uidl-saved))))) + (when elt + (setcdr elt nil) + (pop3-uidl-save)))) + t)) + +(defun pop3-send-streaming-command (process command messages total-size) + (erase-buffer) + (let ((count (length messages)) + (i 1) + (start-point (point-min)) + (waited-for 0)) + (while messages + (process-send-string process (format "%s %d\r\n" command (pop messages))) + ;; Only do 100 messages at a time to avoid pipe stalls. + (when (zerop (% i pop3-stream-length)) + (setq start-point + (pop3-wait-for-messages process pop3-stream-length + total-size start-point)) + (incf waited-for pop3-stream-length)) + (incf i)) + (pop3-wait-for-messages process (- count waited-for) + total-size start-point))) + +(defun pop3-wait-for-messages (process count total-size start-point) + (while (> count 0) + (goto-char start-point) + (while (or (and (re-search-forward "^\\+OK" nil t) + (or (not total-size) + (re-search-forward "^\\.\r?\n" nil t))) + (re-search-forward "^-ERR " nil t)) + (decf count) + (setq start-point (point))) + (unless (memq (process-status process) '(open run)) + (error "pop3 process died")) + (when total-size + (let ((size 0)) + (goto-char (point-min)) + (while (re-search-forward "^\\+OK.*\n" nil t) + (setq size (+ size (- (point)) + (if (re-search-forward "^\\.\r?\n" nil 'move) + (match-beginning 0) + (point))))) + (message "pop3 retrieved %dKB (%d%%)" + (truncate (/ size 1000)) + (truncate (* (/ (* size 1.0) total-size) 100))))) + (pop3-accept-process-output process)) + start-point) + +(defun pop3-write-to-file (file messages) + (let ((pop-buffer (current-buffer)) + (start (point-min)) + beg end + temp-buffer) + (with-temp-buffer + (setq temp-buffer (current-buffer)) + (with-current-buffer pop-buffer + (goto-char (point-min)) + (while (re-search-forward "^\\+OK" nil t) + (forward-line 1) + (setq beg (point)) + (when (re-search-forward "^\\.\r?\n" nil t) + (setq start (point)) + (forward-line -1) + (setq end (point))) + (with-current-buffer temp-buffer + (goto-char (point-max)) + (let ((hstart (point))) + (insert-buffer-substring pop-buffer beg end) + (pop3-clean-region hstart (point)) + (goto-char (point-max)) + (pop3-munge-message-separator hstart (point)) + (when pop3-leave-mail-on-server + (pop3-uidl-add-xheader hstart (pop messages))) + (goto-char (point-max)))))) + (let ((coding-system-for-write 'binary)) + (goto-char (point-min)) + ;; Check whether something inserted a newline at the start and + ;; delete it. + (when (eolp) + (delete-char 1)) + (write-region (point-min) (point-max) file nil 'nomesg))))) + +(defun pop3-logon (process) + (let ((pop3-password pop3-password)) + ;; for debugging only + (if pop3-debug (switch-to-buffer (process-buffer process))) + ;; query for password + (if (and pop3-password-required (not pop3-password)) + (setq pop3-password + (read-passwd (format "Password for %s: " pop3-maildrop)))) + (cond ((equal 'apop pop3-authentication-scheme) + (pop3-apop process pop3-maildrop)) + ((equal 'pass pop3-authentication-scheme) + (pop3-user process pop3-maildrop) + (pop3-pass process)) + (t (error "Invalid POP3 authentication scheme"))))) + +(defun pop3-get-message-count () + "Return the number of messages in the maildrop." + (let* ((process (pop3-open-server pop3-mailhost pop3-port)) + message-count + (pop3-password pop3-password)) + ;; for debugging only + (if pop3-debug (switch-to-buffer (process-buffer process))) + ;; query for password + (if (and pop3-password-required (not pop3-password)) + (setq pop3-password + (read-passwd (format "Password for %s: " pop3-maildrop)))) + (cond ((equal 'apop pop3-authentication-scheme) + (pop3-apop process pop3-maildrop)) + ((equal 'pass pop3-authentication-scheme) + (pop3-user process pop3-maildrop) + (pop3-pass process)) + (t (error "Invalid POP3 authentication scheme"))) + (setq message-count (car (pop3-stat process))) + (pop3-quit process) + message-count)) + +(defun pop3-uidl-stat (process) + "Return a list of unread message numbers and total size." + (pop3-send-command process "UIDL") + (let (err messages size) + (if (condition-case code + (progn + (pop3-read-response process) + t) + (error (setq err (error-message-string code)) + nil)) + (let ((start pop3-read-point) + saved list) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (error "pop3 server closed the connection")) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker) + pop3-uidl nil) + (while (progn (forward-line -1) (>= (point) start)) + (when (looking-at "[0-9]+ \\([^\n\r ]+\\)") + (push (match-string 1) pop3-uidl))) + (when pop3-uidl + (setq pop3-uidl-saved (pop3-uidl-load) + saved (cdr (assoc pop3-maildrop + (cdr (assoc pop3-mailhost + pop3-uidl-saved))))) + (let ((i (length pop3-uidl))) + (while (> i 0) + (unless (member (nth (1- i) pop3-uidl) saved) + (push i messages)) + (decf i))) + (when messages + (setq list (pop3-list process) + size 0) + (dolist (msg messages) + (setq size (+ size (cdr (assq msg list))))) + (list messages size))))) + (message "%s doesn't support UIDL (%s), so we try a regressive way..." + pop3-mailhost err) + (sit-for 1) + (setq size (pop3-stat process)) + (dotimes (i (car size)) (push (1+ i) messages)) + (setcar size (nreverse messages)) + size))) + +(defun pop3-uidl-dele (process) + "Delete messages according to `pop3-leave-mail-on-server'. +Return non-nil if it is necessary to update the local UIDL file." + (let* ((ctime (current-time)) + (srvr (assoc pop3-mailhost pop3-uidl-saved)) + (saved (assoc pop3-maildrop (cdr srvr))) + i uidl mod new tstamp dele) + (setcdr (cdr ctime) nil) + ;; Add new messages to the data to be saved. + (cond ((and pop3-uidl saved) + (setq i (1- (length pop3-uidl))) + (while (>= i 0) + (unless (member (setq uidl (nth i pop3-uidl)) (cdr saved)) + (push ctime new) + (push uidl new)) + (decf i))) + (pop3-uidl + (setq new (apply 'nconc (mapcar (lambda (elt) (list elt ctime)) + pop3-uidl))))) + (when new (setq mod t)) + ;; List expirable messages and delete them from the data to be saved. + (setq ctime (when (numberp pop3-leave-mail-on-server) + (/ (+ (* (car ctime) 65536.0) (cadr ctime)) 86400)) + i (1- (length saved))) + (while (> i 0) + (if (member (setq uidl (nth (1- i) saved)) pop3-uidl) + (progn + (setq tstamp (nth i saved)) + (if (and ctime + (> (- ctime (/ (+ (* (car tstamp) 65536.0) (cadr tstamp)) + 86400)) + pop3-leave-mail-on-server)) + ;; Mails to delete. + (progn + (setq mod t) + (push uidl dele)) + ;; Mails to keep. + (push tstamp new) + (push uidl new))) + ;; Mails having been deleted in the server. + (setq mod t)) + (decf i 2)) + (cond (saved + (setcdr saved new)) + (srvr + (setcdr (last srvr) (list (cons pop3-maildrop new)))) + (t + (add-to-list 'pop3-uidl-saved + (list pop3-mailhost (cons pop3-maildrop new)) + t))) + ;; Actually delete the messages in the server. + (when dele + (setq uidl nil + i (length pop3-uidl)) + (while (> i 0) + (when (member (nth (1- i) pop3-uidl) dele) + (push i uidl)) + (decf i)) + (when uidl + (pop3-send-streaming-command process "DELE" uidl nil))) + mod)) + +(defun pop3-uidl-load () + "Load saved UIDL." + (when (file-exists-p pop3-uidl-file) + (with-temp-buffer + (condition-case code + (progn + (insert-file-contents pop3-uidl-file) + (goto-char (point-min)) + (read (current-buffer))) + (error + (message "Error while loading %s (%s)" + pop3-uidl-file (error-message-string code)) + (sit-for 1) + nil))))) + +(defun pop3-uidl-save () + "Save UIDL." + (with-temp-buffer + (if pop3-uidl-saved + (progn + (insert "(") + (dolist (srvr pop3-uidl-saved) + (when (cdr srvr) + (insert "(\"" (pop srvr) "\"\n ") + (dolist (elt srvr) + (when (cdr elt) + (insert "(\"" (pop elt) "\"\n ") + (while elt + (insert (format "\"%s\" %s\n " (pop elt) (pop elt)))) + (delete-char -4) + (insert ")\n "))) + (delete-char -3) + (if (eq (char-before) ?\)) + (insert ")\n ") + (goto-char (1+ (point-at-bol))) + (delete-region (point) (point-max))))) + (when (eq (char-before) ? ) + (delete-char -2)) + (insert ")\n")) + (insert "()\n")) + (let ((buffer-file-name pop3-uidl-file) + (delete-old-versions t) + (kept-new-versions kept-new-versions) + (kept-old-versions kept-old-versions) + (version-control version-control)) + (if (consp pop3-uidl-file-backup) + (setq kept-new-versions (cadr pop3-uidl-file-backup) + kept-old-versions (car pop3-uidl-file-backup) + version-control t) + (setq version-control pop3-uidl-file-backup)) + (save-buffer)))) + +(defun pop3-uidl-add-xheader (start msgno) + "Add X-UIDL header." + (let ((case-fold-search t)) + (save-restriction + (narrow-to-region start (progn + (goto-char start) + (search-forward "\n\n" nil 'move) + (1- (point)))) + (goto-char start) + (while (re-search-forward "^x-uidl:" nil t) + (while (progn + (forward-line 1) + (memq (char-after) '(?\t ? )))) + (delete-region (match-beginning 0) (point))) + (goto-char (point-max)) + (insert "X-UIDL: " (nth (1- msgno) pop3-uidl) "\n")))) + +(defcustom pop3-stream-type nil + "*Transport security type for POP3 connections. +This may be either nil (plain connection), `ssl' (use an +SSL/TSL-secured stream) or `starttls' (use the starttls mechanism +to turn on TLS security after opening the stream). However, if +this is nil, `ssl' is assumed for connections to port +995 (pop3s)." + :version "23.1" ;; No Gnus + :group 'pop3 + :type '(choice (const :tag "Plain" nil) + (const :tag "SSL/TLS" ssl) + (const starttls))) + +(defun pop3-open-server (mailhost port) + "Open TCP connection to MAILHOST on PORT. +Returns the process associated with the connection." + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + result) + (with-current-buffer + (get-buffer-create (concat " trace of POP session to " + mailhost)) + (erase-buffer) + (setq pop3-read-point (point-min)) + (setq result + (open-network-stream + "POP" (current-buffer) mailhost port + :type (cond + ((or (eq pop3-stream-type 'ssl) + (and (not pop3-stream-type) + (member port '(995 "pop3s")))) + 'tls) + (t + (or pop3-stream-type 'network))) + :warn-unless-encrypted t + :capability-command "CAPA\r\n" + :end-of-command "^\\(-ERR\\|+OK\\).*\n" + :end-of-capability "^\\.\r?\n\\|^-ERR" + :success "^\\+OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (and (string-match "\\bSTLS\\b" capabilities) + "STLS\r\n")))) + (when result + (let ((response (plist-get (cdr result) :greeting))) + (setq pop3-timestamp + (substring response (or (string-match "<" response) 0) + (+ 1 (or (string-match ">" response) -1))))) + (set-process-query-on-exit-flag (car result) nil) + (erase-buffer) + (car result))))) + +;; Support functions + +(defun pop3-send-command (process command) + (set-buffer (process-buffer process)) + (goto-char (point-max)) + ;; (if (= (aref command 0) ?P) + ;; (insert "PASS <omitted>\r\n") + ;; (insert command "\r\n")) + (setq pop3-read-point (point)) + (goto-char (point-max)) + (process-send-string process (concat command "\r\n"))) + +(defun pop3-read-response (process &optional return) + "Read the response from the server. +Return the response string if optional second argument is non-nil." + (let ((case-fold-search nil) + match-end) + (with-current-buffer (process-buffer process) + (goto-char pop3-read-point) + (while (and (memq (process-status process) '(open run)) + (not (search-forward "\r\n" nil t))) + (pop3-accept-process-output process) + (goto-char pop3-read-point)) + (setq match-end (point)) + (goto-char pop3-read-point) + (if (looking-at "-ERR") + (error "%s" (buffer-substring (point) (- match-end 2))) + (if (not (looking-at "+OK")) + (progn (setq pop3-read-point match-end) nil) + (setq pop3-read-point match-end) + (if return + (buffer-substring (point) match-end) + t) + ))))) + +(defun pop3-clean-region (start end) + (setq end (set-marker (make-marker) end)) + (save-excursion + (goto-char start) + (while (and (< (point) end) (search-forward "\r\n" end t)) + (replace-match "\n" t t)) + (goto-char start) + (while (and (< (point) end) (re-search-forward "^\\." end t)) + (replace-match "" t t) + (forward-char))) + (set-marker end nil)) + +;; Copied from message-make-date. +(defun pop3-make-date (&optional now) + "Make a valid date header. +If NOW, use that time instead." + (require 'parse-time) + (let* ((now (or now (current-time))) + (zone (nth 8 (decode-time now))) + (sign "+")) + (when (< zone 0) + (setq sign "-") + (setq zone (- zone))) + (concat + (format-time-string "%d" now) + ;; The month name of the %b spec is locale-specific. Pfff. + (format " %s " + (capitalize (car (rassoc (nth 4 (decode-time now)) + parse-time-months)))) + (format-time-string "%Y %H:%M:%S %z" now)))) + +(defun pop3-munge-message-separator (start end) + "Check to see if a message separator exists. If not, generate one." + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (if (not (or (looking-at "From .?") ; Unix mail + (looking-at "\001\001\001\001\n") ; MMDF + (looking-at "BABYL OPTIONS:") ; Babyl + )) + (let* ((from (mail-strip-quoted-names (mail-fetch-field "From"))) + (tdate (mail-fetch-field "Date")) + (date (split-string (or (and tdate + (not (string= "" tdate)) + tdate) + (pop3-make-date)) + " ")) + (From_)) + ;; sample date formats I have seen + ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT) + ;; Date: 08 Jul 1996 23:22:24 -0400 + ;; should be + ;; Tue Jul 9 09:04:21 1996 + + ;; Fixme: This should use timezone on the date field contents. + (setq date + (cond ((not date) + "Tue Jan 1 00:00:0 1900") + ((string-match "[A-Z]" (nth 0 date)) + (format "%s %s %s %s %s" + (nth 0 date) (nth 2 date) (nth 1 date) + (nth 4 date) (nth 3 date))) + (t + ;; this really needs to be better but I don't feel + ;; like writing a date to day converter. + (format "Sun %s %s %s %s" + (nth 1 date) (nth 0 date) + (nth 3 date) (nth 2 date))) + )) + (setq From_ (format "\nFrom %s %s\n" from date)) + (while (string-match "," From_) + (setq From_ (concat (substring From_ 0 (match-beginning 0)) + (substring From_ (match-end 0))))) + (goto-char (point-min)) + (insert From_) + (if (search-forward "\n\n" nil t) + nil + (goto-char (point-max)) + (insert "\n")) + (let ((size (- (point-max) (point)))) + (forward-line -1) + (insert (format "Content-Length: %s\n" size))) + ))))) + +;; The Command Set + +;; AUTHORIZATION STATE + +(defun pop3-user (process user) + "Send USER information to POP3 server." + (pop3-send-command process (format "USER %s" user)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (error "USER %s not valid" user)))) + +(defun pop3-pass (process) + "Send authentication information to the server." + (pop3-send-command process (format "PASS %s" pop3-password)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process)))) + +(defun pop3-apop (process user) + "Send alternate authentication information to the server." + (let ((pass pop3-password)) + (if (and pop3-password-required (not pass)) + (setq pass + (read-passwd (format "Password for %s: " pop3-maildrop)))) + (if pass + (let ((hash (md5 (concat pop3-timestamp pass) nil nil 'binary))) + (pop3-send-command process (format "APOP %s %s" user hash)) + (let ((response (pop3-read-response process t))) + (if (not (and response (string-match "+OK" response))) + (pop3-quit process))))) + )) + +;; TRANSACTION STATE + +(defun pop3-stat (process) + "Return the number of messages in the maildrop and the maildrop's size." + (pop3-send-command process "STAT") + (let ((response (pop3-read-response process t))) + (list (string-to-number (nth 1 (split-string response " "))) + (string-to-number (nth 2 (split-string response " ")))) + )) + +(defun pop3-list (process &optional msg) + "If MSG is nil, return an alist of (MESSAGE-ID . SIZE) pairs. +Otherwise, return the size of the message-id MSG" + (pop3-send-command process (if msg + (format "LIST %d" msg) + "LIST")) + (let ((response (pop3-read-response process t))) + (if msg + (string-to-number (nth 2 (split-string response " "))) + (let ((start pop3-read-point) end) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker)) + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (mapcar #'(lambda (s) (let ((split (split-string s " "))) + (cons (string-to-number (nth 0 split)) + (string-to-number (nth 1 split))))) + (split-string (buffer-substring start end) "\r\n" t))))))) + +(defun pop3-retr (process msg crashbuf) + "Retrieve message-id MSG to buffer CRASHBUF." + (pop3-send-command process (format "RETR %s" msg)) + (pop3-read-response process) + (let ((start pop3-read-point) end) + (with-current-buffer (process-buffer process) + (while (not (re-search-forward "^\\.\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (error "pop3 server closed the connection")) + (pop3-accept-process-output process) + (goto-char start)) + (setq pop3-read-point (point-marker)) + ;; this code does not seem to work for some POP servers... + ;; and I cannot figure out why not. + ;; (goto-char (match-beginning 0)) + ;; (backward-char 2) + ;; (if (not (looking-at "\r\n")) + ;; (insert "\r\n")) + ;; (re-search-forward "\\.\r\n") + (goto-char (match-beginning 0)) + (setq end (point-marker)) + (pop3-clean-region start end) + (pop3-munge-message-separator start end) + (with-current-buffer crashbuf + (erase-buffer)) + (copy-to-buffer crashbuf start end) + (delete-region start end) + ))) + +(defun pop3-dele (process msg) + "Mark message-id MSG as deleted." + (pop3-send-command process (format "DELE %s" msg)) + (pop3-read-response process)) + +(defun pop3-noop (process msg) + "No-operation." + (pop3-send-command process "NOOP") + (pop3-read-response process)) + +(defun pop3-last (process) + "Return highest accessed message-id number for the session." + (pop3-send-command process "LAST") + (let ((response (pop3-read-response process t))) + (string-to-number (nth 1 (split-string response " "))) + )) + +(defun pop3-rset (process) + "Remove all delete marks from current maildrop." + (pop3-send-command process "RSET") + (pop3-read-response process)) + +;; UPDATE + +(defun pop3-quit (process) + "Close connection to POP3 server. +Tell server to remove all messages marked as deleted, unlock the maildrop, +and close the connection." + (pop3-send-command process "QUIT") + (pop3-read-response process t) + (if process + (with-current-buffer (process-buffer process) + (goto-char (point-max)) + (delete-process process)))) + +;; Summary of POP3 (Post Office Protocol version 3) commands and responses + +;;; AUTHORIZATION STATE + +;; Initial TCP connection +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [POP3 server ready] + +;; USER name +;; Arguments: a server specific user-id (required) +;; Restrictions: authorization state [after unsuccessful USER or PASS +;; Possible responses: +;; +OK [valid user-id] +;; -ERR [invalid user-id] + +;; PASS string +;; Arguments: a server/user-id specific password (required) +;; Restrictions: authorization state, after successful USER +;; Possible responses: +;; +OK [maildrop locked and ready] +;; -ERR [invalid password] +;; -ERR [unable to lock maildrop] + +;; STLS (RFC 2595) +;; Arguments: none +;; Restrictions: Only permitted in AUTHORIZATION state. +;; Possible responses: +;; +OK +;; -ERR + +;;; TRANSACTION STATE + +;; STAT +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn mm [# of messages, size of maildrop] + +;; LIST [msg] +;; Arguments: a message-id (optional) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [scan listing follows] +;; -ERR [no such message] + +;; RETR msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message contents follow] +;; -ERR [no such message] + +;; DELE msg +;; Arguments: a message-id (required) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [message deleted] +;; -ERR [no such message] + +;; NOOP +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK + +;; LAST +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK nn [highest numbered message accessed] + +;; RSET +;; Arguments: none +;; Restrictions: transaction state +;; Possible responses: +;; +OK [all delete marks removed] + +;; UIDL [msg] +;; Arguments: a message-id (optional) +;; Restrictions: transaction state; msg must not be deleted +;; Possible responses: +;; +OK [uidl listing follows] +;; -ERR [no such message] + +;;; UPDATE STATE + +;; QUIT +;; Arguments: none +;; Restrictions: none +;; Possible responses: +;; +OK [TCP connection closed] + +(provide 'pop3) + +;;; pop3.el ends here diff --git a/lisp/net/puny.el b/lisp/net/puny.el new file mode 100644 index 00000000000..50bde85287d --- /dev/null +++ b/lisp/net/puny.el @@ -0,0 +1,248 @@ +;;; puny.el --- translate non-ASCII domain names to ASCII + +;; Copyright (C) 2015-2016 Free Software Foundation, Inc. + +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Keywords: mail, net + +;; 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: + +;; Written by looking at +;; http://stackoverflow.com/questions/183485/can-anyone-recommend-a-good-free-javascript-for-punycode-to-unicode-conversion + +;;; Code: + +(require 'seq) + +(defun puny-encode-domain (domain) + "Encode DOMAIN according to the IDNA/punycode algorithm. +For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." + ;; The vast majority of domain names are not IDNA domain names, so + ;; add a check first to avoid doing unnecessary work. + (if (string-match "\\'[[:ascii:]]+\\'" domain) + domain + (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) + +(defun puny-encode-string (string) + "Encode STRING according to the IDNA/punycode algorithm. +This is used to encode non-ASCII domain names. +For instance, \"bücher\" => \"xn--bcher-kva\"." + (let ((ascii (seq-filter (lambda (char) + (< char 128)) + string))) + (if (= (length ascii) (length string)) + string + (concat "xn--" + (if (null ascii) + "" + (concat ascii "-")) + (puny-encode-complex (length ascii) string))))) + +(defun puny-decode-domain (domain) + "Decode DOMAIN according to the IDNA/punycode algorithm. +For instance, \"xn--ff-2sa.org\" => \"fśf.org\"." + (mapconcat 'puny-decode-string (split-string domain "[.]") ".")) + +(defun puny-decode-string (string) + "Decode an IDNA/punycode-encoded string. +For instance \"xn--bcher-kva\" => \"bücher\"." + (if (string-match "\\`xn--" string) + (puny-decode-string-internal (substring string 4)) + string)) + +(defconst puny-initial-n 128) +(defconst puny-initial-bias 72) +(defconst puny-base 36) +(defconst puny-damp 700) +(defconst puny-tmin 1) +(defconst puny-tmax 26) +(defconst puny-skew 28) + +;; 0-25 a-z +;; 26-36 0-9 +(defun puny-encode-digit (d) + (if (< d 26) + (+ ?a d) + (+ ?0 (- d 26)))) + +(defun puny-adapt (delta num-points first-time) + (let ((delta (if first-time + (/ delta puny-damp) + (/ delta 2))) + (k 0)) + (setq delta (+ delta (/ delta num-points))) + (while (> delta (/ (* (- puny-base puny-tmin) + puny-tmax) + 2)) + (setq delta (/ delta (- puny-base puny-tmin)) + k (+ k puny-base))) + (+ k (/ (* (1+ (- puny-base puny-tmin)) delta) + (+ delta puny-skew))))) + +(defun puny-encode-complex (insertion-points string) + (let ((n puny-initial-n) + (delta 0) + (bias puny-initial-bias) + (h insertion-points) + result m ijv q) + (while (< h (length string)) + (setq ijv (cl-loop for char across string + when (>= char n) + minimize char)) + (setq m ijv) + (setq delta (+ delta (* (- m n) (+ h 1))) + n m) + (cl-loop for char across string + when (< char n) + do (cl-incf delta) + when (= char ijv) + do (progn + (setq q delta) + (cl-loop with k = puny-base + for t1 = (cond + ((<= k bias) + puny-tmin) + ((>= k (+ bias puny-tmax)) + puny-tmax) + (t + (- k bias))) + while (>= q t1) + do (push (puny-encode-digit + (+ t1 (mod (- q t1) + (- puny-base t1)))) + result) + do (setq q (/ (- q t1) (- puny-base t1)) + k (+ k puny-base))) + (push (puny-encode-digit q) result) + (setq bias (puny-adapt delta (+ h 1) (= h insertion-points)) + delta 0 + h (1+ h)))) + (cl-incf delta) + (cl-incf n)) + (nreverse result))) + +(defun puny-decode-digit (cp) + (cond + ((<= cp ?9) + (+ (- cp ?0) 26)) + ((<= cp ?Z) + (- cp ?A)) + ((<= cp ?z) + (- cp ?a)) + (t + puny-base))) + +(defun puny-decode-string-internal (string) + (with-temp-buffer + (insert string) + (goto-char (point-max)) + (search-backward "-" nil (point-min)) + ;; The encoded chars are after the final dash. + (let ((encoded (buffer-substring (1+ (point)) (point-max))) + (ic 0) + (i 0) + (bias puny-initial-bias) + (n puny-initial-n) + out) + (delete-region (point) (point-max)) + (while (< ic (length encoded)) + (let ((old-i i) + (w 1) + (k puny-base) + digit t1) + (cl-loop do (progn + (setq digit (puny-decode-digit (aref encoded ic))) + (cl-incf ic) + (cl-incf i (* digit w)) + (setq t1 (cond + ((<= k bias) + puny-tmin) + ((>= k (+ bias puny-tmax)) + puny-tmax) + (t + (- k bias))))) + while (>= digit t1) + do (setq w (* w (- puny-base t1)) + k (+ k puny-base))) + (setq out (1+ (buffer-size))) + (setq bias (puny-adapt (- i old-i) out (= old-i 0)))) + + (setq n (+ n (/ i out)) + i (mod i out)) + (goto-char (point-min)) + (forward-char i) + (insert (format "%c" n)) + (cl-incf i))) + (buffer-string))) + +;; http://www.unicode.org/reports/tr39/#Restriction_Level_Detection +;; http://www.unicode.org/reports/tr31/#Table_Candidate_Characters_for_Inclusion_in_Identifiers + +(defun puny-highly-restrictive-string-p (string) + "Say whether STRING is \"highly restrictive\" in the Unicode IDNA sense. +See http://www.unicode.org/reports/tr39/#Restriction_Level_Detection +for details. The main idea is that if you're mixing +scripts (like latin and cyrillic), you may confuse the user by +using homographs." + (let ((scripts + (delq + t + (seq-uniq + (seq-map (lambda (char) + (if (memq char + ;; These characters are always allowed + ;; in any string. + '(#x0027 ; APOSTROPHE + #x002D ; HYPHEN-MINUS + #x002E ; FULL STOP + #x003A ; COLON + #x00B7 ; MIDDLE DOT + #x058A ; ARMENIAN HYPHEN + #x05F3 ; HEBREW PUNCTUATION GERESH + #x05F4 ; HEBREW PUNCTUATION GERSHAYIM + #x0F0B ; TIBETAN MARK INTERSYLLABIC TSHEG + #x200C ; ZERO WIDTH NON-JOINER* + #x200D ; ZERO WIDTH JOINER* + #x2010 ; HYPHEN + #x2019 ; RIGHT SINGLE QUOTATION MARK + #x2027 ; HYPHENATION POINT + #x30A0 ; KATAKANA-HIRAGANA DOUBLE HYPHEN + #x30FB)) ; KATAKANA MIDDLE DOT + t + (aref char-script-table char))) + string))))) + (or + ;; Every character uses the same script. + (= (length scripts) 1) + (seq-some 'identity + (mapcar (lambda (list) + (seq-every-p (lambda (script) + (memq script list)) + scripts)) + '((latin han hiragana kana) + (latin han bopomofo) + (latin han hangul))))))) + +(defun puny-highly-restrictive-domain-p (domain) + "Say whether DOMAIN is \"highly restrictive\" in the Unicode IDNA sense. +See `puny-highly-restrictive-string-p' for further details." + (seq-every-p 'puny-highly-restrictive-string-p (split-string domain "[.]"))) + +(provide 'puny) + +;;; puny.el ends here diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index 55b43f63963..66e6326085c 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -103,7 +103,12 @@ connected to automatically. `:encryption' VALUE must be `plain' (the default) for unencrypted connections, or `tls' -for connections using SSL/TLS." +for connections using SSL/TLS. + +`:server-alias' + +VALUE must be a string that will be used instead of the server name for +display purposes. If absent, the real server name will be displayed instead." :type '(alist :key-type string :value-type (plist :options ((:nick string) @@ -113,7 +118,8 @@ for connections using SSL/TLS." (:full-name string) (:channels (repeat string)) (:encryption (choice (const tls) - (const plain)))))) + (const plain))) + (:server-alias string)))) :group 'rcirc) (defcustom rcirc-default-port 6667 @@ -484,22 +490,26 @@ If ARG is non-nil, instead prompt for connection parameters." (channels (plist-get (cdr c) :channels)) (password (plist-get (cdr c) :password)) (encryption (plist-get (cdr c) :encryption)) + (server-alias (plist-get (cdr c) :server-alias)) contact) (when server (let (connected) (dolist (p (rcirc-process-list)) - (when (string= server (process-name p)) + (when (string= (or server-alias server) (process-name p)) (setq connected p))) (if (not connected) (condition-case nil (rcirc-connect server port nick user-name - full-name channels password encryption) - (quit (message "Quit connecting to %s" server))) + full-name channels password encryption + server-alias) + (quit (message "Quit connecting to %s" + (or server-alias server)))) (with-current-buffer (process-buffer connected) (setq contact (process-contact - (get-buffer-process (current-buffer)) :host)) + (get-buffer-process (current-buffer)) :name)) (setq connected-servers - (cons (if (stringp contact) contact server) + (cons (if (stringp contact) + contact (or server-alias server)) connected-servers)))))))) (when connected-servers (message "Already connected to %s" @@ -528,9 +538,10 @@ If ARG is non-nil, instead prompt for connection parameters." ;;;###autoload (defun rcirc-connect (server &optional port nick user-name - full-name startup-channels password encryption) + full-name startup-channels password encryption + server-alias) (save-excursion - (message "Connecting to %s..." server) + (message "Connecting to %s..." (or server-alias server)) (let* ((inhibit-eol-conversion) (port-number (if port (if (stringp port) @@ -542,7 +553,7 @@ If ARG is non-nil, instead prompt for connection parameters." (full-name (or full-name rcirc-default-full-name)) (startup-channels startup-channels) (process (open-network-stream - server nil server port-number + (or server-alias server) nil server port-number :type (or encryption 'plain)))) ;; set up process (set-process-coding-system process 'raw-text 'raw-text) @@ -557,7 +568,8 @@ If ARG is non-nil, instead prompt for connection parameters." password encryption)) (setq-local rcirc-process process) (setq-local rcirc-server server) - (setq-local rcirc-server-name server) ; Update when we get 001 response. + (setq-local rcirc-server-name + (or server-alias server)) ; Update when we get 001 response. (setq-local rcirc-buffer-alist nil) (setq-local rcirc-nick-table (make-hash-table :test 'equal)) (setq-local rcirc-nick nick) @@ -584,7 +596,7 @@ If ARG is non-nil, instead prompt for connection parameters." (setq rcirc-keepalive-timer (run-at-time 0 (/ rcirc-timeout-seconds 2) 'rcirc-keepalive))) - (message "Connecting to %s...done" server) + (message "Connecting to %s...done" (or server-alias server)) ;; return process object process))) @@ -599,10 +611,7 @@ If ARG is non-nil, instead prompt for connection parameters." `(with-current-buffer rcirc-server-buffer ,@body)) -(defalias 'rcirc-float-time - (if (featurep 'xemacs) - 'time-to-seconds - 'float-time)) +(define-obsolete-function-alias 'rcirc-float-time 'float-time "26.1") (defun rcirc-prompt-for-encryption (server-plist) "Prompt the user for the encryption method to use. @@ -626,7 +635,7 @@ last ping." (rcirc-send-ctcp process rcirc-nick (format "KEEPALIVE %f" - (rcirc-float-time)))))) + (float-time)))))) (rcirc-process-list)) ;; no processes, clean up timer (when (timerp rcirc-keepalive-timer) @@ -635,7 +644,7 @@ last ping." (defun rcirc-handler-ctcp-KEEPALIVE (process _target _sender message) (with-rcirc-process-buffer process - (setq header-line-format (format "%f" (- (rcirc-float-time) + (setq header-line-format (format "%f" (- (float-time) (string-to-number message)))))) (defvar rcirc-debug-buffer "*rcirc debug*") @@ -2330,7 +2339,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" (rcirc-float-time)))) + (let ((timestamp (format "%.0f" (float-time)))) (rcirc-send-ctcp process target "PING" timestamp))) (defun rcirc-cmd-me (args &optional process target) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 2c8ff79763f..9d42fde0756 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -36,6 +36,7 @@ (require 'subr-x) (require 'dom) (require 'seq) +(require 'svg) (defgroup shr nil "Simple HTML Renderer" @@ -64,6 +65,12 @@ fit these criteria." :group 'shr :type 'boolean) +(defcustom shr-use-colors t + "If non-nil, respect color specifications in the HTML." + :version "25.2" + :group 'shr + :type 'boolean) + (defcustom shr-table-horizontal-line nil "Character used to draw horizontal table lines. If nil, don't draw horizontal table lines." @@ -136,6 +143,14 @@ cid: URL as the argument.") (defvar shr-inhibit-images nil "If non-nil, inhibit loading images.") +(defvar shr-external-rendering-functions nil + "Alist of tag/function pairs used to alter how shr renders certain tags. +For instance, eww uses this to alter rendering of title, forms +and other things: +((title . eww-tag-title) + (form . eww-tag-form) + ...)") + ;;; Internal variables. (defvar shr-folding-mode nil) @@ -151,7 +166,6 @@ cid: URL as the argument.") (defvar shr-depth 0) (defvar shr-warning nil) (defvar shr-ignore-cache nil) -(defvar shr-external-rendering-functions nil) (defvar shr-target-id nil) (defvar shr-table-separator-length 1) (defvar shr-table-separator-pixel-width 0) @@ -172,10 +186,16 @@ cid: URL as the argument.") (define-key map "w" 'shr-copy-url) (define-key map "u" 'shr-copy-url) (define-key map "v" 'shr-browse-url) - (define-key map "o" 'shr-save-contents) + (define-key map "O" 'shr-save-contents) (define-key map "\r" 'shr-browse-url) map)) +(defvar shr-image-map + (let ((map (copy-keymap shr-map))) + (when (boundp 'image-map) + (set-keymap-parent map image-map)) + map)) + ;; Public functions and commands. (declare-function libxml-parse-html-region "xml.c" (start end &optional base-url discard-comments)) @@ -254,22 +274,19 @@ DOM should be a parse tree as generated by (set-window-hscroll nil 0) (shr-descend dom) (shr-fill-lines start (point)) - (shr-remove-trailing-whitespace start (point)) + (shr--remove-blank-lines-at-the-end start (point)) (when shr-warning (message "%s" shr-warning)))) -(defun shr-remove-trailing-whitespace (start end) - (let ((width (window-width))) - (save-restriction +(defun shr--remove-blank-lines-at-the-end (start end) + (save-restriction + (save-excursion (narrow-to-region start end) - (goto-char start) - (while (not (eobp)) - (end-of-line) - (when (> (shr-previous-newline-padding-width (current-column)) width) - (dolist (overlay (overlays-at (point))) - (when (overlay-get overlay 'before-string) - (overlay-put overlay 'before-string nil)))) - (forward-line 1))))) + (goto-char end) + (when (and (re-search-backward "[^ \n]" nil t) + (not (eobp))) + (forward-line 1) + (delete-region (point) (point-max)))))) (defun shr-copy-url (&optional image-url) "Copy the URL under point to the kill ring. @@ -435,11 +452,10 @@ size, and full-buffer size." (defun shr-descend (dom) (let ((function - (or - ;; Allow other packages to override (or provide) rendering - ;; of elements. - (cdr (assq (dom-tag dom) shr-external-rendering-functions)) - (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray))) + (intern (concat "shr-tag-" (symbol-name (dom-tag dom))) obarray)) + ;; Allow other packages to override (or provide) rendering + ;; of elements. + (external (cdr (assq (dom-tag dom) shr-external-rendering-functions))) (style (dom-attr dom 'style)) (shr-stylesheet shr-stylesheet) (shr-depth (1+ shr-depth)) @@ -454,9 +470,12 @@ size, and full-buffer size." (setq style nil))) ;; If we have a display:none, then just ignore this part of the DOM. (unless (equal (cdr (assq 'display shr-stylesheet)) "none") - (if (fboundp function) - (funcall function dom) - (shr-generic dom)) + (cond (external + (funcall external dom)) + ((fboundp function) + (funcall function dom)) + (t + (shr-generic dom))) (when (and shr-target-id (equal (dom-attr dom 'id) shr-target-id)) ;; If the element was empty, we don't have anything to put the @@ -535,6 +554,16 @@ size, and full-buffer size." (insert string) (shr-pixel-column)))) +(defsubst shr--translate-insertion-chars () + ;; Remove soft hyphens. + (goto-char (point-min)) + (while (search-forward "" nil t) + (replace-match "" t t)) + ;; Translate non-breaking spaces into real spaces. + (goto-char (point-min)) + (while (search-forward " " nil t) + (replace-match " " t t))) + (defun shr-insert (text) (when (and (not (bolp)) (get-text-property (1- (point)) 'image-url)) @@ -545,14 +574,11 @@ size, and full-buffer size." (insert text) (save-restriction (narrow-to-region start (point)) - ;; Remove soft hyphens. - (goto-char (point-min)) - (while (search-forward "" nil t) - (replace-match "" t t)) + (shr--translate-insertion-chars) (goto-char (point-max))))) (t (let ((font-start (point))) - (when (and (string-match "\\`[ \t\n\r ]" text) + (when (and (string-match "\\`[ \t\n\r]" text) (not (bolp)) (not (eq (char-after (1- (point))) ? ))) (insert " ")) @@ -562,14 +588,11 @@ size, and full-buffer size." (save-restriction (narrow-to-region start (point)) (goto-char start) - (when (looking-at "[ \t\n\r ]+") + (when (looking-at "[ \t\n\r]+") (replace-match "" t t)) - (while (re-search-forward "[ \t\n\r ]+" nil t) + (while (re-search-forward "[ \t\n\r]+" nil t) (replace-match " " t t)) - ;; Remove soft hyphens. - (goto-char (point-min)) - (while (search-forward "" nil t) - (replace-match "" t t)) + (shr--translate-insertion-chars) (goto-char (point-max))) ;; We may have removed everything we inserted if if was just ;; spaces. @@ -952,10 +975,14 @@ element is the data blob and the second element is the content-type." (create-image data 'svg t :ascent 100)) ((eq size 'full) (ignore-errors - (shr-rescale-image data content-type))) + (shr-rescale-image data content-type + (plist-get flags :width) + (plist-get flags :height)))) (t (ignore-errors - (shr-rescale-image data content-type)))))) + (shr-rescale-image data content-type + (plist-get flags :width) + (plist-get flags :height))))))) (when image ;; When inserting big-ish pictures, put them at the ;; beginning of the line. @@ -978,21 +1005,40 @@ element is the data blob and the second element is the content-type." image) (insert (or alt "")))) -(defun shr-rescale-image (data &optional content-type) - "Rescale DATA, if too big, to fit the current buffer." - (if (not (and (fboundp 'imagemagick-types) - (get-buffer-window (current-buffer)))) +(defun shr-rescale-image (data content-type width height) + "Rescale DATA, if too big, to fit the current buffer. +WIDTH and HEIGHT are the sizes given in the HTML data, if any." + (if (or (not (fboundp 'imagemagick-types)) + (not (get-buffer-window (current-buffer)))) (create-image data nil t :ascent 100) - (let ((edges (window-inside-pixel-edges - (get-buffer-window (current-buffer))))) - (create-image - data 'imagemagick t - :ascent 100 - :max-width (truncate (* shr-max-image-proportion - (- (nth 2 edges) (nth 0 edges)))) - :max-height (truncate (* shr-max-image-proportion - (- (nth 3 edges) (nth 1 edges)))) - :format content-type)))) + (let* ((edges (window-inside-pixel-edges + (get-buffer-window (current-buffer)))) + (max-width (truncate (* shr-max-image-proportion + (- (nth 2 edges) (nth 0 edges))))) + (max-height (truncate (* shr-max-image-proportion + (- (nth 3 edges) (nth 1 edges))))) + (scaling (image-compute-scaling-factor image-scaling-factor))) + (when (or (and width + (> width max-width)) + (and height + (> height max-height))) + (setq width nil + height nil)) + (if (and width height + (< (* width scaling) max-width) + (< (* height scaling) max-height)) + (create-image + data 'imagemagick t + :ascent 100 + :width width + :height height + :format content-type) + (create-image + data 'imagemagick t + :ascent 100 + :max-width max-width + :max-height max-height + :format content-type))))) ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) @@ -1071,8 +1117,15 @@ START, and END. Note that START and END should be markers." url))) (if title (format "%s (%s)" iri title) iri)) 'follow-link t - 'mouse-face 'highlight - 'keymap shr-map))) + 'mouse-face 'highlight)) + ;; Don't overwrite any keymaps that are already in the buffer (i.e., + ;; image keymaps). + (while (and start + (< start (point))) + (let ((next (next-single-property-change start 'keymap nil (point)))) + (if (get-text-property start 'keymap) + (setq start next) + (put-text-property start (or next (point)) 'keymap shr-map))))) (defun shr-encode-url (url) "Encode URL." @@ -1104,7 +1157,9 @@ ones, in case fg and bg are nil." (shr-color-visible bg fg))))))) (defun shr-colorize-region (start end fg &optional bg) - (when (and (or fg bg) (>= (display-color-cells) 88)) + (when (and shr-use-colors + (or fg bg) + (>= (display-color-cells) 88)) (let ((new-colors (shr-color-check fg bg))) (when new-colors (when fg @@ -1117,18 +1172,6 @@ ones, in case fg and bg are nil." t))) new-colors))) -(defun shr-previous-newline-padding-width (width) - (let ((overlays (overlays-at (point))) - (previous-width 0)) - (if (null overlays) - width - (dolist (overlay overlays) - (setq previous-width - (+ previous-width - (length (plist-get (overlay-properties overlay) - 'before-string))))) - (+ width previous-width)))) - ;;; Tag-specific rendering rules. (defun shr-tag-html (dom) @@ -1137,7 +1180,9 @@ ones, in case fg and bg are nil." ((equal dir "ltr") (setq bidi-paragraph-direction 'left-to-right)) ((equal dir "rtl") - (setq bidi-paragraph-direction 'right-to-left)))) + (setq bidi-paragraph-direction 'right-to-left)) + ((equal dir "auto") + (setq bidi-paragraph-direction nil)))) (shr-generic dom)) (defun shr-tag-body (dom) @@ -1223,9 +1268,6 @@ ones, in case fg and bg are nil." (defun shr-tag-s (dom) (shr-fontize-dom dom 'shr-strike-through)) -(defun shr-tag-del (dom) - (shr-fontize-dom dom 'shr-strike-through)) - (defun shr-tag-b (dom) (shr-fontize-dom dom 'bold)) @@ -1245,6 +1287,24 @@ ones, in case fg and bg are nil." (let ((shr-current-font 'default)) (shr-generic dom))) +(defun shr-tag-ins (cont) + (let* ((start (point)) + (color "green") + (shr-stylesheet (nconc (list (cons 'color color)) + shr-stylesheet))) + (shr-generic cont) + (shr-colorize-region start (point) color + (cdr (assq 'background-color shr-stylesheet))))) + +(defun shr-tag-del (cont) + (let* ((start (point)) + (color "red") + (shr-stylesheet (nconc (list (cons 'color color)) + shr-stylesheet))) + (shr-fontize-dom cont 'shr-strike-through) + (shr-colorize-region start (point) color + (cdr (assq 'background-color shr-stylesheet))))) + (defun shr-parse-style (style) (when style (save-match-data @@ -1388,11 +1448,14 @@ The preference is a float determined from `shr-prefer-media-type'." (defun shr-tag-img (dom &optional url) (when (or url (and dom - (> (length (dom-attr dom 'src)) 0))) + (or (> (length (dom-attr dom 'src)) 0) + (> (length (dom-attr dom 'srcset)) 0)))) (when (> (current-column) 0) (insert "\n")) (let ((alt (dom-attr dom 'alt)) - (url (shr-expand-url (or url (dom-attr dom 'src))))) + (width (shr-string-number (dom-attr dom 'width))) + (height (shr-string-number (dom-attr dom 'height))) + (url (shr-expand-url (or url (shr--preferred-image dom))))) (let ((start (point-marker))) (when (zerop (length alt)) (setq alt "*")) @@ -1405,7 +1468,8 @@ The preference is a float determined from `shr-prefer-media-type'." (string-match "\\`data:" url)) (let ((image (shr-image-from-data (substring url (match-end 0))))) (if image - (funcall shr-put-image-function image alt) + (funcall shr-put-image-function image alt + (list :width width :height height)) (insert alt)))) ((and (not shr-inhibit-images) (string-match "\\`cid:" url)) @@ -1414,7 +1478,8 @@ The preference is a float determined from `shr-prefer-media-type'." (if (or (not shr-content-function) (not (setq image (funcall shr-content-function url)))) (insert alt) - (funcall shr-put-image-function image alt)))) + (funcall shr-put-image-function image alt + (list :width width :height height))))) ((or shr-inhibit-images (and shr-blocked-images (string-match shr-blocked-images url))) @@ -1422,20 +1487,26 @@ The preference is a float determined from `shr-prefer-media-type'." (shr-insert alt)) ((and (not shr-ignore-cache) (url-is-cached (shr-encode-url url))) - (funcall shr-put-image-function (shr-get-image-data url) alt)) + (funcall shr-put-image-function (shr-get-image-data url) alt + (list :width width :height height))) (t - (insert alt " ") (when (and shr-ignore-cache (url-is-cached (shr-encode-url url))) (let ((file (url-cache-create-filename (shr-encode-url url)))) (when (file-exists-p file) (delete-file file)))) + (when (image-type-available-p 'svg) + (insert-image + (shr-make-placeholder-image dom) + (or alt ""))) + (insert " ") (url-queue-retrieve (shr-encode-url url) 'shr-image-fetched - (list (current-buffer) start (set-marker (make-marker) (1- (point)))) + (list (current-buffer) start (set-marker (make-marker) (point)) + (list :width width :height height)) t t))) (when (zerop shr-table-depth) ;; We are not in a table. - (put-text-property start (point) 'keymap shr-map) + (put-text-property start (point) 'keymap shr-image-map) (put-text-property start (point) 'shr-alt alt) (put-text-property start (point) 'image-url url) (put-text-property start (point) 'image-displayer @@ -1444,6 +1515,87 @@ The preference is a float determined from `shr-prefer-media-type'." (shr-fill-text (or (dom-attr dom 'title) alt)))))))) +(defun shr--preferred-image (dom) + (let ((srcset (dom-attr dom 'srcset)) + (frame-width (frame-pixel-width)) + (width (string-to-number (or (dom-attr dom 'width) "100"))) + candidate) + (when (> (length srcset) 0) + ;; srcset consist of a series of URL/size specifications + ;; separated by the ", " string. + (setq srcset + (sort (mapcar + (lambda (elem) + (let ((spec (split-string elem " "))) + (cond + ((= (length spec) 1) + ;; Make sure it's well formed. + (list (car spec) 0)) + ((string-match "\\([0-9]+\\)x\\'" (cadr spec)) + ;; If we have an "x" form, then use the width + ;; spec to compute the real width. + (list (car spec) + (* width (string-to-number + (match-string 1 (cadr spec)))))) + (t + (list (car spec) + (string-to-number (cadr spec))))))) + (split-string srcset ", ")) + (lambda (e1 e2) + (> (cadr e1) (cadr e2))))) + ;; Choose the smallest picture that's bigger than the current + ;; frame. + (setq candidate (caar srcset)) + (while (and srcset + (> (cadr (car srcset)) frame-width)) + (setq candidate (caar srcset)) + (pop srcset))) + (or candidate (dom-attr dom 'src)))) + +(defun shr-string-number (string) + (if (null string) + nil + (setq string (replace-regexp-in-string "[^0-9]" "" string)) + (if (zerop (length string)) + nil + (string-to-number string)))) + +(defun shr-make-placeholder-image (dom) + (let* ((edges (and + (get-buffer-window (current-buffer)) + (window-inside-pixel-edges + (get-buffer-window (current-buffer))))) + (scaling (image-compute-scaling-factor image-scaling-factor)) + (width (truncate + (* (or (shr-string-number (dom-attr dom 'width)) 100) + scaling))) + (height (truncate + (* (or (shr-string-number (dom-attr dom 'height)) 100) + scaling))) + (max-width + (and edges + (truncate (* shr-max-image-proportion + (- (nth 2 edges) (nth 0 edges)))))) + (max-height (and edges + (truncate (* shr-max-image-proportion + (- (nth 3 edges) (nth 1 edges)))))) + svg image) + (when (and max-width + (> width max-width)) + (setq height (truncate (* (/ (float max-width) width) height)) + width max-width)) + (when (and max-height + (> height max-height)) + (setq width (truncate (* (/ (float max-height) height) width)) + height max-height)) + (setq svg (svg-create width height)) + (svg-gradient svg "background" 'linear '((0 . "#b0b0b0") (100 . "#808080"))) + (svg-rectangle svg 0 0 width height :gradient "background" + :stroke-width 2 :stroke-color "black") + (let ((image (svg-image svg))) + (setf (image-property image :ascent) 100) + image))) + (defun shr-tag-pre (dom) (let ((shr-folding-mode 'none) (shr-current-font 'default)) @@ -1510,7 +1662,9 @@ The preference is a float determined from `shr-prefer-media-type'." (put-text-property start (1+ start) 'shr-continuation-indentation shr-indentation) (put-text-property start (1+ start) 'shr-prefix-length (length bullet)) - (shr-generic dom))))) + (shr-generic dom)))) + (unless (bolp) + (insert "\n"))) (defun shr-mark-fill (start) ;; We may not have inserted any text to fill. @@ -1573,6 +1727,24 @@ The preference is a float determined from `shr-prefer-media-type'." (shr-colorize-region start (point) color (cdr (assq 'background-color shr-stylesheet)))))) +(defun shr-tag-bdo (dom) + (let* ((direction (dom-attr dom 'dir)) + (char (cond + ((equal direction "ltr") + ?\N{LEFT-TO-RIGHT OVERRIDE}) + ((equal direction "rtl") + ?\N{RIGHT-TO-LEFT OVERRIDE})))) + (when char + (insert ?\N{FIRST STRONG ISOLATE} char)) + (shr-generic dom) + (when char + (insert ?\N{POP DIRECTIONAL FORMATTING} ?\N{POP DIRECTIONAL ISOLATE})))) + +(defun shr-tag-bdi (dom) + (insert ?\N{FIRST STRONG ISOLATE}) + (shr-generic dom) + (insert ?\N{POP DIRECTIONAL ISOLATE})) + ;;; Table rendering algorithm. ;; Table rendering is the only complicated thing here. We do this by diff --git a/lisp/net/sieve-manage.el b/lisp/net/sieve-manage.el new file mode 100644 index 00000000000..695bbd860de --- /dev/null +++ b/lisp/net/sieve-manage.el @@ -0,0 +1,575 @@ +;;; sieve-manage.el --- Implementation of the managesieve protocol in elisp + +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Albert Krewinkel <tarleb@moltkeplatz.de> + +;; 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 library provides an elisp API for the managesieve network +;; protocol. +;; +;; It uses the SASL library for authentication, which means it +;; supports DIGEST-MD5, CRAM-MD5, SCRAM-MD5, NTLM, PLAIN and LOGIN +;; methods. STARTTLS is not well tested, but should be easy to get to +;; work if someone wants. +;; +;; The API should be fairly obvious for anyone familiar with the +;; managesieve protocol, interface functions include: +;; +;; `sieve-manage-open' +;; open connection to managesieve server, returning a buffer to be +;; used by all other API functions. +;; +;; `sieve-manage-opened' +;; check if a server is open or not +;; +;; `sieve-manage-close' +;; close a server connection. +;; +;; `sieve-manage-listscripts' +;; `sieve-manage-deletescript' +;; `sieve-manage-getscript' +;; performs managesieve protocol actions +;; +;; and that's it. Example of a managesieve session in *scratch*: +;; +;; (with-current-buffer (sieve-manage-open "mail.example.com") +;; (sieve-manage-authenticate) +;; (sieve-manage-listscripts)) +;; +;; => ((active . "main") "vacation") +;; +;; References: +;; +;; draft-martin-managesieve-02.txt, +;; "A Protocol for Remotely Managing Sieve Scripts", +;; by Tim Martin. +;; +;; Release history: +;; +;; 2001-10-31 Committed to Oort Gnus. +;; 2002-07-27 Added DELETESCRIPT. Suggested by Ned Ludd. +;; 2002-08-03 Use SASL library. +;; 2013-06-05 Enabled STARTTLS support, fixed bit rot. + +;;; Code: + +(if (locate-library "password-cache") + (require 'password-cache) + (require 'password)) + +(eval-when-compile (require 'cl)) +(require 'sasl) +(require 'starttls) +(autoload 'sasl-find-mechanism "sasl") +(autoload 'auth-source-search "auth-source") + +;; User customizable variables: + +(defgroup sieve-manage nil + "Low-level Managesieve protocol issues." + :group 'mail + :prefix "sieve-") + +(defcustom sieve-manage-log "*sieve-manage-log*" + "Name of buffer for managesieve session trace." + :type 'string + :group 'sieve-manage) + +(defcustom sieve-manage-server-eol "\r\n" + "The EOL string sent from the server." + :type 'string + :group 'sieve-manage) + +(defcustom sieve-manage-client-eol "\r\n" + "The EOL string we send to the server." + :type 'string + :group 'sieve-manage) + +(defcustom sieve-manage-authenticators '(digest-md5 + cram-md5 + scram-md5 + ntlm + plain + login) + "Priority of authenticators to consider when authenticating to server." + ;; FIXME Improve this. It's not `set'. + ;; It's like (repeat (choice (const ...))), where each choice can + ;; only appear once. + :type '(repeat symbol) + :group 'sieve-manage) + +(defcustom sieve-manage-authenticator-alist + '((cram-md5 sieve-manage-cram-md5-p sieve-manage-cram-md5-auth) + (digest-md5 sieve-manage-digest-md5-p sieve-manage-digest-md5-auth) + (scram-md5 sieve-manage-scram-md5-p sieve-manage-scram-md5-auth) + (ntlm sieve-manage-ntlm-p sieve-manage-ntlm-auth) + (plain sieve-manage-plain-p sieve-manage-plain-auth) + (login sieve-manage-login-p sieve-manage-login-auth)) + "Definition of authenticators. + +\(NAME CHECK AUTHENTICATE) + +NAME names the authenticator. CHECK is a function returning non-nil if +the server support the authenticator and AUTHENTICATE is a function +for doing the actual authentication." + :type '(repeat (list (symbol :tag "Name") (function :tag "Check function") + (function :tag "Authentication function"))) + :group 'sieve-manage) + +(defcustom sieve-manage-default-port "sieve" + "Default port number or service name for managesieve protocol." + :type '(choice integer string) + :version "24.4" + :group 'sieve-manage) + +(defcustom sieve-manage-default-stream 'network + "Default stream type to use for `sieve-manage'." + :version "24.1" + :type 'symbol + :group 'sieve-manage) + +;; Internal variables: + +(defconst sieve-manage-local-variables '(sieve-manage-server + sieve-manage-port + sieve-manage-auth + sieve-manage-stream + sieve-manage-process + sieve-manage-client-eol + sieve-manage-server-eol + sieve-manage-capability)) +(defconst sieve-manage-coding-system-for-read 'binary) +(defconst sieve-manage-coding-system-for-write 'binary) +(defvar sieve-manage-stream nil) +(defvar sieve-manage-auth nil) +(defvar sieve-manage-server nil) +(defvar sieve-manage-port nil) +(defvar sieve-manage-state 'closed + "Managesieve state. +Valid states are `closed', `initial', `nonauth', and `auth'.") +(defvar sieve-manage-process nil) +(defvar sieve-manage-capability nil) + +;; Internal utility functions +(autoload 'mm-enable-multibyte "mm-util") + +(defun sieve-manage-make-process-buffer () + (with-current-buffer + (generate-new-buffer (format " *sieve %s:%s*" + sieve-manage-server + sieve-manage-port)) + (mapc 'make-local-variable sieve-manage-local-variables) + (mm-enable-multibyte) + (buffer-disable-undo) + (current-buffer))) + +(defun sieve-manage-erase (&optional p buffer) + (let ((buffer (or buffer (current-buffer)))) + (and sieve-manage-log + (with-current-buffer (get-buffer-create sieve-manage-log) + (mm-enable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert-buffer-substring buffer (with-current-buffer buffer + (point-min)) + (or p (with-current-buffer buffer + (point-max))))))) + (delete-region (point-min) (or p (point-max)))) + +(defun sieve-manage-open-server (server port &optional stream buffer) + "Open network connection to SERVER on PORT. +Return the buffer associated with the connection." + (with-current-buffer buffer + (sieve-manage-erase) + (setq sieve-manage-state 'initial) + (destructuring-bind (proc . props) + (open-network-stream + "SIEVE" buffer server port + :type stream + :capability-command "CAPABILITY\r\n" + :end-of-command "^\\(OK\\|NO\\).*\n" + :success "^OK.*\n" + :return-list t + :starttls-function + (lambda (capabilities) + (when (string-match "\\bSTARTTLS\\b" capabilities) + "STARTTLS\r\n"))) + (setq sieve-manage-process proc) + (setq sieve-manage-capability + (sieve-manage-parse-capability (plist-get props :capabilities))) + ;; Ignore new capabilities issues after successful STARTTLS + (when (and (memq stream '(nil network starttls)) + (eq (plist-get props :type) 'tls)) + (sieve-manage-drop-next-answer)) + (current-buffer)))) + +;; Authenticators +(defun sieve-sasl-auth (buffer mech) + "Login to server using the SASL MECH method." + (message "sieve: Authenticating using %s..." mech) + (with-current-buffer buffer + (let* ((auth-info (auth-source-search :host sieve-manage-server + :port "sieve" + :max 1 + :create t)) + (user-name (or (plist-get (nth 0 auth-info) :user) "")) + (user-password (or (plist-get (nth 0 auth-info) :secret) "")) + (user-password (if (functionp user-password) + (funcall user-password) + user-password)) + (client (sasl-make-client (sasl-find-mechanism (list mech)) + user-name "sieve" sieve-manage-server)) + (sasl-read-passphrase + ;; We *need* to copy the password, because sasl will modify it + ;; somehow. + `(lambda (prompt) ,(copy-sequence user-password))) + (step (sasl-next-step client nil)) + (tag (sieve-manage-send + (concat + "AUTHENTICATE \"" + mech + "\"" + (and (sasl-step-data step) + (concat + " \"" + (base64-encode-string + (sasl-step-data step) + 'no-line-break) + "\""))))) + data rsp) + (catch 'done + (while t + (setq rsp nil) + (goto-char (point-min)) + (while (null (or (progn + (setq rsp (sieve-manage-is-string)) + (if (not (and rsp (looking-at + sieve-manage-server-eol))) + (setq rsp nil) + (goto-char (match-end 0)) + rsp)) + (setq rsp (sieve-manage-is-okno)))) + (accept-process-output sieve-manage-process 1) + (goto-char (point-min))) + (sieve-manage-erase) + (when (sieve-manage-ok-p rsp) + (when (and (cadr rsp) + (string-match "^SASL \"\\([^\"]+\\)\"" (cadr rsp))) + (sasl-step-set-data + step (base64-decode-string (match-string 1 (cadr rsp))))) + (if (and (setq step (sasl-next-step client step)) + (setq data (sasl-step-data step))) + ;; We got data for server but it's finished + (error "Server not ready for SASL data: %s" data) + ;; The authentication process is finished. + (throw 'done t))) + (unless (stringp rsp) + (error "Server aborted SASL authentication: %s" (caddr rsp))) + (sasl-step-set-data step (base64-decode-string rsp)) + (setq step (sasl-next-step client step)) + (sieve-manage-send + (if (sasl-step-data step) + (concat "\"" + (base64-encode-string (sasl-step-data step) + 'no-line-break) + "\"") + "")))) + (message "sieve: Login using %s...done" mech)))) + +(defun sieve-manage-cram-md5-p (buffer) + (sieve-manage-capability "SASL" "CRAM-MD5" buffer)) + +(defun sieve-manage-cram-md5-auth (buffer) + "Login to managesieve server using the CRAM-MD5 SASL method." + (sieve-sasl-auth buffer "CRAM-MD5")) + +(defun sieve-manage-digest-md5-p (buffer) + (sieve-manage-capability "SASL" "DIGEST-MD5" buffer)) + +(defun sieve-manage-digest-md5-auth (buffer) + "Login to managesieve server using the DIGEST-MD5 SASL method." + (sieve-sasl-auth buffer "DIGEST-MD5")) + +(defun sieve-manage-scram-md5-p (buffer) + (sieve-manage-capability "SASL" "SCRAM-MD5" buffer)) + +(defun sieve-manage-scram-md5-auth (buffer) + "Login to managesieve server using the SCRAM-MD5 SASL method." + (sieve-sasl-auth buffer "SCRAM-MD5")) + +(defun sieve-manage-ntlm-p (buffer) + (sieve-manage-capability "SASL" "NTLM" buffer)) + +(defun sieve-manage-ntlm-auth (buffer) + "Login to managesieve server using the NTLM SASL method." + (sieve-sasl-auth buffer "NTLM")) + +(defun sieve-manage-plain-p (buffer) + (sieve-manage-capability "SASL" "PLAIN" buffer)) + +(defun sieve-manage-plain-auth (buffer) + "Login to managesieve server using the PLAIN SASL method." + (sieve-sasl-auth buffer "PLAIN")) + +(defun sieve-manage-login-p (buffer) + (sieve-manage-capability "SASL" "LOGIN" buffer)) + +(defun sieve-manage-login-auth (buffer) + "Login to managesieve server using the LOGIN SASL method." + (sieve-sasl-auth buffer "LOGIN")) + +;; Managesieve API + +(defun sieve-manage-open (server &optional port stream auth buffer) + "Open a network connection to a managesieve SERVER (string). +Optional argument PORT is port number (integer) on remote server. +Optional argument STREAM is any of `sieve-manage-streams' (a symbol). +Optional argument AUTH indicates authenticator to use, see +`sieve-manage-authenticators' for available authenticators. +If nil, chooses the best stream the server is capable of. +Optional argument BUFFER is buffer (buffer, or string naming buffer) +to work in." + (setq sieve-manage-port (or port sieve-manage-default-port)) + (with-current-buffer (or buffer (sieve-manage-make-process-buffer)) + (setq sieve-manage-server (or server + sieve-manage-server) + sieve-manage-stream (or stream + sieve-manage-stream + sieve-manage-default-stream) + sieve-manage-auth (or auth + sieve-manage-auth)) + (message "sieve: Connecting to %s..." sieve-manage-server) + (sieve-manage-open-server sieve-manage-server + sieve-manage-port + sieve-manage-stream + (current-buffer)) + (when (sieve-manage-opened (current-buffer)) + ;; Choose authenticator + (when (and (null sieve-manage-auth) + (not (eq sieve-manage-state 'auth))) + (dolist (auth sieve-manage-authenticators) + (when (funcall (nth 1 (assq auth sieve-manage-authenticator-alist)) + buffer) + (setq sieve-manage-auth auth) + (return))) + (unless sieve-manage-auth + (error "Couldn't figure out authenticator for server"))) + (sieve-manage-erase) + (current-buffer)))) + +(defun sieve-manage-authenticate (&optional buffer) + "Authenticate on server in BUFFER. +Return `sieve-manage-state' value." + (with-current-buffer (or buffer (current-buffer)) + (if (eq sieve-manage-state 'nonauth) + (when (funcall (nth 2 (assq sieve-manage-auth + sieve-manage-authenticator-alist)) + (current-buffer)) + (setq sieve-manage-state 'auth)) + sieve-manage-state))) + +(defun sieve-manage-opened (&optional buffer) + "Return non-nil if connection to managesieve server in BUFFER is open. +If BUFFER is nil then the current buffer is used." + (and (setq buffer (get-buffer (or buffer (current-buffer)))) + (buffer-live-p buffer) + (with-current-buffer buffer + (and sieve-manage-process + (memq (process-status sieve-manage-process) '(open run)))))) + +(defun sieve-manage-close (&optional buffer) + "Close connection to managesieve server in BUFFER. +If BUFFER is nil, the current buffer is used." + (with-current-buffer (or buffer (current-buffer)) + (when (sieve-manage-opened) + (sieve-manage-send "LOGOUT") + (sit-for 1)) + (when (and sieve-manage-process + (memq (process-status sieve-manage-process) '(open run))) + (delete-process sieve-manage-process)) + (setq sieve-manage-process nil) + (sieve-manage-erase) + t)) + +(defun sieve-manage-capability (&optional name value buffer) + "Check if capability NAME of server BUFFER match VALUE. +If it does, return the server value of NAME. If not returns nil. +If VALUE is nil, do not check VALUE and return server value. +If NAME is nil, return the full server list of capabilities." + (with-current-buffer (or buffer (current-buffer)) + (if (null name) + sieve-manage-capability + (let ((server-value (cadr (assoc name sieve-manage-capability)))) + (when (or (null value) + (and server-value + (string-match value server-value))) + server-value))))) + +(defun sieve-manage-listscripts (&optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send "LISTSCRIPTS") + (sieve-manage-parse-listscripts))) + +(defun sieve-manage-havespace (name size &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "HAVESPACE \"%s\" %s" name size)) + (sieve-manage-parse-okno))) + +(defun sieve-manage-putscript (name content &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "PUTSCRIPT \"%s\" {%d+}%s%s" name + ;; Here we assume that the coding-system will + ;; replace each char with a single byte. + ;; This is always the case if `content' is + ;; a unibyte string. + (length content) + sieve-manage-client-eol content)) + (sieve-manage-parse-okno))) + +(defun sieve-manage-deletescript (name &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "DELETESCRIPT \"%s\"" name)) + (sieve-manage-parse-okno))) + +(defun sieve-manage-getscript (name output-buffer &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "GETSCRIPT \"%s\"" name)) + (let ((script (sieve-manage-parse-string))) + (sieve-manage-parse-crlf) + (with-current-buffer output-buffer + (insert script)) + (sieve-manage-parse-okno)))) + +(defun sieve-manage-setactive (name &optional buffer) + (with-current-buffer (or buffer (current-buffer)) + (sieve-manage-send (format "SETACTIVE \"%s\"" name)) + (sieve-manage-parse-okno))) + +;; Protocol parsing routines + +(defun sieve-manage-wait-for-answer () + (let ((pattern "^\\(OK\\|NO\\).*\n") + pos) + (while (not pos) + (setq pos (search-forward-regexp pattern nil t)) + (goto-char (point-min)) + (sleep-for 0 50)) + pos)) + +(defun sieve-manage-drop-next-answer () + (sieve-manage-wait-for-answer) + (sieve-manage-erase)) + +(defun sieve-manage-ok-p (rsp) + (string= (downcase (or (car-safe rsp) "")) "ok")) + +(defun sieve-manage-is-okno () + (when (looking-at (concat + "^\\(OK\\|NO\\)\\( (\\([^)]+\\))\\)?\\( \\(.*\\)\\)?" + sieve-manage-server-eol)) + (let ((status (match-string 1)) + (resp-code (match-string 3)) + (response (match-string 5))) + (when response + (goto-char (match-beginning 5)) + (setq response (sieve-manage-is-string))) + (list status resp-code response)))) + +(defun sieve-manage-parse-okno () + (let (rsp) + (while (null rsp) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min)) + (setq rsp (sieve-manage-is-okno))) + (sieve-manage-erase) + rsp)) + +(defun sieve-manage-parse-capability (str) + "Parse managesieve capability string `STR'. +Set variable `sieve-manage-capability' to " + (let ((capas (delq nil + (mapcar #'split-string-and-unquote + (split-string str "\n"))))) + (when (string= "OK" (caar (last capas))) + (setq sieve-manage-state 'nonauth)) + capas)) + +(defun sieve-manage-is-string () + (cond ((looking-at "\"\\([^\"]+\\)\"") + (prog1 + (match-string 1) + (goto-char (match-end 0)))) + ((looking-at (concat "{\\([0-9]+\\+?\\)}" sieve-manage-server-eol)) + (let ((pos (match-end 0)) + (len (string-to-number (match-string 1)))) + (if (< (point-max) (+ pos len)) + nil + (goto-char (+ pos len)) + (buffer-substring pos (+ pos len))))))) + +(defun sieve-manage-parse-string () + (let (rsp) + (while (null rsp) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min)) + (setq rsp (sieve-manage-is-string))) + (sieve-manage-erase (point)) + rsp)) + +(defun sieve-manage-parse-crlf () + (when (looking-at sieve-manage-server-eol) + (sieve-manage-erase (match-end 0)))) + +(defun sieve-manage-parse-listscripts () + (let (tmp rsp data) + (while (null rsp) + (while (null (or (setq rsp (sieve-manage-is-okno)) + (setq tmp (sieve-manage-is-string)))) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min))) + (when tmp + (while (not (looking-at (concat "\\( ACTIVE\\)?" + sieve-manage-server-eol))) + (accept-process-output (get-buffer-process (current-buffer)) 1) + (goto-char (point-min))) + (if (match-string 1) + (push (cons 'active tmp) data) + (push tmp data)) + (goto-char (match-end 0)) + (setq tmp nil))) + (sieve-manage-erase) + (if (sieve-manage-ok-p rsp) + data + rsp))) + +(defun sieve-manage-send (cmdstr) + (setq cmdstr (concat cmdstr sieve-manage-client-eol)) + (and sieve-manage-log + (with-current-buffer (get-buffer-create sieve-manage-log) + (mm-enable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (insert cmdstr))) + (process-send-string sieve-manage-process cmdstr)) + +(provide 'sieve-manage) + +;; sieve-manage.el ends here diff --git a/lisp/net/sieve-mode.el b/lisp/net/sieve-mode.el new file mode 100644 index 00000000000..77ab44f02db --- /dev/null +++ b/lisp/net/sieve-mode.el @@ -0,0 +1,236 @@ +;;; sieve-mode.el --- Sieve code editing commands for Emacs + +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> + +;; 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 file contain editing mode functions and font-lock support for +;; editing Sieve scripts. It sets up C-mode with support for +;; sieve-style #-comments and a lightly hacked syntax table. It was +;; strongly influenced by awk-mode.el. +;; +;; Put something similar to the following in your .emacs to use this file: +;; +;; (load "~/lisp/sieve") +;; (setq auto-mode-alist (cons '("\\.siv\\'" . sieve-mode) auto-mode-alist)) +;; +;; References: +;; +;; RFC 3028, +;; "Sieve: A Mail Filtering Language", +;; by Tim Showalter. +;; +;; Release history: +;; +;; 2001-03-02 version 1.0 posted to gnu.emacs.sources +;; version 1.1 change file extension into ".siv" (official one) +;; added keymap and menubar to hook into sieve-manage +;; 2001-10-31 version 1.2 committed to Oort Gnus + +;;; Code: + +(autoload 'sieve-manage "sieve") +(autoload 'sieve-upload "sieve") +(eval-when-compile + (require 'font-lock)) + +(defgroup sieve nil + "Sieve." + :group 'languages) + +(defcustom sieve-mode-hook nil + "Hook run in sieve mode buffers." + :type 'hook) + +;; Font-lock + +(defvar sieve-control-commands-face 'sieve-control-commands + "Face name used for Sieve Control Commands.") + +(defface sieve-control-commands + '((((type tty) (class color)) (:foreground "blue" :weight light)) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Orchid")) + (((class color) (background dark)) (:foreground "LightSteelBlue")) + (t (:bold t))) + "Face used for Sieve Control Commands.") +;; backward-compatibility alias +(put 'sieve-control-commands-face 'face-alias 'sieve-control-commands) +(put 'sieve-control-commands-face 'obsolete-face "22.1") + +(defvar sieve-action-commands-face 'sieve-action-commands + "Face name used for Sieve Action Commands.") + +(defface sieve-action-commands + '((((type tty) (class color)) (:foreground "blue" :weight bold)) + (((class color) (background light)) (:foreground "Blue")) + (((class color) (background dark)) (:foreground "LightSkyBlue")) + (t (:inverse-video t :bold t))) + "Face used for Sieve Action Commands.") +;; backward-compatibility alias +(put 'sieve-action-commands-face 'face-alias 'sieve-action-commands) +(put 'sieve-action-commands-face 'obsolete-face "22.1") + +(defvar sieve-test-commands-face 'sieve-test-commands + "Face name used for Sieve Test Commands.") + +(defface sieve-test-commands + '((((type tty) (class color)) (:foreground "magenta")) + (((class grayscale) (background light)) + (:foreground "LightGray" :bold t :underline t)) + (((class grayscale) (background dark)) + (:foreground "Gray50" :bold t :underline t)) + (((class color) (background light)) (:foreground "CadetBlue")) + (((class color) (background dark)) (:foreground "Aquamarine")) + (t (:bold t :underline t))) + "Face used for Sieve Test Commands.") +;; backward-compatibility alias +(put 'sieve-test-commands-face 'face-alias 'sieve-test-commands) +(put 'sieve-test-commands-face 'obsolete-face "22.1") + +(defvar sieve-tagged-arguments-face 'sieve-tagged-arguments + "Face name used for Sieve Tagged Arguments.") + +(defface sieve-tagged-arguments + '((((type tty) (class color)) (:foreground "cyan" :weight bold)) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:bold t))) + "Face used for Sieve Tagged Arguments.") +;; backward-compatibility alias +(put 'sieve-tagged-arguments-face 'face-alias 'sieve-tagged-arguments) +(put 'sieve-tagged-arguments-face 'obsolete-face "22.1") + + +(defconst sieve-font-lock-keywords + (eval-when-compile + (list + ;; control commands + (cons (regexp-opt '("require" "if" "else" "elsif" "stop") + 'words) + 'sieve-control-commands-face) + ;; action commands + (cons (regexp-opt '("fileinto" "redirect" "reject" "keep" "discard") + 'words) + 'sieve-action-commands-face) + ;; test commands + (cons (regexp-opt '("address" "allof" "anyof" "exists" "false" + "true" "header" "not" "size" "envelope" + "body") + 'words) + 'sieve-test-commands-face) + (cons "\\Sw+:\\sw+" + 'sieve-tagged-arguments-face)))) + +;; Syntax table + +(defvar sieve-mode-syntax-table + (let ((st (make-syntax-table))) + (modify-syntax-entry ?\\ "\\" st) + (modify-syntax-entry ?\n "> " st) + (modify-syntax-entry ?\f "> " st) + (modify-syntax-entry ?\# "< " st) + (modify-syntax-entry ?/ ". 14" st) + (modify-syntax-entry ?* ". 23b" st) + (modify-syntax-entry ?+ "." st) + (modify-syntax-entry ?- "." st) + (modify-syntax-entry ?= "." st) + (modify-syntax-entry ?% "." st) + (modify-syntax-entry ?< "." st) + (modify-syntax-entry ?> "." st) + (modify-syntax-entry ?& "." st) + (modify-syntax-entry ?| "." st) + (modify-syntax-entry ?_ "_" st) + (modify-syntax-entry ?\' "\"" st) + st) + "Syntax table in use in sieve-mode buffers.") + + +;; Key map definition + +(defvar sieve-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-c\C-l" 'sieve-upload) + (define-key map "\C-c\C-c" 'sieve-upload-and-kill) + (define-key map "\C-c\C-m" 'sieve-manage) + map) + "Key map used in sieve mode.") + +;; Menu + +(easy-menu-define sieve-mode-menu sieve-mode-map + "Sieve Menu." + '("Sieve" + ["Upload script" sieve-upload t] + ["Manage scripts on server" sieve-manage t])) + +;; Code for Sieve editing mode. + + +(defun sieve-syntax-propertize (beg end) + (goto-char beg) + (sieve-syntax-propertize-text end) + (funcall + (syntax-propertize-rules + ;; FIXME: When there's a "text:" with a # comment, the \n plays dual role: + ;; it closes the comment and starts the string. This is problematic for us + ;; since syntax-table entries can either close a comment or + ;; delimit a string, but not both. + ("\\_<text:[ \t]*\\(?:#.*\\(.\\)\\)?\\(\n\\)" + (1 ">") + (2 (prog1 (unless (save-excursion + (nth 8 (syntax-ppss (match-beginning 0)))) + (string-to-syntax "|")) + (sieve-syntax-propertize-text end))))) + beg end)) + +(defun sieve-syntax-propertize-text (end) + (let ((ppss (syntax-ppss))) + (when (and (eq t (nth 3 ppss)) + (re-search-forward "^\\.\\(\n\\)" end 'move)) + (put-text-property (match-beginning 1) (match-end 1) + 'syntax-table (string-to-syntax "|"))))) + +;;;###autoload +(define-derived-mode sieve-mode c-mode "Sieve" + "Major mode for editing Sieve code. +This is much like C mode except for the syntax of comments. Its keymap +inherits from C mode's and it has the same variables for customizing +indentation. It has its own abbrev table and its own syntax table. + +Turning on Sieve mode runs `sieve-mode-hook'." + (set (make-local-variable 'paragraph-start) (concat "$\\|" page-delimiter)) + (set (make-local-variable 'paragraph-separate) paragraph-start) + (set (make-local-variable 'comment-start) "#") + (set (make-local-variable 'comment-end) "") + ;;(set (make-local-variable 'comment-start-skip) "\\(^\\|\\s-\\);?#+ *") + (set (make-local-variable 'comment-start-skip) "#+ *") + (set (make-local-variable 'syntax-propertize-function) + #'sieve-syntax-propertize) + (set (make-local-variable 'font-lock-defaults) + '(sieve-font-lock-keywords nil nil ((?_ . "w")))) + (easy-menu-add-item nil nil sieve-mode-menu)) + +(provide 'sieve-mode) + +;; sieve-mode.el ends here diff --git a/lisp/net/sieve.el b/lisp/net/sieve.el new file mode 100644 index 00000000000..2046e53697d --- /dev/null +++ b/lisp/net/sieve.el @@ -0,0 +1,372 @@ +;;; sieve.el --- Utilities to manage sieve scripts + +;; Copyright (C) 2001-2016 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> + +;; 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 file contain utilities to facilitate upload, download and +;; general management of sieve scripts. Currently only the +;; Managesieve protocol is supported (using sieve-manage.el), but when +;; (useful) alternatives become available, they might be supported as +;; well. +;; +;; The cursor navigation was inspired by biff-mode by Franklin Lee. +;; +;; Release history: +;; +;; 2001-10-31 Committed to Oort Gnus. +;; 2002-07-27 Fix down-mouse-2 and down-mouse-3 in manage-mode. Fix menubar +;; in manage-mode. Change some messages. Added sieve-deactivate*, +;; sieve-remove. Fixed help text in manage-mode. Suggested by +;; Ned Ludd. +;; +;; Todo: +;; +;; * Namespace? This file contains `sieve-manage' and +;; `sieve-manage-mode', but there is a sieve-manage.el file as well. +;; Can't think of a good solution though, this file need a *-mode, +;; and naming it `sieve-mode' would collide with sieve-mode.el. One +;; solution would be to come up with some better name that this file +;; can use that doesn't have the managesieve specific "manage" in +;; it. sieve-dired? i dunno. we could copy all off sieve.el into +;; sieve-manage.el too, but I'd like to separate the interface from +;; the protocol implementation since the backends are likely to +;; change (well). +;; +;; * Define servers? We could have a customize buffer to create a server, +;; with authentication/stream/etc parameters, much like Gnus, and then +;; only use names of defined servers when interacting with M-x sieve-*. +;; Right now you can't use STARTTLS, which sieve-manage.el provides + +;;; Code: + +(require 'sieve-manage) +(require 'sieve-mode) + +;; User customizable variables: + +(defgroup sieve nil + "Manage sieve scripts." + :version "22.1" + :group 'tools) + +(defcustom sieve-new-script "<new script>" + "Name of name script indicator." + :type 'string + :group 'sieve) + +(defcustom sieve-buffer "*sieve*" + "Name of sieve management buffer." + :type 'string + :group 'sieve) + +(defcustom sieve-template "\ +require \"fileinto\"; + +# Example script (remove comment character '#' to make it effective!): +# +# if header :contains \"from\" \"coyote\" { +# discard; +# } elsif header :contains [\"subject\"] [\"$$$\"] { +# discard; +# } else { +# fileinto \"INBOX\"; +# } +" + "Template sieve script." + :type 'string + :group 'sieve) + +;; Internal variables: + +(defvar sieve-manage-buffer nil) +(defvar sieve-buffer-header-end nil) +(defvar sieve-buffer-script-name nil + "The real script name of the buffer.") +(make-local-variable 'sieve-buffer-script-name) + +;; Sieve-manage mode: + +(defvar sieve-manage-mode-map + (let ((map (make-sparse-keymap))) + ;; various + (define-key map "?" 'sieve-help) + (define-key map "h" 'sieve-help) + ;; activating + (define-key map "m" 'sieve-activate) + (define-key map "u" 'sieve-deactivate) + (define-key map "\M-\C-?" 'sieve-deactivate-all) + ;; navigation keys + (define-key map "\C-p" 'sieve-prev-line) + (define-key map [up] 'sieve-prev-line) + (define-key map "\C-n" 'sieve-next-line) + (define-key map [down] 'sieve-next-line) + (define-key map " " 'sieve-next-line) + (define-key map "n" 'sieve-next-line) + (define-key map "p" 'sieve-prev-line) + (define-key map "\C-m" 'sieve-edit-script) + (define-key map "f" 'sieve-edit-script) + (define-key map "o" 'sieve-edit-script-other-window) + (define-key map "r" 'sieve-remove) + (define-key map "q" 'sieve-bury-buffer) + (define-key map "Q" 'sieve-manage-quit) + (define-key map [(down-mouse-2)] 'sieve-edit-script) + (define-key map [(down-mouse-3)] 'sieve-manage-mode-menu) + map) + "Keymap for `sieve-manage-mode'.") + +(easy-menu-define sieve-manage-mode-menu sieve-manage-mode-map + "Sieve Menu." + '("Manage Sieve" + ["Edit script" sieve-edit-script t] + ["Activate script" sieve-activate t] + ["Deactivate script" sieve-deactivate t])) + +(define-derived-mode sieve-manage-mode fundamental-mode "Sieve-manage" + "Mode used for sieve script management." + (buffer-disable-undo (current-buffer)) + (setq truncate-lines t) + (easy-menu-add sieve-manage-mode-menu sieve-manage-mode-map)) + +(put 'sieve-manage-mode 'mode-class 'special) + +;; Commands used in sieve-manage mode: + +(defun sieve-manage-quit () + "Quit Manage Sieve and close the connection." + (interactive) + (sieve-manage-close sieve-manage-buffer) + (kill-buffer sieve-manage-buffer) + (kill-buffer (current-buffer))) + +(defun sieve-bury-buffer () + "Bury the Manage Sieve buffer without closing the connection." + (interactive) + (bury-buffer)) + +(defun sieve-activate (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (when (or (null name) (string-equal name sieve-new-script)) + (error "No sieve script at point")) + (message "Activating script %s..." name) + (setq err (sieve-manage-setactive name sieve-manage-buffer)) + (sieve-refresh-scriptlist) + (if (sieve-manage-ok-p err) + (message "Activating script %s...done" name) + (message "Activating script %s...failed: %s" name (nth 2 err))))) + +(defun sieve-deactivate-all (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (message "Deactivating scripts...") + (setq err (sieve-manage-setactive "" sieve-manage-buffer)) + (sieve-refresh-scriptlist) + (if (sieve-manage-ok-p err) + (message "Deactivating scripts...done") + (message "Deactivating scripts...failed: %s" (nth 2 err))))) + +(defalias 'sieve-deactivate 'sieve-deactivate-all) + +(defun sieve-remove (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point)) err) + (when (or (null name) (string-equal name sieve-new-script)) + (error "No sieve script at point")) + (message "Removing sieve script %s..." name) + (setq err (sieve-manage-deletescript name sieve-manage-buffer)) + (unless (sieve-manage-ok-p err) + (error "Removing sieve script %s...failed: " err)) + (sieve-refresh-scriptlist) + (message "Removing sieve script %s...done" name))) + +(defun sieve-edit-script (&optional pos) + (interactive "d") + (let ((name (sieve-script-at-point))) + (unless name + (error "No sieve script at point")) + (if (not (string-equal name sieve-new-script)) + (let ((newbuf (generate-new-buffer name)) + err) + (setq err (sieve-manage-getscript name newbuf sieve-manage-buffer)) + (switch-to-buffer newbuf) + (unless (sieve-manage-ok-p err) + (error "Sieve download failed: %s" err))) + (switch-to-buffer (get-buffer-create "template.siv")) + (insert sieve-template)) + (sieve-mode) + (setq sieve-buffer-script-name name) + (goto-char (point-min)) + (message + (substitute-command-keys + "Press \\[sieve-upload] to upload script to server.")))) + +(defmacro sieve-change-region (&rest body) + "Turns off sieve-region before executing BODY, then re-enables it after. +Used to bracket operations which move point in the sieve-buffer." + `(progn + (sieve-highlight nil) + ,@body + (sieve-highlight t))) +(put 'sieve-change-region 'lisp-indent-function 0) + +(defun sieve-next-line (&optional arg) + (interactive) + (unless arg + (setq arg 1)) + (if (save-excursion + (forward-line arg) + (sieve-script-at-point)) + (sieve-change-region + (forward-line arg)) + (message "End of list"))) + +(defun sieve-prev-line (&optional arg) + (interactive) + (unless arg + (setq arg -1)) + (if (save-excursion + (forward-line arg) + (sieve-script-at-point)) + (sieve-change-region + (forward-line arg)) + (message "Beginning of list"))) + +(defun sieve-help () + "Display help for various sieve commands." + (interactive) + (if (eq last-command 'sieve-help) + ;; would need minor-mode for log-edit-mode + (describe-function 'sieve-mode) + (message "%s" (substitute-command-keys + "`\\[sieve-edit-script]':edit `\\[sieve-activate]':activate `\\[sieve-deactivate]':deactivate `\\[sieve-remove]':remove")))) + +;; Create buffer: + +(defun sieve-setup-buffer (server port) + (setq buffer-read-only nil) + (erase-buffer) + (buffer-disable-undo) + (let* ((port (or port sieve-manage-default-port)) + (header (format "Server : %s:%s\n\n" server port))) + (insert header)) + (set (make-local-variable 'sieve-buffer-header-end) + (point-max))) + +(defun sieve-script-at-point (&optional pos) + "Return name of sieve script at point POS, or nil." + (interactive "d") + (get-char-property (or pos (point)) 'script-name)) + +(defun sieve-highlight (on) + "Turn ON or off highlighting on the current language overlay." + (overlay-put (car (overlays-at (point))) 'face (if on 'highlight 'default))) + +(defun sieve-insert-scripts (scripts) + "Format and insert LANGUAGE-LIST strings into current buffer at point." + (while scripts + (let ((p (point)) + (ext nil) + (script (pop scripts))) + (if (consp script) + (insert (format " ACTIVE %s" (cdr script))) + (insert (format " %s" script))) + (setq ext (make-overlay p (point))) + (overlay-put ext 'mouse-face 'highlight) + (overlay-put ext 'script-name (if (consp script) + (cdr script) + script)) + (insert "\n")))) + +(defun sieve-open-server (server &optional port) + "Open SERVER (on PORT) and authenticate." + (with-current-buffer + (or ;; open server + (set (make-local-variable 'sieve-manage-buffer) + (sieve-manage-open server port)) + (error "Error opening server %s" server)) + (sieve-manage-authenticate))) + +(defun sieve-refresh-scriptlist () + (interactive) + (with-current-buffer sieve-buffer + (setq buffer-read-only nil) + (delete-region (or sieve-buffer-header-end (point-max)) (point-max)) + (goto-char (point-max)) + ;; get list of script names and print them + (let ((scripts (sieve-manage-listscripts sieve-manage-buffer))) + (if (null scripts) + (insert + (substitute-command-keys + (format + "No scripts on server, press \\[sieve-edit-script] on %s to create a new script.\n" + sieve-new-script))) + (insert + (substitute-command-keys + (format (concat "%d script%s on server, press \\[sieve-edit-script] on a script " + "name edits it, or\npress \\[sieve-edit-script] on %s to create " + "a new script.\n") (length scripts) + (if (eq (length scripts) 1) "" "s") + sieve-new-script)))) + (save-excursion + (sieve-insert-scripts (list sieve-new-script)) + (sieve-insert-scripts scripts))) + (sieve-highlight t) + (setq buffer-read-only t))) + +;;;###autoload +(defun sieve-manage (server &optional port) + (interactive "sServer: ") + (switch-to-buffer (get-buffer-create sieve-buffer)) + (sieve-manage-mode) + (sieve-setup-buffer server port) + (if (sieve-open-server server port) + (sieve-refresh-scriptlist) + (message "Could not open server %s" server))) + +;;;###autoload +(defun sieve-upload (&optional name) + (interactive) + (when (or (get-buffer sieve-buffer) (call-interactively 'sieve-manage)) + (let ((script (buffer-string)) err) + (with-current-buffer (get-buffer sieve-buffer) + (setq err (sieve-manage-putscript + (or name sieve-buffer-script-name (buffer-name)) + script sieve-manage-buffer)) + (if (sieve-manage-ok-p err) + (message (substitute-command-keys + "Sieve upload done. Use \\[sieve-manage] to manage scripts.")) + (message "Sieve upload failed: %s" (nth 2 err))))))) + +;;;###autoload +(defun sieve-upload-and-bury (&optional name) + (interactive) + (sieve-upload name) + (bury-buffer)) + +;;;###autoload +(defun sieve-upload-and-kill (&optional name) + (interactive) + (sieve-upload name) + (kill-buffer)) + +(provide 'sieve) + +;; sieve.el ends here diff --git a/lisp/net/soap-client.el b/lisp/net/soap-client.el index 12c9f419555..f8973a3a537 100644 --- a/lisp/net/soap-client.el +++ b/lisp/net/soap-client.el @@ -5,7 +5,7 @@ ;; Author: Alexandru Harsanyi <AlexHarsanyi@gmail.com> ;; Author: Thomas Fitzsimmons <fitzsim@fitzsim.org> ;; Created: December, 2009 -;; Version: 3.0.2 +;; Version: 3.1.1 ;; Keywords: soap, web-services, comm, hypermedia ;; Package: soap-client ;; Homepage: https://github.com/alex-hhh/emacs-soap-client @@ -1249,8 +1249,8 @@ See also `soap-wsdl-resolve-references'." (when messages (error (mapconcat 'identity (nreverse messages) "; and: ")))) (cl-labels ((fail-with-message (format value) - (push (format format value) messages) - (throw 'invalid nil))) + (push (format format value) messages) + (throw 'invalid nil))) (catch 'invalid (let ((enumeration (soap-xs-simple-type-enumeration type))) (when (and (> (length enumeration) 1) @@ -1630,7 +1630,7 @@ This is a specialization of `soap-encode-value' for `soap-xs-complex-type' objects." (case (soap-xs-complex-type-indicator type) (array - (error "soap-encode-xs-complex-type arrays are handled elsewhere")) + (error "Arrays of type soap-encode-xs-complex-type are handled elsewhere")) ((sequence choice all nil) (let ((type-list (list type))) @@ -2999,6 +2999,33 @@ http://schemas.xmlsoap.org/soap/encoding/\"\n")) :type 'boolean :group 'soap-client) +(defun soap-find-port (wsdl service) + "Return the WSDL port having SERVICE name. +Signal an error if not found." + (or (catch 'found + (dolist (p (soap-wsdl-ports wsdl)) + (when (equal service (soap-element-name p)) + (throw 'found p)))) + (error "Unknown SOAP service: %s" service))) + +(defun soap-find-operation (port operation-name) + "Inside PORT, find OPERATION-NAME, a `soap-port-type'. +Signal an error if not found." + (let* ((binding (soap-port-binding port)) + (op (gethash operation-name (soap-binding-operations binding)))) + (or op + (error "No operation %s for SOAP service %s" + operation-name (soap-element-name port))))) + +(defun soap-operation-arity (wsdl service operation-name) + "Return the number of arguments required by a soap operation. +WSDL, SERVICE, OPERATION-NAME and PARAMETERS are as described in +`soap-invoke'." + (let* ((port (soap-find-port wsdl service)) + (op (soap-find-operation port operation-name)) + (bop (soap-bound-operation-operation op))) + (length (soap-operation-parameter-order bop)))) + (defun soap-invoke-internal (callback cbargs wsdl service operation-name &rest parameters) "Implement `soap-invoke' and `soap-invoke-async'. @@ -3006,54 +3033,43 @@ If CALLBACK is non-nil, operate asynchronously, then call CALLBACK as (apply CALLBACK RESPONSE CBARGS), where RESPONSE is the SOAP invocation result. If CALLBACK is nil, operate synchronously. WSDL, SERVICE, OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." - (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-request-data - ;; url-request-data expects a unibyte string already encoded... - (encode-coding-string - (soap-create-envelope operation parameters wsdl - (soap-port-service-url port)) - 'utf-8)) - (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") - (url-http-attempt-keepalives t) - (url-request-extra-headers - (list - (cons "SOAPAction" - (concat "\"" (soap-bound-operation-soap-action - operation) "\"")) - (cons "Content-Type" - "text/xml; charset=utf-8")))) - (if callback - (url-retrieve - (soap-port-service-url port) - (lambda (status) - (let ((data-buffer (current-buffer))) - (unwind-protect - (let ((error-status (plist-get status :error))) - (if error-status - (signal (car error-status) (cdr error-status)) - (apply callback - (soap-parse-envelope - (soap-parse-server-response) - operation wsdl) - cbargs))) - ;; Ensure the url-retrieve buffer is not leaked. - (and (buffer-live-p data-buffer) - (kill-buffer data-buffer)))))) + (let* ((port (soap-find-port wsdl service)) + (operation (soap-find-operation port operation-name))) + (let ((url-request-method "POST") + (url-package-name "soap-client.el") + (url-package-version "1.0") + (url-request-data + ;; url-request-data expects a unibyte string already encoded... + (encode-coding-string + (soap-create-envelope operation parameters wsdl + (soap-port-service-url port)) + 'utf-8)) + (url-mime-charset-string "utf-8;q=1, iso-8859-1;q=0.5") + (url-http-attempt-keepalives t) + (url-request-extra-headers + (list + (cons "SOAPAction" + (concat "\"" (soap-bound-operation-soap-action + operation) "\"")) + (cons "Content-Type" + "text/xml; charset=utf-8")))) + (if callback + (url-retrieve + (soap-port-service-url port) + (lambda (status) + (let ((data-buffer (current-buffer))) + (unwind-protect + (let ((error-status (plist-get status :error))) + (if error-status + (signal (car error-status) (cdr error-status)) + (apply callback + (soap-parse-envelope + (soap-parse-server-response) + operation wsdl) + cbargs))) + ;; Ensure the url-retrieve buffer is not leaked. + (and (buffer-live-p data-buffer) + (kill-buffer data-buffer)))))) (let ((buffer (url-retrieve-synchronously (soap-port-service-url port)))) (condition-case err @@ -3077,7 +3093,7 @@ OPERATION-NAME and PARAMETERS are as described in `soap-invoke'." (error (when soap-debug (pop-to-buffer buffer)) - (error (error-message-string err)))))))))) + (error (error-message-string err))))))))) (defun soap-invoke (wsdl service operation-name &rest parameters) "Invoke a SOAP operation and return the result. diff --git a/lisp/net/starttls.el b/lisp/net/starttls.el new file mode 100644 index 00000000000..096ed2adc0d --- /dev/null +++ b/lisp/net/starttls.el @@ -0,0 +1,304 @@ +;;; starttls.el --- STARTTLS functions + +;; Copyright (C) 1999-2016 Free Software Foundation, Inc. + +;; Author: Daiki Ueno <ueno@unixuser.org> +;; Author: Simon Josefsson <simon@josefsson.org> +;; Created: 1999/11/20 +;; Keywords: TLS, SSL, OpenSSL, GnuTLS, mail, news + +;; 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 module defines some utility functions for STARTTLS profiles. + +;; [RFC 2595] "Using TLS with IMAP, POP3 and ACAP" +;; by Chris Newman <chris.newman@innosoft.com> (1999/06) + +;; This file now contains a combination of the two previous +;; implementations both called "starttls.el". The first one is Daiki +;; Ueno's starttls.el which uses his own "starttls" command line tool, +;; and the second one is Simon Josefsson's starttls.el which uses +;; "gnutls-cli" from GnuTLS. +;; +;; If "starttls" is available, it is preferred by the code over +;; "gnutls-cli", for backwards compatibility. Use +;; `starttls-use-gnutls' to toggle between implementations if you have +;; both tools installed. It is recommended to use GnuTLS, though, as +;; it performs more verification of the certificates. + +;; The GnuTLS support requires GnuTLS 0.9.90 (released 2003-10-08) or +;; later, from <http://www.gnu.org/software/gnutls/>, or "starttls" +;; from <ftp://ftp.opaopa.org/pub/elisp/>. + +;; Usage is similar to `open-network-stream'. For example: +;; +;; (when (setq tmp (starttls-open-stream +;; "test" (current-buffer) "yxa.extundo.com" 25)) +;; (accept-process-output tmp 15) +;; (process-send-string tmp "STARTTLS\n") +;; (accept-process-output tmp 15) +;; (message "STARTTLS output:\n%s" (starttls-negotiate tmp)) +;; (process-send-string tmp "EHLO foo\n")) + +;; An example run yields the following output: +;; +;; 220 yxa.extundo.com ESMTP Sendmail 8.12.11/8.12.11/Debian-3; Wed, 26 May 2004 19:12:29 +0200; (No UCE/UBE) logging access from: c494102a.s-bi.bostream.se(OK)-c494102a.s-bi.bostream.se [217.215.27.65] +;; 220 2.0.0 Ready to start TLS +;; 250-yxa.extundo.com Hello c494102a.s-bi.bostream.se [217.215.27.65], pleased to meet you +;; 250-ENHANCEDSTATUSCODES +;; 250-PIPELINING +;; 250-EXPN +;; 250-VERB +;; 250-8BITMIME +;; 250-SIZE +;; 250-DSN +;; 250-ETRN +;; 250-AUTH DIGEST-MD5 CRAM-MD5 PLAIN LOGIN +;; 250-DELIVERBY +;; 250 HELP +;; nil +;; +;; With the message buffer containing: +;; +;; STARTTLS output: +;; *** Starting TLS handshake +;; - Server's trusted authorities: +;; [0]: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; - Certificate type: X.509 +;; - Got a certificate list of 2 certificates. +;; +;; - Certificate[0] info: +;; # The hostname in the certificate matches 'yxa.extundo.com'. +;; # valid since: Wed May 26 12:16:00 CEST 2004 +;; # expires at: Wed Jul 26 12:16:00 CEST 2023 +;; # serial number: 04 +;; # fingerprint: 7c 04 4b c1 fa 26 9b 5d 90 22 52 3c 65 3d 85 3a +;; # version: #1 +;; # public key algorithm: RSA +;; # Modulus: 1024 bits +;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=Mail server,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; +;; - Certificate[1] info: +;; # valid since: Sun May 23 11:35:00 CEST 2004 +;; # expires at: Sun Jul 23 11:35:00 CEST 2023 +;; # serial number: 00 +;; # fingerprint: fc 76 d8 63 1a c9 0b 3b fa 40 fe ed 47 7a 58 ae +;; # version: #3 +;; # public key algorithm: RSA +;; # Modulus: 1024 bits +;; # Subject's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; # Issuer's DN: C=SE,ST=Stockholm,L=Stockholm,O=YXA,OU=CA,CN=yxa.extundo.com,EMAIL=staff@yxa.extundo.com +;; +;; - Peer's certificate issuer is unknown +;; - Peer's certificate is NOT trusted +;; - Version: TLS 1.0 +;; - Key Exchange: RSA +;; - Cipher: ARCFOUR 128 +;; - MAC: SHA +;; - Compression: NULL + +;;; Code: + +(defgroup starttls nil + "Support for `Transport Layer Security' protocol." + :version "21.1" + :group 'mail) + +(defcustom starttls-gnutls-program "gnutls-cli" + "Name of GnuTLS command line tool. +This program is used when GnuTLS is used, i.e. when +`starttls-use-gnutls' is non-nil." + :version "22.1" + :type 'string + :group 'starttls) + +(defcustom starttls-program "starttls" + "The program to run in a subprocess to open an TLSv1 connection. +This program is used when the `starttls' command is used, +i.e. when `starttls-use-gnutls' is nil." + :type 'string + :group 'starttls) + +(defcustom starttls-use-gnutls (not (executable-find starttls-program)) + "*Whether to use GnuTLS instead of the `starttls' command." + :version "22.1" + :type 'boolean + :group 'starttls) + +(defcustom starttls-extra-args nil + "Extra arguments to `starttls-program'. +These apply when the `starttls' command is used, i.e. when +`starttls-use-gnutls' is nil." + :type '(repeat string) + :group 'starttls) + +(defcustom starttls-extra-arguments nil + "Extra arguments to `starttls-gnutls-program'. +These apply when GnuTLS is used, i.e. when `starttls-use-gnutls' is non-nil. + +For example, non-TLS compliant servers may require +'(\"--protocols\" \"ssl3\"). Invoke \"gnutls-cli --help\" to +find out which parameters are available." + :version "22.1" + :type '(repeat string) + :group 'starttls) + +(defcustom starttls-process-connection-type nil + "*Value for `process-connection-type' to use when starting STARTTLS process." + :version "22.1" + :type 'boolean + :group 'starttls) + +(defcustom starttls-connect "- Simple Client Mode:\n\n" + "*Regular expression indicating successful connection. +The default is what GnuTLS's \"gnutls-cli\" outputs." + ;; GnuTLS cli.c:main() prints this string when it is starting to run + ;; in the application read/write phase. If the logic, or the string + ;; itself, is modified, this must be updated. + :version "22.1" + :type 'regexp + :group 'starttls) + +(defcustom starttls-failure "\\*\\*\\* Handshake has failed" + "*Regular expression indicating failed TLS handshake. +The default is what GnuTLS's \"gnutls-cli\" outputs." + ;; GnuTLS cli.c:do_handshake() prints this string on failure. If the + ;; logic, or the string itself, is modified, this must be updated. + :version "22.1" + :type 'regexp + :group 'starttls) + +(defcustom starttls-success "- Compression: " + "*Regular expression indicating completed TLS handshakes. +The default is what GnuTLS's \"gnutls-cli\" outputs." + ;; GnuTLS cli.c:do_handshake() calls, on success, + ;; common.c:print_info(), that unconditionally print this string + ;; last. If that logic, or the string itself, is modified, this + ;; must be updated. + :version "22.1" + :type 'regexp + :group 'starttls) + +(defun starttls-negotiate-gnutls (process) + "Negotiate TLS on PROCESS opened by `open-starttls-stream'. +This should typically only be done once. It typically returns a +multi-line informational message with information about the +handshake, or nil on failure." + (let (buffer info old-max done-ok done-bad) + (if (null (setq buffer (process-buffer process))) + ;; XXX How to remove/extract the TLS negotiation junk? + (signal-process (process-id process) 'SIGALRM) + (with-current-buffer buffer + (save-excursion + (setq old-max (goto-char (point-max))) + (signal-process (process-id process) 'SIGALRM) + (while (and (processp process) + (eq (process-status process) 'run) + (save-excursion + (goto-char old-max) + (not (or (setq done-ok (re-search-forward + starttls-success nil t)) + (setq done-bad (re-search-forward + starttls-failure nil t)))))) + (accept-process-output process 1 100) + (sit-for 0.1)) + (setq info (buffer-substring-no-properties old-max (point-max))) + (delete-region old-max (point-max)) + (if (or (and done-ok (not done-bad)) + ;; Prevent mitm that fake success msg after failure msg. + (and done-ok done-bad (< done-ok done-bad))) + info + (message "STARTTLS negotiation failed: %s" info) + nil)))))) + +(defun starttls-negotiate (process) + (if starttls-use-gnutls + (starttls-negotiate-gnutls process) + (signal-process (process-id process) 'SIGALRM))) + +(defun starttls-open-stream-gnutls (name buffer host port) + (message "Opening STARTTLS connection to `%s:%s'..." host port) + (let* (done + (old-max (with-current-buffer buffer (point-max))) + (process-connection-type starttls-process-connection-type) + (process (apply #'start-process name buffer + starttls-gnutls-program "-s" host + "-p" (if (integerp port) + (int-to-string port) + port) + starttls-extra-arguments))) + (set-process-query-on-exit-flag process nil) + (while (and (processp process) + (eq (process-status process) 'run) + (with-current-buffer buffer + (goto-char old-max) + (not (setq done (re-search-forward + starttls-connect nil t))))) + (accept-process-output process 0 100) + (sit-for 0.1)) + (if done + (with-current-buffer buffer + (delete-region old-max done)) + (delete-process process) + (setq process nil)) + (message "Opening STARTTLS connection to `%s:%s'...%s" + host port (if done "done" "failed")) + process)) + +;;;###autoload +(defun starttls-open-stream (name buffer host port) + "Open a TLS connection for a port to a host. +Returns a subprocess object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST PORT. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or `buffer-name') to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is name of the host to connect to, or its IP address. +Fourth arg PORT is an integer specifying a port to connect to. +If `starttls-use-gnutls' is nil, this may also be a service name, but +GnuTLS requires a port number." + (if starttls-use-gnutls + (starttls-open-stream-gnutls name buffer host port) + (message "Opening STARTTLS connection to `%s:%s'" host (format "%s" port)) + (let* ((process-connection-type starttls-process-connection-type) + (process (apply #'start-process + name buffer starttls-program + host (format "%s" port) + starttls-extra-args))) + (set-process-query-on-exit-flag process nil) + process))) + +(defun starttls-available-p () + "Say whether the STARTTLS programs are available." + (and (not (memq system-type '(windows-nt ms-dos))) + (executable-find (if starttls-use-gnutls + starttls-gnutls-program + starttls-program)))) + +(defalias 'starttls-any-program-available 'starttls-available-p) +(make-obsolete 'starttls-any-program-available 'starttls-available-p + "2011-08-02") + +(provide 'starttls) + +;;; starttls.el ends here diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 32fd1888d36..5940b713958 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -35,10 +35,6 @@ (require 'tramp) -;; Pacify byte-compiler. -(defvar directory-listing-before-filename-regexp) -(defvar directory-sep-char) - ;;;###tramp-autoload (defcustom tramp-adb-program "adb" "Name of the Android Debug Bridge program." @@ -109,7 +105,6 @@ It is used for TCP/IP devices." (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-adb-handle-directory-files-and-attributes) - (dired-call-process . ignore) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-adb-handle-expand-file-name) @@ -162,7 +157,7 @@ It is used for TCP/IP devices." (shell-command . tramp-adb-handle-shell-command) (start-file-process . tramp-adb-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) + (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-adb-handle-write-region)) @@ -199,7 +194,7 @@ pass to the OPERATION." tramp-current-host nil nil)) result) (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) (while (eq 'run (process-status p)) (accept-process-output p 0.1)) (accept-process-output p 0.1) @@ -213,7 +208,7 @@ pass to the OPERATION." (lambda (elt) (setcar (cdr elt) - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string ":" tramp-prefix-port-format (car (cdr elt))))) result) result)))) @@ -233,12 +228,9 @@ pass to the OPERATION." (unless (tramp-run-real-handler 'file-name-absolute-p (list localname)) (setq localname (concat "/" 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 ((directory-sep-char ?/) - (default-directory (tramp-compat-temporary-file-directory))) + ;; `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 @@ -261,8 +253,7 @@ pass to the OPERATION." (with-tramp-file-property v localname "file-truename" (let ((result nil)) ; result steps in reverse order (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((directory-sep-char ?/) - (steps (tramp-compat-split-string localname "/")) + (let* ((steps (split-string localname "/" 'omit)) (localnamedir (tramp-run-real-handler 'file-name-as-directory (list localname))) (is-dir (string= localname localnamedir)) @@ -312,8 +303,7 @@ pass to the OPERATION." "Symlink target `%s' on wrong host" symlink-target)) (setq symlink-target localname)) (setq steps - (append (tramp-compat-split-string - symlink-target "/") + (append (split-string symlink-target "/" 'omit) steps))) (t ;; It's a file. @@ -450,9 +440,8 @@ Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." (split-string (apply 'concat (mapcar (lambda (s) - (tramp-compat-replace-regexp-in-string - "\\(.\\)" " -\\1" - (tramp-compat-replace-regexp-in-string "^-" "" s))) + (replace-regexp-in-string + "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) ;; FIXME: Warning about removed switches (long and non-dash). (delq nil (mapcar @@ -585,8 +574,7 @@ Emacs dired can't find files." v 'file-error "Cannot make local copy of file `%s'" filename)) (set-file-modes tmpfile - (logior (or (file-modes filename) 0) - (tramp-compat-octal-to-decimal "0400")))) + (logior (or (file-modes filename) 0) (string-to-number "0400" 8)))) tmpfile))) (defun tramp-adb-handle-file-writable-p (filename) @@ -631,8 +619,7 @@ But handle the case, if the \"test\" command is not available." (copy-file filename tmpfile 'ok) (set-file-modes tmpfile - (logior (or (file-modes tmpfile) 0) - (tramp-compat-octal-to-decimal "0600")))) + (logior (or (file-modes tmpfile) 0) (string-to-number "0600" 8)))) (tramp-run-real-handler 'write-region (list start end tmpfile append 'no-message lockname confirm)) @@ -657,8 +644,7 @@ But handle the case, if the \"test\" command is not available." (with-parsed-tramp-file-name filename nil (tramp-flush-file-property v (file-name-directory localname)) (tramp-flush-file-property v localname) - (tramp-adb-send-command-and-check - v (format "chmod %s %s" (tramp-compat-decimal-to-octal mode) localname)))) + (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) (defun tramp-adb-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." @@ -736,10 +722,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (tramp-file-name-handler - 'file-remote-p filename 'localname)) - (l2 (tramp-file-name-handler - 'file-remote-p newname 'localname))) + (let ((l1 (file-remote-p filename 'localname)) + (l2 (file-remote-p newname 'localname))) (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) @@ -755,7 +739,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Error renaming %s to %s" filename newname)) ;; Rename by copy. - (copy-file filename newname ok-if-already-exists t t) + (copy-file + filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) (delete-file filename)))))) (defun tramp-adb-handle-process-file @@ -856,12 +841,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to nil, no remote file will be changed - ;; by `program'. If it doesn't exist, we assume its default - ;; value t. - (unless (and (boundp 'process-file-side-effects) - (not (symbol-value 'process-file-side-effects))) + (unless process-file-side-effects (tramp-flush-directory-property v "")) ;; Return exit status. @@ -941,9 +921,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (current-buffer)))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (if (functionp 'display-message-or-buffer) - (tramp-compat-funcall 'display-message-or-buffer output-buffer) - (pop-to-buffer output-buffer)))))))) + (display-message-or-buffer output-buffer))))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -1008,7 +986,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; process. We ignore errors, because the process ;; could have finished already. (ignore-errors - (tramp-compat-set-process-query-on-exit-flag p t) + (set-process-query-on-exit-flag p t) (set-marker (process-mark p) (point))) ;; Return process. p)))) @@ -1035,7 +1013,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (host (tramp-file-name-host vec)) (port (tramp-file-name-port vec)) (devices (mapcar 'cadr (tramp-adb-parse-device-names nil)))) - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string tramp-prefix-port-format ":" (cond ((member host devices) host) ;; This is the case when the host is connected to the default port. @@ -1051,7 +1029,7 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" (not (zerop (length host))) (not (tramp-adb-execute-adb-command vec "connect" - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string tramp-prefix-port-format ":" host)))) ;; When new device connected, running other adb command (e.g. ;; adb shell) immediately will fail. To get around this @@ -1205,7 +1183,7 @@ connection if a previous connection has died for some reason." (unless (eq 'run (process-status p)) (tramp-error vec 'file-error "Terminated!")) (tramp-set-connection-property p "vector" vec) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) ;; Check whether the properties have been changed. If ;; yes, this is a strong indication that we must expire all @@ -1250,7 +1228,7 @@ connection if a previous connection has died for some reason." ;; Read the expression. (goto-char (point-min)) (read (current-buffer))) - ":" 'omit-nulls)) + ":" 'omit)) ;; Mark it as connected. (tramp-set-connection-property p "connected" t))))))) diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 26825ffa2dd..158cfb5cae3 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -75,25 +75,7 @@ details see the info pages." (choice :tag " Value" sexp)))) (defcustom tramp-persistency-file-name - (cond - ;; GNU Emacs. - ((and (fboundp 'locate-user-emacs-file)) - (expand-file-name (tramp-compat-funcall 'locate-user-emacs-file "tramp"))) - ((and (boundp 'user-emacs-directory) - (stringp (symbol-value 'user-emacs-directory)) - (file-directory-p (symbol-value 'user-emacs-directory))) - (expand-file-name "tramp" (symbol-value 'user-emacs-directory))) - ((and (not (featurep 'xemacs)) (file-directory-p "~/.emacs.d/")) - "~/.emacs.d/tramp") - ;; XEmacs. - ((and (boundp 'user-init-directory) - (stringp (symbol-value 'user-init-directory)) - (file-directory-p (symbol-value 'user-init-directory))) - (expand-file-name "tramp" (symbol-value 'user-init-directory))) - ((and (featurep 'xemacs) (file-directory-p "~/.xemacs/")) - "~/.xemacs/tramp") - ;; For users without `~/.emacs.d/' or `~/.xemacs/'. - (t "~/.tramp")) + (expand-file-name (locate-user-emacs-file "tramp")) "File which keeps connection history for Tramp connections." :group 'tramp :type 'file) @@ -241,8 +223,10 @@ This is suppressed for temporary buffers." ;;;###tramp-autoload (defun tramp-get-connection-property (key property default) "Get the named PROPERTY for the connection. -KEY identifies the connection, it is either a process or a vector. -If the value is not set for the connection, returns DEFAULT." +KEY identifies the connection, it is either a process or a +vector. A special case is nil, which is used to cache connection +properties of the local machine. If the value is not set for the +connection, returns DEFAULT." ;; Unify key by removing localname and hop from vector. Work with a ;; copy in order to avoid side effects. (when (vectorp key) @@ -259,8 +243,10 @@ If the value is not set for the connection, returns DEFAULT." ;;;###tramp-autoload (defun tramp-set-connection-property (key property value) "Set the named PROPERTY of a connection to VALUE. -KEY identifies the connection, it is either a process or a vector. -PROPERTY is set persistent when KEY is a vector." +KEY identifies the connection, it is either a process or a +vector. A special case is nil, which is used to cache connection +properties of the local machine. PROPERTY is set persistent when +KEY is a vector." ;; Unify key by removing localname and hop from vector. Work with a ;; copy in order to avoid side effects. (when (vectorp key) @@ -276,13 +262,17 @@ PROPERTY is set persistent when KEY is a vector." ;;;###tramp-autoload (defun tramp-connection-property-p (key property) "Check whether named PROPERTY of a connection is defined. -KEY identifies the connection, it is either a process or a vector." +KEY identifies the connection, it is either a process or a +vector. A special case is nil, which is used to cache connection +properties of the local machine." (not (eq (tramp-get-connection-property key property 'undef) 'undef))) ;;;###tramp-autoload (defun tramp-flush-connection-property (key) "Remove all properties identified by KEY. -KEY identifies the connection, it is either a process or a vector." +KEY identifies the connection, it is either a process or a +vector. A special case is nil, which is used to cache connection +properties of the local machine." ;; Unify key by removing localname and hop from vector. Work with a ;; copy in order to avoid side effects. (when (vectorp key) @@ -307,19 +297,14 @@ KEY identifies the connection, it is either a process or a vector." (maphash (lambda (key value) ;; Remove text properties from KEY and VALUE. - ;; `substring-no-properties' does not exist in XEmacs. - (when (functionp 'substring-no-properties) - (when (vectorp key) - (dotimes (i (length key)) - (when (stringp (aref key i)) - (aset key i - (tramp-compat-funcall - 'substring-no-properties (aref key i)))))) - (when (stringp key) - (setq key (tramp-compat-funcall 'substring-no-properties key))) - (when (stringp value) - (setq value - (tramp-compat-funcall 'substring-no-properties value)))) + (when (vectorp key) + (dotimes (i (length key)) + (when (stringp (aref key i)) + (aset key i (substring-no-properties (aref key i)))))) + (when (stringp key) + (setq key (substring-no-properties key))) + (when (stringp value) + (setq value (substring-no-properties value))) ;; Dump. (let ((tmp (format "(%s %s)" @@ -418,8 +403,8 @@ for all methods. Resulting data are derived from connection history." ;; When "emacs -Q" has been called, both variables are nil. ;; We do not load the persistency file then, in order to ;; have a clean test environment. - (or (and (boundp 'init-file-user) (symbol-value 'init-file-user)) - (and (boundp 'site-run-file) (symbol-value 'site-run-file)))) + (or init-file-user + site-run-file)) (condition-case err (with-temp-buffer (insert-file-contents tramp-persistency-file-name) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index e7901bb7861..856011fc0ee 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -31,6 +31,9 @@ (require 'tramp) ;; Pacify byte-compiler. +(declare-function mml-mode "mml") +(declare-function mml-insert-empty-tag "mml") +(declare-function reporter-dump-variable "reporter") (defvar reporter-eval-buffer) (defvar reporter-prompt-for-summary-p) @@ -128,7 +131,7 @@ This includes password cache, file cache, connection cache, buffers." (setq tramp-locked nil) ;; Flush password cache. - (tramp-compat-funcall 'password-reset) + (password-reset) ;; Flush file and connection cache. (clrhash tramp-cache-data) @@ -142,7 +145,7 @@ This includes password cache, file cache, connection cache, buffers." "Kill all remote buffers." (interactive) - ;; Remove all Tramp related buffers. + ;; Remove all Tramp related connections. (tramp-cleanup-all-connections) ;; Remove all buffers with a remote default-directory. @@ -166,7 +169,6 @@ This includes password cache, file cache, connection cache, buffers." (defun tramp-bug () "Submit a bug report to the Tramp developers." (interactive) - (require 'reporter) (catch 'dont-send (let ((reporter-prompt-for-summary-p t)) (reporter-submit-bug-report @@ -185,7 +187,6 @@ This includes password cache, file cache, connection cache, buffers." backup-by-copying-when-mismatch backup-by-copying-when-privileged-mismatch backup-directory-alist - bkup-backup-directory-info password-cache password-cache-expiry remote-file-name-inhibit-cache @@ -194,8 +195,7 @@ This includes password cache, file cache, connection cache, buffers." 'tramp-load-report-modules ; pre-hook 'tramp-append-tramp-buffers ; post-hook - (tramp-compat-funcall - (if (functionp 'propertize) 'propertize 'progn) + (propertize "\n" 'display "\ Enter your bug report in this message, including as much detail as you possibly can about the problem, what you did to cause it @@ -243,7 +243,7 @@ buffer in your bug report. (base64-encode-string (encode-coding-string val 'raw-text))))))) ;; Dump variable. - (tramp-compat-funcall 'reporter-dump-variable varsym mailbuf) + (reporter-dump-variable varsym mailbuf) (unless (hash-table-p val) ;; Remove string quotation. @@ -264,15 +264,8 @@ buffer in your bug report. (defun tramp-load-report-modules () "Load needed modules for reporting." - ;; We load message.el and mml.el from Gnus. - (if (featurep 'xemacs) - (progn - (load "message" 'noerror) - (load "mml" 'noerror)) - (require 'message nil 'noerror) - (require 'mml nil 'noerror)) - (tramp-compat-funcall 'message-mode) - (tramp-compat-funcall 'mml-mode t)) + (message-mode) + (mml-mode t)) (defun tramp-append-tramp-buffers () "Append Tramp buffers and buffer local variables into the bug report." @@ -303,7 +296,7 @@ buffer in your bug report. ;; Non-tramp variables of interest. '(default-directory)) 'string<)) - (tramp-compat-funcall 'reporter-dump-variable varsym elbuf)) + (reporter-dump-variable varsym elbuf)) (lisp-indent-line) (insert ")\n")) (insert-buffer-substring elbuf))) @@ -313,7 +306,7 @@ buffer in your bug report. (ignore-errors (mapc (lambda (x) (when (string-match "tramp" x) (insert x "\n"))) - (split-string (tramp-compat-funcall 'list-load-path-shadows t) "\n"))) + (split-string (list-load-path-shadows t) "\n"))) ;; Append buffers only when we are in message mode. (when (and @@ -322,7 +315,7 @@ buffer in your bug report. (symbol-value 'mml-mode)) (let ((tramp-buf-regexp "\\*\\(debug \\)?tramp/") - (buffer-list (tramp-compat-funcall 'tramp-list-tramp-buffers)) + (buffer-list (tramp-list-tramp-buffers)) (curbuf (current-buffer))) ;; There is at least one Tramp buffer. @@ -364,13 +357,13 @@ the debug buffer(s).") (kill-buffer nil) (switch-to-buffer curbuf) (goto-char (point-max)) - (insert (tramp-compat-funcall 'propertize "\n" 'display "\n\ + (insert (propertize "\n" 'display "\n\ This is a special notion of the `gnus/message' package. If you use another mail agent (by copying the contents of this buffer) please ensure that the buffers are attached to your email.\n\n")) (dolist (buffer buffer-list) - (tramp-compat-funcall - 'mml-insert-empty-tag 'part 'type "text/plain" + (mml-insert-empty-tag + 'part 'type "text/plain" 'encoding "base64" 'disposition "attachment" 'buffer buffer 'description buffer)) (set-buffer-modified-p nil)) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 44923aee895..0e9fcb501a7 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,9 +23,8 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 24. This -;; package provides compatibility functions for Emacs 22, Emacs 23, -;; XEmacs 21.4+ and SXEmacs 22. +;; Tramp's main Emacs version for development is Emacs 25. This +;; package provides compatibility functions for Emacs 23 and Emacs 24. ;;; Code: @@ -33,164 +32,57 @@ (eval-when-compile (require 'cl)) -(eval-and-compile - - ;; GNU Emacs 22. - (unless (fboundp 'ignore-errors) - (load "cl" 'noerror) - (load "cl-macs" 'noerror)) - - ;; Some packages must be required for XEmacs, because we compile - ;; with -no-autoloads. - (when (featurep 'xemacs) - (require 'cus-edit) - (require 'env) - (require 'executable) - (require 'outline) - (require 'passwd) - (require 'pp) - (require 'regexp-opt) - (require 'time-date)) - - (require 'advice) - (require 'custom) - (require 'format-spec) - (require 'shell) - ;; Introduced in Emacs 23.2. - (require 'ucs-normalize nil 'noerror) - - (require 'trampver) - (require 'tramp-loaddefs) - - ;; As long as password.el is not part of (X)Emacs, it shouldn't be - ;; mandatory. - (if (featurep 'xemacs) - (load "password" 'noerror) - (or (require 'password-cache nil 'noerror) - (require 'password nil 'noerror))) ; Part of contrib. - - ;; auth-source is relatively new. - (if (featurep 'xemacs) - (load "auth-source" 'noerror) - (require 'auth-source nil 'noerror)) - - ;; Load the appropriate timer package. - (if (featurep 'xemacs) - (require 'timer-funcs) - (require 'timer)) - - ;; Avoid byte-compiler warnings if the byte-compiler supports this. - ;; Currently, XEmacs supports this. - (when (featurep 'xemacs) - (unless (boundp 'byte-compile-default-warnings) - (defvar byte-compile-default-warnings nil)) - (delq 'unused-vars byte-compile-default-warnings)) - - ;; `last-coding-system-used' is unknown in XEmacs. - (unless (boundp 'last-coding-system-used) - (defvar last-coding-system-used nil)) - - ;; `directory-sep-char' is an obsolete variable in Emacs. But it is - ;; used in XEmacs, so we set it here and there. The following is - ;; needed to pacify Emacs byte-compiler. - ;; Note that it was removed altogether in Emacs 24.1. - (when (boundp 'directory-sep-char) - (defvar byte-compile-not-obsolete-var nil) - (setq byte-compile-not-obsolete-var 'directory-sep-char) - ;; Emacs 23.2. - (defvar byte-compile-not-obsolete-vars nil) - (setq byte-compile-not-obsolete-vars '(directory-sep-char))) - - ;; `remote-file-name-inhibit-cache' has been introduced with Emacs 24.1. - ;; Besides t, nil, and integer, we use also timestamps (as - ;; returned by `current-time') internally. - (unless (boundp 'remote-file-name-inhibit-cache) - (defvar remote-file-name-inhibit-cache nil)) - - ;; For not existing functions, or functions with a changed argument - ;; list, there are compiler warnings. We want to avoid them in - ;; cases we know what we do. - (defmacro tramp-compat-funcall (function &rest arguments) - (if (featurep 'xemacs) - `(funcall (symbol-function ,function) ,@arguments) - `(when (or (subrp ,function) (functionp ,function)) - (with-no-warnings (funcall ,function ,@arguments))))) - - ;; `set-buffer-multibyte' comes from Emacs Leim. - (unless (fboundp 'set-buffer-multibyte) - (defalias 'set-buffer-multibyte 'ignore)) - - ;; The following functions cannot be aliases of the corresponding - ;; `tramp-handle-*' functions, because this would bypass the locking - ;; mechanism. - - ;; `process-file' does not exist in XEmacs. - (unless (fboundp 'process-file) - (defalias 'process-file - (lambda (program &optional infile buffer display &rest args) - (when (tramp-tramp-file-p default-directory) - (apply - 'tramp-file-name-handler - 'process-file program infile buffer display args))))) - - ;; `start-file-process' is new in Emacs 23. - (unless (fboundp 'start-file-process) - (defalias 'start-file-process - (lambda (name buffer program &rest program-args) - (when (tramp-tramp-file-p default-directory) - (apply - 'tramp-file-name-handler - 'start-file-process name buffer program program-args))))) - - ;; `set-file-times' is also new in Emacs 23. - (unless (fboundp 'set-file-times) - (defalias 'set-file-times - (lambda (filename &optional time) - (when (tramp-tramp-file-p filename) - (tramp-compat-funcall - 'tramp-file-name-handler 'set-file-times filename time))))) - - ;; We currently use "[" and "]" in the filename format for IPv6 - ;; hosts of GNU Emacs. This means that Emacs wants to expand - ;; wildcards if `find-file-wildcards' is non-nil, and then barfs - ;; because no expansion could be found. We detect this situation - ;; and do something really awful: we have `file-expand-wildcards' - ;; return the original filename if it can't expand anything. Let's - ;; just hope that this doesn't break anything else. - ;; It is not needed anymore since GNU Emacs 23.2. - (unless (or (featurep 'xemacs) - ;; `featurep' has only one argument in XEmacs. - (funcall 'featurep 'files 'remote-wildcards)) - (defadvice file-expand-wildcards +(require 'auth-source) +(require 'advice) +(require 'custom) +(require 'format-spec) +(require 'password-cache) +(require 'shell) +(require 'timer) +(require 'ucs-normalize) + +(require 'trampver) +(require 'tramp-loaddefs) + +;; `remote-file-name-inhibit-cache' has been introduced with Emacs +;; 24.1. Besides t, nil, and integer, we use also timestamps (as +;; returned by `current-time') internally. +(unless (boundp 'remote-file-name-inhibit-cache) + (defvar remote-file-name-inhibit-cache nil)) + +;; For not existing functions, obsolete functions, or functions with a +;; changed argument list, there are compiler warnings. We want to +;; avoid them in cases we know what we do. +(defmacro tramp-compat-funcall (function &rest arguments) + `(when (or (subrp ,function) (functionp ,function)) + (with-no-warnings (funcall ,function ,@arguments)))) + +;; We currently use "[" and "]" in the filename format for IPv6 hosts +;; of GNU Emacs. This means that Emacs wants to expand wildcards if +;; `find-file-wildcards' is non-nil, and then barfs because no +;; expansion could be found. We detect this situation and do +;; something really awful: we have `file-expand-wildcards' return the +;; original filename if it can't expand anything. Let's just hope +;; that this doesn't break anything else. It is not needed anymore +;; since GNU Emacs 23.2. +(unless (featurep 'files 'remote-wildcards) + (defadvice file-expand-wildcards (around tramp-advice-file-expand-wildcards activate) - (let ((name (ad-get-arg 0))) - ;; If it's a Tramp file, look if wildcards need to be expanded - ;; at all. - (if (and - (tramp-tramp-file-p name) - (not (string-match - "[[*?]" (tramp-compat-funcall - 'file-remote-p name 'localname)))) - (setq ad-return-value (list name)) - ;; Otherwise, just run the original function. - ad-do-it))) - (add-hook - 'tramp-unload-hook - (lambda () - (ad-remove-advice - 'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards) - (ad-activate 'file-expand-wildcards)))) - - ;; `redisplay' does not exist in XEmacs. - (unless (fboundp 'redisplay) - (defalias 'redisplay 'ignore))) - -;; `with-temp-message' does not exist in XEmacs. -(if (fboundp 'with-temp-message) - (defalias 'tramp-compat-with-temp-message 'with-temp-message) - (defmacro tramp-compat-with-temp-message (_message &rest body) - "Display MESSAGE temporarily if non-nil while BODY is evaluated." - `(progn ,@body))) + (let ((name (ad-get-arg 0))) + ;; If it's a Tramp file, look if wildcards need to be expanded + ;; at all. + (if (and + (tramp-tramp-file-p name) + (not (string-match "[[*?]" (file-remote-p name 'localname)))) + (setq ad-return-value (list name)) + ;; Otherwise, just run the original function. + ad-do-it))) + (add-hook + 'tramp-unload-hook + (lambda () + (ad-remove-advice + 'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards) + (ad-activate 'file-expand-wildcards)))) ;; `condition-case-unless-debug' is introduced with Emacs 24. (if (fboundp 'condition-case-unless-debug) @@ -208,105 +100,23 @@ (funcall ,bodysym) ,@handlers)))))) -;; `font-lock-add-keywords' does not exist in XEmacs. -(defun tramp-compat-font-lock-add-keywords (mode keywords &optional how) - "Add highlighting KEYWORDS for MODE." - (ignore-errors - (tramp-compat-funcall 'font-lock-add-keywords mode keywords how))) - (defsubst tramp-compat-temporary-file-directory () - "Return name of directory for temporary files (compat function). -For Emacs, this is the variable `temporary-file-directory', for XEmacs -this is the function `temp-directory'." - (let (file-name-handler-alist) - ;; We must return a local directory. If it is remote, we could - ;; run into an infloop. - (cond - ((and (boundp 'temporary-file-directory) - (eval (car (get 'temporary-file-directory 'standard-value))))) - ((fboundp 'temp-directory) (tramp-compat-funcall 'temp-directory)) - ((let ((d (getenv "TEMP"))) (and d (file-directory-p d))) - (file-name-as-directory (getenv "TEMP"))) - ((let ((d (getenv "TMP"))) (and d (file-directory-p d))) - (file-name-as-directory (getenv "TMP"))) - ((let ((d (getenv "TMPDIR"))) (and d (file-directory-p d))) - (file-name-as-directory (getenv "TMPDIR"))) - ((file-exists-p "c:/temp") (file-name-as-directory "c:/temp")) - (t (message (concat "Neither `temporary-file-directory' nor " - "`temp-directory' is defined -- using /tmp.")) - (file-name-as-directory "/tmp"))))) - -;; `make-temp-file' exists in Emacs only. On XEmacs, we use our own -;; implementation with `make-temp-name', creating the temporary file -;; immediately in order to avoid a security hole. + "Return name of directory for temporary files. +It is the default value of `temporary-file-directory'." + ;; We must return a local directory. If it is remote, we could run + ;; into an infloop. + (eval (car (get 'temporary-file-directory 'standard-value)))) + (defsubst tramp-compat-make-temp-file (f &optional dir-flag) - "Create a temporary file (compat function). + "Create a local temporary file (compat function). Add the extension of F, if existing." (let* (file-name-handler-alist (prefix (expand-file-name (symbol-value 'tramp-temp-name-prefix) (tramp-compat-temporary-file-directory))) - (extension (file-name-extension f t)) - result) - (condition-case nil - (setq result - (tramp-compat-funcall 'make-temp-file prefix dir-flag extension)) - (error - ;; We use our own implementation, taken from files.el. - (while - (condition-case () - (progn - (setq result (concat (make-temp-name prefix) extension)) - (if dir-flag - (make-directory result) - (write-region "" nil result nil 'silent)) - nil) - (file-already-exists t)) - ;; The file was somehow created by someone else between - ;; `make-temp-name' and `write-region', let's try again. - nil))) - result)) - -;; `most-positive-fixnum' does not exist in XEmacs. -(defsubst tramp-compat-most-positive-fixnum () - "Return largest positive integer value (compat function)." - (cond - ((boundp 'most-positive-fixnum) (symbol-value 'most-positive-fixnum)) - ;; Default value in XEmacs. - (t 134217727))) - -(defun tramp-compat-decimal-to-octal (i) - "Return a string consisting of the octal digits of I. -Not actually used. Use `(format \"%o\" i)' instead?" - (cond ((< i 0) (error "Cannot convert negative number to octal")) - ((not (integerp i)) (error "Cannot convert non-integer to octal")) - ((zerop i) "0") - (t (concat (tramp-compat-decimal-to-octal (/ i 8)) - (number-to-string (% i 8)))))) - -;; Kudos to Gerd Moellmann for this suggestion. -(defun tramp-compat-octal-to-decimal (ostr) - "Given a string of octal digits, return a decimal number." - (let ((x (or ostr ""))) - ;; `save-match' is in `tramp-mode-string-to-int' which calls this. - (unless (string-match "\\`[0-7]*\\'" x) - (error "Non-octal junk in string `%s'" x)) - (string-to-number ostr 8))) - -;; ID-FORMAT does not exist in XEmacs. -(defun tramp-compat-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files (compat function)." - (cond - ((or (null id-format) (eq id-format 'integer)) - (file-attributes filename)) - ((tramp-tramp-file-p filename) - (tramp-compat-funcall - 'tramp-file-name-handler 'file-attributes filename id-format)) - (t (condition-case nil - (tramp-compat-funcall 'file-attributes filename id-format) - (wrong-number-of-arguments (file-attributes filename)))))) - -;; PRESERVE-UID-GID does not exist in XEmacs. + (extension (file-name-extension f t))) + (make-temp-file prefix dir-flag extension))) + ;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with Emacs 24.1 ;; (as PRESERVE-SELINUX-CONTEXT), and renamed in Emacs 24.3. (defun tramp-compat-copy-file @@ -320,21 +130,13 @@ Not actually used. Use `(format \"%o\" i)' instead?" 'copy-file filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) (wrong-number-of-arguments - (tramp-compat-copy-file + (copy-file filename newname ok-if-already-exists keep-date preserve-uid-gid)))) - (preserve-uid-gid - (condition-case nil - (tramp-compat-funcall - 'copy-file filename newname ok-if-already-exists keep-date - preserve-uid-gid) - (wrong-number-of-arguments - (tramp-compat-copy-file - filename newname ok-if-already-exists keep-date)))) (t - (copy-file filename newname ok-if-already-exists keep-date)))) + (copy-file + filename newname ok-if-already-exists keep-date preserve-uid-gid)))) -;; `copy-directory' is a new function in Emacs 23.2. Implementation -;; is taken from there. +;; COPY-CONTENTS has been introduced with Emacs 24.1. (defun tramp-compat-copy-directory (directory newname &optional keep-time parents copy-contents) "Make a copy of DIRECTORY (compat function)." @@ -401,12 +203,10 @@ Not actually used. Use `(format \"%o\" i)' instead?" (cond (trash (tramp-compat-funcall 'delete-directory directory recursive trash)) - (recursive - (tramp-compat-funcall 'delete-directory directory recursive)) (t - (delete-directory directory))) - ;; This Emacs version does not support the RECURSIVE or TRASH flag. We - ;; use the implementation from Emacs 23.2. + (delete-directory directory recursive))) + ;; This Emacs version does not support the TRASH flag. We use the + ;; implementation from Emacs 23.2. (wrong-number-of-arguments (setq directory (directory-file-name (expand-file-name directory))) (if (not (file-symlink-p directory)) @@ -418,42 +218,6 @@ Not actually used. Use `(format \"%o\" i)' instead?" directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))) (delete-directory directory)))) -;; MUST-SUFFIX doesn't exist on XEmacs. -(defun tramp-compat-load (file &optional noerror nomessage nosuffix must-suffix) - "Like `load' for Tramp files (compat function)." - (if must-suffix - (tramp-compat-funcall 'load file noerror nomessage nosuffix must-suffix) - (load file noerror nomessage nosuffix))) - -;; `number-sequence' does not exist in XEmacs. Implementation is -;; taken from Emacs 23. -(defun tramp-compat-number-sequence (from &optional to inc) - "Return a sequence of numbers from FROM to TO as a list (compat function)." - (if (or (subrp 'number-sequence) (symbol-file 'number-sequence)) - (tramp-compat-funcall 'number-sequence from to inc) - (if (or (not to) (= from to)) - (list from) - (or inc (setq inc 1)) - (when (zerop inc) (error "The increment can not be zero")) - (let (seq (n 0) (next from)) - (if (> inc 0) - (while (<= next to) - (setq seq (cons next seq) - n (1+ n) - next (+ from (* n inc)))) - (while (>= next to) - (setq seq (cons next seq) - n (1+ n) - next (+ from (* n inc))))) - (nreverse seq))))) - -(defun tramp-compat-split-string (string pattern) - "Like `split-string' but omit empty strings. -In Emacs, (split-string \"/foo/bar\" \"/\") returns (\"foo\" \"bar\"). -This is, the first, empty, element is omitted. In XEmacs, the first -element is not omitted." - (delete "" (split-string string pattern))) - (defun tramp-compat-process-running-p (process-name) "Returns t if system process PROCESS-NAME is running for `user-login-name'." (when (stringp process-name) @@ -466,7 +230,7 @@ element is not omitted." ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) (let (result) (dolist (pid (tramp-compat-funcall 'list-system-processes) result) - (let ((attributes (tramp-compat-funcall 'process-attributes pid))) + (let ((attributes (process-attributes pid))) (when (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) (let ((comm (cdr (assoc 'comm attributes)))) @@ -476,135 +240,16 @@ element is not omitted." (and comm (string-match (concat "^" (regexp-quote comm)) process-name)))) - (setq result t)))))) - - ;; Fallback, if there is no Lisp support yet. - (t (let ((default-directory - (if (tramp-tramp-file-p default-directory) - (tramp-compat-temporary-file-directory) - default-directory)) - (unix95 (getenv "UNIX95")) - result) - (setenv "UNIX95" "1") - (when (member - (user-login-name) - (tramp-compat-split-string - (shell-command-to-string - (format "ps -C %s -o user=" process-name)) - "[ \f\t\n\r\v]+")) - (setq result t)) - (setenv "UNIX95" unix95) - result))))) - -;; The following functions do not exist in XEmacs. We ignore this; -;; they are used for checking a remote tty. -(defun tramp-compat-process-get (process propname) - "Return the value of PROCESS' PROPNAME property. -This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'." - (ignore-errors (tramp-compat-funcall 'process-get process propname))) - -(defun tramp-compat-process-put (process propname value) - "Change PROCESS' PROPNAME property to VALUE. -It can be retrieved with `(process-get PROCESS PROPNAME)'." - (ignore-errors (tramp-compat-funcall 'process-put process propname value))) - -(defun tramp-compat-set-process-query-on-exit-flag (process flag) - "Specify if query is needed for process when Emacs is exited. -If the second argument flag is non-nil, Emacs will query the user before -exiting if process is running." - (if (fboundp 'set-process-query-on-exit-flag) - (tramp-compat-funcall 'set-process-query-on-exit-flag process flag) - (tramp-compat-funcall 'process-kill-without-query process flag))) - -;; There exist different implementations for this function. -(defun tramp-compat-coding-system-change-eol-conversion (coding-system eol-type) - "Return a coding system like CODING-SYSTEM but with given EOL-TYPE. -EOL-TYPE can be one of `dos', `unix', or `mac'." - (cond ((fboundp 'coding-system-change-eol-conversion) - (tramp-compat-funcall - 'coding-system-change-eol-conversion coding-system eol-type)) - ((fboundp 'subsidiary-coding-system) - (tramp-compat-funcall - 'subsidiary-coding-system coding-system - (cond ((eq eol-type 'dos) 'crlf) - ((eq eol-type 'unix) 'lf) - ((eq eol-type 'mac) 'cr) - (t (error - "Unknown EOL-TYPE `%s', must be `dos', `unix', or `mac'" - eol-type))))) - (t (error "Can't change EOL conversion -- is MULE missing?")))) - -;; `replace-regexp-in-string' does not exist in XEmacs. -;; Implementation is taken from Emacs 24. -(if (fboundp 'replace-regexp-in-string) - (defalias 'tramp-compat-replace-regexp-in-string 'replace-regexp-in-string) - (defun tramp-compat-replace-regexp-in-string - (regexp rep string &optional fixedcase literal subexp start) - "Replace all matches for REGEXP with REP in STRING. - -Return a new string containing the replacements. - -Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the -arguments with the same names of function `replace-match'. If START -is non-nil, start replacements at that index in STRING. - -REP is either a string used as the NEWTEXT arg of `replace-match' or a -function. If it is a function, it is called with the actual text of each -match, and its value is used as the replacement text. When REP is called, -the match data are the result of matching REGEXP against a substring -of STRING. - -To replace only the first match (if any), make REGEXP match up to \\' -and replace a sub-expression, e.g. - (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1) - => \" bar foo\"" - - (let ((l (length string)) - (start (or start 0)) - matches str mb me) - (save-match-data - (while (and (< start l) (string-match regexp string start)) - (setq mb (match-beginning 0) - me (match-end 0)) - ;; If we matched the empty string, make sure we advance by one char - (when (= me mb) (setq me (min l (1+ mb)))) - ;; Generate a replacement for the matched substring. - ;; Operate only on the substring to minimize string consing. - ;; Set up match data for the substring for replacement; - ;; presumably this is likely to be faster than munging the - ;; match data directly in Lisp. - (string-match regexp (setq str (substring string mb me))) - (setq matches - (cons (replace-match (if (stringp rep) - rep - (funcall rep (match-string 0 str))) - fixedcase literal str subexp) - (cons (substring string start mb) ; unmatched prefix - matches))) - (setq start me)) - ;; Reconstruct a string from the pieces. - (setq matches (cons (substring string start l) matches)) ; leftover - (apply #'concat (nreverse matches)))))) + (setq result t))))))))) ;; `default-toplevel-value' has been declared in Emacs 24. (unless (fboundp 'default-toplevel-value) (defalias 'default-toplevel-value 'symbol-value)) -;; `format-message' is new in Emacs 25, and does not exist in XEmacs. +;; `format-message' is new in Emacs 25. (unless (fboundp 'format-message) (defalias 'format-message 'format)) -;; `delete-dups' does not exist in XEmacs 21.4. -(if (fboundp 'delete-dups) - (defalias 'tramp-compat-delete-dups 'delete-dups) - (defun tramp-compat-delete-dups (list) - "Destructively remove `equal' duplicates from LIST. -Store the result in LIST and return it. LIST must be a proper list. -Of several `equal' occurrences of an element in LIST, the first -one is kept." - (tramp-compat-funcall - 'cl-delete-duplicates list '(:test equal :from-end) nil))) - (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-loaddefs 'force) diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 902b0a4ed86..caca3c0cb4c 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -39,15 +39,6 @@ (defvar ange-ftp-name-format) ;; Disable Ange-FTP from file-name-handler-alist. -;; To handle EFS, the following functions need to be dealt with: -;; -;; * dired-before-readin-hook contains efs-dired-before-readin -;; * file-name-handler-alist contains efs-file-handler-function -;; and efs-root-handler-function and efs-sifn-handler-function -;; * find-file-hooks contains efs-set-buffer-mode -;; -;; But it won't happen for EFS since the XEmacs maintainers -;; don't want to use a unified filename syntax. (defun tramp-disable-ange-ftp () "Turn Ange-FTP off. This is useful for unified remoting. See @@ -104,14 +95,15 @@ present for backward compatibility." ;; ... and add it to the method list. ;;;###tramp-autoload -(unless (featurep 'xemacs) - (add-to-list 'tramp-methods (cons tramp-ftp-method nil)) +(add-to-list 'tramp-methods (cons tramp-ftp-method nil)) - ;; Add some defaults for `tramp-default-method-alist'. - (add-to-list 'tramp-default-method-alist - (list "\\`ftp\\." nil tramp-ftp-method)) - (add-to-list 'tramp-default-method-alist - (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))) +;; Add some defaults for `tramp-default-method-alist'. +;;;###tramp-autoload +(add-to-list 'tramp-default-method-alist + (list "\\`ftp\\." nil tramp-ftp-method)) +;;;###tramp-autoload +(add-to-list 'tramp-default-method-alist + (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) ;; Add completion function for FTP method. ;;;###tramp-autoload @@ -195,9 +187,8 @@ pass to the OPERATION." tramp-ftp-method)) ;;;###tramp-autoload -(unless (featurep 'xemacs) - (add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))) +(add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler)) (add-hook 'tramp-unload-hook (lambda () diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index dee8333e547..098d40e7cc0 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -422,7 +422,6 @@ Every entry is a list (NAME ADDRESS).") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - (dired-call-process . ignore) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-gvfs-handle-expand-file-name) @@ -474,7 +473,7 @@ Every entry is a list (NAME ADDRESS).") (shell-command . ignore) (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) + (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-gvfs-handle-write-region)) @@ -562,8 +561,7 @@ will be traced by Tramp with trace level 6." (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) -(tramp-compat-font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. @@ -623,19 +621,19 @@ file names." (and t2 (not (tramp-gvfs-file-name-p newname)))) ;; We cannot copy or rename directly. + ;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with + ;; Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and renamed + ;; in Emacs 24.3. (let ((tmpfile (tramp-compat-make-temp-file filename))) (cond (preserve-extended-attributes - (tramp-compat-funcall + (funcall file-operation filename tmpfile t keep-date preserve-uid-gid preserve-extended-attributes)) - (preserve-uid-gid - (tramp-compat-funcall - file-operation filename tmpfile t keep-date preserve-uid-gid)) (t - (tramp-compat-funcall - file-operation filename tmpfile t keep-date))) + (funcall + file-operation filename tmpfile t keep-date preserve-uid-gid))) (rename-file tmpfile newname ok-if-already-exists)) ;; Direct action. @@ -693,19 +691,18 @@ file names." (tramp-gvfs-do-copy-or-rename-file 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)) - ;; Compat section. + ;; Compat section. PRESERVE-EXTENDED-ATTRIBUTES has been + ;; introduced with Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and + ;; renamed in Emacs 24.3. (preserve-extended-attributes (tramp-run-real-handler 'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes))) - (preserve-uid-gid - (tramp-run-real-handler - 'copy-file - (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) (t (tramp-run-real-handler - 'copy-file (list filename newname ok-if-already-exists keep-date))))) + 'copy-file + (list filename newname ok-if-already-exists keep-date preserve-uid-gid))))) (defun tramp-gvfs-handle-delete-directory (directory &optional recursive trash) "Like `delete-directory' for Tramp files." @@ -923,7 +920,7 @@ file names." (tramp-error v 'file-error "Cannot make local copy of non-existing file `%s'" filename)) - (copy-file filename tmpfile t t) + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) (defun tramp-gvfs-handle-file-name-all-completions (filename directory) @@ -960,7 +957,7 @@ file names." (when cache-hit (list cache-hit)))) ;; We cannot use a length of 0, because file properties ;; for "foo" and "foo/" are identical. - (tramp-compat-number-sequence (length filename) 1 -1))))) + (number-sequence (length filename) 1 -1))))) ;; Cache expired or no matching cache entry found so we need ;; to perform a remote operation. @@ -1024,9 +1021,9 @@ file names." (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity (process-command p) " ") p) (tramp-set-connection-property p "vector" v) - (tramp-compat-process-put p 'events events) - (tramp-compat-process-put p 'watch-name localname) - (tramp-compat-set-process-query-on-exit-flag p nil) + (process-put p 'events events) + (process-put p 'watch-name localname) + (set-process-query-on-exit-flag p nil) (set-process-filter p 'tramp-gvfs-monitor-file-process-filter) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. @@ -1039,7 +1036,7 @@ file names." (defun tramp-gvfs-monitor-file-process-filter (proc string) "Read output from \"gvfs-monitor-file\" and add corresponding \ file-notify events." - (let* ((rest-string (tramp-compat-process-get proc 'rest-string)) + (let* ((rest-string (process-get proc 'rest-string)) (dd (with-current-buffer (process-buffer proc) default-directory)) (ddu (regexp-quote (tramp-gvfs-url-file-name dd)))) (when rest-string @@ -1047,7 +1044,7 @@ file-notify events." (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) ;; Attribute change is returned in unused wording. - string (tramp-compat-replace-regexp-in-string + string (replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) (when (string-match "Monitoring not supported" string) (delete-process proc)) @@ -1060,7 +1057,7 @@ file-notify events." string) (let ((file (match-string 1 string)) (action (intern-soft - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string "_" "-" (downcase (match-string 2 string)))))) (setq string (replace-match "" nil nil string)) ;; File names are returned as URL paths. We must convert them. @@ -1079,12 +1076,12 @@ file-notify events." ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) - (tramp-compat-process-put proc 'rest-string string))) + (process-put proc 'rest-string string))) (defun tramp-gvfs-handle-file-readable-p (filename) "Like `file-readable-p' for Tramp files." (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-executable-p" + (with-tramp-file-property v localname "file-readable-p" (tramp-check-cached-permissions v ?r)))) (defun tramp-gvfs-handle-file-writable-p (filename) @@ -1125,7 +1122,8 @@ file-notify events." (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) (tramp-gvfs-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t t) + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) (tramp-run-real-handler 'rename-file (list filename newname ok-if-already-exists)))) @@ -1133,8 +1131,7 @@ file-notify events." (start end filename &optional append visit lockname confirm) "Like `write-region' for Tramp files." (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)) + (when (and 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"))) @@ -1203,8 +1200,7 @@ file-notify events." (defun tramp-gvfs-file-name (object-path) "Retrieve file name from D-Bus OBJECT-PATH." (dbus-unescape-from-identifier - (tramp-compat-replace-regexp-in-string - "^.*/\\([^/]+\\)$" "\\1" object-path))) + (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) (defun tramp-bluez-address (device) "Return bluetooth device address from a given bluetooth DEVICE name." @@ -1293,7 +1289,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." ;; host signature. (with-temp-buffer ;; Preserve message for `progress-reporter'. - (tramp-compat-with-temp-message "" + (with-temp-message "" (insert message) (pop-to-buffer (current-buffer)) (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) @@ -1533,7 +1529,7 @@ connection if a previous connection has died for some reason." :name (tramp-buffer-name vec) :buffer (tramp-get-connection-buffer vec) :server t :host 'local :service t))) - (tramp-compat-set-process-query-on-exit-flag p nil))) + (set-process-query-on-exit-flag p nil))) (unless (tramp-gvfs-connection-mounted-p vec) (let* ((method (tramp-file-name-method vec)) @@ -1755,7 +1751,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." 'split-string (shell-command-to-string (format "avahi-browse -trkp %s" service)) "[\n\r]+" 'omit "^\\+;.*$")))) - (tramp-compat-delete-dups + (delete-dups (mapcar (lambda (x) (let* ((list (split-string x ";")) diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el index f868bead09a..a1ddceb4682 100644 --- a/lisp/net/tramp-gw.el +++ b/lisp/net/tramp-gw.el @@ -108,7 +108,7 @@ tramp-gw-vector 4 "Opening auxiliary process `%s', speaking with process `%s'" proc tramp-gw-gw-proc) - (tramp-compat-set-process-query-on-exit-flag proc nil) + (set-process-query-on-exit-flag proc nil) ;; We don't want debug messages, because the corresponding debug ;; buffer might be undecided. (let ((tramp-verbose 0)) @@ -158,7 +158,7 @@ instead of the host name declared in TARGET-VEC." :name (tramp-buffer-name aux-vec) :buffer nil :host 'local :server t :noquery t :service t :coding 'binary)) (set-process-sentinel tramp-gw-aux-proc 'tramp-gw-aux-proc-sentinel) - (tramp-compat-set-process-query-on-exit-flag tramp-gw-aux-proc nil) + (set-process-query-on-exit-flag tramp-gw-aux-proc nil) (tramp-message vec 4 "Opening auxiliary process `%s', listening on port %d" tramp-gw-aux-proc (process-contact tramp-gw-aux-proc :service)))) @@ -204,7 +204,7 @@ instead of the host name declared in TARGET-VEC." (tramp-file-name-port target-vec))) (set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel) (set-process-coding-system tramp-gw-gw-proc 'binary 'binary) - (tramp-compat-set-process-query-on-exit-flag tramp-gw-gw-proc nil) + (set-process-query-on-exit-flag tramp-gw-gw-proc nil) (tramp-message vec 4 "Opened %s process `%s'" (case gw-method ('tunnel "HTTP tunnel") ('socks "SOCKS")) @@ -235,14 +235,14 @@ authentication is requested from proxy server, provide it." (setq proc (open-network-stream name buffer (nth 1 socks-server) (nth 2 socks-server))) (set-process-coding-system proc 'binary 'binary) - (tramp-compat-set-process-query-on-exit-flag proc nil) + (set-process-query-on-exit-flag proc nil) ;; Send CONNECT command. (process-send-string proc (format "%s%s\r\n" command authentication)) (tramp-message tramp-gw-vector 6 "\n%s" (format "%s%s\r\n" command - (tramp-compat-replace-regexp-in-string ;; no password in trace! + (replace-regexp-in-string ;; no password in trace! "Basic [^\r\n]+" "Basic xxxxx" authentication t))) (with-current-buffer buffer ;; Trap errors to be traced in the right trace buffer. Often, diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index bff6ec31156..14c6f949853 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -32,7 +32,6 @@ (eval-when-compile (require 'cl) (require 'dired)) -(defvar directory-sep-char) (defvar tramp-gw-tunnel-method) (defvar tramp-gw-socks-method) (defvar vc-handled-backends) @@ -118,7 +117,7 @@ detected as prompt when being sent on echoing hosts, therefore.") "Which ssh Control* arguments to use. If it is a string, it should have the form -\"-o ControlMaster=auto -o ControlPath='tramp.%%r@%%h:%%p' +\"-o ControlMaster=auto -o ControlPath=\\='tramp.%%r@%%h:%%p\\=' -o ControlPersist=no\". Percent characters in the ControlPath spec must be doubled, because the string is used as format string. @@ -285,6 +284,15 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-connection-timeout 10))) ;;;###tramp-autoload +(add-to-list + 'tramp-methods + '("sg" + (tramp-login-program "sg") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) +;;;###tramp-autoload (add-to-list 'tramp-methods '("sudo" (tramp-login-program "sudo") @@ -300,6 +308,14 @@ The string is used in `tramp-methods'.") (tramp-connection-timeout 10))) ;;;###tramp-autoload (add-to-list 'tramp-methods + '("doas" + (tramp-login-program "doas") + (tramp-login-args (("-u" "%u") ("-s"))) + (tramp-remote-shell "/bin/sh") + (tramp-remote-shell-args ("-c")) + (tramp-connection-timeout 10))) +;;;###tramp-autoload +(add-to-list 'tramp-methods '("ksu" (tramp-login-program "ksu") (tramp-login-args (("%u") ("-q"))) @@ -380,9 +396,8 @@ The string is used in `tramp-methods'.") (tramp-remote-shell-args ("-c")) (tramp-copy-program "pscp") (tramp-copy-args (("-l" "%u") ("-P" "%p") ("-sftp") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t))) + ("-q"))) + (tramp-copy-keep-date t))) ;;;###tramp-autoload (add-to-list 'tramp-methods '("fcp" @@ -401,7 +416,7 @@ The string is used in `tramp-methods'.") ;;;###tramp-autoload (add-to-list 'tramp-default-user-alist - `(,(concat "\\`" (regexp-opt '("su" "sudo" "ksu")) "\\'") + `(,(concat "\\`" (regexp-opt '("su" "sudo" "doas" "ksu")) "\\'") nil "root")) ;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. ;; Do not add "plink" based methods, they ask interactively for the user. @@ -447,12 +462,17 @@ The string is used in `tramp-methods'.") "Default list of (FUNCTION FILE) pairs to be examined for su methods.") ;;;###tramp-autoload +(defconst tramp-completion-function-alist-sg + '((tramp-parse-etc-group "/etc/group")) + "Default list of (FUNCTION FILE) pairs to be examined for sg methods.") + +;;;###tramp-autoload (defconst tramp-completion-function-alist-putty `((tramp-parse-putty ,(if (memq system-type '(windows-nt)) "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions" "~/.putty/sessions"))) - "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") + "Default list of (FUNCTION REGISTRY) pairs to be examined for putty sessions.") ;;;###tramp-autoload (eval-after-load 'tramp @@ -471,7 +491,9 @@ The string is used in `tramp-methods'.") (tramp-set-completion-function "nc" tramp-completion-function-alist-telnet) (tramp-set-completion-function "su" tramp-completion-function-alist-su) (tramp-set-completion-function "sudo" tramp-completion-function-alist-su) + (tramp-set-completion-function "doas" tramp-completion-function-alist-su) (tramp-set-completion-function "ksu" tramp-completion-function-alist-su) + (tramp-set-completion-function "sg" tramp-completion-function-alist-sg) (tramp-set-completion-function "krlogin" tramp-completion-function-alist-rsh) (tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) @@ -484,7 +506,7 @@ The string is used in `tramp-methods'.") ;; "getconf PATH" yields: ;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin ;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin -;; GNU/Linux (Debian, Suse): /bin:/usr/bin +;; GNU/Linux (Debian, Suse, RHEL): /bin:/usr/bin ;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! ;; Darwin: /usr/bin:/bin:/usr/sbin:/sbin ;; IRIX64: /usr/bin @@ -986,10 +1008,7 @@ of command line.") (directory-files . tramp-handle-directory-files) (directory-files-and-attributes . tramp-sh-handle-directory-files-and-attributes) - ;; `dired-call-process' performed by default handler. (dired-compress-file . tramp-sh-handle-dired-compress-file) - (dired-recursive-delete-directory - . tramp-sh-handle-dired-recursive-delete-directory) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-sh-handle-expand-file-name) (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) @@ -1025,8 +1044,6 @@ of command line.") ;; `get-file-buffer' performed by default handler. (insert-directory . tramp-sh-handle-insert-directory) (insert-file-contents . tramp-handle-insert-file-contents) - (insert-file-contents-literally - . tramp-sh-handle-insert-file-contents-literally) (load . tramp-handle-load) (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) (make-directory . tramp-sh-handle-make-directory) @@ -1041,7 +1058,7 @@ of command line.") (shell-command . tramp-handle-shell-command) (start-file-process . tramp-sh-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) + (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) (write-region . tramp-sh-handle-write-region)) @@ -1148,10 +1165,8 @@ target of the symlink differ." (format "tramp_perl_file_truename %s" (tramp-shell-quote-argument localname))))) - ;; Do it yourself. We bind `directory-sep-char' here for - ;; XEmacs on Windows, which would otherwise use backslash. - (t (let ((directory-sep-char ?/) - (steps (tramp-compat-split-string localname "/")) + ;; Do it yourself. + (t (let ((steps (split-string localname "/" 'omit)) (thisstep nil) (numchase 0) ;; Don't make the following value larger than @@ -1200,9 +1215,8 @@ target of the symlink differ." symlink-target)) (setq symlink-target localname)) (setq steps - (append (tramp-compat-split-string - symlink-target "/") - steps))) + (append + (split-string symlink-target "/" 'omit) steps))) (t ;; It's a file. (setq result (cons thisstep result))))) @@ -1355,8 +1369,8 @@ target of the symlink differ." res-gid ;; 4. Last access time, as a list of integers. Normally ;; this would be in the same format as `current-time', but - ;; the subseconds part is not currently implemented, and (0 - ;; 0) denotes an unknown time. + ;; the subseconds part is not currently implemented, and + ;; (0 0) denotes an unknown time. ;; 5. Last modification time, likewise. ;; 6. Last status change time, likewise. '(0 0) '(0 0) '(0 0) ;CCC how to find out? @@ -1370,8 +1384,7 @@ target of the symlink differ." ;; 10. Inode number. res-inode ;; 11. Device number. Will be replaced by a virtual device number. - -1 - )))))) + -1)))))) (defun tramp-do-file-attributes-with-perl (vec localname &optional id-format) @@ -1428,8 +1441,7 @@ target of the symlink differ." (attr (file-attributes f)) ;; '(-1 65535) means file doesn't exists yet. (modtime (or (nth 5 attr) '(-1 65535)))) - (when (boundp 'last-coding-system-used) - (setq coding-system-used (symbol-value 'last-coding-system-used))) + (setq coding-system-used last-coding-system-used) ;; We use '(0 0) as a don't-know value. See also ;; `tramp-do-file-attributes-with-ls'. (if (not (equal modtime '(0 0))) @@ -1443,8 +1455,7 @@ target of the symlink differ." (setq attr (buffer-substring (point) (point-at-eol)))) (tramp-set-file-property v localname "visited-file-modtime-ild" attr)) - (when (boundp 'last-coding-system-used) - (set 'last-coding-system-used coding-system-used)) + (setq last-coding-system-used coding-system-used) nil))))) ;; This function makes the same assumption as @@ -1463,7 +1474,7 @@ of." ;; connection. (if (or (not f) (eq (visited-file-modtime) 0) - (not (tramp-file-name-handler 'file-remote-p f nil 'connected))) + (not (file-remote-p f nil 'connected))) t (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) @@ -1508,48 +1519,26 @@ of." ;; FIXME: extract the proper text from chmod's stderr. (tramp-barf-unless-okay v - (format "chmod %s %s" - (tramp-compat-decimal-to-octal mode) - (tramp-shell-quote-argument localname)) + (format "chmod %o %s" mode (tramp-shell-quote-argument localname)) "Error while changing file's mode %s" filename))) (defun tramp-sh-handle-set-file-times (filename &optional time) "Like `set-file-times' for Tramp files." - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (when (tramp-get-remote-touch v) - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time)) - ;; With GNU Emacs, `format-time-string' has an - ;; optional parameter ZONE. This is preferred, - ;; because we could handle the case when the remote - ;; host is located in a different time zone as the - ;; local host. - (utc (not (featurep 'xemacs)))) - (tramp-send-command-and-check - v (format - "%s %s %s %s" - (if utc "env TZ=UTC" "") - (tramp-get-remote-touch v) - (if (tramp-get-connection-property v "touch-t" nil) - (format "-t %s" - (if utc - (format-time-string "%Y%m%d%H%M.%S" time t) - (format-time-string "%Y%m%d%H%M.%S" time))) - "") - (tramp-shell-quote-argument localname)))))) - - ;; We handle also the local part, because in older Emacsen, - ;; without `set-file-times', this function is an alias for this. - ;; We are local, so we don't need the UTC settings. - (zerop - (tramp-call-process - nil "touch" nil nil nil "-t" - (format-time-string "%Y%m%d%H%M.%S" time) - (tramp-shell-quote-argument filename))))) + (with-parsed-tramp-file-name filename nil + (when (tramp-get-remote-touch v) + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + (let ((time (if (or (null time) (equal time '(0 0))) + (current-time) + time))) + (tramp-send-command-and-check + v (format + "env TZ=UTC %s %s %s" + (tramp-get-remote-touch v) + (if (tramp-get-connection-property v "touch-t" nil) + (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) + "") + (tramp-shell-quote-argument localname))))))) (defun tramp-set-file-uid-gid (filename &optional uid gid) "Set the ownership for FILENAME. @@ -1653,8 +1642,7 @@ be non-negative integers." (goto-char (point-max)) (delete-blank-lines) (when (> (point-max) (point-min)) - (tramp-compat-funcall - 'substring-no-properties (buffer-string)))))))) + (substring-no-properties (buffer-string)))))))) (defun tramp-sh-handle-set-file-acl (filename acl-string) "Like `set-file-acl' for Tramp files." @@ -1905,7 +1893,7 @@ be non-negative integers." (when cache-hit (list cache-hit)))) ;; We cannot use a length of 0, because file properties ;; for "foo" and "foo/" are identical. - (tramp-compat-number-sequence (length filename) 1 -1))))) + (number-sequence (length filename) 1 -1))))) ;; Cache expired or no matching cache entry found so we need ;; to perform a remote operation. @@ -1928,14 +1916,7 @@ be non-negative integers." (format "tramp_perl_file_name_all_completions %s %s %d" (tramp-shell-quote-argument localname) (tramp-shell-quote-argument filename) - (if (symbol-value - ;; `read-file-name-completion-ignore-case' - ;; is introduced with Emacs 22.1. - (if (boundp - 'read-file-name-completion-ignore-case) - 'read-file-name-completion-ignore-case - 'completion-ignore-case)) - 1 0))) + (if read-file-name-completion-ignore-case 1 0))) (format (concat "(cd %s 2>&1 && (%s -a %s 2>/dev/null" @@ -2058,19 +2039,18 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (tramp-do-copy-or-rename-file 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes)) - ;; Compat section. + ;; Compat section. PRESERVE-EXTENDED-ATTRIBUTES has been + ;; introduced with Emacs 24.1 (as PRESERVE-SELINUX-CONTEXT), and + ;; renamed in Emacs 24.3. (preserve-extended-attributes (tramp-run-real-handler 'copy-file (list filename newname ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes))) - (preserve-uid-gid - (tramp-run-real-handler - 'copy-file - (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) (t (tramp-run-real-handler - 'copy-file (list filename newname ok-if-already-exists keep-date))))) + 'copy-file + (list filename newname ok-if-already-exists keep-date preserve-uid-gid))))) (defun tramp-sh-handle-copy-directory (dirname newname &optional keep-date parents copy-contents) @@ -2125,7 +2105,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) (tramp-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t t) + 'rename filename newname ok-if-already-exists + 'keep-time 'preserve-uid-gid) (tramp-run-real-handler 'rename-file (list filename newname ok-if-already-exists)))) @@ -2291,11 +2272,11 @@ the uid and gid from FILENAME." op)))) (localname1 (if t1 - (tramp-file-name-handler 'file-remote-p filename 'localname) + (file-remote-p filename 'localname) filename)) (localname2 (if t2 - (tramp-file-name-handler 'file-remote-p newname 'localname) + (file-remote-p newname 'localname) newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) @@ -2333,12 +2314,12 @@ the uid and gid from FILENAME." (zerop (logand (file-modes (file-name-directory localname1)) - (tramp-compat-octal-to-decimal "1000")))) + (string-to-number "1000" 8)))) (file-writable-p (file-name-directory localname2)) (or (file-directory-p localname2) (file-writable-p localname2)))) (if (eq op 'copy) - (tramp-compat-copy-file + (copy-file localname1 localname2 ok-if-already-exists keep-date preserve-uid-gid) (tramp-run-real-handler @@ -2378,15 +2359,14 @@ the uid and gid from FILENAME." ;; Since this does not work reliable, we also ;; give read permissions. (set-file-modes - (concat prefix tmpfile) - (tramp-compat-octal-to-decimal "0777")) + (concat prefix tmpfile) (string-to-number "0777" 8)) (tramp-set-file-uid-gid (concat prefix tmpfile) (tramp-get-local-uid 'integer) (tramp-get-local-gid 'integer))) (t2 (if (eq op 'copy) - (tramp-compat-copy-file + (copy-file localname1 tmpfile t keep-date preserve-uid-gid) (tramp-run-real-handler @@ -2395,8 +2375,7 @@ the uid and gid from FILENAME." ;; We must change the ownership as local user. ;; Since this does not work reliable, we also ;; give read permissions. - (set-file-modes - tmpfile (tramp-compat-octal-to-decimal "0777")) + (set-file-modes tmpfile (string-to-number "0777" 8)) (tramp-set-file-uid-gid tmpfile (tramp-get-remote-uid v 'integer) @@ -2455,7 +2434,7 @@ The method used must be an out-of-band method." ;; Save exit. (ignore-errors (if dir-flag - (tramp-compat-delete-directory + (delete-directory (expand-file-name ".." tmpfile) 'recursive) (delete-file tmpfile))))) @@ -2628,7 +2607,7 @@ The method used must be an out-of-band method." orig-vec 6 "%s" (mapconcat 'identity (process-command p) " ")) (tramp-set-connection-property p "vector" orig-vec) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) ;; We must adapt `tramp-local-end-of-line' for ;; sending the password. @@ -2676,7 +2655,7 @@ The method used must be an out-of-band method." (unless (eq op 'copy) (if (file-regular-p filename) (delete-file filename) - (tramp-compat-delete-directory filename 'recursive)))))) + (delete-directory filename 'recursive)))))) (defun tramp-sh-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -2716,51 +2695,16 @@ The method used must be an out-of-band method." ;; Dired. -;; CCC: This does not seem to be enough. Something dies when -;; we try and delete two directories under Tramp :/ -(defun tramp-sh-handle-dired-recursive-delete-directory (filename) - "Recursively delete the directory given. -This is like `dired-recursive-delete-directory' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; Run a shell command 'rm -r <localname>'. - ;; Code shamelessly stolen from the dired implementation and, um, hacked :) - (unless (file-exists-p filename) - (tramp-error v 'file-error "No such directory: %s" filename)) - ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>). - (tramp-send-command - v - (format "rm -rf %s" (tramp-shell-quote-argument localname)) - ;; Don't read the output, do it explicitly. - nil t) - ;; Wait for the remote system to return to us... - ;; This might take a while, allow it plenty of time. - (tramp-wait-for-output (tramp-get-connection-process v) 120) - ;; Make sure that it worked... - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) - (and (file-exists-p filename) - (tramp-error - v 'file-error "Failed to recursively delete %s" filename)))) +(defvar dired-compress-file-suffixes) +(declare-function dired-remove-file "dired-aux") -(defun tramp-sh-handle-dired-compress-file (file &rest _ok-flag) +(defun tramp-sh-handle-dired-compress-file (file) "Like `dired-compress-file' for Tramp files." - ;; OK-FLAG is valid for XEmacs only, but not implemented. ;; Code stolen mainly from dired-aux.el. (with-parsed-tramp-file-name file nil (tramp-flush-file-property v localname) (save-excursion - (let ((suffixes - (if (not (featurep 'xemacs)) - ;; Emacs case - (symbol-value 'dired-compress-file-suffixes) - ;; XEmacs has `dired-compression-method-alist', which is - ;; transformed into `dired-compress-file-suffixes' structure. - (mapcar - (lambda (x) - (list (concat (regexp-quote (nth 1 x)) "\\'") - nil - (mapconcat 'identity (nth 3 x) " "))) - (symbol-value 'dired-compression-method-alist)))) + (let ((suffixes dired-compress-file-suffixes) suffix) ;; See if any suffix rule matches this file name. (while suffixes @@ -2778,8 +2722,7 @@ This is like `dired-recursive-delete-directory' for Tramp files." (when (tramp-send-command-and-check v (concat (nth 2 suffix) " " (tramp-shell-quote-argument localname))) - ;; `dired-remove-file' is not defined in XEmacs. - (tramp-compat-funcall 'dired-remove-file file) + (dired-remove-file file) (string-match (car suffix) file) (concat (substring file 0 (match-beginning 0)))))) (t @@ -2789,8 +2732,7 @@ This is like `dired-recursive-delete-directory' for Tramp files." (when (tramp-send-command-and-check v (concat "gzip -f " (tramp-shell-quote-argument localname))) - ;; `dired-remove-file' is not defined in XEmacs. - (tramp-compat-funcall 'dired-remove-file file) + (dired-remove-file file) (cond ((file-exists-p (concat file ".gz")) (concat file ".gz")) ((file-exists-p (concat file ".z")) @@ -2900,9 +2842,7 @@ This is like `dired-recursive-delete-directory' for Tramp files." ;; Decode the output, it could be multibyte. (decode-coding-region beg (point-max) - (or file-name-coding-system - (and (boundp 'default-file-name-coding-system) - (symbol-value 'default-file-name-coding-system)))) + (or file-name-coding-system default-file-name-coding-system)) ;; The inserted file could be from somewhere else. (when (and (not wildcard) (not full-directory-p)) @@ -2929,9 +2869,10 @@ the result will be a local, non-Tramp, file name." ;; 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 connection is not established yet, run the real handler. (if (not (tramp-connectable-p name)) - (tramp-run-real-handler 'expand-file-name (list name nil)) + (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)) @@ -2965,13 +2906,10 @@ the result will be a local, non-Tramp, file name." (while (string-match "//" localname) (setq localname (replace-match "/" t t localname))) ;; No tilde characters in file name, 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 ((directory-sep-char ?/) - (default-directory (tramp-compat-temporary-file-directory))) + ;; `expand-file-name' (this does "/./" and "/../"). + ;; `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 @@ -3093,7 +3031,7 @@ the result will be a local, non-Tramp, file name." ;; Send the command. (tramp-send-command v command nil t) ; nooutput ;; Check, whether a pty is associated. - (unless (tramp-compat-process-get + (unless (process-get (tramp-get-connection-process v) 'remote-tty) (tramp-error v 'file-error @@ -3103,7 +3041,7 @@ the result will be a local, non-Tramp, file name." ;; process. We ignore errors, because the process ;; could have finished already. (ignore-errors - (tramp-compat-set-process-query-on-exit-flag p t) + (set-process-query-on-exit-flag p t) (set-marker (process-mark p) (point))) ;; Return process. p)))) @@ -3227,12 +3165,7 @@ the result will be a local, non-Tramp, file name." ;; because the remote process could have changed them. (when tmpinput (delete-file tmpinput)) - ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to nil, no remote file will be changed - ;; by `program'. If it doesn't exist, we assume its default - ;; value t. - (unless (and (boundp 'process-file-side-effects) - (not (symbol-value 'process-file-side-effects))) + (unless process-file-side-effects (tramp-flush-directory-property v "")) ;; Return exit status. @@ -3258,7 +3191,7 @@ the result will be a local, non-Tramp, file name." ;; `copy-file' handles direct copy and out-of-band methods. ((or (tramp-local-host-p v) (tramp-method-out-of-band-p v size)) - (copy-file filename tmpfile t t)) + (copy-file filename tmpfile 'ok-if-already-exists 'keep-time)) ;; Use inline encoding for file transfer. (rem-enc @@ -3319,30 +3252,6 @@ the result will be a local, non-Tramp, file name." (run-hooks 'tramp-handle-file-local-copy-hook) tmpfile))) -;; This is needed for XEmacs only. Code stolen from files.el. -(defun tramp-sh-handle-insert-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally' for Tramp files." - (let ((format-alist nil) - (after-insert-file-functions nil) - (coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion) - (find-buffer-file-type-function - (if (fboundp 'find-buffer-file-type) - (symbol-function 'find-buffer-file-type) - nil)) - (inhibit-file-name-handlers - '(epa-file-handler image-file-handler jka-compr-handler)) - (inhibit-file-name-operation 'insert-file-contents)) - (unwind-protect - (progn - (fset 'find-buffer-file-type (lambda (_filename) t)) - (insert-file-contents filename visit beg end replace)) - ;; Save exit. - (if find-buffer-file-type-function - (fset 'find-buffer-file-type find-buffer-file-type-function) - (fmakunbound 'find-buffer-file-type))))) - ;; CCC grok LOCKNAME (defun tramp-sh-handle-write-region (start end filename &optional append visit lockname confirm) @@ -3359,14 +3268,13 @@ the result will be a local, non-Tramp, file name." ;; (error ;; "tramp-sh-handle-write-region: LOCKNAME must be nil or equal FILENAME")) - ;; XEmacs takes a coding system as the seventh argument, not `confirm'. - (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) + (when (and 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"))) - (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer)) + (let ((uid (or (nth 2 (file-attributes filename 'integer)) (tramp-get-remote-uid v 'integer))) - (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer)) + (gid (or (nth 3 (file-attributes filename 'integer)) (tramp-get-remote-gid v 'integer)))) (if (and (tramp-local-host-p v) @@ -3424,9 +3332,7 @@ the result will be a local, non-Tramp, file name." (signal (car err) (cdr err)))) ;; Now, `last-coding-system-used' has the right value. Remember it. - (when (boundp 'last-coding-system-used) - (setq coding-system-used - (symbol-value 'last-coding-system-used)))) + (setq coding-system-used last-coding-system-used)) ;; The permissions of the temporary file should be set. If ;; FILENAME does not exist (eq modes nil) it has been @@ -3436,7 +3342,7 @@ the result will be a local, non-Tramp, file name." (when modes (set-file-modes tmpfile - (logior (or modes 0) (tramp-compat-octal-to-decimal "0400")))) + (logior (or modes 0) (string-to-number "0400" 8)))) ;; This is a bit lengthy due to the different methods ;; possible for file transfer. First, we check whether the @@ -3576,7 +3482,7 @@ the result will be a local, non-Tramp, file name." (let (last-coding-system-used (need-chown t)) ;; Set file modification time. (when (or (eq visit t) (stringp visit)) - (let ((file-attr (tramp-compat-file-attributes filename 'integer))) + (let ((file-attr (file-attributes filename 'integer))) (set-visited-file-modtime ;; We must pass modtime explicitly, because FILENAME can ;; be different from (buffer-file-name), f.e. if @@ -3611,7 +3517,7 @@ the result will be a local, non-Tramp, file name." ;; any other remote command. (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." - (tramp-compat-with-temp-message "" + (with-temp-message "" (with-parsed-tramp-file-name file nil (with-tramp-progress-reporter v 3 (format-message "Checking `vc-registered' for %s" file) @@ -3768,7 +3674,12 @@ Fall back to normal file name handler if no Tramp handler exists." (concat "create,modify,move,moved_from,moved_to,move_self," "delete,delete_self,ignored")) ((memq 'attribute-change flags) "attrib,ignored")) - sequence `(,command "-mq" "-e" ,events ,localname))) + sequence `(,command "-mq" "-e" ,events ,localname) + ;; Make events a list of symbols. + events + (mapcar + (lambda (x) (intern-soft (replace-regexp-in-string "_" "-" x))) + (split-string events "," 'omit)))) ;; None. (t (tramp-error v 'file-notify-error @@ -3789,10 +3700,10 @@ Fall back to normal file name handler if no Tramp handler exists." (mapconcat 'identity sequence " ")) (tramp-message v 6 "Run `%s', %S" (mapconcat 'identity sequence " ") p) (tramp-set-connection-property p "vector" v) - ;; Needed for `tramp-sh-gvfs-monitor-dir-process-filter'. - (tramp-compat-process-put p 'events events) - (tramp-compat-process-put p 'watch-name localname) - (tramp-compat-set-process-query-on-exit-flag p nil) + ;; Needed for process filter. + (process-put p 'events events) + (process-put p 'watch-name localname) + (set-process-query-on-exit-flag p nil) (set-process-filter p filter) ;; There might be an error if the monitor is not supported. ;; Give the filter a chance to read the output. @@ -3805,16 +3716,17 @@ Fall back to normal file name handler if no Tramp handler exists." (defun tramp-sh-gvfs-monitor-dir-process-filter (proc string) "Read output from \"gvfs-monitor-dir\" and add corresponding \ file-notify events." - (let ((remote-prefix + (let ((events (process-get proc 'events)) + (remote-prefix (with-current-buffer (process-buffer proc) (file-remote-p default-directory))) - (rest-string (tramp-compat-process-get proc 'rest-string))) + (rest-string (process-get proc 'rest-string))) (when rest-string (tramp-message proc 10 "Previous string:\n%s" rest-string)) (tramp-message proc 6 "%S\n%s" proc string) (setq string (concat rest-string string) ;; Attribute change is returned in unused wording. - string (tramp-compat-replace-regexp-in-string + string (replace-regexp-in-string "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) (when (string-match "Monitoring not supported" string) (delete-process proc)) @@ -3831,59 +3743,65 @@ file-notify events." (object (list proc - (intern-soft - (tramp-compat-replace-regexp-in-string - "_" "-" (downcase (match-string 4 string)))) + (list + (intern-soft + (replace-regexp-in-string + "_" "-" (downcase (match-string 4 string))))) ;; File names are returned as absolute paths. We must ;; add the remote prefix. (concat remote-prefix file) (when file1 (concat remote-prefix file1))))) (setq string (replace-match "" nil nil string)) ;; Remove watch when file or directory to be watched is deleted. - (when (and (member (cadr object) '(moved deleted)) - (string-equal - file (tramp-compat-process-get proc 'watch-name))) + (when (and (member (caadr object) '(moved deleted)) + (string-equal file (process-get proc 'watch-name))) (delete-process proc)) ;; Usually, we would add an Emacs event now. Unfortunately, ;; `unread-command-events' does not accept several events at - ;; once. Therefore, we apply the callback directly. - (when (member (cadr object) (tramp-compat-process-get proc 'events)) - (tramp-compat-funcall 'file-notify-callback object)))) + ;; once. Therefore, we apply the handler directly. + (when (member (caadr object) events) + (tramp-compat-funcall + 'file-notify-handle-event + `(file-notify ,object file-notify-callback))))) ;; Save rest of the string. (when (zerop (length string)) (setq string nil)) (when string (tramp-message proc 10 "Rest string:\n%s" string)) - (tramp-compat-process-put proc 'rest-string string))) + (process-put proc 'rest-string string))) (defun tramp-sh-inotifywait-process-filter (proc string) "Read output from \"inotifywait\" and add corresponding file-notify events." - (tramp-message proc 6 "%S\n%s" proc string) - (dolist (line (split-string string "[\n\r]+" 'omit-nulls)) - ;; Check, whether there is a problem. - (unless - (string-match - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)+" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") - line) - (tramp-error proc 'file-notify-error "%s" line)) - - (let ((object - (list - proc - (mapcar - (lambda (x) - (intern-soft - (tramp-compat-replace-regexp-in-string "_" "-" (downcase x)))) - (split-string (match-string 1 line) "," 'omit-nulls)) - (match-string 3 line)))) - ;; Remove watch when file or directory to be watched is deleted. - (when (equal (cadr object) 'ignored) - (delete-process proc)) - ;; Usually, we would add an Emacs event now. Unfortunately, - ;; `unread-command-events' does not accept several events at - ;; once. Therefore, we apply the callback directly. - (tramp-compat-funcall 'file-notify-callback object)))) + (let ((events (process-get proc 'events))) + (tramp-message proc 6 "%S\n%s" proc string) + (dolist (line (split-string string "[\n\r]+" 'omit)) + ;; Check, whether there is a problem. + (unless + (string-match + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)+" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") + line) + (tramp-error proc 'file-notify-error "%s" line)) + + (let ((object + (list + proc + (mapcar + (lambda (x) + (intern-soft + (replace-regexp-in-string "_" "-" (downcase x)))) + (split-string (match-string 1 line) "," 'omit)) + (match-string 3 line)))) + ;; Remove watch when file or directory to be watched is deleted. + (when (member (caadr object) '(move-self delete-self ignored)) + (delete-process proc)) + ;; Usually, we would add an Emacs event now. Unfortunately, + ;; `unread-command-events' does not accept several events at + ;; once. Therefore, we apply the handler directly. + (when (member (caadr object) events) + (tramp-compat-funcall + 'file-notify-handle-event + `(file-notify ,object file-notify-callback))))))) ;;; Internal Functions: @@ -3899,7 +3817,7 @@ Only send the definition if it has not already been done." vec 5 (format-message "Sending script `%s'" name) ;; In bash, leading TABs like in `tramp-vc-registered-read-file-names' ;; could result in unwanted command expansion. Avoid this. - (setq script (tramp-compat-replace-regexp-in-string + (setq script (replace-regexp-in-string (make-string 1 ?\t) (make-string 8 ? ) script)) ;; The script could contain a call of Perl. This is masked with `%s'. (when (and (string-match "%s" script) @@ -3972,8 +3890,7 @@ This function expects to be in the right *tramp* buffer." (setq result (concat "\\" progname)))) (unless result (when ignore-tilde - ;; Remove all ~/foo directories from dirlist. In XEmacs, - ;; `remove' is in CL, and we want to avoid CL dependencies. + ;; Remove all ~/foo directories from dirlist. (let (newdl d) (while dirlist (setq d (car dirlist)) @@ -4216,45 +4133,36 @@ process to set up. VEC specifies the connection." ;; CCC this can't be the right way to do it. Hm. (tramp-message vec 5 "Determining coding system") (with-current-buffer (process-buffer proc) - (if (featurep 'mule) - ;; Use MULE to select the right EOL convention for communicating - ;; with the process. - (let ((cs (or (and (memq 'utf-8 (coding-system-list)) - (string-match "utf-?8" (tramp-get-remote-locale vec)) - (cons 'utf-8 'utf-8)) - (tramp-compat-funcall 'process-coding-system proc) - (cons 'undecided 'undecided))) - cs-decode cs-encode) - (when (symbolp cs) (setq cs (cons cs cs))) - (setq cs-decode (or (car cs) 'undecided) - cs-encode (or (cdr cs) 'undecided)) - (setq cs-encode - (tramp-compat-coding-system-change-eol-conversion - cs-encode - (if (string-match - "^Darwin" (tramp-get-connection-property vec "uname" "")) - 'mac 'unix))) - (tramp-send-command vec "echo foo ; echo bar" t) - (goto-char (point-min)) - (when (search-forward "\r" nil t) - (setq cs-decode (tramp-compat-coding-system-change-eol-conversion - cs-decode 'dos))) - ;; Special setting for Mac OS X. - (when (and (string-match - "^Darwin" (tramp-get-connection-property vec "uname" "")) - (memq 'utf-8-hfs (coding-system-list))) - (setq cs-decode 'utf-8-hfs - cs-encode 'utf-8-hfs)) - (tramp-compat-funcall - 'set-buffer-process-coding-system cs-decode cs-encode) - (tramp-message - vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode)) - ;; Look for ^M and do something useful if found. + ;; Use MULE to select the right EOL convention for communicating + ;; with the process. + (let ((cs (or (and (memq 'utf-8 (coding-system-list)) + (string-match "utf-?8" (tramp-get-remote-locale vec)) + (cons 'utf-8 'utf-8)) + (process-coding-system proc) + (cons 'undecided 'undecided))) + cs-decode cs-encode) + (when (symbolp cs) (setq cs (cons cs cs))) + (setq cs-decode (or (car cs) 'undecided) + cs-encode (or (cdr cs) 'undecided) + cs-encode + (coding-system-change-eol-conversion + cs-encode + (if (string-match + "^Darwin" (tramp-get-connection-property vec "uname" "")) + 'mac 'unix))) + (tramp-send-command vec "echo foo ; echo bar" t) + (goto-char (point-min)) (when (search-forward "\r" nil t) - ;; We have found a ^M but cannot frob the process coding system - ;; because we're running on a non-MULE Emacs. Let's try - ;; stty, instead. - (tramp-send-command vec "stty -onlcr" t)))) + (setq cs-decode (coding-system-change-eol-conversion cs-decode 'dos))) + ;; Special setting for Mac OS X. + (when (and (string-match + "^Darwin" (tramp-get-connection-property vec "uname" "")) + (memq 'utf-8-hfs (coding-system-list))) + (setq cs-decode 'utf-8-hfs + cs-encode 'utf-8-hfs)) + (set-buffer-process-coding-system cs-decode cs-encode) + (tramp-message + vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))) (tramp-send-command vec "set +o vi +o emacs" t) @@ -4311,7 +4219,7 @@ process to set up. VEC specifies the connection." ;; Set `remote-tty' process property. (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\"" 'noerror))) (unless (zerop (length tty)) - (tramp-compat-process-put proc 'remote-tty tty))) + (process-put proc 'remote-tty tty))) ;; Dump stty settings in the traces. (when (>= tramp-verbose 9) @@ -4324,7 +4232,7 @@ process to set up. VEC specifies the connection." (copy-sequence tramp-remote-process-environment))) unset vars item) (while env - (setq item (tramp-compat-split-string (car env) "=")) + (setq item (split-string (car env) "=" 'omit)) (setcdr item (mapconcat 'identity (cdr item) "=")) (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) (push (format "%s %s" (car item) (cdr item)) vars) @@ -4514,8 +4422,7 @@ Goes through the list `tramp-local-coding-commands' and value (format-spec-make ?t - (tramp-file-name-handler - 'file-remote-p tmpfile 'localname))))) + (file-remote-p tmpfile 'localname))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4711,7 +4618,7 @@ Gateway hops are already opened." (push (vector (tramp-file-name-method hop) (tramp-file-name-user hop) - (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil nil) + (tramp-gw-open-connection vec gw hop) nil nil) target-alist) ;; For the password prompt, we need the correct values. ;; Therefore, we must remember the gateway vector. But we @@ -4845,6 +4752,7 @@ connection if a previous connection has died for some reason." (unless (and p (processp p) (memq (process-status p) '(run open))) ;; If `non-essential' is non-nil, don't reopen a new connection. + ;; This variable has been introduced with Emacs 24.1. (when (and (boundp 'non-essential) (symbol-value 'non-essential)) (throw 'non-essential 'non-essential)) @@ -4882,6 +4790,9 @@ connection if a previous connection has died for some reason." (options (tramp-ssh-controlmaster-options vec)) (process-connection-type tramp-process-connection-type) (process-adaptive-read-buffering nil) + ;; There are unfortune settings for "cmdproxy" on + ;; W32 systems. + (process-coding-system-alist nil) (coding-system-for-read nil) ;; This must be done in order to avoid our file ;; name handler. @@ -4899,7 +4810,7 @@ connection if a previous connection has died for some reason." ;; Set sentinel and query flag. (tramp-set-connection-property p "vector" vec) (set-process-sentinel p 'tramp-process-sentinel) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) (setq tramp-current-connection (cons (butlast (append vec nil) 2) (current-time)) tramp-current-host (system-name)) @@ -5198,12 +5109,12 @@ Return ATTR." (when (and (numberp (nth 2 attr)) (< (nth 2 attr) 0)) (setcar (nthcdr 2 attr) -1)) (when (and (floatp (nth 2 attr)) - (<= (nth 2 attr) (tramp-compat-most-positive-fixnum))) + (<= (nth 2 attr) most-positive-fixnum)) (setcar (nthcdr 2 attr) (round (nth 2 attr)))) (when (and (numberp (nth 3 attr)) (< (nth 3 attr) 0)) (setcar (nthcdr 3 attr) -1)) (when (and (floatp (nth 3 attr)) - (<= (nth 3 attr) (tramp-compat-most-positive-fixnum))) + (<= (nth 3 attr) most-positive-fixnum)) (setcar (nthcdr 3 attr) (round (nth 3 attr)))) ;; Convert last access time. (unless (listp (nth 4 attr)) @@ -5224,7 +5135,7 @@ Return ATTR." (when (< (nth 7 attr) 0) (setcar (nthcdr 7 attr) -1)) (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) (tramp-compat-most-positive-fixnum))) + (<= (nth 7 attr) most-positive-fixnum)) (setcar (nthcdr 7 attr) (round (nth 7 attr)))) ;; Convert file mode bits to string. (unless (stringp (nth 8 attr)) @@ -5356,7 +5267,7 @@ Return ATTR." (when elt1 (setcdr elt1 (append - (tramp-compat-split-string (or default-remote-path "") ":") + (split-string (or default-remote-path "") ":" 'omit) (cdr elt1))) (setq remote-path (delq 'tramp-default-remote-path remote-path))) @@ -5364,7 +5275,7 @@ Return ATTR." (when elt2 (setcdr elt2 (append - (tramp-compat-split-string (or own-remote-path "") ":") + (split-string (or own-remote-path "") ":" 'omit) (cdr elt2))) (setq remote-path (delq 'tramp-own-remote-path remote-path))) @@ -5570,7 +5481,7 @@ Return ATTR." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (tramp-file-name-handler 'file-remote-p tmpfile 'localname)))) + (file-remote-p tmpfile 'localname)))) (delete-file tmpfile)) result))) diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 509e2e388b8..c4dde050c83 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -224,7 +224,6 @@ See `tramp-actions-before-shell' for more info.") (directory-files . tramp-smb-handle-directory-files) (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - (dired-call-process . ignore) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) (expand-file-name . tramp-smb-handle-expand-file-name) @@ -276,7 +275,7 @@ See `tramp-actions-before-shell' for more info.") (shell-command . tramp-handle-shell-command) (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) + (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) (write-region . tramp-smb-handle-write-region)) @@ -419,12 +418,11 @@ pass to the OPERATION." (unwind-protect (progn (make-directory tmpdir) - (tramp-compat-copy-directory - dirname tmpdir keep-date 'parents) - (tramp-compat-copy-directory + (copy-directory dirname tmpdir keep-date 'parents) + (copy-directory (expand-file-name (file-name-nondirectory dirname) tmpdir) newname keep-date parents)) - (tramp-compat-delete-directory tmpdir 'recursive)))) + (delete-directory tmpdir 'recursive)))) ;; We can copy recursively. ((or t1 t2) @@ -448,7 +446,7 @@ pass to the OPERATION." (port (tramp-file-name-port v)) (share (tramp-smb-get-share v)) (localname (file-name-as-directory - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v)))) (tmpdir (make-temp-name (expand-file-name @@ -510,7 +508,7 @@ pass to the OPERATION." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (tramp-set-connection-property p "vector" v) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-with-tar) (while (memq (process-status p) '(run open)) @@ -520,7 +518,7 @@ pass to the OPERATION." ;; Reset the transfer process properties. (tramp-set-connection-property v "process-name" nil) (tramp-set-connection-property v "process-buffer" nil) - (when t1 (tramp-compat-delete-directory tmpdir 'recurse)))) + (when t1 (delete-directory tmpdir 'recurse)))) ;; Handle KEEP-DATE argument. (when keep-date @@ -555,7 +553,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." 0 (format "Copying %s to %s" filename newname) (if (file-directory-p filename) - (tramp-compat-copy-directory filename newname keep-date t t) + (tramp-compat-copy-directory + filename newname keep-date 'parents 'copy-contents) (let ((tmpfile (file-local-copy filename))) (if tmpfile @@ -601,7 +600,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (mapc (lambda (file) (if (file-directory-p file) - (tramp-compat-delete-directory file recursive) + (delete-directory file recursive) (delete-file file))) ;; We do not want to delete "." and "..". (directory-files @@ -665,7 +664,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; Sort them if necessary. (unless nosort (setq result (sort result 'string-lessp))) ;; Remove double entries. - (tramp-compat-delete-dups result))) + (delete-dups result))) (defun tramp-smb-handle-expand-file-name (name &optional dir) "Like `expand-file-name' for Tramp files." @@ -730,7 +729,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (domain (tramp-file-name-domain v)) (port (tramp-file-name-port v)) (share (tramp-smb-get-share v)) - (localname (tramp-compat-replace-regexp-in-string + (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" real-host "/" share) "-E"))) @@ -765,11 +764,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (tramp-set-connection-property p "vector" v) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-get-acl) (when (> (point-max) (point-min)) - (tramp-compat-funcall - 'substring-no-properties (buffer-string))))) + (substring-no-properties (buffer-string))))) ;; Reset the transfer process properties. (tramp-set-connection-property v "process-name" nil) @@ -1068,9 +1066,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-smb-send-command v (if (tramp-smb-get-cifs-capabilities v) - (format - "posix_mkdir \"%s\" %s" - file (tramp-compat-decimal-to-octal (default-file-modes))) + (format "posix_mkdir \"%s\" %o" file (default-file-modes)) (format "mkdir \"%s\"" file))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. @@ -1240,12 +1236,7 @@ target of the symlink differ." (unless outbuf (kill-buffer (tramp-get-connection-property v "process-buffer" nil))) - ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to nil, no remote file will be changed - ;; by `program'. If it doesn't exist, we assume its default - ;; value t. - (unless (and (boundp 'process-file-side-effects) - (not (symbol-value 'process-file-side-effects))) + (unless process-file-side-effects (tramp-flush-directory-property v "")) ;; Return exit status. @@ -1296,9 +1287,10 @@ target of the symlink differ." (tramp-error v2 'file-error "Cannot rename `%s'" filename)))) ;; We must rename via copy. - (tramp-compat-copy-file filename newname ok-if-already-exists t t t) + (copy-file + filename newname ok-if-already-exists 'keep-time 'preserve-uid-gid) (if (file-directory-p filename) - (tramp-compat-delete-directory filename 'recursive) + (delete-directory filename 'recursive) (delete-file filename))))) (defun tramp-smb-action-set-acl (proc vec) @@ -1325,10 +1317,10 @@ target of the symlink differ." (domain (tramp-file-name-domain v)) (port (tramp-file-name-port v)) (share (tramp-smb-get-share v)) - (localname (tramp-compat-replace-regexp-in-string + (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" real-host "/" share) "-E" "-S" - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string "\n" "," acl-string)))) (if (not (zerop (length real-user))) @@ -1364,7 +1356,7 @@ target of the symlink differ." (tramp-message v 6 "%s" (mapconcat 'identity (process-command p) " ")) (tramp-set-connection-property p "vector" v) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) (tramp-process-actions p v nil tramp-smb-actions-set-acl) (goto-char (point-max)) (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) @@ -1387,9 +1379,7 @@ target of the symlink differ." (when (tramp-smb-get-cifs-capabilities v) (tramp-flush-file-property v localname) (unless (tramp-smb-send-command - v (format "chmod \"%s\" %s" - (tramp-smb-get-localname v) - (tramp-compat-decimal-to-octal mode))) + v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) (tramp-error v 'file-error "Error while changing file's mode %s" filename))))) @@ -1460,9 +1450,7 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." "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)) + (when (and 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"))) @@ -1575,10 +1563,6 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." ;; Add directory itself. (push '("" "drwxrwxrwx" 0 (0 0)) res) - ;; There's a very strange error (debugged with XEmacs 21.4.14) - ;; If there's no short delay, it returns nil. No idea about. - (when (featurep 'xemacs) (sleep-for 0.01)) - ;; Return entries. (delq nil res)))))) @@ -1738,7 +1722,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (member "pathnames" (split-string - (buffer-substring (point) (point-at-eol)) nil t))))))))) + (buffer-substring (point) (point-at-eol)) nil 'omit))))))))) (defun tramp-smb-get-stat-capability (vec) "Check, whether the SMB server supports the STAT command." @@ -1878,7 +1862,7 @@ If ARGUMENT is non-nil, use it as argument for (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) (tramp-set-connection-property p "vector" vec) - (tramp-compat-set-process-query-on-exit-flag p nil) + (set-process-query-on-exit-flag p nil) ;; Set variables for computing the prompt for reading password. (setq tramp-current-method tramp-smb-method diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 26672d1fabb..28fc9c748bb 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -34,9 +34,7 @@ ;; Notes: ;; ----- ;; -;; This package only works for Emacs 22.1 and higher, and for XEmacs 21.4 -;; and higher. For XEmacs 21, you need the package `fsf-compat' for -;; the `with-timeout' macro. +;; This package only works for Emacs 23.1 and higher. ;; ;; Also see the todo list at the bottom of this file. ;; @@ -61,11 +59,7 @@ ;; Pacify byte-compiler. (eval-when-compile (require 'cl)) -(defvar bkup-backup-directory-info) -(defvar directory-sep-char) (defvar eshell-path-env) -(defvar ls-lisp-use-insert-directory-program) -(defvar outline-regexp) ;;; User Customizable Internal Variables: @@ -102,11 +96,8 @@ Any level x includes messages for all levels 1 .. x-1. The levels are :group 'tramp :type 'integer) -;; Emacs case. -(eval-and-compile - (when (boundp 'backup-directory-alist) - (defcustom tramp-backup-directory-alist nil - "Alist of filename patterns and backup directory names. +(defcustom tramp-backup-directory-alist nil + "Alist of filename patterns and backup directory names. Each element looks like (REGEXP . DIRECTORY), with the same meaning like in `backup-directory-alist'. If a Tramp file is backed up, and DIRECTORY is a local file name, the backup directory is prepended with Tramp file @@ -116,34 +107,9 @@ name prefix \(method, user, host) of file. gives the same backup policy for Tramp files on their hosts like the policy for local files." - :group 'tramp - :type '(repeat (cons (regexp :tag "Regexp matching filename") - (directory :tag "Backup directory name")))))) - -;; XEmacs case. We cannot check for `bkup-backup-directory-info', because -;; the package "backup-dir" might not be loaded yet. -(eval-and-compile - (when (featurep 'xemacs) - (defcustom tramp-bkup-backup-directory-info nil - "Alist of (FILE-REGEXP BACKUP-DIR OPTIONS ...)) -It has the same meaning like `bkup-backup-directory-info' from package -`backup-dir'. If a Tramp file is backed up, and BACKUP-DIR is a local -file name, the backup directory is prepended with Tramp file name prefix -\(method, user, host) of file. - -\(setq tramp-bkup-backup-directory-info bkup-backup-directory-info) - -gives the same backup policy for Tramp files on their hosts like the -policy for local files." - :type '(repeat - (list (regexp :tag "File regexp") - (string :tag "Backup Dir") - (set :inline t - (const ok-create) - (const full-path) - (const prepend-name) - (const search-upward)))) - :group 'tramp))) + :group 'tramp + :type '(repeat (cons (regexp :tag "Regexp matching filename") + (directory :tag "Backup directory name")))) (defcustom tramp-auto-save-directory nil "Put auto-save files in this directory, if set. @@ -154,9 +120,7 @@ This setting has precedence over `auto-save-file-name-transforms'." (directory :tag "Auto save directory name"))) (defcustom tramp-encoding-shell - (if (memq system-type '(windows-nt)) - (getenv "COMSPEC") - "/bin/sh") + (or (tramp-compat-funcall 'w32-shell-name) "/bin/sh") "Use this program for encoding and decoding commands on the local host. This shell is used to execute the encoding and decoding command on the local host, so if you want to use `~' in those commands, you should @@ -180,16 +144,14 @@ use for the remote host." :type '(file :must-match t)) (defcustom tramp-encoding-command-switch - (if (string-match "cmd\\.exe" (or tramp-encoding-shell "")) - "/c" - "-c") + (if (tramp-compat-funcall 'w32-shell-dos-semantics) "/c" "-c") "Use this switch together with `tramp-encoding-shell' for local commands. See the variable `tramp-encoding-shell' for more information." :group 'tramp :type 'string) (defcustom tramp-encoding-command-interactive - (unless (string-match "cmd\\.exe" (or tramp-encoding-shell "")) "-i") + (unless (tramp-compat-funcall 'w32-shell-dos-semantics) "-i") "Use this switch together with `tramp-encoding-shell' for interactive shells. See the variable `tramp-encoding-shell' for more information." :version "24.1" @@ -329,25 +291,9 @@ useful only in combination with `tramp-default-proxies-alist'.") ;; PuTTY is installed. We don't take it, if it is installed on a ;; non-windows system, or pscp from the pssh (parallel ssh) package ;; is found. - ((and (eq system-type 'windows-nt) - (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" - "plink")) + ((and (eq system-type 'windows-nt) (executable-find "pscp")) "pscp") ;; There is an ssh installation. - ((executable-find "scp") - (if (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")) - "scp" - "ssh")) + ((executable-find "scp") "scp") ;; Fallback. (t "ftp")) "Default method to use for transferring files. @@ -482,6 +428,7 @@ names from FILE for completion. The following predefined FUNCTIONs exists: * `tramp-parse-sknownhosts' for \"~/.ssh2/knownhosts/*\" like files, * `tramp-parse-hosts' for \"/etc/hosts\" like files, * `tramp-parse-passwd' for \"/etc/passwd\" like files. + * `tramp-parse-etc-group' for \"/etc/group\" like files. * `tramp-parse-netrc' for \"~/.netrc\" like files. * `tramp-parse-putty' for PuTTY registered sessions. @@ -541,7 +488,7 @@ Sometimes the prompt is reported to look like \"login as:\"." ;; regexp works only for GNU Emacs. ;; Allow also [] style prompts. They can appear only during ;; connection initialization; Tramp redefines the prompt afterwards. - (concat (if (featurep 'xemacs) "" "\\(?:^\\|\r\\)") + (concat "\\(?:^\\|\r\\)" "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' @@ -559,6 +506,7 @@ This regexp must match both `tramp-initial-end-of-output' and (defcustom tramp-password-prompt-regexp (format "^.*\\(%s\\).*:\^@? *" + ;; `password-word-equivalents' has been introduced with Emacs 24.4. (if (boundp 'password-word-equivalents) (regexp-opt (symbol-value 'password-word-equivalents)) "password\\|passphrase")) @@ -677,28 +625,17 @@ Useful for \"rsync\" like methods.") (make-variable-buffer-local 'tramp-temp-buffer-file-name) (put 'tramp-temp-buffer-file-name 'permanent-local t) -;; XEmacs is distributed with few Lisp packages. Further packages are -;; installed using EFS. If we use a unified filename format, then -;; Tramp is required in addition to EFS. (But why can't Tramp just -;; disable EFS when Tramp is loaded? Then XEmacs can ship with EFS -;; just like before.) Another reason for using a separate filename -;; syntax on XEmacs is that EFS hooks into XEmacs in many places, but -;; Tramp only knows how to deal with `file-name-handler-alist', not -;; the other places. - -;; Currently, we have the choice between 'ftp and 'sep. ;;;###autoload -(defcustom tramp-syntax - (if (featurep 'xemacs) 'sep 'ftp) +(defcustom tramp-syntax 'ftp "Tramp filename syntax to be used. It can have the following values: - `ftp' -- Ange-FTP respective EFS like syntax (GNU Emacs default) - `sep' -- Syntax as defined for XEmacs." + `ftp' -- Ange-FTP like syntax + `sep' -- Syntax as defined for XEmacs originally." :group 'tramp :version "24.4" - :type `(choice (const :tag ,(if (featurep 'xemacs) "EFS" "Ange-FTP") ftp) + :type '(choice (const :tag "Ange-FTP" ftp) (const :tag "XEmacs" sep))) (defconst tramp-prefix-format @@ -883,15 +820,13 @@ See also `tramp-file-name-regexp'.") "\\`/\\(\\[.*\\]\\|[^/|:]\\{2,\\}[^/|]*\\):" "\\`/[^/|:][^/|]*:") "Value for `tramp-file-name-regexp' for unified remoting. -Emacs (not XEmacs) uses a unified filename syntax for Ange-FTP and -Tramp. See `tramp-file-name-structure' for more explanations. +See `tramp-file-name-structure' for more explanations. On W32 systems, the volume letter must be ignored.") ;;;###autoload (defconst tramp-file-name-regexp-separate "\\`/\\[.*\\]" "Value for `tramp-file-name-regexp' for separate remoting. -XEmacs uses a separate filename syntax for Tramp and EFS. See `tramp-file-name-structure' for more explanations.") ;;;###autoload @@ -919,7 +854,6 @@ Also see `tramp-file-name-structure'.") (if (memq system-type '(cygwin windows-nt)) "\\`/[^/]\\{2,\\}\\'" "\\`/[^/]*\\'") "Value for `tramp-completion-file-name-regexp' for unified remoting. -GNU Emacs uses a unified filename syntax for Tramp and Ange-FTP. See `tramp-file-name-structure' for more explanations. On W32 systems, the volume letter must be ignored.") @@ -928,7 +862,6 @@ On W32 systems, the volume letter must be ignored.") (defconst tramp-completion-file-name-regexp-separate "\\`/\\([[][^]]*\\)?\\'" "Value for `tramp-completion-file-name-regexp' for separate remoting. -XEmacs uses a separate filename syntax for Tramp and EFS. See `tramp-file-name-structure' for more explanations.") ;;;###autoload @@ -951,10 +884,7 @@ Also see `tramp-file-name-structure'.") ;; to drop bytes when data is sent too quickly. There is also a connection ;; buffer local variable, which is computed depending on remote host properties ;; when `tramp-chunksize' is zero or nil. -(defcustom tramp-chunksize - (when (and (not (featurep 'xemacs)) - (memq system-type '(hpux))) - 500) +(defcustom tramp-chunksize (when (memq system-type '(hpux)) 500) ;; Parentheses in docstring starting at beginning of line are escaped. ;; Fontification is messed up when ;; `open-paren-in-column-0-is-defun-start' set to t. @@ -1077,9 +1007,10 @@ means to use always cached values for the directory contents." (defvar tramp-current-connection nil "Last connection timestamp.") -;;;###autoload (defconst tramp-completion-file-name-handler-alist - '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) + '((expand-file-name . tramp-completion-handle-expand-file-name) + (file-name-all-completions + . tramp-completion-handle-file-name-all-completions) (file-name-completion . tramp-completion-handle-file-name-completion)) "Alist of completion handler functions. Used for file names matching `tramp-file-name-regexp'. Operations @@ -1111,11 +1042,10 @@ If VEC is a vector, check first in connection properties. Afterwards, check in `tramp-methods'. If the `tramp-methods' entry does not exist, return nil." (let ((hash-entry - (tramp-compat-replace-regexp-in-string - "^tramp-" "" (symbol-name param)))) + (replace-regexp-in-string "^tramp-" "" (symbol-name param)))) (if (tramp-connection-property-p vec hash-entry) ;; We use the cached property. - (tramp-get-connection-property vec hash-entry nil) + (tramp-get-connection-property vec hash-entry nil) ;; Use the static value from `tramp-methods'. (let ((methods-entry (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) @@ -1230,11 +1160,10 @@ their replacement." ;; This works with the current set of `tramp-obsolete-methods'. ;; Must be improved, if their are more sophisticated replacements. (setq result (substring result 0 -1))) - ;; We must mark, whether a default value has been used. Not - ;; applicable for XEmacs. - (if (or method (null result) (null (functionp 'propertize))) + ;; We must mark, whether a default value has been used. + (if (or method (null result)) result - (tramp-compat-funcall 'propertize result 'tramp-default t)))) + (propertize result 'tramp-default t)))) (defun tramp-find-user (method user host) "Return the right user string to use. @@ -1252,11 +1181,10 @@ This is USER, if non-nil. Otherwise, do a lookup in (setq choices nil))) luser) tramp-default-user))) - ;; We must mark, whether a default value has been used. Not - ;; applicable for XEmacs. - (if (or user (null result) (null (functionp 'propertize))) + ;; We must mark, whether a default value has been used. + (if (or user (null result)) result - (tramp-compat-funcall 'propertize result 'tramp-default t)))) + (propertize result 'tramp-default t)))) (defun tramp-find-host (method user host) "Return the right host string to use. @@ -1447,8 +1375,7 @@ ARGUMENTS to actually emit the message (if applicable)." (when (bobp) (insert (format - ";; %sEmacs: %s Tramp: %s -*- mode: outline; -*-" - (if (featurep 'sxemacs) "SX" (if (featurep 'xemacs) "X" "GNU ")) + ";; Emacs: %s Tramp: %s -*- mode: outline; -*-" emacs-version tramp-version)) (when (>= tramp-verbose 10) (insert @@ -1481,7 +1408,6 @@ ARGUMENTS to actually emit the message (if applicable)." '("tramp-backtrace" "tramp-compat-condition-case-unless-debug" "tramp-compat-funcall" - "tramp-compat-with-temp-message" "tramp-condition-case-unless-debug" "tramp-debug-message" "tramp-error" @@ -1651,14 +1577,13 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (put 'with-parsed-tramp-file-name 'lisp-indent-function 2) (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) -(tramp-compat-font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value) (let* ((parameters (cdr reporter)) (message (aref parameters 3))) (when (string-match message (or (current-message) "")) - (tramp-compat-funcall 'progress-reporter-update reporter value)))) + (progress-reporter-update reporter value)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) "Executes BODY, spinning a progress reporter with MESSAGE. @@ -1675,19 +1600,18 @@ without a visible progress reporter." ;; Display only when there is a minimum level. (<= ,level (min tramp-verbose 3))) (ignore-errors - (let ((pr (tramp-compat-funcall - #'make-progress-reporter ,message))) + (let ((pr (make-progress-reporter ,message nil nil))) (when pr - (run-at-time 3 0.1 - #'tramp-progress-reporter-update pr))))))) + (run-at-time + 3 0.1 #'tramp-progress-reporter-update pr))))))) (unwind-protect ;; Execute the body. (prog1 (progn ,@body) (setq cookie "done")) ;; Stop progress reporter. - (if tm (tramp-compat-funcall 'cancel-timer tm)) + (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) -(tramp-compat-font-lock-add-keywords +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-progress-reporter\\>")) (defmacro with-tramp-file-property (vec file property &rest body) @@ -1706,8 +1630,7 @@ FILE must be a local file name on a connection identified via VEC." (put 'with-tramp-file-property 'lisp-indent-function 3) (put 'with-tramp-file-property 'edebug-form-spec t) -(tramp-compat-font-lock-add-keywords - 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise executes BODY and set." @@ -1722,7 +1645,7 @@ FILE must be a local file name on a connection identified via VEC." (put 'with-tramp-connection-property 'lisp-indent-function 2) (put 'with-tramp-connection-property 'edebug-form-spec t) -(tramp-compat-font-lock-add-keywords +(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) (defun tramp-drop-volume-letter (name) @@ -1787,16 +1710,17 @@ Example: (defun tramp-get-completion-function (method) "Returns a list of completion functions for METHOD. For definition of that list see `tramp-set-completion-function'." - (cons - ;; Hosts visited once shall be remembered. - `(tramp-parse-connection-properties ,method) + (append + `(;; Default settings are taken into account. + (tramp-parse-default-user-host ,method) + ;; Hosts visited once shall be remembered. + (tramp-parse-connection-properties ,method)) ;; The method related defaults. (cdr (assoc method tramp-completion-function-alist)))) ;;; Fontification of `read-file-name': -;; rfn-eshadow.el is part of Emacs 22. It is autoloaded. (defvar tramp-rfn-eshadow-overlay) (make-variable-buffer-local 'tramp-rfn-eshadow-overlay) @@ -1806,28 +1730,22 @@ Adds another overlay hiding filename parts according to Tramp's special handling of `substitute-in-file-name'." (when (symbol-value 'minibuffer-completing-file-name) (setq tramp-rfn-eshadow-overlay - (tramp-compat-funcall - 'make-overlay - (tramp-compat-funcall 'minibuffer-prompt-end) - (tramp-compat-funcall 'minibuffer-prompt-end))) + (make-overlay (minibuffer-prompt-end) (minibuffer-prompt-end))) ;; Copy rfn-eshadow-overlay properties. - (let ((props (tramp-compat-funcall - 'overlay-properties (symbol-value 'rfn-eshadow-overlay)))) + (let ((props (overlay-properties (symbol-value 'rfn-eshadow-overlay)))) (while 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)) + (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 - 'tramp-rfn-eshadow-setup-minibuffer) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'rfn-eshadow-setup-minibuffer-hook - 'tramp-rfn-eshadow-setup-minibuffer)))) +(add-hook 'rfn-eshadow-setup-minibuffer-hook + 'tramp-rfn-eshadow-setup-minibuffer) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'rfn-eshadow-setup-minibuffer-hook + 'tramp-rfn-eshadow-setup-minibuffer))) (defconst tramp-rfn-eshadow-update-overlay-regexp (format "[^%s/~]*\\(/\\|~\\)" tramp-postfix-host-format)) @@ -1839,15 +1757,13 @@ This is intended to be used as a minibuffer `post-command-hook' for been set up by `rfn-eshadow-setup-minibuffer'." ;; In remote files name, there is a shadowing just for the local part. (ignore-errors - (let ((end (or (tramp-compat-funcall - 'overlay-end (symbol-value 'rfn-eshadow-overlay)) - (tramp-compat-funcall 'minibuffer-prompt-end))) + (let ((end (or (overlay-end (symbol-value 'rfn-eshadow-overlay)) + (minibuffer-prompt-end))) ;; We do not want to send any remote command. (non-essential t)) (when (tramp-tramp-file-p - (tramp-compat-funcall - 'buffer-substring-no-properties end (point-max))) + (buffer-substring-no-properties end (point-max))) (save-excursion (save-restriction (narrow-to-region @@ -1859,17 +1775,15 @@ been set up by `rfn-eshadow-setup-minibuffer'." (let ((rfn-eshadow-overlay tramp-rfn-eshadow-overlay) (rfn-eshadow-update-overlay-hook nil) file-name-handler-alist) - (tramp-compat-funcall - 'move-overlay rfn-eshadow-overlay (point-max) (point-max)) - (tramp-compat-funcall 'rfn-eshadow-update-overlay)))))))) - -(when (boundp 'rfn-eshadow-update-overlay-hook) - (add-hook 'rfn-eshadow-update-overlay-hook - 'tramp-rfn-eshadow-update-overlay) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'rfn-eshadow-update-overlay-hook - 'tramp-rfn-eshadow-update-overlay)))) + (move-overlay rfn-eshadow-overlay (point-max) (point-max)) + (rfn-eshadow-update-overlay)))))))) + +(add-hook 'rfn-eshadow-update-overlay-hook + 'tramp-rfn-eshadow-update-overlay) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'rfn-eshadow-update-overlay-hook + 'tramp-rfn-eshadow-update-overlay))) ;; Inodes don't exist for some file systems. Therefore we must ;; generate virtual ones. Used in `find-buffer-visiting'. The method @@ -1892,12 +1806,13 @@ been set up by `rfn-eshadow-setup-minibuffer'." If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." (or (file-modes filename) - (logand (default-file-modes) (tramp-compat-octal-to-decimal "0666")))) + (logand (default-file-modes) (string-to-number "0666" 8)))) (defun tramp-replace-environment-variables (filename) "Replace environment variables in FILENAME. Return the string with the replaced variables." (or (ignore-errors + ;; Optional arg has been introduced with Emacs 24 (?). (tramp-compat-funcall 'substitute-env-vars filename 'only-defined)) ;; We need an own implementation. (save-match-data @@ -1912,35 +1827,6 @@ Return the string with the replaced variables." t nil filename))) filename)))) -;; In XEmacs, electricity is implemented via a key map for ?/ and ?~, -;; which calls corresponding functions (see minibuf.el). -(when (fboundp 'minibuffer-electric-separator) - (mapc - (lambda (x) - (eval - `(defadvice ,x - (around ,(intern (format "tramp-advice-%s" x)) activate) - "Invoke `substitute-in-file-name' for Tramp files." - (if (and (symbol-value 'minibuffer-electric-file-name-behavior) - (tramp-tramp-file-p (buffer-substring))) - ;; We don't need to handle `last-input-event', because - ;; due to the key map we know it must be ?/ or ?~. - (let ((s (concat (buffer-substring (point-min) (point)) - (string last-command-char)))) - (delete-region (point-min) (point)) - (insert (substitute-in-file-name s)) - (setq ad-return-value last-command-char)) - ad-do-it))) - (eval - `(add-hook - 'tramp-unload-hook - (lambda () - (ad-remove-advice ',x 'around ',(intern (format "tramp-advice-%s" x))) - (ad-activate ',x))))) - - '(minibuffer-electric-separator - minibuffer-electric-tilde))) - (defun tramp-find-file-name-coding-system-alist (filename tmpname) "Like `find-operation-coding-system' for Tramp filenames. Tramp's `insert-file-contents' and `write-region' work over @@ -2000,49 +1886,35 @@ ARGS are the arguments OPERATION has been called with." (cond ;; FILE resp DIRECTORY. ((member operation - (list 'access-file 'byte-compiler-base-file-name 'delete-directory - 'delete-file 'diff-latest-backup-file 'directory-file-name - 'directory-files 'directory-files-and-attributes - 'dired-compress-file 'dired-uncache - 'file-accessible-directory-p 'file-attributes - 'file-directory-p 'file-executable-p 'file-exists-p - 'file-local-copy 'file-modes - 'file-name-as-directory 'file-name-directory - 'file-name-nondirectory 'file-name-sans-versions - 'file-ownership-preserved-p 'file-readable-p - 'file-regular-p 'file-remote-p 'file-symlink-p 'file-truename - 'file-writable-p 'find-backup-file-name 'find-file-noselect - 'get-file-buffer 'insert-directory 'insert-file-contents - 'load 'make-directory 'make-directory-internal - 'set-file-modes 'substitute-in-file-name - 'unhandled-file-name-directory 'vc-registered - ;; Emacs 22+ only. - 'set-file-times - ;; Emacs 24+ only. - 'file-acl 'file-notify-add-watch - 'file-selinux-context 'set-file-acl 'set-file-selinux-context - ;; XEmacs only. - 'abbreviate-file-name 'create-file-buffer - 'dired-file-modtime 'dired-make-compressed-filename - 'dired-recursive-delete-directory 'dired-set-file-modtime - 'dired-shell-unhandle-file-name 'dired-uucode-file - 'insert-file-contents-literally 'make-temp-name 'recover-file - 'vm-imap-check-mail 'vm-pop-check-mail 'vm-spool-check-mail)) + '(access-file byte-compiler-base-file-name delete-directory + delete-file diff-latest-backup-file directory-file-name + directory-files directory-files-and-attributes + dired-compress-file dired-uncache + file-accessible-directory-p file-attributes + file-directory-p file-executable-p file-exists-p + file-local-copy file-modes + file-name-as-directory file-name-directory + file-name-nondirectory file-name-sans-versions + file-ownership-preserved-p file-readable-p + file-regular-p file-remote-p file-symlink-p file-truename + file-writable-p find-backup-file-name find-file-noselect + get-file-buffer insert-directory insert-file-contents + load make-directory make-directory-internal + set-file-modes set-file-times substitute-in-file-name + unhandled-file-name-directory vc-registered + ;; Emacs 24+ only. + file-acl file-notify-add-watch file-selinux-context + set-file-acl set-file-selinux-context)) (if (file-name-absolute-p (nth 0 args)) (nth 0 args) (expand-file-name (nth 0 args)))) ;; FILE DIRECTORY resp FILE1 FILE2. ((member operation - (list 'add-name-to-file 'copy-file 'expand-file-name - 'file-name-all-completions 'file-name-completion - 'file-newer-than-file-p 'make-symbolic-link 'rename-file - ;; Emacs 23+ only. - 'copy-directory - ;; Emacs 24+ only. - 'file-equal-p 'file-in-directory-p - ;; XEmacs only. - 'dired-make-relative-symlink - 'vm-imap-move-mail 'vm-pop-move-mail 'vm-spool-move-mail)) + '(add-name-to-file copy-directory copy-file expand-file-name + file-name-all-completions file-name-completion + file-newer-than-file-p make-symbolic-link rename-file + ;; Emacs 24+ only. + file-equal-p file-in-directory-p)) (save-match-data (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) @@ -2053,35 +1925,28 @@ ARGS are the arguments OPERATION has been called with." (nth 2 args)) ;; BUFFER. ((member operation - (list 'set-visited-file-modtime 'verify-visited-file-modtime - ;; Emacs 22+ only. - 'make-auto-save-file-name - ;; XEmacs only. - 'backup-buffer)) + '(make-auto-save-file-name + set-visited-file-modtime verify-visited-file-modtime)) (buffer-file-name (if (bufferp (nth 0 args)) (nth 0 args) (current-buffer)))) ;; COMMAND. ((member operation - (list ;; not in Emacs 23+. - 'dired-call-process - ;; Emacs only. - 'shell-command - ;; Emacs 22+ only. - 'process-file - ;; Emacs 23+ only. - 'start-file-process - ;; XEmacs only. - 'dired-print-file 'dired-shell-call-process)) + '(process-file shell-command start-file-process)) default-directory) ;; PROC. - ((member operation (list 'file-notify-rm-watch 'file-notify-valid-p)) + ((member operation + '(;; Emacs 24+ only. + file-notify-rm-watch + ;; Emacs 25+ only. + file-notify-valid-p)) (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) ;; Unknown file primitive. (t (error "unknown file I/O primitive: %s" operation)))) -(defun tramp-find-foreign-file-name-handler (filename) +(defun tramp-find-foreign-file-name-handler + (filename &optional operation completion) "Return foreign file name handler if exists." (when (tramp-tramp-file-p filename) (let ((v (tramp-dissect-file-name filename t)) @@ -2089,11 +1954,17 @@ ARGS are the arguments OPERATION has been called with." elt res) ;; When we are not fully sure that filename completion is safe, ;; we should not return a handler. - (when (or (tramp-file-name-method v) (tramp-file-name-user v) + (when (or (not completion) + (tramp-file-name-method v) (tramp-file-name-user v) (and (tramp-file-name-host v) (not (member (tramp-file-name-host v) (mapcar 'car tramp-methods)))) - (not (tramp-completion-mode-p))) + ;; Some operations are safe by default. + (member + operation + '(file-name-as-directory + file-name-directory + file-name-nondirectory))) (while handler (setq elt (car handler) handler (cdr handler)) @@ -2121,13 +1992,15 @@ Falls back to normal file name handler if no Tramp file name handler exists." (tramp-replace-environment-variables (apply 'tramp-file-name-for-operation operation args))) (completion (tramp-completion-mode-p)) - (foreign (tramp-find-foreign-file-name-handler filename))) + (foreign + (tramp-find-foreign-file-name-handler + filename operation completion)) + result) (with-parsed-tramp-file-name filename nil ;; Call the backend function. (if foreign (tramp-condition-case-unless-debug err - (let ((sf (symbol-function foreign)) - result) + (let ((sf (symbol-function foreign))) ;; Some packages set the default directory to a ;; remote path, before respective Tramp packages ;; are already loaded. This results in @@ -2191,8 +2064,13 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;; Propagate the error. (t (signal (car err) (cdr err)))))) - ;; Nothing to do for us. - (tramp-run-real-handler operation args))))) + ;; Nothing to do for us. However, since we are in + ;; `tramp-mode', we must suppress the volume letter on + ;; MS Windows. + (setq result (tramp-run-real-handler operation args)) + (if (stringp result) + (tramp-drop-volume-letter result) + result))))) ;; When `tramp-mode' is not enabled, we don't do anything. (tramp-run-real-handler operation args))) @@ -2224,17 +2102,17 @@ preventing reentrant calls of Tramp.") Together with `tramp-locked', this implements a locking mechanism preventing reentrant calls of Tramp.") -;;;###autoload -(progn (defun tramp-completion-file-name-handler (operation &rest args) +;; Avoid recursive loading of tramp.el. +;;;###autoload(defun tramp-completion-file-name-handler (operation &rest args) +;;;###autoload (tramp-completion-run-real-handler operation args)) + +(defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler. Falls back to normal file name handler if no Tramp file name handler exists." - ;; We bind `directory-sep-char' here for XEmacs on Windows, which - ;; would otherwise use backslash. - (let ((directory-sep-char ?/) - (fn (assoc operation tramp-completion-file-name-handler-alist))) + (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) (if (and ;; When `tramp-mode' is not enabled, we don't do anything. - fn tramp-mode + fn tramp-mode (tramp-completion-mode-p) ;; For other syntaxes than `sep', the regexp matches many common ;; situations where the user doesn't actually want to use Tramp. ;; So to avoid autoloading Tramp after typing just "/s", we @@ -2242,8 +2120,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;; indicated his interest in using a fancier completion system. (or (eq tramp-syntax 'sep) (featurep 'tramp) ;; If it's loaded, we may as well use it. - ;; `partial-completion-mode' does not exist in XEmacs. - ;; It is obsoleted with Emacs 24.1. + ;; `partial-completion-mode' is obsoleted with Emacs 24.1. (and (boundp 'partial-completion-mode) (symbol-value 'partial-completion-mode)) ;; FIXME: These may have been loaded even if the user never @@ -2251,14 +2128,13 @@ Falls back to normal file name handler if no Tramp file name handler exists." (featurep 'ido) (featurep 'icicles))) (save-match-data (apply (cdr fn) args)) - (tramp-completion-run-real-handler operation args))))) + (tramp-completion-run-real-handler operation args)))) ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." - ;; Avoid recursive loading of tramp.el. `temporary-file-directory' - ;; does not exist in XEmacs, so we must use something else. - (let ((default-directory "/")) + ;; Avoid recursive loading of tramp.el. + (let ((default-directory temporary-file-directory)) (load "tramp" nil t)) (apply operation args))) @@ -2343,6 +2219,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;;; File name handler functions for completion mode: +;;;###autoload (defvar tramp-completion-mode nil "If non-nil, external packages signal that they are in file name completion. @@ -2361,15 +2238,13 @@ should never be set globally, the intention is to let-bind it.") ;; variable. On the other hand, those files shouldn't have partial ;; Tramp file name syntax. Maybe another variable should be introduced ;; overwriting this check in such cases. Or we change Tramp file name -;; syntax in order to avoid ambiguities, like in XEmacs ... -;;;###tramp-autoload +;; syntax in order to avoid ambiguities. (defun tramp-completion-mode-p () "Check, whether method / user name / host name completion is active." (or ;; Signal from outside. `non-essential' has been introduced in Emacs 24. (and (boundp 'non-essential) (symbol-value 'non-essential)) tramp-completion-mode - ;; Emacs. (equal last-input-event 'tab) (and (natnump last-input-event) (or @@ -2377,24 +2252,7 @@ should never be set globally, the intention is to let-bind it.") (equal last-input-event ?\t) (and (not (event-modifiers last-input-event)) (or (equal last-input-event ?\?) - (equal last-input-event ?\ ))))) - ;; XEmacs. - (and (featurep 'xemacs) - ;; `last-input-event' might be nil. - (not (null last-input-event)) - ;; `last-input-event' may have no character approximation. - (tramp-compat-funcall 'event-to-character last-input-event) - (or - ;; ?\t has event-modifier 'control. - (equal - (tramp-compat-funcall 'event-to-character last-input-event) ?\t) - (and (not (event-modifiers last-input-event)) - (or (equal - (tramp-compat-funcall 'event-to-character last-input-event) - ?\?) - (equal - (tramp-compat-funcall 'event-to-character last-input-event) - ?\ ))))))) + (equal last-input-event ?\ ))))))) (defun tramp-connectable-p (filename) "Check, whether it is possible to connect the remote host w/o side-effects. @@ -2407,10 +2265,25 @@ not in completion mode." (p (tramp-get-connection-process v))) (and p (processp p) (memq (process-status p) '(run open)))))))) +(defun tramp-completion-handle-expand-file-name + (name &optional dir) + "Like `expand-file-name' for Tramp files." + (if (tramp-completion-mode-p) + (progn + ;; 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))) + ;; Return NAME. + name) + + (tramp-completion-run-real-handler + 'expand-file-name (list name dir)))) + ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of ;; tramp-file-name structures. For all of them we return possible completions. -;;;###autoload (defun tramp-completion-handle-file-name-all-completions (filename directory) "Like `file-name-all-completions' for partial Tramp files." @@ -2483,7 +2356,6 @@ not in completion mode." 'file-name-all-completions (list (list filename directory))))))) ;; Method, host name and user name completion for a file. -;;;###autoload (defun tramp-completion-handle-file-name-completion (filename directory &optional predicate) "Like `file-name-completion' for Tramp files." @@ -2675,6 +2547,12 @@ PARTIAL-USER must match USER, PARTIAL-HOST must match HOST." (unless (zerop (+ (length user) (length host))) (tramp-completion-make-tramp-file-name method user host nil))) +(defun tramp-parse-default-user-host (method) + "Return a list of (user host) tuples allowed to access for METHOD. +This function is added always in `tramp-get-completion-function' +for all methods. Resulting data are derived from default settings." + `((,(tramp-find-user method nil nil) ,(tramp-find-host method nil nil)))) + ;; Generic function. (defun tramp-parse-group (regexp match-level skip-regexp) "Return a (user host) tuple allowed to access. @@ -2781,17 +2659,18 @@ User is always nil." (tramp-parse-group (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)") 1 " \t")) -;; For su-alike methods it would be desirable to return "root@localhost" -;; as default. Unfortunately, we have no information whether any user name -;; has been typed already. So we use `tramp-current-user' as indication, -;; assuming it is set in `tramp-completion-handle-file-name-all-completions'. ;;;###tramp-autoload (defun tramp-parse-passwd (filename) "Return a list of (user host) tuples allowed to access. Host is always \"localhost\"." - (if (zerop (length tramp-current-user)) - '(("root" nil)) - (tramp-parse-file filename 'tramp-parse-passwd-group))) + (with-tramp-connection-property nil "parse-passwd" + (if (executable-find "getent") + (with-temp-buffer + (when (zerop (tramp-call-process nil "getent" nil t nil "passwd")) + (goto-char (point-min)) + (loop while (not (eobp)) collect + (tramp-parse-etc-group-group)))) + (tramp-parse-file filename 'tramp-parse-passwd-group)))) (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. @@ -2804,6 +2683,29 @@ Host is always \"localhost\"." result)) ;;;###tramp-autoload +(defun tramp-parse-etc-group (filename) + "Return a list of (group host) tuples allowed to access. +Host is always \"localhost\"." + (with-tramp-connection-property nil "parse-group" + (if (executable-find "getent") + (with-temp-buffer + (when (zerop (tramp-call-process nil "getent" nil t nil "group")) + (goto-char (point-min)) + (loop while (not (eobp)) collect + (tramp-parse-etc-group-group)))) + (tramp-parse-file filename 'tramp-parse-etc-group-group)))) + +(defun tramp-parse-etc-group-group () + "Return a (group host) tuple allowed to access. +Host is always \"localhost\"." + (let ((result) + (split (split-string (buffer-substring (point) (point-at-eol)) ":"))) + (when (member (user-login-name) (split-string (nth 3 split) "," 'omit)) + (setq result (list (nth 0 split) "localhost"))) + (forward-line 1) + result)) + +;;;###tramp-autoload (defun tramp-parse-netrc (filename) "Return a list of (user host) tuples allowed to access. User may be nil." @@ -2827,12 +2729,13 @@ User may be nil." "Return a list of (user host) tuples allowed to access. User is always nil." (if (memq system-type '(windows-nt)) - (with-temp-buffer - (when (zerop (tramp-call-process - nil "reg" nil t nil "query" registry-or-dirname)) - (goto-char (point-min)) - (loop while (not (eobp)) collect - (tramp-parse-putty-group registry-or-dirname)))) + (with-tramp-connection-property nil "parse-putty" + (with-temp-buffer + (when (zerop (tramp-call-process + nil "reg" nil t nil "query" registry-or-dirname)) + (goto-char (point-min)) + (loop while (not (eobp)) collect + (tramp-parse-putty-group registry-or-dirname))))) ;; UNIX case. (tramp-parse-shostkeys-sknownhosts registry-or-dirname (concat "^\\(" tramp-host-regexp "\\)$")))) @@ -2868,10 +2771,8 @@ User is always nil." (substring directory 0 -1) directory))) -(defun tramp-handle-directory-files - (directory &optional full match nosort files-only) +(defun tramp-handle-directory-files (directory &optional full match nosort) "Like `directory-files' for Tramp files." - ;; FILES-ONLY is valid for XEmacs only. (when (file-directory-p directory) (setq directory (file-name-as-directory (expand-file-name directory))) (let ((temp (nreverse (file-name-all-completions "" directory))) @@ -2879,12 +2780,7 @@ User is always nil." (while temp (setq item (directory-file-name (pop temp))) - (when (and (or (null match) (string-match match item)) - (or (null files-only) - ;; Files only. - (and (equal files-only t) (file-regular-p item)) - ;; Directories only. - (file-directory-p item))) + (when (or (null match) (string-match match item)) (push (if full (concat directory item) item) result))) (if nosort result (sort result 'string<))))) @@ -2894,15 +2790,14 @@ User is always nil." "Like `directory-files-and-attributes' for Tramp files." (mapcar (lambda (x) - (cons x (tramp-compat-file-attributes + (cons x (file-attributes (if full x (expand-file-name x directory)) id-format))) (directory-files directory full match nosort))) -(defun tramp-handle-dired-uncache (dir &optional dir-p) +(defun tramp-handle-dired-uncache (dir) "Like `dired-uncache' for Tramp files." - ;; DIR-P is valid for XEmacs only. (with-parsed-tramp-file-name - (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil + (if (file-directory-p dir) dir (file-name-directory dir)) nil (tramp-flush-directory-property v localname))) (defun tramp-handle-file-accessible-directory-p (filename) @@ -2946,13 +2841,17 @@ User is always nil." ;; `file-name-as-directory' would be sufficient except localname is ;; the empty string. (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. + ;; Run the command on the localname portion only unless we are in + ;; completion mode. (tramp-make-tramp-file-name (tramp-file-name-method v) (tramp-file-name-user v) (tramp-file-name-host v) - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) ""))) + (if (and (tramp-completion-mode-p) + (zerop (length (tramp-file-name-localname v)))) + "" + (tramp-run-real-handler + 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))) (tramp-file-name-hop v)))) (defun tramp-handle-file-name-completion @@ -3035,43 +2934,19 @@ User is always nil." (defun tramp-handle-find-backup-file-name (filename) "Like `find-backup-file-name' for Tramp files." (with-parsed-tramp-file-name filename nil - ;; We set both variables. It doesn't matter whether it is - ;; Emacs or XEmacs. (let ((backup-directory-alist - ;; Emacs case. - (when (boundp 'backup-directory-alist) - (if (symbol-value 'tramp-backup-directory-alist) - (mapcar - (lambda (x) - (cons - (car x) - (if (and (stringp (cdr x)) - (file-name-absolute-p (cdr x)) - (not (tramp-file-name-p (cdr x)))) - (tramp-make-tramp-file-name method user host (cdr x)) - (cdr x)))) - (symbol-value 'tramp-backup-directory-alist)) - (symbol-value 'backup-directory-alist)))) - - (bkup-backup-directory-info - ;; XEmacs case. - (when (boundp 'bkup-backup-directory-info) - (if (symbol-value 'tramp-bkup-backup-directory-info) - (mapcar - (lambda (x) - (nconc - (list (car x)) - (list - (if (and (stringp (car (cdr x))) - (file-name-absolute-p (car (cdr x))) - (not (tramp-file-name-p (car (cdr x))))) - (tramp-make-tramp-file-name - method user host (car (cdr x))) - (car (cdr x)))) - (cdr (cdr x)))) - (symbol-value 'tramp-bkup-backup-directory-info)) - (symbol-value 'bkup-backup-directory-info))))) - + (if tramp-backup-directory-alist + (mapcar + (lambda (x) + (cons + (car x) + (if (and (stringp (cdr x)) + (file-name-absolute-p (cdr x)) + (not (tramp-file-name-p (cdr x)))) + (tramp-make-tramp-file-name method user host (cdr x)) + (cdr x)))) + tramp-backup-directory-alist) + backup-directory-alist))) (tramp-run-real-handler 'find-backup-file-name (list filename))))) (defun tramp-handle-insert-directory @@ -3182,8 +3057,7 @@ User is always nil." ;; When the file is not readable for the owner, it ;; cannot be inserted, even if it is readable for the ;; group or for everybody. - (set-file-modes - local-copy (tramp-compat-octal-to-decimal "0600")) + (set-file-modes local-copy (string-to-number "0600" 8)) (when (and (null remote-copy) (tramp-get-method-parameter @@ -3193,9 +3067,7 @@ User is always nil." (setq tramp-temp-buffer-file-name local-copy)) ;; We must ensure that `file-coding-system-alist' - ;; matches `local-copy'. We must also use `visit', - ;; otherwise there might be an error in the - ;; `revert-buffer' function under XEmacs. + ;; matches `local-copy'. (let ((file-coding-system-alist (tramp-find-file-name-coding-system-alist filename local-copy))) @@ -3251,7 +3123,7 @@ User is always nil." (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect - (tramp-compat-load local-copy noerror t nosuffix must-suffix) + (load local-copy noerror t nosuffix must-suffix) (delete-file local-copy))))) t))) @@ -3345,9 +3217,7 @@ User is always nil." (current-buffer)))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (if (functionp 'display-message-or-buffer) - (tramp-compat-funcall 'display-message-or-buffer output-buffer) - (pop-to-buffer output-buffer)))))))) + (display-message-or-buffer output-buffer))))))) (defun tramp-handle-substitute-in-file-name (filename) "Like `substitute-in-file-name' for Tramp files. @@ -3367,14 +3237,6 @@ User is always nil." (let (process-environment) (tramp-run-real-handler 'substitute-in-file-name (list filename))))) -(defun tramp-handle-unhandled-file-name-directory (_filename) - "Like `unhandled-file-name-directory' for Tramp files." - ;; Starting with Emacs 23, we must simply return nil. But we must - ;; keep backward compatibility, also with XEmacs. "~/" cannot be - ;; returned, because there might be machines without a HOME - ;; directory (like hydra). - (and (< emacs-major-version 23) "/")) - (defun tramp-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." (unless (buffer-file-name) @@ -3403,7 +3265,7 @@ of." ;; connection. (if (or (not f) (eq (visited-file-modtime) 0) - (not (tramp-file-name-handler 'file-remote-p f nil 'connected))) + (not (file-remote-p f nil 'connected))) t (with-parsed-tramp-file-name f nil (let* ((remote-file-name-inhibit-cache t) @@ -3454,7 +3316,7 @@ of." (with-current-buffer (process-buffer proc) (file-exists-p (concat (file-remote-p default-directory) - (tramp-compat-process-get proc 'watch-name)))))) + (process-get proc 'watch-name)))))) ;;; Functions for establishing connection: @@ -3657,9 +3519,7 @@ for process communication also." ;; Under Windows XP, accept-process-output doesn't return ;; sometimes. So we add an additional timeout. (with-timeout ((or timeout 1)) - (if (featurep 'xemacs) - (accept-process-output p timeout timeout-msecs) - (accept-process-output p timeout timeout-msecs (and proc t)))) + (accept-process-output p timeout timeout-msecs (and proc t))) (tramp-message proc 10 "%s %s %s\n%s" proc (process-status proc) p (buffer-string))))) @@ -3684,11 +3544,10 @@ Erase echoed commands if exists." (when (or (not (tramp-get-connection-property proc "check-remote-echo" nil)) ;; Sometimes, the echo string is suppressed on the remote side. (not (string-equal - (tramp-compat-funcall - 'substring-no-properties tramp-echo-mark-marker + (substring-no-properties + tramp-echo-mark-marker 0 (min tramp-echo-mark-marker-length (1- (point-max)))) - (tramp-compat-funcall - 'buffer-substring-no-properties + (buffer-substring-no-properties (point-min) (min (+ (point-min) tramp-echo-mark-marker-length) (point-max)))))) @@ -3706,22 +3565,15 @@ Expects the output of PROC to be sent to the current buffer. Returns the string that matched, or nil. Waits indefinitely if TIMEOUT is nil." (with-current-buffer (process-buffer proc) - (let ((found (tramp-check-for-regexp proc regexp)) - (start-time (current-time))) + (let ((found (tramp-check-for-regexp proc regexp))) (cond (timeout - ;; Work around a bug in XEmacs 21, where the timeout - ;; expires faster than it should. This degenerates - ;; to polling for buggy XEmacsen, but oh, well. - (while (and (not found) - (< (tramp-time-diff (current-time) start-time) - timeout)) - (with-timeout (timeout) - (while (not found) - (tramp-accept-process-output proc 1) - (unless (memq (process-status proc) '(run open)) - (tramp-error-with-buffer - nil proc 'file-error "Process has died")) - (setq found (tramp-check-for-regexp proc regexp)))))) + (with-timeout (timeout) + (while (not found) + (tramp-accept-process-output proc 1) + (unless (memq (process-status proc) '(run open)) + (tramp-error-with-buffer + nil proc 'file-error "Process has died")) + (setq found (tramp-check-for-regexp proc regexp))))) (t (while (not found) (tramp-accept-process-output proc 1) @@ -3761,9 +3613,8 @@ the remote host use line-endings as defined in the variable (let (buffer-read-only) (delete-region (point-min) (point-max))) ;; Replace "\n" by `tramp-rsh-end-of-line'. (setq string - (mapconcat 'identity - (tramp-compat-split-string string "\n") - tramp-rsh-end-of-line)) + (mapconcat + 'identity (split-string string "\n") tramp-rsh-end-of-line)) (unless (or (string= string "") (string-equal (substring string -1) tramp-rsh-end-of-line)) (setq string (concat string tramp-rsh-end-of-line))) @@ -3827,57 +3678,47 @@ would yield t. On the other hand, the following check results in nil: (save-match-data (logior (cond - ((char-equal owner-read ?r) (tramp-compat-octal-to-decimal "00400")) + ((char-equal owner-read ?r) (string-to-number "00400" 8)) ((char-equal owner-read ?-) 0) (t (error "Second char `%c' must be one of `r-'" owner-read))) (cond - ((char-equal owner-write ?w) (tramp-compat-octal-to-decimal "00200")) + ((char-equal owner-write ?w) (string-to-number "00200" 8)) ((char-equal owner-write ?-) 0) (t (error "Third char `%c' must be one of `w-'" owner-write))) (cond - ((char-equal owner-execute-or-setid ?x) - (tramp-compat-octal-to-decimal "00100")) - ((char-equal owner-execute-or-setid ?S) - (tramp-compat-octal-to-decimal "04000")) - ((char-equal owner-execute-or-setid ?s) - (tramp-compat-octal-to-decimal "04100")) + ((char-equal owner-execute-or-setid ?x) (string-to-number "00100" 8)) + ((char-equal owner-execute-or-setid ?S) (string-to-number "04000" 8)) + ((char-equal owner-execute-or-setid ?s) (string-to-number "04100" 8)) ((char-equal owner-execute-or-setid ?-) 0) (t (error "Fourth char `%c' must be one of `xsS-'" owner-execute-or-setid))) (cond - ((char-equal group-read ?r) (tramp-compat-octal-to-decimal "00040")) + ((char-equal group-read ?r) (string-to-number "00040" 8)) ((char-equal group-read ?-) 0) (t (error "Fifth char `%c' must be one of `r-'" group-read))) (cond - ((char-equal group-write ?w) (tramp-compat-octal-to-decimal "00020")) + ((char-equal group-write ?w) (string-to-number "00020" 8)) ((char-equal group-write ?-) 0) (t (error "Sixth char `%c' must be one of `w-'" group-write))) (cond - ((char-equal group-execute-or-setid ?x) - (tramp-compat-octal-to-decimal "00010")) - ((char-equal group-execute-or-setid ?S) - (tramp-compat-octal-to-decimal "02000")) - ((char-equal group-execute-or-setid ?s) - (tramp-compat-octal-to-decimal "02010")) + ((char-equal group-execute-or-setid ?x) (string-to-number "00010" 8)) + ((char-equal group-execute-or-setid ?S) (string-to-number "02000" 8)) + ((char-equal group-execute-or-setid ?s) (string-to-number "02010" 8)) ((char-equal group-execute-or-setid ?-) 0) (t (error "Seventh char `%c' must be one of `xsS-'" group-execute-or-setid))) (cond - ((char-equal other-read ?r) - (tramp-compat-octal-to-decimal "00004")) + ((char-equal other-read ?r) (string-to-number "00004" 8)) ((char-equal other-read ?-) 0) (t (error "Eighth char `%c' must be one of `r-'" other-read))) (cond - ((char-equal other-write ?w) (tramp-compat-octal-to-decimal "00002")) - ((char-equal other-write ?-) 0) - (t (error "Ninth char `%c' must be one of `w-'" other-write))) + ((char-equal other-write ?w) (string-to-number "00002" 8)) + ((char-equal other-write ?-) 0) + (t (error "Ninth char `%c' must be one of `w-'" other-write))) (cond - ((char-equal other-execute-or-sticky ?x) - (tramp-compat-octal-to-decimal "00001")) - ((char-equal other-execute-or-sticky ?T) - (tramp-compat-octal-to-decimal "01000")) - ((char-equal other-execute-or-sticky ?t) - (tramp-compat-octal-to-decimal "01001")) + ((char-equal other-execute-or-sticky ?x) (string-to-number "00001" 8)) + ((char-equal other-execute-or-sticky ?T) (string-to-number "01000" 8)) + ((char-equal other-execute-or-sticky ?t) (string-to-number "01001" 8)) ((char-equal other-execute-or-sticky ?-) 0) (t (error "Tenth char `%c' must be one of `xtT-'" other-execute-or-sticky))))))) @@ -3935,9 +3776,10 @@ This is used internally by `tramp-file-mode-from-int'." ;;;###tramp-autoload (defun tramp-get-local-gid (id-format) + ;; `group-gid' has been introduced with Emacs 24.4. (if (and (fboundp 'group-gid) (equal id-format 'integer)) (tramp-compat-funcall 'group-gid) - (nth 3 (tramp-compat-file-attributes "~/" id-format)))) + (nth 3 (file-attributes "~/" id-format)))) (defun tramp-get-local-locale (&optional vec) ;; We use key nil for local connection properties. @@ -3979,7 +3821,7 @@ be granted." (tramp-get-file-property vec (tramp-file-name-localname vec) (concat "file-attributes-" suffix) nil) - (tramp-compat-file-attributes + (file-attributes (tramp-make-tramp-file-name (tramp-file-name-method vec) (tramp-file-name-user vec) @@ -4050,7 +3892,7 @@ be granted." (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (with-tramp-connection-property vec "tmpdir" (or (and (file-directory-p dir) (file-writable-p dir) - (tramp-file-name-handler 'file-remote-p dir 'localname)) + (file-remote-p dir 'localname)) (tramp-error vec 'file-error "Directory %s not accessible" dir))) dir)) @@ -4071,7 +3913,7 @@ Return the local name of the temporary file." (setq result nil) ;; This creates the file by side effect. (set-file-times result) - (set-file-modes result (tramp-compat-octal-to-decimal "0700")))) + (set-file-modes result (string-to-number "0700" 8)))) ;; Return the local part. (with-parsed-tramp-file-name result nil localname))) @@ -4087,9 +3929,6 @@ Return the local name of the temporary file." (remove-hook 'kill-buffer-hook 'tramp-delete-temp-file-function))) -;;; Auto saving to a special directory: -(defvar auto-save-file-name-transforms) - (defun tramp-handle-make-auto-save-file-name () "Like `make-auto-save-file-name' for Tramp files. Returns a file name in `tramp-auto-save-directory' for autosaving @@ -4104,9 +3943,8 @@ this file, if that variable is non-nil." (let ((system-type 'not-windows) (auto-save-file-name-transforms - (if (and (null tramp-auto-save-directory) - (boundp 'auto-save-file-name-transforms)) - (symbol-value 'auto-save-file-name-transforms))) + (if (null tramp-auto-save-directory) + auto-save-file-name-transforms)) (buffer-file-name (if (null tramp-auto-save-directory) buffer-file-name @@ -4120,61 +3958,8 @@ this file, if that variable is non-nil." ("]" . "_r")) (buffer-file-name)) tramp-auto-save-directory)))) - ;; Run plain `make-auto-save-file-name'. There might be an advice when - ;; it is not a magic file name operation (since Emacs 22). - ;; We must deactivate it temporarily. - (if (not (ad-is-active 'make-auto-save-file-name)) - (tramp-run-real-handler 'make-auto-save-file-name nil) - ;; else - (ad-deactivate 'make-auto-save-file-name) - (prog1 - (tramp-run-real-handler 'make-auto-save-file-name nil) - (ad-activate 'make-auto-save-file-name))))) - -(unless (tramp-exists-file-name-handler 'make-auto-save-file-name) - (defadvice make-auto-save-file-name - (around tramp-advice-make-auto-save-file-name () activate) - "Invoke `tramp-*-handle-make-auto-save-file-name' for Tramp files." - (if (tramp-tramp-file-p (buffer-file-name)) - ;; We cannot call `tramp-handle-make-auto-save-file-name' - ;; directly, because this would bypass the locking mechanism. - (setq ad-return-value - (tramp-file-name-handler 'make-auto-save-file-name)) - ad-do-it)) - (add-hook - 'tramp-unload-hook - (lambda () - (ad-remove-advice - 'make-auto-save-file-name - 'around 'tramp-advice-make-auto-save-file-name) - (ad-activate 'make-auto-save-file-name)))) - -;; In XEmacs < 21.5, autosaved remote files have permission 0666 minus -;; umask. This is a security threat. - -(defun tramp-set-auto-save-file-modes () - "Set permissions of autosaved remote files to the original permissions." - (let ((bfn (buffer-file-name))) - (when (and (tramp-tramp-file-p bfn) - (buffer-modified-p) - (stringp buffer-auto-save-file-name) - (not (equal bfn buffer-auto-save-file-name))) - (unless (file-exists-p buffer-auto-save-file-name) - (write-region "" nil buffer-auto-save-file-name)) - ;; Permissions should be set always, because there might be an old - ;; auto-saved file belonging to another original file. This could - ;; be a security threat. - (set-file-modes - buffer-auto-save-file-name - (or (file-modes bfn) (tramp-compat-octal-to-decimal "0600")))))) - -(unless (and (featurep 'xemacs) - (= emacs-major-version 21) - (> emacs-minor-version 4)) - (add-hook 'auto-save-hook 'tramp-set-auto-save-file-modes) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'auto-save-hook 'tramp-set-auto-save-file-modes)))) + ;; Run plain `make-auto-save-file-name'. + (tramp-run-real-handler 'make-auto-save-file-name nil))) (defun tramp-subst-strs-in-string (alist string) "Replace all occurrences of the string FROM with TO in STRING. @@ -4268,27 +4053,24 @@ Invokes `password-read' if available, `read-passwd' else." (tramp-check-for-regexp proc tramp-password-prompt-regexp) (format "%s for %s " (capitalize (match-string 1)) key)))) ;; We suspend the timers while reading the password. - (stimers (and (functionp 'with-timeout-suspend) - (tramp-compat-funcall 'with-timeout-suspend))) + (stimers (with-timeout-suspend)) auth-info auth-passwd) (unwind-protect (with-parsed-tramp-file-name key nil (prog1 (or - ;; 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 + ;; See if auth-sources contains something useful. + ;; `auth-source-user-or-password' is an obsoleted + ;; function since Emacs 24.1, it has been replaced by ;; `auth-source-search'. (ignore-errors - (and (boundp 'auth-sources) - (tramp-get-connection-property + (and (tramp-get-connection-property v "first-password-request" nil) ;; Try with Tramp's current method. (if (fboundp 'auth-source-search) (setq auth-info - (tramp-compat-funcall - 'auth-source-search + (auth-source-search :max 1 :user (or tramp-current-user t) :host tramp-current-host @@ -4298,21 +4080,17 @@ Invokes `password-read' if available, `read-passwd' else." auth-passwd (if (functionp auth-passwd) (funcall auth-passwd) auth-passwd)) - (tramp-compat-funcall - 'auth-source-user-or-password + (tramp-compat-funcall 'auth-source-user-or-password "password" tramp-current-host tramp-current-method)))) ;; Try the password cache. - (when (functionp 'password-read) - (let ((password - (tramp-compat-funcall 'password-read pw-prompt key))) - (tramp-compat-funcall 'password-cache-add key password) - password)) + (let ((password (password-read pw-prompt key))) + (password-cache-add key password) + password) ;; Else, get the password interactively. (read-passwd pw-prompt)) (tramp-set-connection-property v "first-password-request" nil))) ;; Reenable the timers. - (and (functionp 'with-timeout-unsuspend) - (tramp-compat-funcall 'with-timeout-unsuspend stimers))))) + (with-timeout-unsuspend stimers)))) ;;;###tramp-autoload (defun tramp-clear-passwd (vec) @@ -4324,11 +4102,10 @@ Invokes `password-read' if available, `read-passwd' else." (tramp-dissect-file-name (concat tramp-prefix-format - (tramp-compat-replace-regexp-in-string + (replace-regexp-in-string (concat tramp-postfix-hop-regexp "$") tramp-postfix-host-format hop)))))) - (tramp-compat-funcall - 'password-cache-remove + (password-cache-remove (tramp-make-tramp-file-name (tramp-file-name-method vec) (tramp-file-name-user vec) @@ -4351,24 +4128,8 @@ Invokes `password-read' if available, `read-passwd' else." (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." - (cond ((and (fboundp 'subtract-time) - (fboundp 'float-time)) - (tramp-compat-funcall - 'float-time (tramp-compat-funcall 'subtract-time t1 t2))) - ((and (fboundp 'subtract-time) - (fboundp 'time-to-seconds)) - (tramp-compat-funcall - 'time-to-seconds (tramp-compat-funcall 'subtract-time t1 t2))) - ((fboundp 'itimer-time-difference) - (tramp-compat-funcall - 'itimer-time-difference - (if (< (length t1) 3) (append t1 '(0)) t1) - (if (< (length t2) 3) (append t2 '(0)) t2))) - (t - (let ((time (time-subtract t1 t2))) - (+ (* (car time) 65536.0) - (cadr time) - (/ (or (nth 2 time) 0) 1000000.0)))))) + ;; Starting with Emacs 25.1, we could change this to use `time-subtract'. + (float-time (tramp-compat-funcall 'subtract-time t1 t2))) ;; Currently (as of Emacs 20.5), the function `shell-quote-argument' ;; does not deal well with newline characters. Newline is replaced by @@ -4463,7 +4224,6 @@ Only works for Bourne-like shells." ;; * In Emacs 21, `insert-directory' shows total number of bytes used ;; by the files in that directory. Add this here. ;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman) -;; * abbreviate-file-name ;; * Better error checking. At least whenever we see something ;; strange when doing zerop, we should kill the process and start ;; again. (Greg Stark) diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index fc65c0a1081..64cc47e26a5 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -6,7 +6,7 @@ ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.2.13.25.1 +;; Version: 2.3.0-pre ;; This file is part of GNU Emacs. @@ -27,45 +27,36 @@ ;; In the Tramp GIT repository, the version number and the bug report ;; address are auto-frobbed from configure.ac, so you should edit that -;; file and run "autoconf && ./configure" to change them. (X)Emacs +;; file and run "autoconf && ./configure" to change them. Emacs ;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; ;; should be changed only there. ;;;###tramp-autoload -(defconst tramp-version "2.2.13.25.1" +(defconst tramp-version "2.3.0-pre" "This version of Tramp.") ;;;###tramp-autoload (defconst tramp-bug-report-address "tramp-devel@gnu.org" "Email address to send bug reports to.") -;; `locate-dominating-file' does not exist in XEmacs. But it is not used here. -(autoload 'locate-dominating-file "files") -(autoload 'tramp-compat-replace-regexp-in-string "tramp-compat") - (defun tramp-repository-get-version () "Try to return as a string the repository revision of the Tramp sources." - (unless (featurep 'xemacs) - (let ((dir (locate-dominating-file (locate-library "tramp") ".git"))) - (when dir - (with-temp-buffer - (let ((default-directory (file-name-as-directory dir))) - (and (zerop - (ignore-errors - (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) - (not (zerop (buffer-size))) - (tramp-compat-replace-regexp-in-string - "\n" "" (buffer-string))))))))) - -;; Check for (X)Emacs version. -(let ((x (if (or (>= emacs-major-version 22) - (and (featurep 'xemacs) - (= emacs-major-version 21) - (>= emacs-minor-version 4))) - "ok" - (format "Tramp 2.2.13.25.1 is not fit for %s" - (when (string-match "^.*$" (emacs-version)) - (match-string 0 (emacs-version))))))) + (let ((dir (locate-dominating-file (locate-library "tramp") ".git"))) + (when dir + (with-temp-buffer + (let ((default-directory (file-name-as-directory dir))) + (and (zerop + (ignore-errors + (call-process "git" nil '(t nil) nil "rev-parse" "HEAD"))) + (not (zerop (buffer-size))) + (replace-regexp-in-string "\n" "" (buffer-string)))))))) + +;; Check for Emacs version. +(let ((x (if (>= emacs-major-version 23) + "ok" + (format "Tramp 2.3.0-pre is not fit for %s" + (when (string-match "^.*$" (emacs-version)) + (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) (add-hook 'tramp-unload-hook |