Commit 9f9aa044 authored by Chong Yidong's avatar Chong Yidong
Browse files

Cleanups and improvements for FFAP and URL.

* ffap.el (ffap-url-unwrap-local): Make it work right.
Use url-generic-parse-url, and handle host names and Windows
filenames properly.
(ffap-url-unwrap-remote): Use url-generic-parse-url.
(ffap-url-unwrap-remote): Accept list values, specifying a list of
URL schemes to work on.
(ffap--toggle-read-only): New function.
(ffap-read-only, ffap-read-only-other-window)
(ffap-read-only-other-frame): Use it.
(ffap-fixup-url): Don't check ffap-ftp-regexp, since it is not
necessary for ffap-url-unwrap-remote.

* url-parse.el (url-path-and-query, url-port-if-non-default): New
functions.
(url-generic-parse-url): Don't set the portspec slot if it is not
specified; that is what `url-port' is for.
(url-port): Only require the scheme to be specified to call
url-scheme-get-property.

* url-util.el (url-encode-url): Use url-path-and-query.

* url-vars.el (url-mime-charset-string): Load mm-util lazily.

Fixes: debbugs:9131
parent 97107e2e
......@@ -150,6 +150,12 @@ these commands now).
** erc will look up server/channel names via auth-source and use the
channel keys found, if any.
** FFAP
*** The option `ffap-url-unwrap-remote' can now be a list of strings,
specifying URL types which should be converted to remote file names at
the FFAP prompt. The default is now '("ftp").
** Follow mode
*** The obsolete variable `follow-mode-off-hook' has been removed.
......
2012-05-10 Chong Yidong <cyd@gnu.org>
* ffap.el (ffap-url-unwrap-local): Make it work right (Bug#9131).
Use url-generic-parse-url, and handle host names and Windows
filenames properly.
(ffap-url-unwrap-remote): Use url-generic-parse-url.
(ffap-url-unwrap-remote): Accept list values, specifying a list of
URL schemes to work on.
(ffap--toggle-read-only): New function.
(ffap-read-only, ffap-read-only-other-window)
(ffap-read-only-other-frame): Use it.
(ffap-fixup-url): Don't check ffap-ftp-regexp, since it is not
necessary for ffap-url-unwrap-remote.
2012-05-10 Dave Abrahams <dave@boostpro.com>
* cus-start.el (create-lockfiles): Add it.
......
......@@ -105,6 +105,8 @@
;;; Code:
(require 'url-parse)
(define-obsolete-variable-alias 'ffap-version 'emacs-version "23.2")
(defgroup ffap nil
......@@ -136,10 +138,7 @@ If nil, ffap doesn't do shell prompt stripping."
regexp)
:group 'ffap)
(defcustom ffap-ftp-regexp
;; This used to test for ange-ftp or efs being present, but it should be
;; harmless (and simpler) to give it this value unconditionally.
"\\`/[^/:]+:"
(defcustom ffap-ftp-regexp "\\`/[^/:]+:"
"File names matching this regexp are treated as remote ffap.
If nil, ffap neither recognizes nor generates such names."
:type '(choice (const :tag "Disable" nil)
......@@ -148,15 +147,20 @@ If nil, ffap neither recognizes nor generates such names."
:group 'ffap)
(defcustom ffap-url-unwrap-local t
"If non-nil, convert `file:' URL to local file name before prompting."
"If non-nil, convert some URLs to local file names before prompting.
Only \"file:\" and \"ftp:\" URLs are converted, and only if they
do not specify a host, or the host is either \"localhost\" or
equal to `system-name'."
:type 'boolean
:group 'ffap)
(defcustom ffap-url-unwrap-remote t
"If non-nil, convert `ftp:' URL to remote file name before prompting.
This is ignored if `ffap-ftp-regexp' is nil."
:type 'boolean
:group 'ffap)
(defcustom ffap-url-unwrap-remote '("ftp")
"If non-nil, convert URLs to remote file names before prompting.
If the value is a list of strings, that specifies a list of URL
schemes (e.g. \"ftp\"); in that case, only convert those URLs."
:type '(choice (repeat string) boolean)
:group 'ffap
:version "24.2")
(defcustom ffap-ftp-default-user "anonymous"
"User name in ftp file names generated by `ffap-host-to-path'.
......@@ -247,14 +251,14 @@ ffap most of the time."
(defcustom ffap-file-finder 'find-file
"The command called by `find-file-at-point' to find a file."
:type 'function
:group 'ffap)
(put 'ffap-file-finder 'risky-local-variable t)
:group 'ffap
:risky t)
(defcustom ffap-directory-finder 'dired
"The command called by `dired-at-point' to find a directory."
:type 'function
:group 'ffap)
(put 'ffap-directory-finder 'risky-local-variable t)
:group 'ffap
:risky t)
(defcustom ffap-url-fetcher
(if (fboundp 'browse-url)
......@@ -271,8 +275,28 @@ For a fancy alternative, get `ffap-url.el'."
(const browse-url-netscape)
(const browse-url-mosaic)
function)
:group 'ffap
:risky t)
(defcustom ffap-next-regexp
;; If you want ffap-next to find URL's only, try this:
;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp)
;; (concat "\\<" (substring ffap-url-regexp 2))))
;;
;; It pays to put a big fancy regexp here, since ffap-guesser is
;; much more time-consuming than regexp searching:
"[/:.~[:alpha:]]/\\|@[[:alpha:]][-[:alnum:]]*\\."
"Regular expression governing movements of `ffap-next'."
:type 'regexp
:group 'ffap)
(put 'ffap-url-fetcher 'risky-local-variable t)
(defcustom dired-at-point-require-prefix nil
"If non-nil, reverse the prefix argument to `dired-at-point'.
This is nil so neophytes notice FFAP. Experts may prefer to
disable FFAP most of the time."
:type 'boolean
:group 'ffap
:version "20.3")
;;; Compatibility:
......@@ -293,18 +317,6 @@ For a fancy alternative, get `ffap-url.el'."
;; then, broke it up into ffap-next-guess (noninteractive) and
;; ffap-next (a command). It now work on files as well as url's.
(defcustom ffap-next-regexp
;; If you want ffap-next to find URL's only, try this:
;; (and ffap-url-regexp (string-match "\\\\`" ffap-url-regexp)
;; (concat "\\<" (substring ffap-url-regexp 2))))
;;
;; It pays to put a big fancy regexp here, since ffap-guesser is
;; much more time-consuming than regexp searching:
"[/:.~[:alpha:]]/\\|@[[:alpha:]][-[:alnum:]]*\\."
"Regular expression governing movements of `ffap-next'."
:type 'regexp
:group 'ffap)
(defvar ffap-next-guess nil
"Last value returned by `ffap-next-guess'.")
......@@ -606,28 +618,45 @@ Looks at `ffap-ftp-default-user', returns \"\" for \"localhost\"."
string)))
;; Broke these out of ffap-fixup-url, for use of ffap-url package.
(defsubst ffap-url-unwrap-local (url)
"Return URL as a local file, or nil. Ignores `ffap-url-regexp'."
(and (string-match "\\`\\(file\\|ftp\\):/?\\([^/]\\|\\'\\)" url)
(substring url (1+ (match-end 1)))))
(defsubst ffap-url-unwrap-remote (url)
"Return URL as a remote file, or nil. Ignores `ffap-url-regexp'."
(and (string-match "\\`\\(ftp\\|file\\)://\\([^:/]+\\):?\\(/.*\\)" url)
(concat
(ffap-host-to-filename (substring url (match-beginning 2) (match-end 2)))
(substring url (match-beginning 3) (match-end 3)))))
;; Test: (ffap-url-unwrap-remote "ftp://foo.com/bar.boz")
(defun ffap-url-unwrap-local (url)
"Return URL as a local file name, or nil."
(let* ((obj (url-generic-parse-url url))
(host (url-host obj))
(filename (car (url-path-and-query obj))))
(when (and (member (url-type obj) '("ftp" "file"))
(member host `("" "localhost" ,(system-name))))
;; On Windows, "file:///C:/foo" should unwrap to "C:/foo"
(if (and (memq system-type '(ms-dos windows-nt cygwin))
(string-match "\\`/[a-zA-Z]:" filename))
(substring filename 1)
filename))))
(defun ffap-url-unwrap-remote (url)
"Return URL as a remote file name, or nil."
(let* ((obj (url-generic-parse-url url))
(scheme (url-type obj))
(valid-schemes (if (listp ffap-url-unwrap-remote)
ffap-url-unwrap-remote
'("ftp")))
(host (url-host obj))
(port (url-port-if-non-default obj))
(user (url-user obj))
(filename (car (url-path-and-query obj))))
(when (and (member scheme valid-schemes)
(string-match "\\`[a-zA-Z][-a-zA-Z0-9+.]*\\'" scheme)
(not (equal host "")))
(concat "/" scheme ":"
(if user (concat user "@"))
host
(if port (concat "#" (number-to-string port)))
":" filename))))
(defun ffap-fixup-url (url)
"Clean up URL and return it, maybe as a file name."
(cond
((not (stringp url)) nil)
((and ffap-url-unwrap-local (ffap-url-unwrap-local url)))
((and ffap-url-unwrap-remote ffap-ftp-regexp
(ffap-url-unwrap-remote url)))
;; All this seems to do is remove any trailing "#anchor" part (Bug#898).
;;; ((fboundp 'url-normalize-url) ; may autoload url (part of w3)
;;; (url-normalize-url url))
((and ffap-url-unwrap-local (ffap-url-unwrap-local url)))
((and ffap-url-unwrap-remote (ffap-url-unwrap-remote url)))
(url)))
......@@ -1076,38 +1105,33 @@ Assumes the buffer has not changed."
;; ignore non-relative links, trim punctuation. The other will
;; actually look back if point is in whitespace, but I would rather
;; ffap be less aggressive in such situations.
(and
ffap-url-regexp
(or
;; In a w3 buffer button?
(and (eq major-mode 'w3-mode)
;; interface recommended by wmperry:
(w3-view-this-url t))
;; Is there a reason not to strip trailing colon?
(let ((name (ffap-string-at-point 'url)))
(cond
((string-match "^url:" name) (setq name (substring name 4)))
((and (string-match "\\`[^:</>@]+@[^:</>@]+[[:alnum:]]\\'" name)
;; "foo@bar": could be "mailto" or "news" (a Message-ID).
;; Without "<>" it must be "mailto". Otherwise could be
;; either, so consult `ffap-foo-at-bar-prefix'.
(let ((prefix (if (and (equal (ffap-string-around) "<>")
;; Expect some odd characters:
(string-match "[$.0-9].*[$.0-9].*@" name))
;; Could be news:
ffap-foo-at-bar-prefix
"mailto")))
(and prefix (setq name (concat prefix ":" name))))))
((ffap-newsgroup-p name) (setq name (concat "news:" name)))
((and (string-match "\\`[[:alnum:]]+\\'" name) ; <mic> <root> <nobody>
(equal (ffap-string-around) "<>")
;; (ffap-user-p name):
(not (string-match "~" (expand-file-name (concat "~" name))))
)
(setq name (concat "mailto:" name)))
)
(and (ffap-url-p name) name)
))))
(when ffap-url-regexp
(or (and (eq major-mode 'w3-mode) ; In a w3 buffer button?
(w3-view-this-url t))
;; Is there a reason not to strip trailing colon?
(let ((name (ffap-string-at-point 'url)))
(cond
((string-match "^url:" name) (setq name (substring name 4)))
((and (string-match "\\`[^:</>@]+@[^:</>@]+[[:alnum:]]\\'" name)
;; "foo@bar": could be "mailto" or "news" (a Message-ID).
;; Without "<>" it must be "mailto". Otherwise could be
;; either, so consult `ffap-foo-at-bar-prefix'.
(let ((prefix (if (and (equal (ffap-string-around) "<>")
;; Expect some odd characters:
(string-match "[$.0-9].*[$.0-9].*@" name))
;; Could be news:
ffap-foo-at-bar-prefix
"mailto")))
(and prefix (setq name (concat prefix ":" name))))))
((ffap-newsgroup-p name) (setq name (concat "news:" name)))
((and (string-match "\\`[[:alnum:]]+\\'" name) ; <mic> <root> <nobody>
(equal (ffap-string-around) "<>")
;; (ffap-user-p name):
(not (string-match "~" (expand-file-name (concat "~" name)))))
(setq name (concat "mailto:" name))))
(if (ffap-url-p name)
name)))))
(defvar ffap-gopher-regexp
"^.*\\<\\(Type\\|Name\\|Path\\|Host\\|Port\\) *= *\\(.*\\) *$"
......@@ -1342,8 +1366,6 @@ which may actually result in an URL rather than a filename."
;;; Highlighting (`ffap-highlight'):
;;
;; Based on overlay highlighting in Emacs 19.28 isearch.el.
(defvar ffap-highlight t
"If non-nil, ffap highlights the current buffer substring.")
......@@ -1676,6 +1698,11 @@ Only intended for interactive use."
(set-window-dedicated-p win wdp))
value))
(defun ffap--toggle-read-only (buffer)
(with-current-buffer buffer
(with-no-warnings
(toggle-read-only 1))))
(defun ffap-read-only ()
"Like `ffap', but mark buffer as read-only.
Only intended for interactive use."
......@@ -1683,7 +1710,7 @@ Only intended for interactive use."
(let ((value (call-interactively 'ffap)))
(unless (or (bufferp value) (bufferp (car-safe value)))
(setq value (current-buffer)))
(mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
(mapc #'ffap--toggle-read-only
(if (listp value) value (list value)))
value))
......@@ -1692,7 +1719,7 @@ Only intended for interactive use."
Only intended for interactive use."
(interactive)
(let ((value (ffap-other-window)))
(mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
(mapc #'ffap--toggle-read-only
(if (listp value) value (list value)))
value))
......@@ -1701,7 +1728,7 @@ Only intended for interactive use."
Only intended for interactive use."
(interactive)
(let ((value (ffap-other-frame)))
(mapc (lambda (b) (with-current-buffer b (toggle-read-only 1)))
(mapc #'ffap--toggle-read-only
(if (listp value) value (list value)))
value))
......@@ -1743,8 +1770,7 @@ Only intended for interactive use."
(defun ffap-ro-mode-hook ()
"Bind `ffap-next' and `ffap-menu' to M-l and M-m, resp."
(local-set-key "\M-l" 'ffap-next)
(local-set-key "\M-m" 'ffap-menu)
)
(local-set-key "\M-m" 'ffap-menu))
(defun ffap-gnus-hook ()
"Bind `ffap-gnus-next' and `ffap-gnus-menu' to M-l and M-m, resp."
......@@ -1788,13 +1814,6 @@ Only intended for interactive use."
(interactive) (ffap-gnus-wrapper '(ffap-menu)))
(defcustom dired-at-point-require-prefix nil
"If set, reverses the prefix argument to `dired-at-point'.
This is nil so neophytes notice ffap. Experts may prefer to disable
ffap most of the time."
:type 'boolean
:group 'ffap
:version "20.3")
;;;###autoload
(defun dired-at-point (&optional filename)
......@@ -1901,7 +1920,7 @@ Only intended for interactive use."
;;; Hooks to put in `file-name-at-point-functions':
;;;###autoload
(progn (defun ffap-guess-file-name-at-point ()
(defun ffap-guess-file-name-at-point ()
"Try to get a file name at point.
This hook is intended to be put in `file-name-at-point-functions'."
(when (fboundp 'ffap-guesser)
......@@ -1918,14 +1937,13 @@ This hook is intended to be put in `file-name-at-point-functions'."
(when guess
(if (file-directory-p guess)
(file-name-as-directory guess)
guess))))))
guess)))))
;;; Offer default global bindings (`ffap-bindings'):
(defvar ffap-bindings
'(
(global-set-key [S-mouse-3] 'ffap-at-mouse)
'((global-set-key [S-mouse-3] 'ffap-at-mouse)
(global-set-key [C-S-mouse-3] 'ffap-menu)
(global-set-key "\C-x\C-f" 'find-file-at-point)
......@@ -1945,9 +1963,7 @@ This hook is intended to be put in `file-name-at-point-functions'."
(add-hook 'gnus-summary-mode-hook 'ffap-gnus-hook)
(add-hook 'gnus-article-mode-hook 'ffap-gnus-hook)
(add-hook 'vm-mode-hook 'ffap-ro-mode-hook)
(add-hook 'rmail-mode-hook 'ffap-ro-mode-hook)
;; (setq dired-x-hands-off-my-keys t) ; the default
)
(add-hook 'rmail-mode-hook 'ffap-ro-mode-hook))
"List of binding forms evaluated by function `ffap-bindings'.
A reasonable ffap installation needs just this one line:
(ffap-bindings)
......
2012-05-10 Chong Yidong <cyd@gnu.org>
* url-parse.el (url-path-and-query, url-port-if-non-default): New
functions.
(url-generic-parse-url): Don't set the portspec slot if it is not
specified; that is what `url-port' is for.
(url-port): Only require the scheme to be specified to call
url-scheme-get-property.
* url-util.el (url-encode-url): Use url-path-and-query.
* url-vars.el (url-mime-charset-string): Load mm-util lazily.
2012-05-09 Chong Yidong <cyd@gnu.org>
* url-util.el (url-encode-url): New function for URL quoting.
......@@ -12,6 +25,7 @@
whole path and query inside the FILENAME slot. Improve docstring.
(url-recreate-url-attributes): Mark as obsolete.
(url-recreate-url): Handle missing scheme and userinfo.
(url-path-and-query): New function.
* url-http.el (url-http-create-request): Ignore obsolete
attributes slot of url-object.
......
......@@ -39,22 +39,52 @@
silent (use-cookies t))
(defsubst url-port (urlobj)
"Return the port number for the URL specified by URLOBJ."
(or (url-portspec urlobj)
(if (url-fullness urlobj)
(if (url-type urlobj)
(url-scheme-get-property (url-type urlobj) 'default-port))))
(defsetf url-port (urlobj) (port) `(setf (url-portspec ,urlobj) ,port))
(defun url-path-and-query (urlobj)
"Return the path and query components of URLOBJ.
These two components are store together in the FILENAME slot of
the object. The return value of this function is (PATH . QUERY),
where each of PATH and QUERY are strings or nil."
(let ((name (url-filename urlobj))
path query)
(when name
(if (string-match "\\?" name)
(setq path (substring name 0 (match-beginning 0))
query (substring name (match-end 0)))
(setq path name)))
(if (equal path "") (setq path nil))
(if (equal query "") (setq query nil))
(cons path query)))
(defun url-port-if-non-default (urlobj)
"Return the port number specified by URLOBJ, if it is not the default.
If the specified port number is the default, return nil."
(let ((port (url-portspec urlobj))
type)
(and port
(or (null (setq type (url-type urlobj)))
(not (equal port (url-scheme-get-property type 'default-port))))
port)))
;;;###autoload
(defun url-recreate-url (urlobj)
"Recreate a URL string from the parsed URLOBJ."
(let ((type (url-type urlobj))
(user (url-user urlobj))
(pass (url-password urlobj))
(host (url-host urlobj))
(port (url-portspec urlobj))
(file (url-filename urlobj))
(frag (url-target urlobj)))
(let* ((type (url-type urlobj))
(user (url-user urlobj))
(pass (url-password urlobj))
(host (url-host urlobj))
;; RFC 3986: "omit the port component and its : delimiter if
;; port is empty or if its value would be the same as that of
;; the scheme's default."
(port (url-port-if-non-default urlobj))
(file (url-filename urlobj))
(frag (url-target urlobj)))
(concat (if type (concat type ":"))
(if (url-fullness urlobj) "//")
(if (or user pass)
......@@ -62,15 +92,7 @@
(if pass (concat ":" pass))
"@"))
host
;; RFC 3986: "omit the port component and its : delimiter
;; if port is empty or if its value would be the same as
;; that of the scheme's default."
(and port
(or (null type)
(not (equal port
(url-scheme-get-property type
'default-port))))
(format ":%d" (url-port urlobj)))
(if port (format ":%d" (url-port urlobj)))
(or file "/")
(if frag (concat "#" frag)))))
......@@ -102,8 +124,8 @@ TARGET is the fragment identifier component (used to refer to a
ATTRIBUTES is nil; this slot originally stored the attribute and
value alists for IMAP URIs, but this feature was removed
since it conflicts with RFC 3986.
FULLNESS is non-nil iff the authority component of the URI is
present.
FULLNESS is non-nil iff the hierarchical sequence component of
the URL starts with two slashes, \"//\".
The parser follows RFC 3986, except that it also tries to handle
URIs that are not fully specified (e.g. lacking TYPE), and it
......@@ -174,10 +196,6 @@ parses to
(setq port (string-to-number port))))
(setq host (downcase host)))
(and (null port)
scheme
(setq port (url-scheme-get-property scheme 'default-port)))
;; Now point is on the / ? or # which terminates the
;; authority, or at the end of the URI, or (if there is no
;; authority) at the beginning of the absolute path.
......
......@@ -418,31 +418,26 @@ should return it unchanged."
(user (url-user obj))
(pass (url-password obj))
(host (url-host obj))
(file (url-filename obj))
(frag (url-target obj))
path query)
(path-and-query (url-path-and-query obj))
(path (car path-and-query))
(query (cdr path-and-query))
(frag (url-target obj)))
(if user
(setf (url-user obj) (url-hexify-string user)))
(if pass
(setf (url-password obj) (url-hexify-string pass)))
(when host
;; No special encoding for IPv6 literals.
(unless (string-match "\\`\\[.*\\]\\'" host)
(setf (url-host obj)
(url-hexify-string host url-host-allowed-chars))))
;; Split FILENAME slot into its PATH and QUERY components, and
;; encode them separately. The PATH component can contain
;; unreserved characters, %-encodings, and /:@!$&'()*+,;=
(when file
(if (string-match "\\?" file)
(setq path (substring file 0 (match-beginning 0))
query (substring file (match-end 0)))
(setq path file))
(setq path (url-hexify-string path url-path-allowed-chars))
(if query
(setq query (url-hexify-string query url-query-allowed-chars)))
(setf (url-filename obj)
(if query (concat path "?" query) path)))
;; No special encoding for IPv6 literals.
(and host
(not (string-match "\\`\\[.*\\]\\'" host))
(setf (url-host obj)
(url-hexify-string host url-host-allowed-chars)))
(if path
(setq path (url-hexify-string path url-path-allowed-chars)))
(if query
(setq query (url-hexify-string query url-query-allowed-chars)))
(setf (url-filename obj) (if query (concat path "?" query) path))
(if frag
(setf (url-target obj)
(url-hexify-string frag url-query-allowed-chars)))
......
......@@ -21,8 +21,6 @@
;;; Code:
(require 'mm-util)
(defconst url-version "Emacs"
"Version number of URL package.")
......@@ -221,6 +219,7 @@ Should be an assoc list of headers/contents.")
(defun url-mime-charset-string ()
"Generate a list of preferred MIME charsets for HTTP requests.
Generated according to current coding system priorities."
(require 'mm-util)
(if (fboundp 'sort-coding-systems)
(let ((ordered (sort-coding-systems
(let (accum)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment