Mercurial > emacs

comparison lisp/url/url-about.el @ 54791:04bb18c57fc6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
(url-scheme-registry): Defvar. (url-about): Use text/plain.
author Stefan Monnier <monnier@iro.umontreal.ca>
date Mon, 12 Apr 2004 04:01:43 +0000
parents e8824c4f5f7e
children a8fa7c632ee4 eb7e8d483840
comparison
equal deleted inserted replaced
54790:12b895a7fee2 54791:04bb18c57fc6
1 ;;; url-about.el --- Show internal URLs 1 ;;; url-about.el --- Show internal URLs
2
3 ;; Copyright (c) 2001, 2004 Free Software Foundation, Inc.
4
2 ;; Keywords: comm, data, processes, hypermedia 5 ;; Keywords: comm, data, processes, hypermedia
3 6
4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 7 ;; This file is part of GNU Emacs.
5 ;;; Copyright (c) 2001 Free Software Foundation, Inc. 8 ;;
6 ;;; 9 ;; GNU Emacs is free software; you can redistribute it and/or modify
7 ;;; This file is part of GNU Emacs. 10 ;; it under the terms of the GNU General Public License as published by
8 ;;; 11 ;; the Free Software Foundation; either version 2, or (at your option)
9 ;;; GNU Emacs is free software; you can redistribute it and/or modify 12 ;; any later version.
10 ;;; it under the terms of the GNU General Public License as published by 13 ;;
11 ;;; the Free Software Foundation; either version 2, or (at your option) 14 ;; GNU Emacs is distributed in the hope that it will be useful,
12 ;;; any later version. 15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; 16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU Emacs is distributed in the hope that it will be useful, 17 ;; GNU General Public License for more details.
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;;
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 ;; You should have received a copy of the GNU General Public License
17 ;;; GNU General Public License for more details. 20 ;; along with GNU Emacs; see the file COPYING. If not, write to the
18 ;;; 21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; You should have received a copy of the GNU General Public License 22 ;; Boston, MA 02111-1307, USA.
20 ;;; along with GNU Emacs; see the file COPYING. If not, write to the 23
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 24 ;;; Commentary:
22 ;;; Boston, MA 02111-1307, USA. 25
23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 26 ;;; Code:
27
24 (eval-when-compile 28 (eval-when-compile
25 (require 'cl)) 29 (require 'cl))
26 (require 'url-util) 30 (require 'url-util)
27 (require 'url-parse) 31 (require 'url-parse)
28 32
29 (defun url-probe-protocols () 33 (defun url-probe-protocols ()
30 "Returns a list of all potential URL schemes." 34 "Return a list of all potential URL schemes."
31 (or (get 'url-extension-protocols 'probed) 35 (or (get 'url-extension-protocols 'probed)
32 (mapc (lambda (s) (url-scheme-get-property s 'name)) 36 (mapc (lambda (s) (url-scheme-get-property s 'name))
33 (or (get 'url-extension-protocols 'schemes) 37 (or (get 'url-extension-protocols 'schemes)
34 (let ((schemes '("info" "man" "rlogin" "telnet" 38 (let ((schemes '("info" "man" "rlogin" "telnet"
35 "tn3270" "data" "snews"))) 39 "tn3270" "data" "snews")))
39 (push (match-string 1 f) schemes))) 43 (push (match-string 1 f) schemes)))
40 (directory-files d nil "^url-.*\\.el$"))) 44 (directory-files d nil "^url-.*\\.el$")))
41 load-path) 45 load-path)
42 (put 'url-extension-protocols 'schemes schemes) 46 (put 'url-extension-protocols 'schemes schemes)
43 schemes))))) 47 schemes)))))
48
49 (defvar url-scheme-registry)
44 50
45 (defun url-about-protocols (url) 51 (defun url-about-protocols (url)
46 (url-probe-protocols) 52 (url-probe-protocols)
47 (insert "<html>\n" 53 (insert "<html>\n"
48 " <head>\n" 54 " <head>\n"
87 (let* ((item (downcase (url-filename url))) 93 (let* ((item (downcase (url-filename url)))
88 (func (intern (format "url-about-%s" item)))) 94 (func (intern (format "url-about-%s" item))))
89 (if (fboundp func) 95 (if (fboundp func)
90 (progn 96 (progn
91 (set-buffer (generate-new-buffer " *about-data*")) 97 (set-buffer (generate-new-buffer " *about-data*"))
92 (insert "Content-type: text/html\n\n") 98 (insert "Content-type: text/plain\n\n")
93 (funcall func url) 99 (funcall func url)
94 (current-buffer)) 100 (current-buffer))
95 (error "URL does not know about `%s'" item)))) 101 (error "URL does not know about `%s'" item))))
96 102
97 (provide 'url-about) 103 (provide 'url-about)
98 104
99 ;;; arch-tag: 65dd7fca-db3f-4cb1-8026-7dd37d4a460e 105 ;; arch-tag: 65dd7fca-db3f-4cb1-8026-7dd37d4a460e
106 ;;; url-about.el ends here