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