emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

master 1cbf2655db: Extend memory-info for remote systems


From: Michael Albinus
Subject: master 1cbf2655db: Extend memory-info for remote systems
Date: Sun, 27 Nov 2022 10:57:16 -0500 (EST)

branch: master
commit 1cbf2655db40cd474411b77ece57a287eb85ea2c
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>

    Extend memory-info for remote systems
    
    * doc/lispref/files.texi (Magic File Names): Add memory-info.
    
    * doc/lispref/internals.texi (Garbage Collection): memory-info can
    also retrieve values from remote systems.
    
    * etc/NEWS: Document changes in memory-info.  Fix typos.
    
    * lisp/files.el (warn-maybe-out-of-memory): Ensure local memory info.
    
    * lisp/net/tramp.el (tramp-handle-memory-info): New defun.
    (tramp-file-name-for-operation)
    * lisp/net/tramp-adb.el (tramp-adb-file-name-handler-alist):
    * lisp/net/tramp-archive.el (tramp-archive-file-name-handler-alist):
    * lisp/net/tramp-crypt.el (tramp-crypt-file-name-handler-alist):
    * lisp/net/tramp-gvfs.el (tramp-gvfs-file-name-handler-alist):
    * lisp/net/tramp-rclone.el (tramp-rclone-file-name-handler-alist):
    * lisp/net/tramp-sh.el (tramp-sh-file-name-handler-alist):
    * lisp/net/tramp-smb.el (tramp-smb-file-name-handler-alist):
    * lisp/net/tramp-sshfs.el (tramp-sshfs-file-name-handler-alist)
    * lisp/net/tramp-sudoedit.el (tramp-sudoedit-file-name-handler-alist):
    Add 'memory-info'.
    
    * lisp/net/tramp-sshfs.el (tramp-sshfs-handle-exec-path):
    Let-bind `process-file-side-effects'.
    
    * src/alloc.c (Fmemory_info): Support remote systems.
    (Qmemory_info): Declare.
    
    * test/lisp/net/tramp-tests.el (tramp-test31-memory-info): New test.
---
 doc/lispref/files.texi       |  4 +--
 doc/lispref/internals.texi   |  3 ++
 etc/NEWS                     | 73 +++++++++++++++++-----------------------
 lisp/files.el                |  3 +-
 lisp/net/tramp-adb.el        |  1 +
 lisp/net/tramp-archive.el    |  1 +
 lisp/net/tramp-crypt.el      |  1 +
 lisp/net/tramp-gvfs.el       |  1 +
 lisp/net/tramp-rclone.el     |  1 +
 lisp/net/tramp-sh.el         |  1 +
 lisp/net/tramp-smb.el        |  1 +
 lisp/net/tramp-sshfs.el      |  4 ++-
 lisp/net/tramp-sudoedit.el   |  1 +
 lisp/net/tramp.el            | 80 +++++++++++++++++++++++++++++++++++++++++++-
 src/alloc.c                  | 12 ++++++-
 test/lisp/net/tramp-tests.el | 15 +++++++++
 16 files changed, 153 insertions(+), 49 deletions(-)

diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi
index 183b2786ea..4b45d89f9d 100644
--- a/doc/lispref/files.texi
+++ b/doc/lispref/files.texi
@@ -3383,7 +3383,7 @@ first, before handlers for jobs such as remote file 
access.
 @code{make-nearby-temp-file},
 @code{make-process},
 @code{make-symbolic-link},@*
-@code{process-attributes}, @code{process-file},
+@code{memory-info}, @code{process-attributes}, @code{process-file},
 @code{rename-file}, @code{set-file-acl}, @code{set-file-modes},
 @code{set-file-selinux-context}, @code{set-file-times},
 @code{set-visited-file-modtime}, @code{shell-command},
@@ -3445,7 +3445,7 @@ first, before handlers for jobs such as remote file 
access.
 @code{make-nearby-temp-file},
 @code{make-process},
 @code{make-symbolic-link},
-@code{process-attributes}, @code{process-file},
+@code{memory-info}, @code{process-attributes}, @code{process-file},
 @code{rename-file}, @code{set-file-acl}, @code{set-file-modes},
 @code{set-file-selinux-context}, @code{set-file-times},
 @code{set-visited-file-modtime}, @code{shell-command},
diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi
index 4640b6d759..c4e724d761 100644
--- a/doc/lispref/internals.texi
+++ b/doc/lispref/internals.texi
@@ -622,6 +622,9 @@ a certain kind of object.  See the documentation string for 
details.
 @defun memory-info
 This functions returns an amount of total system memory and how much
 of it is free.  On an unsupported system, the value may be @code{nil}.
+
+If @code{default-directory} points to a remote host, memory
+information of that host is returned.
 @end defun
 
 @defvar gcs-done
diff --git a/etc/NEWS b/etc/NEWS
index 3c9243784d..85fdf005e3 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -435,7 +435,7 @@ The user options 'url-gateway-rlogin-host',
 are also obsolete.
 
 ---
-** The user function 'url-irc-function' now takes a 'scheme' argument.
+** The user function 'url-irc-function' now takes a SCHEME argument.
 The user option 'url-irc-function' is now called with a sixth argument
 corresponding to the scheme portion of the target URL.  For example,
 this would be "ircs" for a URL like "ircs://irc.libera.chat".
@@ -1388,7 +1388,7 @@ the QWERTY Slovak keyboards.
 
 * Changes in Specialized Modes and Packages in Emacs 29.1
 
-** ecomplete
+** Ecomplete
 
 ---
 *** New commands 'ecomplete-edit' and 'ecomplete-remove'.
@@ -1510,6 +1510,7 @@ It is enabled by default, but requires that the external 
"shellcheck"
 command is installed.
 
 ** CC Mode
+
 ---
 *** C++ Mode now supports most of the new features in the C++20 standard.
 
@@ -1593,32 +1594,32 @@ If no packages are marked, 'x' will install the package 
under point if
 it isn't already, and remove it if it is installed.
 
 +++
-*** New command 'package-vc-install'
+*** New command 'package-vc-install'.
 Packages can now be installed directly from source by cloning from a
 repository.
 
 +++
-*** New command 'package-vc-install-from-checkout'
+*** New command 'package-vc-install-from-checkout'.
 An existing checkout can now be loaded via package.el, by creating a
 symbolic link from the usual package directory to the checkout.
 
 +++
-*** New command 'package-vc-checkout'
+*** New command 'package-vc-checkout'.
 Used to fetch the source of a package by cloning a repository without
 activating the package.
 
 +++
-*** New command 'package-vc-prepare-patch'
+*** New command 'package-vc-prepare-patch'.
 This command allows you to send patches to package maintainers, for
 packages checked out using 'package-vc-install'.
 
 +++
-*** New command 'package-report-bug'
+*** New command 'package-report-bug'.
 This command helps you compose an email for sending bug reports to
 package maintainers.
 
 +++
-*** New user option 'package-vc-selected-packages'
+*** New user option 'package-vc-selected-packages'.
 By customizing this user option you can specify specific packages to
 install.
 
@@ -1764,7 +1765,7 @@ There are two new values to control the way the 
"*Completions*" buffer
 behaves after pressing a 'TAB' if completion is not unique.  The value
 'always' updates or shows the "*Completions*" buffer after any attempt
 to complete.  The value 'visual' is like 'always', but only updates
-the completions if they are already visible.  The default value 't'
+the completions if they are already visible.  The default value t
 always hides the completion buffer after some completion is made.
 
 *** New commands to complete the minibuffer history.
@@ -1998,11 +1999,11 @@ It narrows to the current node.
 ** EUDC
 
 +++
-*** New user option 'eudc-ignore-options-file' that defaults to 'nil'
+*** New user option 'eudc-ignore-options-file' that defaults to nil.
 The 'eudc-ignore-options-file' user option can be configured to ignore
 the 'eudc-options-file' (typically "~/.emacs.d/eudc-options").  Most
-users should configure this to 't' and put EUDC configuration in the
-main Emacs initialization file (".emacs" or "~/.emacs.d/init.el").
+users should configure this to t and put EUDC configuration in the
+main Emacs initialization file ("~/.emacs" or "~/.emacs.d/init.el").
 
 +++
 *** 'eudc-expansion-overwrites-query' to 'eudc-expansion-save-query-as-kill'.
@@ -2051,15 +2052,15 @@ of attributes to use for queries, and delivers more 
attributes in
 query results.
 
 +++
-*** New back-end for ecomplete
+*** New back-end for ecomplete.
 A new back-end for ecomplete allows information from that database to
 be queried by EUDC, too.  The attributes present in the EUDC query are
 used to select the entry type in the ecomplete database.
 
 +++
-*** New back-end for mailabbrev
+*** New back-end for mailabbrev.
 A new back-end for mailabbrev allows information from that database to
-be queried by EUDC, too.  The attributes email, name, and firstname
+be queried by EUDC, too.  The attributes 'email', 'name', and 'firstname'
 are supported only.
 
 ** EWW/SHR
@@ -2655,13 +2656,13 @@ customize this to "https" to always prefer HTTPS URLs.
 
 ---
 *** New user option 'browse-url-irc-function'.
-This option specifies a function for opening irc:// links.  It
+This option specifies a function for opening "irc://" links.  It
 defaults to the new function 'browse-url-irc'.
 
 ---
 *** New function 'browse-url-irc'.
-This multipurpose autoloaded function can be used for opening irc://
-and ircs:// URLS by any caller that passes a URL string as an initial
+This multipurpose autoloaded function can be used for opening "irc://"
+and "ircs://" URLS by any caller that passes a URL string as an initial
 arg.
 
 ---
@@ -2766,12 +2767,12 @@ error, and now expand to all directories recursively 
(following
 symlinks in the latter case).
 
 +++
-*** Lisp forms in Eshell now treat a 'nil' result as a failed exit status.
+*** Lisp forms in Eshell now treat a nil result as a failed exit status.
 When executing a command that looks like '(lisp form)' and returns
-'nil', Eshell will set the exit status (available in the '$?'
+nil, Eshell will set the exit status (available in the '$?'
 variable) to 2.  This allows commands like that to be used in
 conditionals.  To change this behavior, customize the new
-'eshell-lisp-form-nil-is-failure' option.
+'eshell-lisp-form-nil-is-failure' user option.
 
 ** Shell
 
@@ -2898,7 +2899,7 @@ remote host are shown.  Alternatively, the user option
 The old name is still available as an obsolete function alias.
 
 ---
-*** The url-irc library now understands ircs:// links.
+*** The url-irc library now understands "ircs://" links.
 
 ---
 *** New command 'world-clock-copy-time-as-kill' for 'M-x world-clock'.
@@ -2910,7 +2911,7 @@ The new face 'abbrev-table-name' is used to display the 
abbrev table
 name.
 
 ---
-*** New key binding "O" in `M-x list-buffer'.
+*** New key binding 'O' in 'M-x list-buffer'.
 This key is now bound to 'Buffer-menu-view-other-window', which will
 view this line's buffer in View mode in another window.
 
