| 1 | ;;; url-methods.el --- Load URL schemes as needed |
| 2 | |
| 3 | ;; Copyright (C) 1996-1999, 2004-2011 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Keywords: comm, data, processes, hypermedia |
| 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 | (eval-when-compile |
| 27 | (require 'cl)) |
| 28 | |
| 29 | ;; This loads up some of the small, silly URLs that I really don't |
| 30 | ;; want to bother putting in their own separate files. |
| 31 | (require 'url-parse) |
| 32 | |
| 33 | (defvar url-scheme-registry (make-hash-table :size 7 :test 'equal)) |
| 34 | |
| 35 | (defconst url-scheme-methods |
| 36 | '((default-port . variable) |
| 37 | (asynchronous-p . variable) |
| 38 | (expand-file-name . function) |
| 39 | (file-exists-p . function) |
| 40 | (file-attributes . function) |
| 41 | (parse-url . function) |
| 42 | (file-symlink-p . function) |
| 43 | (file-writable-p . function) |
| 44 | (file-directory-p . function) |
| 45 | (file-executable-p . function) |
| 46 | (directory-files . function) |
| 47 | (file-truename . function)) |
| 48 | "Assoc-list of methods that each URL loader can provide.") |
| 49 | |
| 50 | (defconst url-scheme-default-properties |
| 51 | (list 'name "unknown" |
| 52 | 'loader 'url-scheme-default-loader |
| 53 | 'default-port 0 |
| 54 | 'expand-file-name 'url-identity-expander |
| 55 | 'parse-url 'url-generic-parse-url |
| 56 | 'asynchronous-p nil |
| 57 | 'file-directory-p 'ignore |
| 58 | 'file-truename (lambda (&rest args) |
| 59 | (url-recreate-url (car args))) |
| 60 | 'file-exists-p 'ignore |
| 61 | 'file-attributes 'ignore)) |
| 62 | |
| 63 | (defun url-scheme-default-loader (url &optional callback cbargs) |
| 64 | "Signal an error for an unknown URL scheme." |
| 65 | (error "Unkown URL scheme: %s" (url-type url))) |
| 66 | |
| 67 | (defvar url-scheme--registering-proxy nil) |
| 68 | |
| 69 | (defun url-scheme-register-proxy (scheme) |
| 70 | "Automatically find a proxy for SCHEME and put it in `url-proxy-services'." |
| 71 | (let* ((env-var (concat scheme "_proxy")) |
| 72 | (env-proxy (or (getenv (upcase env-var)) |
| 73 | (getenv (downcase env-var)))) |
| 74 | (cur-proxy (assoc scheme url-proxy-services)) |
| 75 | (urlobj nil) |
| 76 | (url-scheme--registering-proxy t)) |
| 77 | |
| 78 | ;; If env-proxy is an empty string, treat it as if it were nil |
| 79 | (when (and (stringp env-proxy) |
| 80 | (string= env-proxy "")) |
| 81 | (setq env-proxy nil)) |
| 82 | |
| 83 | ;; Store any proxying information - this will not overwrite an old |
| 84 | ;; entry, so that people can still set this information in their |
| 85 | ;; .emacs file |
| 86 | (cond |
| 87 | (cur-proxy nil) ; Keep their old settings |
| 88 | ((null env-proxy) nil) ; No proxy setup |
| 89 | ;; First check if its something like hostname:port |
| 90 | ((string-match "^\\([^:]+\\):\\([0-9]+\\)$" env-proxy) |
| 91 | (setq urlobj (url-generic-parse-url nil)) ; Get a blank object |
| 92 | (setf (url-type urlobj) "http") |
| 93 | (setf (url-host urlobj) (match-string 1 env-proxy)) |
| 94 | (setf (url-port urlobj) (string-to-number (match-string 2 env-proxy)))) |
| 95 | ;; Then check if its a fully specified URL |
| 96 | ((string-match url-nonrelative-link env-proxy) |
| 97 | (setq urlobj (url-generic-parse-url env-proxy)) |
| 98 | (setf (url-type urlobj) "http") |
| 99 | (setf (url-target urlobj) nil)) |
| 100 | ;; Finally, fall back on the assumption that its just a hostname |
| 101 | (t |
| 102 | (setq urlobj (url-generic-parse-url nil)) ; Get a blank object |
| 103 | (setf (url-type urlobj) "http") |
| 104 | (setf (url-host urlobj) env-proxy))) |
| 105 | |
| 106 | (if (and (not cur-proxy) urlobj) |
| 107 | (progn |
| 108 | (setq url-proxy-services |
| 109 | (cons (cons scheme (format "%s:%d" (url-host urlobj) |
| 110 | (url-port urlobj))) |
| 111 | url-proxy-services)) |
| 112 | (message "Using a proxy for %s..." scheme))))) |
| 113 | |
| 114 | (defun url-scheme-get-property (scheme property) |
| 115 | "Get PROPERTY of a URL SCHEME. |
| 116 | Will automatically try to load a backend from url-SCHEME.el if |
| 117 | it has not already been loaded." |
| 118 | (setq scheme (downcase scheme)) |
| 119 | (let ((desc (gethash scheme url-scheme-registry))) |
| 120 | (if (not desc) |
| 121 | (let* ((stub (concat "url-" scheme)) |
| 122 | (loader (intern stub))) |
| 123 | (condition-case () |
| 124 | (require loader) |
| 125 | (error nil)) |
| 126 | (if (fboundp loader) |
| 127 | (progn |
| 128 | ;; Found the module to handle <scheme> URLs |
| 129 | (unless url-scheme--registering-proxy |
| 130 | (url-scheme-register-proxy scheme)) |
| 131 | (setq desc (list 'name scheme |
| 132 | 'loader loader)) |
| 133 | (dolist (cell url-scheme-methods) |
| 134 | (let ((symbol (intern-soft (format "%s-%s" stub (car cell)))) |
| 135 | (type (cdr cell))) |
| 136 | (if symbol |
| 137 | (case type |
| 138 | (function |
| 139 | ;; Store the symbol name of a function |
| 140 | (if (fboundp symbol) |
| 141 | (setq desc (plist-put desc (car cell) symbol)))) |
| 142 | (variable |
| 143 | ;; Store the VALUE of a variable |
| 144 | (if (boundp symbol) |
| 145 | (setq desc (plist-put desc (car cell) |
| 146 | (symbol-value symbol))))) |
| 147 | (otherwise |
| 148 | (error "Malformed url-scheme-methods entry: %S" |
| 149 | cell)))))) |
| 150 | (puthash scheme desc url-scheme-registry))))) |
| 151 | (or (plist-get desc property) |
| 152 | (plist-get url-scheme-default-properties property)))) |
| 153 | |
| 154 | (provide 'url-methods) |
| 155 | |
| 156 | ;;; url-methods.el ends here |