[Emacs-diffs] Changes to emacs/lisp/url/url-expand.el [emacs-unicode-2]

[Miles Bader]

Index: emacs/lisp/url/url-expand.el
diff -c /dev/null emacs/lisp/url/url-expand.el:1.3.4.1
*** /dev/null   Fri Oct 22 10:14:35 2004
--- emacs/lisp/url/url-expand.el        Fri Oct 22 10:13:34 2004
***************
*** 0 ****
--- 1,144 ----
+ ;;; url-expand.el --- expand-file-name for URLs
+ 
+ ;; Copyright (c) 1999 Free Software Foundation, Inc.
+ 
+ ;; Keywords: comm, data, processes
+ 
+ ;; This file is part of GNU Emacs.
+ 
+ ;; GNU Emacs 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 2, or (at your option)
+ ;; any later version.
+ 
+ ;; GNU Emacs 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 GNU Emacs; see the file COPYING.  If not, write to the
+ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ ;; Boston, MA 02111-1307, USA.
+ 
+ ;;; Code:
+ 
+ (require 'url-methods)
+ (require 'url-util)
+ (require 'url-parse)
+ 
+ (defun url-expander-remove-relative-links (name)
+   ;; Strip . and .. from pathnames
+   (let ((new (if (not (string-match "^/" name))
+                (concat "/" name)
+              name)))
+ 
+     ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat
+     ;; the tests that follow are not too complicated in terms of
+     ;; looking for '..' or '../', etc.
+     (if (string-match "/\\.+$" new)
+       (setq new (concat new "/")))
+ 
+     ;; Remove '/./' first
+     (while (string-match "/\\(\\./\\)" new)
+       (setq new (concat (substring new 0 (match-beginning 1))
+                       (substring new (match-end 1)))))
+ 
+     ;; Then remove '/../'
+     (while (string-match "/\\([^/]*/\\.\\./\\)" new)
+       (setq new (concat (substring new 0 (match-beginning 1))
+                       (substring new (match-end 1)))))
+ 
+     ;; Remove cruft at the beginning of the string, so people that put
+     ;; in extraneous '..' because they are morons won't lose.
+     (while (string-match "^/\\.\\.\\(/\\)" new)
+       (setq new (substring new (match-beginning 1) nil)))
+     new))
+ 
+ (defun url-expand-file-name (url &optional default)
+   "Convert URL to a fully specified URL, and canonicalize it.
+ Second arg DEFAULT is a URL to start with if URL is relative.
+ If DEFAULT is nil or missing, the current buffer's URL is used.
+ Path components that are `.' are removed, and 
+ path components followed by `..' are removed, along with the `..' itself."
+   (if (and url (not (string-match "^#" url)))
+       ;; Need to nuke newlines and spaces in the URL, or we open
+       ;; ourselves up to potential security holes.
+       (setq url (mapconcat (function (lambda (x)
+                                      (if (memq x '(?  ?\n ?\r))
+                                          ""
+                                        (char-to-string x))))
+                          url "")))
+ 
+   ;; Need to figure out how/where to expand the fragment relative to
+   (setq default (cond
+                ((vectorp default)
+                 ;; Default URL has already been parsed
+                 default)
+                (default
+                  ;; They gave us a default URL in non-parsed format
+                  (url-generic-parse-url default))
+                (url-current-object
+                 ;; We are in a URL-based buffer, use the pre-parsed object
+                 url-current-object)
+                ((string-match url-nonrelative-link url)
+                 ;; The URL they gave us is absolute, go for it.
+                 nil)
+                (t
+                 ;; Hmmm - this shouldn't ever happen.
+                 (error "url-expand-file-name confused - no default?"))))
+ 
+   (cond
+    ((= (length url) 0)                        ; nil or empty string
+     (url-recreate-url default))
+    ((string-match "^#" url)           ; Offset link, use it raw
+     url)
+    ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it 
immediately
+     url)
+    (t
+     (let* ((urlobj (url-generic-parse-url url))
+          (inhibit-file-name-handlers t)
+          (expander (url-scheme-get-property (url-type default) 
'expand-file-name)))
+       (if (string-match "^//" url)
+         (setq urlobj (url-generic-parse-url (concat (url-type default) ":"
+                                                     url))))
+       (funcall expander urlobj default)
+       (url-recreate-url urlobj)))))
+ 
+ (defun url-identity-expander (urlobj defobj)
+   (url-set-type urlobj (or (url-type urlobj) (url-type defobj))))
+ 
+ (defun url-default-expander (urlobj defobj)
+   ;; The default expansion routine - urlobj is modified by side effect!
+   (if (url-type urlobj)
+       ;; Well, they told us the scheme, let's just go with it.
+       nil
+     (url-set-type urlobj (or (url-type urlobj) (url-type defobj)))
+     (url-set-port urlobj (or (url-port urlobj)
+                            (and (string= (url-type urlobj)
+                                          (url-type defobj))
+                                 (url-port defobj))))
+     (if (not (string= "file" (url-type urlobj)))
+       (url-set-host urlobj (or (url-host urlobj) (url-host defobj))))
+     (if (string= "ftp"  (url-type urlobj))
+       (url-set-user urlobj (or (url-user urlobj) (url-user defobj))))
+     (if (string= (url-filename urlobj) "")
+       (url-set-filename urlobj "/"))
+     (if (string-match "^/" (url-filename urlobj))
+       nil
+       (let ((query nil)
+           (file nil)
+           (sepchar nil))
+       (if (string-match "[?#]" (url-filename urlobj))
+           (setq query (substring (url-filename urlobj) (match-end 0))
+                 file (substring (url-filename urlobj) 0 (match-beginning 0))
+                 sepchar (substring (url-filename urlobj) (match-beginning 0) 
(match-end 0)))
+         (setq file (url-filename urlobj)))
+       (setq file (url-expander-remove-relative-links
+                   (concat (url-basepath (url-filename defobj)) file)))
+       (url-set-filename urlobj (if query (concat file sepchar query) 
file))))))
+ 
+ (provide 'url-expand)
+ 
+ ;;; arch-tag: 7b5f744b-b721-49da-be47-484631680a5a
+ ;;; url-expand.el ends here