lisp/url/url-parse.el

   1 ;;; url-parse.el --- Uniform Resource Locator parser
   2
   3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
   4 ;;   2005, 2006, 2007 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, or (at your option)
  13 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'url-vars)
  30
  31 (autoload 'url-scheme-get-property "url-methods")
  32
  33 (defun url-type (urlobj)
  34   (aref urlobj 0))
  35
  36 (defun url-user (urlobj)
  37   (aref urlobj 1))
  38
  39 (defun url-password (urlobj)
  40   (aref urlobj 2))
  41
  42 (defun url-host (urlobj)
  43   (aref urlobj 3))
  44
  45 (defun url-port (urlobj)
  46   (or (aref urlobj 4)
  47       (if (url-fullness urlobj)
  48           (url-scheme-get-property (url-type urlobj) 'default-port))))
  49
  50 (defun url-filename (urlobj)
  51   (aref urlobj 5))
  52
  53 (defun url-target (urlobj)
  54   (aref urlobj 6))
  55
  56 (defun url-attributes (urlobj)
  57   (aref urlobj 7))
  58
  59 (defun url-fullness (urlobj)
  60   (aref urlobj 8))
  61
  62 (defun url-set-type (urlobj type)
  63   (aset urlobj 0 type))
  64
  65 (defun url-set-user (urlobj user)
  66   (aset urlobj 1 user))
  67
  68 (defun url-set-password (urlobj pass)
  69   (aset urlobj 2 pass))
  70
  71 (defun url-set-host (urlobj host)
  72   (aset urlobj 3 host))
  73
  74 (defun url-set-port (urlobj port)
  75   (aset urlobj 4 port))
  76
  77 (defun url-set-filename (urlobj file)
  78   (aset urlobj 5 file))
  79
  80 (defun url-set-target (urlobj targ)
  81   (aset urlobj 6 targ))
  82
  83 (defun url-set-attributes (urlobj targ)
  84   (aset urlobj 7 targ))
  85
  86 (defun url-set-full (urlobj val)
  87   (aset urlobj 8 val))
  88
  89 ;;;###autoload
  90 (defun url-recreate-url (urlobj)
  91   "Recreate a URL string from the parsed URLOBJ."
  92   (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
  93           (if (url-user urlobj)
  94               (concat (url-user urlobj)
  95                       (if (url-password urlobj)
  96                           (concat ":" (url-password urlobj)))
  97                       "@"))
  98           (url-host urlobj)
  99           (if (and (url-port urlobj)
 100                    (not (equal (url-port urlobj)
 101                                (url-scheme-get-property (url-type urlobj) 'default-port))))
 102               (format ":%d" (url-port urlobj)))
 103           (or (url-filename urlobj) "/")
 104           (url-recreate-url-attributes urlobj)
 105           (if (url-target urlobj)
 106               (concat "#" (url-target urlobj)))))
 107
 108 (defun url-recreate-url-attributes (urlobj)
 109   "Recreate the attributes of an URL string from the parsed URLOBJ."
 110   (when (url-attributes urlobj)
 111     (concat ";"
 112             (mapconcat (lambda (x)
 113                          (if (cdr x)
 114                              (concat (car x) "=" (cdr x))
 115                            (car x)))
 116                        (url-attributes urlobj) ";"))))
 117
 118 ;;;###autoload
 119 (defun url-generic-parse-url (url)
 120   "Return a vector of the parts of URL.
 121 Format is:
 122 \[TYPE USER PASSWORD HOST PORT FILE TARGET ATTRIBUTES FULL\]"
 123   ;; See RFC 3986.
 124   (cond
 125    ((null url)
 126     (make-vector 9 nil))
 127    ((or (not (string-match url-nonrelative-link url))
 128         (= ?/ (string-to-char url)))
 129     ;; This isn't correct, as a relative URL can be a fragment link
 130     ;; (e.g. "#foo") and many other things (see section 4.2).
 131     ;; However, let's not fix something that isn't broken, especially
 132     ;; when close to a release.
 133     (let ((retval (make-vector 9 nil)))
 134       (url-set-filename retval url)
 135       (url-set-full retval nil)
 136       retval))
 137    (t
 138     (with-temp-buffer
 139       (set-syntax-table url-parse-syntax-table)
 140       (let ((save-pos nil)
 141             (prot nil)
 142             (user nil)
 143             (pass nil)
 144             (host nil)
 145             (port nil)
 146             (file nil)
 147             (refs nil)
 148             (attr nil)
 149             (full nil)
 150             (inhibit-read-only t))
 151         (erase-buffer)
 152         (insert url)
 153         (goto-char (point-min))
 154         (setq save-pos (point))
 155
 156         ;; 3.1. Scheme
 157         (if (not (looking-at "//"))
 158             (progn
 159               (skip-chars-forward "a-zA-Z+.\\-")
 160               (downcase-region save-pos (point))
 161               (setq prot (buffer-substring save-pos (point)))
 162               (skip-chars-forward ":")
 163               (setq save-pos (point))))
 164
 165         ;; 3.2. Authority
 166         (if (looking-at "//")
 167             (progn
 168               (setq full t)
 169               (forward-char 2)
 170               (setq save-pos (point))
 171               (skip-chars-forward "^/")
 172               (setq host (buffer-substring save-pos (point)))
 173               (if (string-match "^\\([^@]+\\)@" host)
 174                   (setq user (match-string 1 host)
 175                         host (substring host (match-end 0) nil)))
 176               (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
 177                   (setq pass (match-string 2 user)
 178                         user (match-string 1 user)))
 179               ;; This gives wrong results for IPv6 literal addresses.
 180               (if (string-match ":\\([0-9+]+\\)" host)
 181                   (setq port (string-to-number (match-string 1 host))
 182                         host (substring host 0 (match-beginning 0))))
 183               (if (string-match ":$" host)
 184                   (setq host (substring host 0 (match-beginning 0))))
 185               (setq host (downcase host)
 186                     save-pos (point))))
 187
 188         (if (not port)
 189             (setq port (url-scheme-get-property prot 'default-port)))
 190
 191         ;; 3.3. Path
 192         ;; Gross hack to preserve ';' in data URLs
 193         (setq save-pos (point))
 194
 195         ;; 3.4. Query
 196         (if (string= "data" prot)
 197             (goto-char (point-max))
 198           ;; Now check for references
 199           (skip-chars-forward "^#")
 200           (if (eobp)
 201               nil
 202             (delete-region
 203              (point)
 204              (progn
 205                (skip-chars-forward "#")
 206                (setq refs (buffer-substring (point) (point-max)))
 207                (point-max))))
 208           (goto-char save-pos)
 209           (skip-chars-forward "^;")
 210           (if (not (eobp))
 211               (setq attr (url-parse-args (buffer-substring (point) (point-max)) t)
 212                     attr (nreverse attr))))
 213
 214         (setq file (buffer-substring save-pos (point)))
 215         (if (and host (string-match "%[0-9][0-9]" host))
 216             (setq host (url-unhex-string host)))
 217         (vector prot user pass host port file refs attr full))))))
 218
 219 (provide 'url-parse)
 220
 221 ;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
 222 ;;; url-parse.el ends here