diff lisp/url/url-expand.el @ 54695:3fb37923e567

Initial revision

--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/url/url-expand.el	Sun Apr 04 01:21:46 2004 +0000
@@ -0,0 +1,143 @@
+;;; url-expand.el --- expand-file-name for URLs
+;; Author: $Author: wmperry $
+;; Created: $Date: 1999/12/05 08:09:15 $
+;; Version: $Revision: 1.3 $
+;; Keywords: comm, data, processes
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1999 Free Software Foundation, Inc.
+;;;
+;;; 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.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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)