Mercurial > emacs
comparison lisp/url/url-expand.el @ 54695:3fb37923e567
Initial revision
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Sun, 04 Apr 2004 01:21:46 +0000 |
parents | |
children | 7784ae10206d |
comparison
equal
deleted
inserted
replaced
54694:253149f265f2 | 54695:3fb37923e567 |
---|---|
1 ;;; url-expand.el --- expand-file-name for URLs | |
2 ;; Author: $Author: wmperry $ | |
3 ;; Created: $Date: 1999/12/05 08:09:15 $ | |
4 ;; Version: $Revision: 1.3 $ | |
5 ;; Keywords: comm, data, processes | |
6 | |
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
8 ;;; Copyright (c) 1999 Free Software Foundation, Inc. | |
9 ;;; | |
10 ;;; This file is part of GNU Emacs. | |
11 ;;; | |
12 ;;; GNU Emacs is free software; you can redistribute it and/or modify | |
13 ;;; it under the terms of the GNU General Public License as published by | |
14 ;;; the Free Software Foundation; either version 2, or (at your option) | |
15 ;;; any later version. | |
16 ;;; | |
17 ;;; GNU Emacs is distributed in the hope that it will be useful, | |
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
20 ;;; GNU General Public License for more details. | |
21 ;;; | |
22 ;;; You should have received a copy of the GNU General Public License | |
23 ;;; along with GNU Emacs; see the file COPYING. If not, write to the | |
24 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
25 ;;; Boston, MA 02111-1307, USA. | |
26 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
27 | |
28 (require 'url-methods) | |
29 (require 'url-util) | |
30 (require 'url-parse) | |
31 | |
32 (defun url-expander-remove-relative-links (name) | |
33 ;; Strip . and .. from pathnames | |
34 (let ((new (if (not (string-match "^/" name)) | |
35 (concat "/" name) | |
36 name))) | |
37 | |
38 ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat | |
39 ;; the tests that follow are not too complicated in terms of | |
40 ;; looking for '..' or '../', etc. | |
41 (if (string-match "/\\.+$" new) | |
42 (setq new (concat new "/"))) | |
43 | |
44 ;; Remove '/./' first | |
45 (while (string-match "/\\(\\./\\)" new) | |
46 (setq new (concat (substring new 0 (match-beginning 1)) | |
47 (substring new (match-end 1))))) | |
48 | |
49 ;; Then remove '/../' | |
50 (while (string-match "/\\([^/]*/\\.\\./\\)" new) | |
51 (setq new (concat (substring new 0 (match-beginning 1)) | |
52 (substring new (match-end 1))))) | |
53 | |
54 ;; Remove cruft at the beginning of the string, so people that put | |
55 ;; in extraneous '..' because they are morons won't lose. | |
56 (while (string-match "^/\\.\\.\\(/\\)" new) | |
57 (setq new (substring new (match-beginning 1) nil))) | |
58 new)) | |
59 | |
60 (defun url-expand-file-name (url &optional default) | |
61 "Convert URL to a fully specified URL, and canonicalize it. | |
62 Second arg DEFAULT is a URL to start with if URL is relative. | |
63 If DEFAULT is nil or missing, the current buffer's URL is used. | |
64 Path components that are `.' are removed, and | |
65 path components followed by `..' are removed, along with the `..' itself." | |
66 (if (and url (not (string-match "^#" url))) | |
67 ;; Need to nuke newlines and spaces in the URL, or we open | |
68 ;; ourselves up to potential security holes. | |
69 (setq url (mapconcat (function (lambda (x) | |
70 (if (memq x '(? ?\n ?\r)) | |
71 "" | |
72 (char-to-string x)))) | |
73 url ""))) | |
74 | |
75 ;; Need to figure out how/where to expand the fragment relative to | |
76 (setq default (cond | |
77 ((vectorp default) | |
78 ;; Default URL has already been parsed | |
79 default) | |
80 (default | |
81 ;; They gave us a default URL in non-parsed format | |
82 (url-generic-parse-url default)) | |
83 (url-current-object | |
84 ;; We are in a URL-based buffer, use the pre-parsed object | |
85 url-current-object) | |
86 ((string-match url-nonrelative-link url) | |
87 ;; The URL they gave us is absolute, go for it. | |
88 nil) | |
89 (t | |
90 ;; Hmmm - this shouldn't ever happen. | |
91 (error "url-expand-file-name confused - no default?")))) | |
92 | |
93 (cond | |
94 ((= (length url) 0) ; nil or empty string | |
95 (url-recreate-url default)) | |
96 ((string-match "^#" url) ; Offset link, use it raw | |
97 url) | |
98 ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately | |
99 url) | |
100 (t | |
101 (let* ((urlobj (url-generic-parse-url url)) | |
102 (inhibit-file-name-handlers t) | |
103 (expander (url-scheme-get-property (url-type default) 'expand-file-name))) | |
104 (if (string-match "^//" url) | |
105 (setq urlobj (url-generic-parse-url (concat (url-type default) ":" | |
106 url)))) | |
107 (funcall expander urlobj default) | |
108 (url-recreate-url urlobj))))) | |
109 | |
110 (defun url-identity-expander (urlobj defobj) | |
111 (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))) | |
112 | |
113 (defun url-default-expander (urlobj defobj) | |
114 ;; The default expansion routine - urlobj is modified by side effect! | |
115 (if (url-type urlobj) | |
116 ;; Well, they told us the scheme, let's just go with it. | |
117 nil | |
118 (url-set-type urlobj (or (url-type urlobj) (url-type defobj))) | |
119 (url-set-port urlobj (or (url-port urlobj) | |
120 (and (string= (url-type urlobj) | |
121 (url-type defobj)) | |
122 (url-port defobj)))) | |
123 (if (not (string= "file" (url-type urlobj))) | |
124 (url-set-host urlobj (or (url-host urlobj) (url-host defobj)))) | |
125 (if (string= "ftp" (url-type urlobj)) | |
126 (url-set-user urlobj (or (url-user urlobj) (url-user defobj)))) | |
127 (if (string= (url-filename urlobj) "") | |
128 (url-set-filename urlobj "/")) | |
129 (if (string-match "^/" (url-filename urlobj)) | |
130 nil | |
131 (let ((query nil) | |
132 (file nil) | |
133 (sepchar nil)) | |
134 (if (string-match "[?#]" (url-filename urlobj)) | |
135 (setq query (substring (url-filename urlobj) (match-end 0)) | |
136 file (substring (url-filename urlobj) 0 (match-beginning 0)) | |
137 sepchar (substring (url-filename urlobj) (match-beginning 0) (match-end 0))) | |
138 (setq file (url-filename urlobj))) | |
139 (setq file (url-expander-remove-relative-links | |
140 (concat (url-basepath (url-filename defobj)) file))) | |
141 (url-set-filename urlobj (if query (concat file sepchar query) file)))))) | |
142 | |
143 (provide 'url-expand) |