;;; tramp-make-process.el --- Tramp alternative make-process  -*- lexical-binding:t -*-

;; Copyright (C) 2020 Free Software Foundation, Inc.

;; Author: Michael Albinus <address@hidden>
;; Keywords: comm, processes
;; Package: tramp

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; An alternative implementation of `make-process' for methods in
;; tramp-sh.el and tramp-adb.el.  It does not use shell commands for
;; execution of the asynchronous command.  Instead, it calls the
;; command directly.  This should result in a performance boost.
;;
;; Limitations of this approach:
;;
;; * It works only for connection methods defined in tramp-sh.el and
;;   tramp-adb.el.
;;
;; * It does not support multi-hop methods.
;;
;; * It does not support user authentication, like password handling.
;;
;; * It does not support a separated error stream.
;;
;; * It cannot be killed via `interrupt-process'.
;;
;; * It does not report the remote terminal name via `process-tty-name'.
;;
;; * It does not set environment variable "INSIDE_EMACS".
;;
;; In order to gain even more performance, it is recommended to set or
;; bind `tramp-verbose' to 0 when running `make-process'.

;;; Code:

;; We use BUFFER also as connection buffer during setup. Because of
;; this, its original contents must be saved, and restored once
;; connection has been setup.
(defun tramp-make-process (&rest args)
  "An alternative `make-process' implementation for Tramp files."
  (when args
    (with-parsed-tramp-file-name (expand-file-name default-directory) nil
      (let ((name (plist-get args :name))
	    (buffer (plist-get args :buffer))
	    (command (plist-get args :command))
	    (coding (plist-get args :coding))
	    (noquery (plist-get args :noquery))
	    (connection-type (plist-get args :connection-type))
	    (filter (plist-get args :filter))
	    (sentinel (plist-get args :sentinel))
	    (stderr (plist-get args :stderr)))
	(unless (stringp name)
	  (signal 'wrong-type-argument (list #'stringp name)))
	(unless (or (null buffer) (bufferp buffer) (stringp buffer))
	  (signal 'wrong-type-argument (list #'stringp buffer)))
	(unless (consp command)
	  (signal 'wrong-type-argument (list #'consp command)))
	(unless (or (null coding)
		    (and (symbolp coding) (memq coding coding-system-list))
		    (and (consp coding)
			 (memq (car coding) coding-system-list)
			 (memq (cdr coding) coding-system-list)))
	  (signal 'wrong-type-argument (list #'symbolp coding)))
	(unless (or (null connection-type) (memq connection-type '(pipe pty)))
	  (signal 'wrong-type-argument (list #'symbolp connection-type)))
	(unless (or (null filter) (functionp filter))
	  (signal 'wrong-type-argument (list #'functionp filter)))
	(unless (or (null sentinel) (functionp sentinel))
	  (signal 'wrong-type-argument (list #'functionp sentinel)))
	(unless (or (null stderr) (bufferp stderr) (stringp stderr))
	  (signal 'wrong-type-argument (list #'stringp stderr)))
	(when (and (stringp stderr) (tramp-tramp-file-p stderr)
		   (not (tramp-equal-remote default-directory stderr)))
	  (signal 'file-error (list "Wrong stderr" stderr)))

	(let* ((buffer
		(if buffer
		    (get-buffer-create buffer)
		  ;; BUFFER can be nil.  We use a temporary buffer.
		  (generate-new-buffer tramp-temp-buffer-name)))
	       (command (append `("cd" ,localname "&&")
				(mapcar #'tramp-shell-quote-argument command)))
	       (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer)))
	       (name1 name)
	       (i 0)
	       ;; We do not want to raise an error when `make-process'
	       ;; has been started several times in `eshell' and
	       ;; friends.
	       tramp-current-connection
	       p)

	  (while (get-process name1)
	    ;; NAME must be unique as process name.
	    (setq i (1+ i)
		  name1 (format "%s<%d>" name i)))
	  (setq name name1)
	  ;; Set the new process properties.
	  (tramp-set-connection-property v "process-name" name)
	  (tramp-set-connection-property v "process-buffer" buffer)

	  (with-current-buffer (tramp-get-connection-buffer v)
	    (unwind-protect
		(let* ((login-program
			(or (tramp-get-method-parameter v 'tramp-login-program)
			    "adb"))
		       (login-args
			(or (tramp-get-method-parameter v 'tramp-login-args)
			    '(("shell"))))
		       (async-args
			(tramp-get-method-parameter v 'tramp-async-args))
		       ;; We don't create the temporary file.  In
		       ;; fact, it is just a prefix for the
		       ;; ControlPath option of ssh; the real
		       ;; temporary file has another name, and it is
		       ;; created and protected by ssh.  It is also
		       ;; removed by ssh when the connection is
		       ;; closed.  The temporary file name is cached
		       ;; in the main connection process, therefore
		       ;; we cannot use `tramp-get-connection-process'.
		       (tmpfile
			(with-tramp-connection-property
			    (tramp-get-process v) "temp-file"
			  (make-temp-name
			   (expand-file-name
			    tramp-temp-name-prefix
			    (tramp-compat-temporary-file-directory)))))
		       (options (tramp-ssh-controlmaster-options v))
		       spec)

		  ;; Replace `login-args' place holders.
		  (setq
		   spec (format-spec-make ?t tmpfile)
		   options (format-spec options spec)
		   spec (format-spec-make
			 ?h (or host "") ?u (or user "") ?p (or port "")
			 ?c options ?l "")
		   ;; Add arguments for asynchronous processes.
		   login-args (append async-args login-args)
		   ;; Expand format spec.
		   login-args
		   (tramp-compat-flatten-tree
		    (mapcar
		     (lambda (x)
		       (setq x (mapcar (lambda (y) (format-spec y spec)) x))
		       (unless (member "" x) x))
		     login-args))
		   ;; Split ControlMaster options.
		   login-args
		   (tramp-compat-flatten-tree
		    (mapcar (lambda (x) (split-string x " ")) login-args))
		   p (apply
		      #'start-process
		      name buffer login-program (append login-args command)))

		  (tramp-message v 6 "%s" (string-join (process-command p) " "))
		  ;; Set sentinel and filter.
		  (when sentinel
		    (set-process-sentinel p sentinel))
		  (when filter
		    (set-process-filter p filter))
		  ;; Set query flag and process marker for this
		  ;; process.  We ignore errors, because the
		  ;; process could have finished already.
		  (ignore-errors
		    (set-process-query-on-exit-flag p (null noquery))
		    (set-marker (process-mark p) (point)))
		  ;; We must flush them here already; otherwise
		  ;; `rename-file', `delete-file' or
		  ;; `insert-file-contents' will fail.
		  (tramp-flush-connection-property v "process-name")
		  (tramp-flush-connection-property v "process-buffer")
		  ;; Return process.
		  p)

	      ;; Save exit.
	      (if (string-match-p tramp-temp-buffer-name (buffer-name))
		  (ignore-errors
		    (set-process-buffer p nil)
		    (kill-buffer (current-buffer)))
		(set-buffer-modified-p bmp))
	      (tramp-flush-connection-property v "process-name")
	      (tramp-flush-connection-property v "process-buffer"))))))))

(with-eval-after-load 'tramp-adb
  (defalias 'tramp-adb-handle-make-process #'tramp-make-process))

(with-eval-after-load 'tramp-sh
  (defalias 'tramp-sh-handle-make-process #'tramp-make-process))

(add-hook 'tramp-unload-hook
	  (lambda ()
	    (unload-feature 'tramp-make-process 'force)))

(provide 'tramp-make-process)

;;; tramp-make-process.el ends here