@@ -2968,7 +2969,6 @@ Emacs buffers, like indentation and the like.  The new 
ert function
 This is a lightweight variant of 'js-mode' that is used by default
 when visiting JSON files.
 
-
 ** New mode 'typescript-ts-mode'.
 A major mode based on the tree-sitter library for editing programs
 in the TypeScript language.  It includes support for font-locking,
@@ -4318,22 +4318,17 @@ asynchronous processes.  The hitherto existing 
implementation has been
 moved to 'internal-default-signal-process'.
 
 +++
-** 'list-system-processes' now returns remote process IDs.
+** Some system information functions honor remote systems now.
+'list-system-processes' returns remote process IDs.
+'memory-info' returns memory information of remote systems.
+'process-attributes' expects a remote process ID.
 This happens only when the current buffer's 'default-directory' is
-remote.  In order to preserve the old behavior, apply
+remote.  In order to preserve the old behavior, bind
+'default-directory' to a local directory, like
 
     (let ((default-directory temporary-file-directory))
       (list-system-processes))
 
-+++
-** 'process-attributes' expects a remote process ID now.
-When current buffer's 'default-directory' is remote, the PID argument
-of 'process-attributes' is regarded as a remote process ID.  In order
-to preserve the old behavior, apply
-
-    (let ((default-directory temporary-file-directory))
-      (process-attributes pid))
-
 +++
 ** New functions 'take' and 'ntake'.
 '(take N LIST)' returns the first N elements of LIST; 'ntake' does
