lisp/url/url-expand.el

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