cgit.sxemacs.org Git - packages/blob - xemacs-packages/w3/lisp/url-parse.el

   1 ;;; url-parse.el --- Uniform Resource Locator parser
   2
   3 ;; Copyright (C) 1996-1999, 2004-2012 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 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 (require 'url-vars)
  27 ; (require 'auth-source) ;; XEmacs; required at runtime in
  28 ;                        ;; #'URL-{user,password}-for-url.
  29 (eval-when-compile (require 'cl))
  30
  31 (autoload 'url-scheme-get-property "url-methods")
  32
  33 (defstruct (url
  34             (:constructor nil)
  35             (:constructor url-parse-make-urlobj
  36                           (&optional type user password host portspec filename
  37                                      target attributes fullness))
  38             (:copier nil))
  39   type user password host portspec filename target attributes fullness
  40   silent (use-cookies t))
  41
  42 (defsubst url-port (urlobj)
  43   (or (url-portspec urlobj)
  44       (if (url-fullness urlobj)
  45           (url-scheme-get-property (url-type urlobj) 'default-port))))
  46
  47 (defsetf url-port (urlobj) (port) `(setf (url-portspec ,urlobj) ,port))
  48
  49 ;;;###autoload
  50 (defun url-recreate-url (urlobj)
  51   "Recreate a URL string from the parsed URLOBJ."
  52   (concat (url-type urlobj) ":" (if (url-host urlobj) "//" "")
  53           (if (url-user urlobj)
  54               (concat (url-user urlobj)
  55                       (if (url-password urlobj)
  56                           (concat ":" (url-password urlobj)))
  57                       "@"))
  58           (url-host urlobj)
  59           (if (and (url-port urlobj)
  60                    (not (equal (url-port urlobj)
  61                                (url-scheme-get-property (url-type urlobj) 'default-port))))
  62               (format ":%d" (url-port urlobj)))
  63           (or (url-filename urlobj) "/")
  64           (url-recreate-url-attributes urlobj)
  65           (if (url-target urlobj)
  66               (concat "#" (url-target urlobj)))))
  67
  68 (defun url-recreate-url-attributes (urlobj)
  69   "Recreate the attributes of an URL string from the parsed URLOBJ."
  70   (when (url-attributes urlobj)
  71     (concat ";"
  72             (mapconcat (lambda (x)
  73                          (if (cdr x)
  74                              (concat (car x) "=" (cdr x))
  75                            (car x)))
  76                        (url-attributes urlobj) ";"))))
  77
  78 ;;;###autoload
  79 (defun url-generic-parse-url (url)
  80   "Return an URL-struct of the parts of URL.
  81 The CL-style struct contains the following fields:
  82 TYPE USER PASSWORD HOST PORTSPEC FILENAME TARGET ATTRIBUTES FULLNESS."
  83   ;; See RFC 3986.
  84   (cond
  85    ((null url)
  86     (url-parse-make-urlobj))
  87    ((or (not (string-match url-nonrelative-link url))
  88         (= ?/ (string-to-char url)))
  89     ;; This isn't correct, as a relative URL can be a fragment link
  90     ;; (e.g. "#foo") and many other things (see section 4.2).
  91     ;; However, let's not fix something that isn't broken, especially
  92     ;; when close to a release.
  93     (url-parse-make-urlobj nil nil nil nil nil url))
  94    (t
  95     (with-temp-buffer
  96       ;; Don't let those temp-buffer modifications accidentally
  97       ;; deactivate the mark of the current-buffer.
  98       (let ((deactivate-mark nil))
  99         (set-syntax-table url-parse-syntax-table)
 100         (let ((save-pos nil)
 101               (prot nil)
 102               (user nil)
 103               (pass nil)
 104               (host nil)
 105               (port nil)
 106               (file nil)
 107               (refs nil)
 108               (attr nil)
 109               (full nil)
 110               (inhibit-read-only t))
 111           (erase-buffer)
 112           (insert url)
 113           (goto-char (point-min))
 114           (setq save-pos (point))
 115
 116           ;; 3.1. Scheme
 117           (unless (looking-at "//")
 118             (skip-chars-forward "a-zA-Z+.\\-")
 119             (downcase-region save-pos (point))
 120             (setq prot (buffer-substring save-pos (point)))
 121             (skip-chars-forward ":")
 122             (setq save-pos (point)))
 123
 124           ;; 3.2. Authority
 125           (when (looking-at "//")
 126             (setq full t)
 127             (forward-char 2)
 128             (setq save-pos (point))
 129             (skip-chars-forward "^/")
 130             (setq host (buffer-substring save-pos (point)))
 131             (if (string-match "^\\([^@]+\\)@" host)
 132                 (setq user (match-string 1 host)
 133                       host (substring host (match-end 0) nil)))
 134             (if (and user (string-match "\\([^:]+\\):\\(.*\\)" user))
 135                 (setq pass (match-string 2 user)
 136                       user (match-string 1 user)))
 137             ;; This gives wrong results for IPv6 literal addresses.
 138             (if (string-match ":\\([0-9+]+\\)" host)
 139                 (setq port (string-to-number (match-string 1 host))
 140                       host (substring host 0 (match-beginning 0))))
 141             (if (string-match ":$" host)
 142                 (setq host (substring host 0 (match-beginning 0))))
 143             (setq host (downcase host)
 144                   save-pos (point)))
 145
 146           (if (not port)
 147               (setq port (url-scheme-get-property prot 'default-port)))
 148
 149           ;; 3.3. Path
 150           ;; Gross hack to preserve ';' in data URLs
 151           (setq save-pos (point))
 152
 153           ;; 3.4. Query
 154           (if (string= "data" prot)
 155               (goto-char (point-max))
 156             ;; Now check for references
 157             (skip-chars-forward "^#")
 158             (if (eobp)
 159                 nil
 160               (delete-region
 161                (point)
 162                (progn
 163                  (skip-chars-forward "#")
 164                  (setq refs (buffer-substring (point) (point-max)))
 165                  (point-max))))
 166             (goto-char save-pos)
 167             (skip-chars-forward "^;")
 168             (unless (eobp)
 169               (setq attr (url-parse-args (buffer-substring (point) (point-max))
 170                                          t)
 171                     attr (nreverse attr))))
 172
 173           (setq file (buffer-substring save-pos (point)))
 174           (if (and host (string-match "%[0-9][0-9]" host))
 175               (setq host (url-unhex-string host)))
 176           (url-parse-make-urlobj
 177            prot user pass host port file refs attr full)))))))
 178
 179 (defmacro url-bit-for-url (method lookfor url)
 180   `(let* ((urlobj (url-generic-parse-url url))
 181           (bit (funcall ,method urlobj))
 182           (methods (list 'url-recreate-url
 183                          'url-host))
 184           auth-info)
 185      ;; XEmacs; we don't yet include this in gnus, require
 186      (or (fboundp 'auth-source-search) (require 'auth-source))
 187      (while (and (not bit) (> (length methods) 0))
 188        (setq auth-info (auth-source-search
 189                         :max 1
 190                         :host (funcall (pop methods) urlobj)
 191                         :port (url-type urlobj)))
 192        (setq bit (plist-get (nth 0 auth-info) ,lookfor))
 193        (when (functionp bit)
 194          (setq bit (funcall bit))))
 195      bit))
 196
 197 (defun url-user-for-url (url)
 198   "Attempt to use .authinfo to find a user for this URL."
 199   (url-bit-for-url 'url-user :user url))
 200
 201 (defun url-password-for-url (url)
 202   "Attempt to use .authinfo to find a password for this URL."
 203   (url-bit-for-url 'url-password :secret url))
 204
 205 (provide 'url-parse)
 206
 207 ;;; url-parse.el ends here