view lisp/url/url-expand.el @ 62149:e64f1e2ecec2

(easy-mmode-pretty-mode-name): Explain more about the LIGHTER arg's usage in the doc string. Add commentary to clarify what the code does. Fix the regexp that strips whitespace from LIGHTER. Quote LIGHTER before using it, since it could have characters special to regular expressions.

;;; 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