[GNU ELPA] New package: tramp-locproc

[Michael Albinus <michael.albinus@gmx.de>]

[-- Attachment #1: Type: text/plain, Size: 855 bytes --]

Hi,

I would like to submit a new package to GNU ELPA: tramp-locproc.

It extends the possibility to run local processes for remote files,
which are mounted by Tramp using FUSE, and which do not have an
implementation of remote processes, like Tramp's "rclone" method and all
Tramp methods implemented in tramp-gvfs.el ("ftp", "nextcloud", and
alike). It also adds local processes for Tramp's "sshfs" method,
although it has an own remote processes implementation.

Even files in file archives, implemented by tramp-archive.el, profit
from this new feature.

Beside the obvious advantage to run local processes over remote files,
there is also the disadvantage that file names are adapted in order to
reflect their local mount location.

Therefore, I would appreciate to get feedback, whether people find this
useful.

Thanks, and best regards, Michael.


[-- Attachment #2: tramp-locproc.el --]
[-- Type: text/plain, Size: 10106 bytes --]

;;; 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