@@ -4420,11 +4415,3 @@ 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/>.
-
-
-Local variables:
-coding: utf-8
-mode: outline
-mode: emacs-news
-paragraph-separate: "[         ]"
-end:
diff --git a/lisp/files.el b/lisp/files.el
index f1f890430f..cd35fe3835 100644
--- a/lisp/files.el
+++ b/lisp/files.el
@@ -2308,7 +2308,8 @@ it returns nil or exits non-locally."
   "Warn if an attempt to open file of SIZE bytes may run out of memory."
   (when (and (numberp size) (not (zerop size))
             (integerp out-of-memory-warning-percentage))
-    (let ((meminfo (memory-info)))
+    (let* ((default-directory temporary-file-directory)
+           (meminfo (memory-info)))
       (when (consp meminfo)
        (let ((total-free-memory (float (+ (nth 1 meminfo) (nth 3 meminfo)))))
          (when (> (/ size 1024)
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el
index 49cbf526ec..90020fbb1b 100644
--- a/lisp/net/tramp-adb.el
+++ b/lisp/net/tramp-adb.el
@@ -168,6 +168,7 @@ It is used for TCP/IP devices."
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . tramp-adb-handle-make-process)
     (make-symbolic-link . tramp-handle-make-symbolic-link)
+    (memory-info . tramp-handle-memory-info)
     (process-attributes . tramp-handle-process-attributes)
     (process-file . tramp-adb-handle-process-file)
     (rename-file . tramp-adb-handle-rename-file)
diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el
index 0a8c574d84..1a64689c53 100644
--- a/lisp/net/tramp-archive.el
+++ b/lisp/net/tramp-archive.el
@@ -297,6 +297,7 @@ It must be supported by libarchive(3).")
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . ignore)
     (make-symbolic-link . tramp-archive-handle-not-implemented)
+    ;; `memory-info' performed by default handler.
     (process-attributes . ignore)
     (process-file . ignore)
     (rename-file . tramp-archive-handle-not-implemented)
diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el
index 0973258157..fa40f96818 100644
--- a/lisp/net/tramp-crypt.el
+++ b/lisp/net/tramp-crypt.el
@@ -219,6 +219,7 @@ If NAME doesn't belong to an encrypted remote directory, 
return nil."
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . ignore)
     (make-symbolic-link . tramp-handle-make-symbolic-link)
+    (memory-info . ignore)
     (process-attributes . ignore)
     (process-file . ignore)
     (rename-file . tramp-crypt-handle-rename-file)
diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el
index 477f8fb3fd..73f773e8f4 100644
--- a/lisp/net/tramp-gvfs.el
+++ b/lisp/net/tramp-gvfs.el
@@ -813,6 +813,7 @@ It has been changed in GVFS 1.14.")
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . ignore)
     (make-symbolic-link . tramp-handle-make-symbolic-link)
+    (memory-info . ignore)
     (process-attributes . ignore)
     (process-file . ignore)
     (rename-file . tramp-gvfs-handle-rename-file)
diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el
index 9e379da8c1..8e583cc402 100644
--- a/lisp/net/tramp-rclone.el
+++ b/lisp/net/tramp-rclone.el
@@ -133,6 +133,7 @@
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . ignore)
     (make-symbolic-link . tramp-handle-make-symbolic-link)
+    (memory-info . ignore)
     (process-attributes . ignore)
     (process-file . ignore)
     (rename-file . tramp-rclone-handle-rename-file)
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el
index cfecd32aba..df5800f4e9 100644
--- a/lisp/net/tramp-sh.el
+++ b/lisp/net/tramp-sh.el
@@ -1103,6 +1103,7 @@ Format specifiers \"%s\" are replaced before the script 
is used.")
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . tramp-sh-handle-make-process)
     (make-symbolic-link . tramp-sh-handle-make-symbolic-link)
+    (memory-info . tramp-handle-memory-info)
     (process-attributes . tramp-handle-process-attributes)
     (process-file . tramp-sh-handle-process-file)
     (rename-file . tramp-sh-handle-rename-file)
diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el
index e55f6bb6ee..c720b33b5f 100644
--- a/lisp/net/tramp-smb.el
+++ b/lisp/net/tramp-smb.el
@@ -284,6 +284,7 @@ See `tramp-actions-before-shell' for more info.")
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . ignore)
     (make-symbolic-link . tramp-smb-handle-make-symbolic-link)
+    (memory-info . ignore)
     (process-attributes . ignore)
     (process-file . tramp-smb-handle-process-file)
     (rename-file . tramp-smb-handle-rename-file)
diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el
index 3c67fa6ea2..44c55041ff 100644
--- a/lisp/net/tramp-sshfs.el
+++ b/lisp/net/tramp-sshfs.el
@@ -139,6 +139,7 @@
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . tramp-handle-make-process)
     (make-symbolic-link . tramp-handle-make-symbolic-link)
+    (memory-info . tramp-handle-memory-info)
     (process-attributes . tramp-handle-process-attributes)
     (process-file . tramp-sshfs-handle-process-file)
     (rename-file . tramp-sshfs-handle-rename-file)
@@ -214,7 +215,8 @@ arguments to pass to the OPERATION."
    (with-parsed-tramp-file-name default-directory nil
      (with-tramp-connection-property (tramp-get-process v) "remote-path"
        (with-temp-buffer
-        (process-file "getconf" nil t nil "PATH")
+         (let (process-file-side-effects)
+          (process-file "getconf" nil t nil "PATH"))
         (split-string
          (progn
            ;; Read the expression.
diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el
index bc8739c4d6..fcc27dd834 100644
--- a/lisp/net/tramp-sudoedit.el
+++ b/lisp/net/tramp-sudoedit.el
@@ -129,6 +129,7 @@ See `tramp-actions-before-shell' for more info.")
     (make-nearby-temp-file . tramp-handle-make-nearby-temp-file)
     (make-process . ignore)
     (make-symbolic-link . tramp-sudoedit-handle-make-symbolic-link)
+    (memory-info . ignore)
     (process-attributes . ignore)
     (process-file . ignore)
     (rename-file . tramp-sudoedit-handle-rename-file)
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el
index e9f30bea7b..33e5e80d05 100644
--- a/lisp/net/tramp.el
+++ b/lisp/net/tramp.el
@@ -2656,7 +2656,7 @@ Must be handled by the callers."
              ;; Emacs 27+ only.
              exec-path make-process
              ;; Emacs 29+ only.
-              list-system-processes process-attributes))
+              list-system-processes memory-info process-attributes))
     default-directory)
    ;; PROC.
    ((member operation '(file-notify-rm-watch file-notify-valid-p))
@@ -4884,6 +4884,84 @@ support symbolic links."
    (tramp-dissect-file-name (expand-file-name linkname)) 'file-error
    "make-symbolic-link not supported"))
 
+(defun tramp-handle-memory-info ()
+  "Like `memory-info' for Tramp files."
+  (let ((result '(0 0 0 0))
+        process-file-side-effects)
+    (with-temp-buffer
+      (cond
+       ;; GNU/Linux.
+       ((zerop (process-file "cat" nil '(t) nil "/proc/meminfo"))
+        (goto-char (point-min))
+        (when
+            (re-search-forward
+             (rx bol "MemTotal:" (* space) (group (+ digit)) (* space) "kB" 
eol)
+             nil 'noerror)
+          (setcar (nthcdr 0 result) (string-to-number (match-string 1))))
+        (goto-char (point-min))
+        (when
+            (re-search-forward
+             (rx bol "MemFree:" (* space) (group (+ digit)) (* space) "kB" eol)
+             nil 'noerror)
+          (setcar (nthcdr 1 result) (string-to-number (match-string 1))))
+        (goto-char (point-min))
+        (when
+            (re-search-forward
+             (rx bol "SwapTotal:" (* space) (group (+ digit)) (* space) "kB" 
eol)
+             nil 'noerror)
+          (setcar (nthcdr 2 result) (string-to-number (match-string 1))))
+        (goto-char (point-min))
+        (when
+            (re-search-forward
+             (rx bol "SwapFree:" (* space) (group (+ digit)) (* space) "kB" 
eol)
+             nil 'noerror)
+          (setcar (nthcdr 3 result) (string-to-number (match-string 1)))))
+
+       ;; BSD.
+       ;; 
https://raw.githubusercontent.com/ocochard/myscripts/master/FreeBSD/freebsd-memory.sh
+       ((zerop (process-file "sysctl" nil '(t) nil "-a"))
+        (goto-char (point-min))
+        (when
+            (re-search-forward
+             (rx bol "hw.pagesize:" (* space) (group (+ digit)) eol)
+             nil 'noerror)
+          (let ((pagesize (string-to-number (match-string 1))))
+            (goto-char (point-min))
+            (when
+                (re-search-forward
+                 (rx bol "vm.stats.vm.v_page_count:" (* space)
+                     (group (+ digit)) eol)
+                 nil 'noerror)
+              (setcar
+               (nthcdr 0 result)
+               (/ (* (string-to-number (match-string 1)) pagesize) 1024)))
+            (goto-char (point-min))
+            (when
+                (re-search-forward
+                 (rx bol "vm.stats.vm.v_free_count:" (* space)
+                     (group (+ digit)) eol)
+                 nil 'noerror)
+              (setcar
+               (nthcdr 1 result)
+               (/ (* (string-to-number (match-string 1)) pagesize) 1024)))))
+        (erase-buffer)
+        (when (zerop (process-file "swapctl" nil '(t) nil "-sk"))
+          (goto-char (point-min))
+          (when
+              (re-search-forward
+               (rx bol "Total:" (* space)
+                   (group (+ digit)) (* space) (group (+ digit)) eol)
+               nil 'noerror)
+            (setcar (nthcdr 2 result) (string-to-number (match-string 1)))
+            (setcar
+             (nthcdr 3 result)
+             (- (string-to-number (match-string 1))
+                (string-to-number (match-string 2)))))))))
+
+    ;; Return result.
+    (unless (equal result '(0 0 0 0))
+      result)))
+
 (defun tramp-handle-process-attributes (pid)
   "Like `process-attributes' for Tramp files."
   (catch 'result
diff --git a/src/alloc.c b/src/alloc.c
index 0653f2e0cc..980085d329 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -7435,9 +7435,17 @@ DEFUN ("memory-info", Fmemory_info, Smemory_info, 0, 0, 
0,
        doc: /* Return a list of (TOTAL-RAM FREE-RAM TOTAL-SWAP FREE-SWAP).
 All values are in Kbytes.  If there is no swap space,
 last two values are zero.  If the system is not supported
-or memory information can't be obtained, return nil.  */)
+or memory information can't be obtained, return nil.
+If `default-directory’ is remote, return memory information of the
+respective remote host.  */)
   (void)
 {
+  Lisp_Object handler
+    = Ffind_file_name_handler (BVAR (current_buffer, directory),
+                              Qmemory_info);
+  if (!NILP (handler))
+    return call1 (handler, Qmemory_info);
+
 #if defined HAVE_LINUX_SYSINFO
   struct sysinfo si;
   uintmax_t units;
@@ -7859,6 +7867,8 @@ do hash-consing of the objects allocated to pure space.  
*/);
               doc: /* Non-nil means Emacs cannot get much more Lisp memory.  
*/);
   Vmemory_full = Qnil;
 
+  DEFSYM (Qmemory_info, "memory-info");
+
   DEFSYM (Qconses, "conses");
   DEFSYM (Qsymbols, "symbols");
   DEFSYM (Qstrings, "strings");
diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el
index a79c47be72..6ffb8a6529 100644
--- a/test/lisp/net/tramp-tests.el
+++ b/test/lisp/net/tramp-tests.el
@@ -5388,6 +5388,21 @@ If UNSTABLE is non-nil, the test is tagged as 
`:unstable'."
       ;; Cleanup.
       (ignore-errors (delete-process proc)))))
 
+(ert-deftest tramp-test31-memory-info ()
+  "Check `memory-info'."
+  :tags '(:expensive-test)
+  (skip-unless (tramp--test-enabled))
+  (skip-unless (tramp--test-supports-processes-p))
+  ;; `memory-info' is supported since Emacs 29.1.
+  (skip-unless (tramp--test-emacs29-p))
+
+  (when-let ((default-directory ert-remote-temporary-file-directory)
+             (mi (memory-info)))
+    (should (consp mi))
+    (should (= (length mi) 4))
+    (dotimes (i (length mi))
+      (should (natnump (nth i mi))))))
+
 (defun tramp--test-async-shell-command
     (command output-buffer &optional error-buffer input)
   "Like `async-shell-command', reading the output.



reply via email to

[Prev in Thread] Current Thread [Next in Thread]