1 ;;; url-expand.el --- expand-file-name for URLs
3 ;; Copyright (C) 1999, 2004, 2005, 2006 Free Software Foundation, Inc.
5 ;; Keywords: comm, data, processes
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
21 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
22 ;; Boston, MA 02110-1301, USA.
26 (require 'url-methods
)
30 (defun url-expander-remove-relative-links (name)
31 ;; Strip . and .. from pathnames
32 (let ((new (if (not (string-match "^/" name
))
36 ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat
37 ;; the tests that follow are not too complicated in terms of
38 ;; looking for '..' or '../', etc.
39 (if (string-match "/\\.+$" new
)
40 (setq new
(concat new
"/")))
43 (while (string-match "/\\(\\./\\)" new
)
44 (setq new
(concat (substring new
0 (match-beginning 1))
45 (substring new
(match-end 1)))))
48 (while (string-match "/\\([^/]*/\\.\\./\\)" new
)
49 (setq new
(concat (substring new
0 (match-beginning 1))
50 (substring new
(match-end 1)))))
52 ;; Remove cruft at the beginning of the string, so people that put
53 ;; in extraneous '..' because they are morons won't lose.
54 (while (string-match "^/\\.\\.\\(/\\)" new
)
55 (setq new
(substring new
(match-beginning 1) nil
)))
58 (defun url-expand-file-name (url &optional default
)
59 "Convert URL to a fully specified URL, and canonicalize it.
60 Second arg DEFAULT is a URL to start with if URL is relative.
61 If DEFAULT is nil or missing, the current buffer's URL is used.
62 Path components that are `.' are removed, and
63 path components followed by `..' are removed, along with the `..' itself."
64 (if (and url
(not (string-match "^#" url
)))
65 ;; Need to nuke newlines and spaces in the URL, or we open
66 ;; ourselves up to potential security holes.
67 (setq url
(mapconcat (function (lambda (x)
68 (if (memq x
'(? ?
\n ?
\r))
73 ;; Need to figure out how/where to expand the fragment relative to
76 ;; Default URL has already been parsed
79 ;; They gave us a default URL in non-parsed format
80 (url-generic-parse-url default
))
82 ;; We are in a URL-based buffer, use the pre-parsed object
84 ((string-match url-nonrelative-link url
)
85 ;; The URL they gave us is absolute, go for it.
88 ;; Hmmm - this shouldn't ever happen.
89 (error "url-expand-file-name confused - no default?"))))
92 ((= (length url
) 0) ; nil or empty string
93 (url-recreate-url default
))
94 ((string-match "^#" url
) ; Offset link, use it raw
96 ((string-match url-nonrelative-link url
) ; Fully-qualified URL, return it immediately
99 (let* ((urlobj (url-generic-parse-url url
))
100 (inhibit-file-name-handlers t
)
101 (expander (url-scheme-get-property (url-type default
) 'expand-file-name
)))
102 (if (string-match "^//" url
)
103 (setq urlobj
(url-generic-parse-url (concat (url-type default
) ":"
105 (funcall expander urlobj default
)
106 (url-recreate-url urlobj
)))))
108 (defun url-identity-expander (urlobj defobj
)
109 (url-set-type urlobj
(or (url-type urlobj
) (url-type defobj
))))
111 (defun url-default-expander (urlobj defobj
)
112 ;; The default expansion routine - urlobj is modified by side effect!
113 (if (url-type urlobj
)
114 ;; Well, they told us the scheme, let's just go with it.
116 (url-set-type urlobj
(or (url-type urlobj
) (url-type defobj
)))
117 (url-set-port urlobj
(or (url-port urlobj
)
118 (and (string= (url-type urlobj
)
121 (if (not (string= "file" (url-type urlobj
)))
122 (url-set-host urlobj
(or (url-host urlobj
) (url-host defobj
))))
123 (if (string= "ftp" (url-type urlobj
))
124 (url-set-user urlobj
(or (url-user urlobj
) (url-user defobj
))))
125 (if (string= (url-filename urlobj
) "")
126 (url-set-filename urlobj
"/"))
127 (if (string-match "^/" (url-filename urlobj
))
132 (if (string-match "[?#]" (url-filename urlobj
))
133 (setq query
(substring (url-filename urlobj
) (match-end 0))
134 file
(substring (url-filename urlobj
) 0 (match-beginning 0))
135 sepchar
(substring (url-filename urlobj
) (match-beginning 0) (match-end 0)))
136 (setq file
(url-filename urlobj
)))
137 (setq file
(url-expander-remove-relative-links
138 (concat (url-basepath (url-filename defobj
)) file
)))
139 (url-set-filename urlobj
(if query
(concat file sepchar query
) file
))))))
141 (provide 'url-expand
)
143 ;;; arch-tag: 7b5f744b-b721-49da-be47-484631680a5a
144 ;;; url-expand.el ends here