code.delx.au - gnu-emacs/blob - lisp/url/url-expand.el

   1 ;;; url-expand.el --- expand-file-name for URLs
   2
   3 ;; Copyright (C) 1999, 2004-2016 Free Software Foundation, Inc.
   4
   5 ;; Keywords: comm, data, processes
   6
   7 ;; This file is part of GNU Emacs.
   8
   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 3 of the License, or
  12 ;; (at your option) any later version.
  13
  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.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Code:
  23
  24 (require 'url-methods)
  25 (require 'url-util)
  26 (require 'url-parse)
  27
  28 (defun url-expander-remove-relative-links (name)
  29   (if (equal name "")
  30       ;; An empty name is a properly valid relative URL reference/path.
  31       ""
  32     ;; Strip . and .. from pathnames
  33     (let ((new (if (not (string-match "^/" name))
  34                    (concat "/" name)
  35                  name)))
  36
  37       ;; If it ends with a '/.' or '/..', tack on a trailing '/' sot hat
  38       ;; the tests that follow are not too complicated in terms of
  39       ;; looking for '..' or '../', etc.
  40       (if (string-match "/\\.+$" new)
  41           (setq new (concat new "/")))
  42
  43       ;; Remove '/./' first
  44       (while (string-match "/\\(\\./\\)" new)
  45         (setq new (concat (substring new 0 (match-beginning 1))
  46                           (substring new (match-end 1)))))
  47
  48       ;; Then remove '/../'
  49       (while (string-match "/\\([^/]*/\\.\\./\\)" new)
  50         (setq new (concat (substring new 0 (match-beginning 1))
  51                           (substring new (match-end 1)))))
  52
  53       ;; Remove cruft at the beginning of the string, so people that put
  54       ;; in extraneous '..' because they are morons won't lose.
  55       (while (string-match "^/\\.\\.\\(/\\)" new)
  56         (setq new (substring new (match-beginning 1) nil)))
  57       new)))
  58
  59 (defun url-expand-file-name (url &optional default)
  60   "Convert URL to a fully specified URL, and canonicalize it.
  61 Second arg DEFAULT is a URL to start with if URL is relative.
  62 If DEFAULT is nil or missing, the current buffer's URL is used.
  63 Path components that are `.' are removed, and
  64 path components followed by `..' are removed, along with the `..' itself."
  65   (if (and url (not (string-match "^#" url)))
  66       ;; Need to nuke newlines and spaces in the URL, or we open
  67       ;; ourselves up to potential security holes.
  68       (setq url (mapconcat (function (lambda (x)
  69                                        (if (memq x '(?  ?\n ?\r))
  70                                            ""
  71                                          (char-to-string x))))
  72                            url "")))
  73
  74   ;; Need to figure out how/where to expand the fragment relative to
  75   (setq default (cond
  76                  ((vectorp default)
  77                   ;; Default URL has already been parsed
  78                   default)
  79                  (default
  80                    ;; They gave us a default URL in non-parsed format
  81                    (url-generic-parse-url default))
  82                  (url-current-object
  83                   ;; We are in a URL-based buffer, use the pre-parsed object
  84                   url-current-object)
  85                  ((string-match url-nonrelative-link url)
  86                   ;; The URL they gave us is absolute, go for it.
  87                   nil)
  88                  (t
  89                   ;; Hmmm - this shouldn't ever happen.
  90                   (error "url-expand-file-name confused - no default?"))))
  91
  92   (cond
  93    ((= (length url) 0)                  ; nil or empty string
  94     (url-recreate-url default))
  95    ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately
  96     url)
  97    (t
  98     (let* ((urlobj (url-generic-parse-url url))
  99            (inhibit-file-name-handlers t)
 100            (expander (url-scheme-get-property (url-type default) 'expand-file-name)))
 101       (if (string-match "^//" url)
 102           (setq urlobj (url-generic-parse-url (concat (url-type default) ":"
 103                                                       url))))
 104       (funcall expander urlobj default)
 105       (url-recreate-url urlobj)))))
 106
 107 (defun url-identity-expander (urlobj defobj)
 108   (setf (url-type urlobj) (or (url-type urlobj) (url-type defobj))))
 109
 110 (defun url-default-expander (urlobj defobj)
 111   ;; The default expansion routine - urlobj is modified by side effect!
 112   (if (url-type urlobj)
 113       ;; Well, they told us the scheme, let's just go with it.
 114       nil
 115     (setf (url-type urlobj) (or (url-type urlobj) (url-type defobj)))
 116     (setf (url-port urlobj) (or (url-portspec urlobj)
 117                                 (and (string= (url-type urlobj)
 118                                               (url-type defobj))
 119                                      (url-port defobj))))
 120     (if (not (string= "file" (url-type urlobj)))
 121         (setf (url-host urlobj) (or (url-host urlobj) (url-host defobj))))
 122     (if (string= "ftp"  (url-type urlobj))
 123         (setf (url-user urlobj) (or (url-user urlobj) (url-user defobj))))
 124     ;; If the object we're expanding from is full, then we are now
 125     ;; full.
 126     (unless (url-fullness urlobj)
 127       (setf (url-fullness urlobj) (url-fullness defobj)))
 128     (let* ((pathandquery (url-path-and-query urlobj))
 129            (defpathandquery (url-path-and-query defobj))
 130            (file (car pathandquery))
 131            (query (or (cdr pathandquery) (and (equal file "") (cdr defpathandquery)))))
 132       (if (string-match "^/" (url-filename urlobj))
 133           (setq file (url-expander-remove-relative-links file))
 134         ;; We use concat rather than expand-file-name to combine
 135         ;; directory and file name, since urls do not follow the same
 136         ;; rules as local files on all platforms.
 137         (setq file (url-expander-remove-relative-links
 138                     (if (equal file "")
 139                         (or (car (url-path-and-query defobj)) "")
 140                       (concat (url-file-directory (url-filename defobj)) file)))))
 141       (setf (url-filename urlobj) (if query (concat file "?" query) file)))))
 142
 143 (provide 'url-expand)
 144
 145 ;;; url-expand.el ends here