url-parse.el 7.05 KB
Newer Older
Stefan Monnier's avatar
Stefan Monnier committed
1
;;; url-parse.el --- Uniform Resource Locator parser
Stefan Monnier's avatar
Stefan Monnier committed
2

3
;; Copyright (C) 1996, 1997, 1998, 1999, 2004,
Glenn Morris's avatar
Glenn Morris committed
4
;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
Stefan Monnier's avatar
Stefan Monnier committed
5

Stefan Monnier's avatar
Stefan Monnier committed
6 7
;; Keywords: comm, data, processes

Stefan Monnier's avatar
Stefan Monnier committed
8 9
;; This file is part of GNU Emacs.
;;
10
;; GNU Emacs is free software: you can redistribute it and/or modify
Stefan Monnier's avatar
Stefan Monnier committed
11
;; it under the terms of the GNU General Public License as published by
12 13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

Stefan Monnier's avatar
Stefan Monnier committed
15 16 17 18
;; 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.
19

Stefan Monnier's avatar
Stefan Monnier committed
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/>.
Stefan Monnier's avatar
Stefan Monnier committed
22 23 24 25 26

;;; Commentary:

;;; Code:

Stefan Monnier's avatar
Stefan Monnier committed
27
(require 'url-vars)
28
(require 'auth-source)
29
(eval-when-compile (require 'cl))
Stefan Monnier's avatar
Stefan Monnier committed
30 31 32

(autoload 'url-scheme-get-property "url-methods")

33 34 35 36 37 38
(defstruct (url
            (:constructor nil)
            (:constructor url-parse-make-urlobj
                          (&optional type user password host portspec filename
                                     target attributes fullness))
            (:copier nil))
39
  type user password host portspec filename target attributes fullness silent)
Stefan Monnier's avatar
Stefan Monnier committed
40

41 42 43 44
(defsubst url-port (urlobj)
  (or (url-portspec urlobj)
      (if (url-fullness urlobj)
          (url-scheme-get-property (url-type urlobj) 'default-port))))
Stefan Monnier's avatar
Stefan Monnier committed
45

46
(defsetf url-port (urlobj) (port) `(setf (url-portspec ,urlobj) ,port))
47

Stefan Monnier's avatar
Stefan Monnier committed
48 49
;;;###autoload
(defun url-recreate-url (urlobj)
Stefan Monnier's avatar
Stefan Monnier committed
50
  "Recreate a URL string from the parsed URLOBJ."
Stefan Monnier's avatar
Stefan Monnier committed
51 52 53 54 55 56 57 58 59 60 61
  (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
	  (if (url-user urlobj)
	      (concat (url-user urlobj)
		      (if (url-password urlobj)
			  (concat ":" (url-password urlobj)))
		      "@"))
	  (url-host urlobj)
	  (if (and (url-port urlobj)
		   (not (equal (url-port urlobj)
			       (url-scheme-get-property (url-type urlobj) 'default-port))))
	      (format ":%d" (url-port urlobj)))
62 63
	  (or (url-filename urlobj) "/")          
	  (url-recreate-url-attributes urlobj)
Stefan Monnier's avatar
Stefan Monnier committed
64
	  (if (url-target urlobj)
65 66 67 68 69
	      (concat "#" (url-target urlobj)))))

(defun url-recreate-url-attributes (urlobj)
  "Recreate the attributes of an URL string from the parsed URLOBJ."
  (when (url-attributes urlobj)
70
    (concat ";"
71 72 73 74 75
	    (mapconcat (lambda (x)
                         (if (cdr x)
                             (concat (car x) "=" (cdr x))
                           (car x)))
                       (url-attributes urlobj) ";"))))
Stefan Monnier's avatar
Stefan Monnier committed
76 77 78

;;;###autoload
(defun url-generic-parse-url (url)
79 80 81
  "Return an URL-struct of the parts of URL.
The CL-style struct contains the following fields:
TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS."
82
  ;; See RFC 3986.
Stefan Monnier's avatar
Stefan Monnier committed
83 84
  (cond
   ((null url)
85
    (url-parse-make-urlobj))
Stefan Monnier's avatar
Stefan Monnier committed
86 87
   ((or (not (string-match url-nonrelative-link url))
	(= ?/ (string-to-char url)))
88 89 90 91
    ;; This isn't correct, as a relative URL can be a fragment link
    ;; (e.g. "#foo") and many other things (see section 4.2).
    ;; However, let's not fix something that isn't broken, especially
    ;; when close to a release.
92
    (url-parse-make-urlobj nil nil nil nil nil url))
Stefan Monnier's avatar
Stefan Monnier committed
93
   (t
94
    (with-temp-buffer
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
      ;; Don't let those temp-buffer modifications accidentally
      ;; deactivate the mark of the current-buffer.
      (let ((deactivate-mark nil))
        (set-syntax-table url-parse-syntax-table)
        (let ((save-pos nil)
              (prot nil)
              (user nil)
              (pass nil)
              (host nil)
              (port nil)
              (file nil)
              (refs nil)
              (attr nil)
              (full nil)
              (inhibit-read-only t))
          (erase-buffer)
          (insert url)
          (goto-char (point-min))
          (setq save-pos (point))

          ;; 3.1. Scheme
          (unless (looking-at "//")
            (skip-chars-forward "a-zA-Z+.\\-")
            (downcase-region save-pos (point))
            (setq prot (buffer-substring save-pos (point)))
            (skip-chars-forward ":")
            (setq save-pos (point)))

          ;; 3.2. Authority
          (when (looking-at "//")
            (setq full t)
            (forward-char 2)
            (setq save-pos (point))
            (skip-chars-forward "^/")
            (setq host (buffer-substring save-pos (point)))
            (if (string-match "^\\([^@]+\\)@" host)
                (setq user (match-string 1 host)
                      host (substring host (match-end 0) nil)))
            (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
                (setq pass (match-string 2 user)
                      user (match-string 1 user)))
            ;; This gives wrong results for IPv6 literal addresses.
            (if (string-match ":\\([0-9+]+\\)" host)
                (setq port (string-to-number (match-string 1 host))
                      host (substring host 0 (match-beginning 0))))
            (if (string-match ":$" host)
                (setq host (substring host 0 (match-beginning 0))))
            (setq host (downcase host)
                  save-pos (point)))

          (if (not port)
              (setq port (url-scheme-get-property prot 'default-port)))

          ;; 3.3. Path
          ;; Gross hack to preserve ';' in data URLs
          (setq save-pos (point))

          ;; 3.4. Query
          (if (string= "data" prot)
              (goto-char (point-max))
            ;; Now check for references
            (skip-chars-forward "^#")
            (if (eobp)
                nil
              (delete-region
               (point)
               (progn
                 (skip-chars-forward "#")
                 (setq refs (buffer-substring (point) (point-max)))
                 (point-max))))
            (goto-char save-pos)
            (skip-chars-forward "^;")
            (unless (eobp)
              (setq attr (url-parse-args (buffer-substring (point) (point-max))
                                         t)
170
		    attr (nreverse attr))))
Stefan Monnier's avatar
Stefan Monnier committed
171

172 173 174 175 176
          (setq file (buffer-substring save-pos (point)))
          (if (and host (string-match "%[0-9][0-9]" host))
              (setq host (url-unhex-string host)))
          (url-parse-make-urlobj
           prot user pass host port file refs attr full)))))))
Stefan Monnier's avatar
Stefan Monnier committed
177

178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196
(defmacro url-bit-for-url (method lookfor url)
  `(let* ((urlobj (url-generic-parse-url url))
          (bit (funcall ,method urlobj))
          (methods (list 'url-recreate-url
                         'url-host)))
     (while (and (not bit) (> (length methods) 0))
       (setq bit
             (auth-source-user-or-password
              ,lookfor (funcall (pop methods) urlobj) (url-type urlobj))))
     bit))

(defun url-user-for-url (url)
  "Attempt to use .authinfo to find a user for this URL."
  (url-bit-for-url 'url-user "login" url))

(defun url-password-for-url (url)
  "Attempt to use .authinfo to find a password for this URL."
  (url-bit-for-url 'url-password "password" url))

Stefan Monnier's avatar
Stefan Monnier committed
197
(provide 'url-parse)
Miles Bader's avatar
Miles Bader committed
198

Stefan Monnier's avatar
Stefan Monnier committed
199 200
;; arch-tag: f338325f-71ab-4bee-93cc-78fb9a03d403
;;; url-parse.el ends here