diff options
| -rw-r--r-- | etc/NEWS | 6 | ||||
| -rw-r--r-- | lisp/ChangeLog | 14 | ||||
| -rw-r--r-- | lisp/ffap.el | 210 | ||||
| -rw-r--r-- | lisp/url/ChangeLog | 14 | ||||
| -rw-r--r-- | lisp/url/url-parse.el | 64 | ||||
| -rw-r--r-- | lisp/url/url-util.el | 37 | ||||
| -rw-r--r-- | lisp/url/url-vars.el | 3 |
7 files changed, 205 insertions, 143 deletions
@@ -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. diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f1429f9f875..e983957e285 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,17 @@ +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. diff --git a/lisp/ffap.el b/lisp/ffap.el index 905d7873dc2..a8455189cb9 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -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) diff --git a/lisp/url/ChangeLog b/lisp/url/ChangeLog index b3669a72ac3..c41df0e832b 100644 --- a/lisp/url/ChangeLog +++ b/lisp/url/ChangeLog @@ -1,3 +1,16 @@ +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. diff --git a/lisp/url/url-parse.el b/lisp/url/url-parse.el index 40183a4f533..18c5790313e 100644 --- a/lisp/url/url-parse.el +++ b/lisp/url/url-parse.el @@ -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. diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 4185c87918e..71bc84cab09 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -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))) diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 0d71910849f..6aa14b8bae1 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -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) |