1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-11 09:20:51 +00:00

Add URL handler for file-name-directory (Bug#30444)

* lisp/url/url-handlers.el (url-handler-file-name-directory): New
function which handles special cases for `file-name-directory' and
URLs.
* test/lisp/url/url-handlers-test.el: New file.  Add tests for
`url-handler-file-name-directory'.
This commit is contained in:
Nicolas Petton 2018-03-13 22:07:08 +01:00
parent 9942734c75
commit 6d2b50a245
No known key found for this signature in database
GPG Key ID: E8BCD7866AFCF978
2 changed files with 84 additions and 0 deletions

View File

@ -186,6 +186,7 @@ the arguments that would have been passed to OPERATION."
(put 'file-name-absolute-p 'url-file-handlers (lambda (&rest ignored) t))
(put 'expand-file-name 'url-file-handlers 'url-handler-expand-file-name)
(put 'directory-file-name 'url-file-handlers 'url-handler-directory-file-name)
(put 'file-name-directory 'url-file-handlers 'url-handler-file-name-directory)
(put 'unhandled-file-name-directory 'url-file-handlers 'url-handler-unhandled-file-name-directory)
(put 'file-remote-p 'url-file-handlers 'url-handler-file-remote-p)
;; (put 'file-name-as-directory 'url-file-handlers 'url-handler-file-name-as-directory)
@ -231,6 +232,14 @@ the arguments that would have been passed to OPERATION."
;; a local process.
nil)))
(defun url-handler-file-name-directory (dir)
(let ((url (url-generic-parse-url dir)))
;; Do not attempt to handle `file' URLs which are local.
(if (and (not (equal (url-type url) "file"))
(string-empty-p (url-filename url)))
(url-handler-file-name-directory (concat dir "/"))
(url-run-real-handler 'file-name-directory (list dir)))))
(defun url-handler-file-remote-p (filename &optional identification _connected)
(let ((url (url-generic-parse-url filename)))
(if (and (url-type url) (not (equal (url-type url) "file")))

View File

@ -0,0 +1,75 @@
;;; url-handlers-test.el --- Test suite for url-handlers.el -*- lexical-binding: t; -*-
;; Copyright (C) 2018 Free Software Foundation, Inc.
;; Author: Nicolas Petton <nicolas@petton.fr>
;; 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 this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'ert)
(require 'url-handlers)
(defmacro with-url-handler-mode (&rest body)
"Evaluate BODY with `url-handler-mode' turned on."
(declare (indent 0) (debug t))
(let ((url-handler-mode-active (make-symbol "url-handler-mode-active")))
`(let ((,url-handler-mode-active url-handler-mode))
(unwind-protect
(progn
(unless ,url-handler-mode-active
(url-handler-mode))
,@body)
(unless ,url-handler-mode-active
(url-handler-mode -1))))))
(ert-deftest url-handlers-file-name-directory/preserve-url-types ()
(with-url-handler-mode
(should (equal (file-name-directory "https://gnu.org/index.html")
"https://gnu.org/"))
(should (equal (file-name-directory "http://gnu.org/index.html")
"http://gnu.org/"))
(should (equal (file-name-directory "ftp://gnu.org/index.html")
"ftp://gnu.org/"))))
(ert-deftest url-handlers-file-name-directory/should-not-handle-non-url-file-names ()
(with-url-handler-mode
(should-not (equal (file-name-directory "not-uri://gnu.org")
"not-uri://gnu.org/"))))
(ert-deftest url-handlers-file-name-directory/sub-directories ()
(with-url-handler-mode
(should (equal (file-name-directory "https://foo/bar/baz/index.html")
"https://foo/bar/baz/"))))
(ert-deftest url-handlers-file-name-directory/file-urls ()
(with-url-handler-mode
(should (equal (file-name-directory "file:///foo/bar/baz.txt")
"file:///foo/bar/"))
(should (equal (file-name-directory "file:///")
"file:///"))))
;; Regression test for bug#30444
(ert-deftest url-handlers-file-name-directory/no-filename ()
(with-url-handler-mode
(should (equal (file-name-directory "https://foo.org")
"https://foo.org/"))
(should (equal (file-name-directory "https://foo.org/")
"https://foo.org/"))))
(provide 'url-handlers-test)
;;; url-handlers-test.el ends here