;;; tramp-locproc.el --- Tramp local processes for FUSE mounts  -*- lexical-binding:t -*-

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

;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
;; Package: tramp-locproc
;; Version: 0
;; Package-Requires: ((tramp "2.7.2"))

;; This file is not part of GNU Emacs.

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

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

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

;;; Commentary:

;; This package adds process support for "sshfs", "rclone" and all
;; methods defined in `tramp-gvfs-methods'.  It overwrites the remote
;; process support in "sshfs"; the other methods have no process
;; support otherwise.

;; A remote process runs as a local process, using the local mount
;; name of `default-directory'.  The program name is used literally,
;; after piping through `file-local-name'.  As a consequence, programs
;; on the local host are called, which might not exist on the remote
;; host.

;; Arguments of the process, which are an absolute file name, are
;; transformed to the respective local mount name.  That is, a file
;; name "/path/to/file" is located on the local host as
;; "/mount_point/path/to/file".  This is suppressed if user option
;; `tramp-locproc-extend-arguments' is nil.

;; Although not strictly remote, Tramp archive files are also
;; supported.  That is, a local process can run over the file system
;; which is defined by a file archive, see (info "(tramp) Archive file
;; names") .

;; If this package is unloaded via `M-x unload-feature RET tramp-locproc',
;; the original implementation of the different Tramp backends is restored.

;;; Code:

(require 'tramp)

(defvar tramp-locproc-unload-file-name-handler-alist nil
  "Variable keeping unload information.")

(defun tramp-locproc-massage-file-name-handler-alist (fnha)
  "Adapt FNHA to the needs of `tramp-locproc'.
FNHA is the variable symbol, collecting handler functions for a Tramp backend."
  (let ((val (symbol-value fnha)))
    ;; Prepare unloading.  This must be performed prior modifying FNHA.
    (unless (assq fnha tramp-locproc-unload-file-name-handler-alist)
      (add-to-list
       'tramp-locproc-unload-file-name-handler-alist
       `(,fnha
	 ,(copy-tree (assq 'exec-path val))
	 ,(copy-tree (assq 'make-process val))
	 ,(copy-tree (assq 'process-file val))
	 ,(copy-tree (assq 'shell-command val))
	 ,(copy-tree (assq 'start-file-process val))))
      (add-hook
       'tramp-locproc-unload-hook
       (lambda ()
	 (dolist
	     (entry
	      (alist-get fnha tramp-locproc-unload-file-name-handler-alist))
	   (setcdr (assq (car entry) (symbol-value fnha)) (cdr entry))))))

    ;; Replace handler functions.
    (setcdr (assq 'exec-path val) #'tramp-locproc-handle-exec-path)
    (setcdr (assq 'make-process val) #'tramp-locproc-handle-make-process)
    (setcdr (assq 'process-file val) #'tramp-locproc-handle-process-file)
    (setcdr (assq 'shell-command val) #'tramp-locproc-handle-shell-command)
    (setcdr (assq 'start-file-process val) #'tramp-handle-start-file-process)))

;; `tramp-archive-local-file-name' is introduced in Tramp 2.7.2.
(with-eval-after-load 'tramp-archive
  (when (fboundp 'tramp-archive-local-file-name)
    (tramp-locproc-massage-file-name-handler-alist
     'tramp-archive-file-name-handler-alist)))

;; `tramp-gvfs-local-file-name' is introduced in Tramp 2.7.2.
(with-eval-after-load 'tramp-gvfs
  (when (fboundp 'tramp-gvfs-local-file-name)
    (tramp-locproc-massage-file-name-handler-alist
     'tramp-gvfs-file-name-handler-alist)))

(with-eval-after-load 'tramp-rclone
  (tramp-locproc-massage-file-name-handler-alist
   'tramp-rclone-file-name-handler-alist))

(with-eval-after-load 'tramp-sshfs
  (tramp-locproc-massage-file-name-handler-alist
   'tramp-sshfs-file-name-handler-alist))

(declare-function tramp-archive-local-file-name 'tramp-arechive)
(declare-function tramp-fuse-local-file-name 'tramp-fuse)
(declare-function tramp-gvfs-local-file-name 'tramp-gvfs)

(defun tramp-locproc-local-file-name (filename)
  "Return local mount name of remote FILENAME."
  (funcall
   (cond
    ((tramp-archive-file-name-p filename) #'tramp-archive-local-file-name)
    ((tramp-gvfs-file-name-p filename) #'tramp-gvfs-local-file-name)
    (t #'tramp-fuse-local-file-name))
   filename))

(defun tramp-locproc-mount-point (filename)
  "Return mount point of remote FILENAME."
  (tramp-locproc-local-file-name
   (funcall
    (cond
     ((tramp-archive-file-name-p filename)
      (lambda (string)
	(file-name-as-directory (tramp-archive-file-name-archive string))))
     (t #'file-remote-p))
    filename)))

(defun tramp-locproc-file-name-p (filename)
  "Check if it’s a FILENAME handled by local processes."
  ;; FIXME: Check, that it is activated for the repective backend.
  (or (tramp-archive-file-name-p filename)
      (tramp-gvfs-file-name-p filename)
      (tramp-rclone-file-name-p filename)
      (tramp-sshfs-file-name-p filename)))

(defcustom tramp-locproc-extend-arguments t
  "Whether to prefix arguments of remote processes by the mount-point."
  :group 'tramp
  :type 'boolean)

(defun tramp-locproc-extend-arguments (mount-point args)
  "Return ARGS, a list of local file names, prefixed with MOUNT-POINT.
This can be suppressed by setting user option
`tramp-locproc-extend-arguments' to nil."
  (if tramp-locproc-extend-arguments
      (mapcar
       (lambda (file)
	 (if (and (stringp file) (file-name-absolute-p file))
	     (concat mount-point file) file))
       args)
    args))

(defun tramp-locproc-handle-exec-path ()
  "Like `exec-path' for Tramp files."
  exec-path)

(defun tramp-locproc-handle-make-process (&rest args)
  "An alternative `make-process' implementation for Tramp files."
  (let ((mount-point (tramp-locproc-mount-point default-directory))
	(default-directory (tramp-locproc-local-file-name default-directory))
	(command (plist-get args :command)))
    ;; The car in COMMAND is the program name.  We don't manipulate it.
    (setcdr command (tramp-locproc-extend-arguments mount-point (cdr command)))
    (apply #'make-process (plist-put args :command command))))

(defun tramp-locproc-handle-process-file
    (program &optional infile buffer display &rest args)
  "Like `process-file' for Tramp files."
  (let ((mount-point (tramp-locproc-mount-point default-directory))
	(default-directory (tramp-locproc-local-file-name default-directory)))
    (apply
     #'process-file (file-local-name program) infile buffer display
     (tramp-locproc-extend-arguments mount-point args))))

(defun tramp-locproc-handle-shell-command
    (command &optional output-buffer error-buffer)
  "An alternative `shell-command' implementation for Tramp files."
  (let ((mount-point (tramp-locproc-mount-point default-directory))
	(default-directory (tramp-locproc-local-file-name default-directory))
	(command (split-string command)))
    ;; The first word in COMMAND is the program name.  We don't
    ;; manipulate it.
    (setcdr command (tramp-locproc-extend-arguments mount-point (cdr command)))
    (setq command (mapconcat #'identity command " "))
    (shell-command command output-buffer error-buffer)))

;;; Integration of compile.el:

(defun tramp-locproc-compilation-mode-function ()
  "Setup compilation buffer properly."
  (when (and (compilation-buffer-p (current-buffer))
	     (tramp-locproc-file-name-p default-directory))
    (trace-values (current-buffer) default-directory comint-file-name-prefix)
    (setq default-directory (tramp-locproc-local-file-name default-directory))
    (setq-local comint-file-name-prefix "")))

(with-eval-after-load 'compile
  (trace-function-background 'compilation-setup)
  (trace-function-background 'compilation-get-file-structure)
  (add-hook 'compilation-mode-hook
	    #'tramp-locproc-compilation-mode-function)
  (add-hook 'tramp-locproc-unload-hook
	    (lambda ()
	      (remove-hook 'compilation-mode-hook
			   #'tramp-locproc-compilation-mode-function))))

;;; Integration of shell.el:

(defun tramp-locproc-shell-function (&rest args)
  (let ((default-directory (tramp-locproc-local-file-name default-directory)))
    (apply args)))

(with-eval-after-load 'shell
  (trace-function-background 'shell)
  (advice-add #'shell :around #'tramp-locproc-shell-function)
  (add-hook 'tramp-locproc-unload-hook
	    (lambda ()
	      (advice-remove #'shell :around #'tramp-locproc-shell-function))))

;; FIXME: Do we need this?
;;; Integration of comint.el:

;; (defun tramp-locproc-comint-mode-function ()
;;  "Setup comint mode properly."
;;   (trace-values (current-buffer) default-directory comint-file-name-prefix)
;;   (setq default-directory (tramp-locproc-local-file-name default-directory))
;;   (setq-local comint-file-name-prefix ""))

;; (with-eval-after-load 'comint
;;   (add-hook 'comint-mode-hook
;; 	    #'tramp-locproc-comint-mode-function)
;;   (add-hook 'tramp-locproc-unload-hook
;; 	    (lambda ()
;; 	      (remove-hook 'comint-mode-hook
;; 			   #'tramp-locproc-comint-mode-function))))

;; Development settings.
(require 'trace)
(mapc
 #'trace-function-background
 (mapcar #'intern (all-completions "tramp-locproc-" obarray #'functionp)))

(add-hook 'tramp-unload-hook
	  (lambda ()
	    (unload-feature 'tramp-locproc 'force)))

(provide 'tramp-locproc)

;;; tramp-locproc.el ends here