Mercurial > hg > xemacs-beta

comparison lisp/w3/url-wais.el @ 80:1ce6082ce73f r20-0b90

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b90
author cvs
date Mon, 13 Aug 2007 09:06:37 +0200
parents 9ee227acff29
children 0293115a14e9
comparison
equal deleted inserted replaced
79:5b0a5bbffab6 80:1ce6082ce73f
1 ;;; url-wais.el --- WAIS Uniform Resource Locator retrieval code
2 ;; Author: wmperry
3 ;; Created: 1996/10/09 19:00:59
4 ;; Version: 1.3
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993-1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is not part of GNU Emacs, but the same permissions apply.
12 ;;;
13 ;;; GNU Emacs is free software; you can redistribute it and/or modify
14 ;;; it under the terms of the GNU General Public License as published by
15 ;;; the Free Software Foundation; either version 2, or (at your option)
16 ;;; any later version.
17 ;;;
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;;; GNU General Public License for more details.
22 ;;;
23 ;;; You should have received a copy of the GNU General Public License
24 ;;; along with GNU Emacs; see the file COPYING. If not, write to the
25 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;;; Boston, MA 02111-1307, USA.
27 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
28
29 (require 'url-vars)
30 (require 'url-parse)
31
32
33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
34 ;;; WAIS support
35 ;;; ------------
36 ;;; Here are even more gross hacks that I call native WAIS support.
37 ;;; This code requires a working waisq program that is fully
38 ;;; compatible with waisq from think.com
39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
40 (defun url-create-wais-source (server port dbase)
41 ;; Create a temporary wais source description file. Returns the
42 ;; file name the description is in.
43 (let ((x (url-generate-unique-filename))
44 (y (get-buffer-create " *waisq-tmp*")))
45 (save-excursion
46 (set-buffer y)
47 (erase-buffer)
48 (insert
49 (format
50 (concat "(:source\n:version 3\n"
51 ":ip-name \"%s\"\n:tcp-port %s\n"
52 ":database-name \"%s\"\n)")
53 server (if (equal port "") "210" port) dbase))
54 (write-region (point-min) (point-max) x nil nil)
55 (kill-buffer y))
56 x))
57
58 (defun url-wais-stringtoany (str)
59 ;; Return a wais subelement that specifies STR in any database
60 (concat "(:any :size " (length str) " :bytes #( "
61 (mapconcat 'identity str " ")
62 " ) )"))
63
64 ;(defun url-retrieve-wais-docid (server port dbase local-id)
65 ; (call-process "waisretrieve" nil url-working-buffer nil
66 ; (format "%s:%s@%s:%s" (url-unhex-string local-id)
67 ; dbase server port)))
68
69 ;(url-retrieve-wais-docid "quake.think.com" "210" "directory-of-servers"
70 ; "0 2608 /proj/wais/wais-sources/vpiej-l.src")
71 (defun url-retrieve-wais-docid (server port dbase local-id)
72 ;; Retrieve a wais document.
73 ;; SERVER is the server the database is on (:ip-name in source description)
74 ;; PORT is the port number to contact (:tcp-port in the source description)
75 ;; DBASE is the database name (:database-name in the source description)
76 ;; LOCAL-ID is the document (:original-local-id in the question description)
77 (let* ((dbf (url-create-wais-source server port dbase))
78 (qstr (format
79 (concat "(:question :version 2\n"
80 " :result-documents\n"
81 " ( (:document-id\n"
82 " :document\n"
83 " (:document\n"
84 " :headline \"\"\n"
85 " :doc-id\n"
86 " (:doc-id :original-database %s\n"
87 " :original-local-id %s )\n"
88 " :number-of-bytes -1\n"
89 " :type \"\"\n"
90 " :source\n"
91 " (:source-id :filename \"%s\") ) ) ) )")
92 (url-wais-stringtoany dbase)
93 (url-wais-stringtoany (url-unhex-string local-id))
94 dbf))
95 (qf (url-generate-unique-filename)))
96 (set-buffer (get-buffer-create url-working-buffer))
97 (insert qstr)
98 (write-region (point-min) (point-max) qf nil nil)
99 (erase-buffer)
100 (call-process url-waisq-prog nil url-working-buffer nil "-f" qf "-v" "1")
101 (save-excursion
102 (set-buffer url-working-buffer)
103 (setq url-current-file (url-unhex-string local-id)))
104 (condition-case ()
105 (delete-file dbf)
106 (error nil))
107 (condition-case ()
108 (delete-file qf)
109 (error nil))))
110
111 ;(url-perform-wais-query "quake.think.com" "210" "directory-of-servers" "SGML")
112 (defun url-perform-wais-query (server port dbase search)
113 ;; Perform a wais query.
114 ;; SERVER is the server the database is on (:ip-name in source description)
115 ;; PORT is the port number to contact (:tcp-port in the source description)
116 ;; DBASE is the database name (:database-name in the source description)
117 ;; SEARCH is the search term (:seed-words in the question description)"
118 (let ((dbfname (url-create-wais-source server port dbase))
119 (qfname (url-generate-unique-filename))
120 (results 'url-none-gotten))
121 (save-excursion
122 (url-clear-tmp-buffer)
123 (insert
124 (format
125 (concat "(:question\n"
126 " :version 2\n"
127 " :seed-words \"%s\"\n"
128 " :sourcepath \"" url-temporary-directory "\"\n"
129 " :sources\n"
130 " ( (:source-id\n"
131 " :filename \"%s\"\n"
132 " )\n"
133 " )\n"
134 " :maximum-results 100)\n")
135 search dbfname))
136 (write-region (point-min) (point-max) qfname nil nil)
137 (erase-buffer)
138 (call-process url-waisq-prog nil url-working-buffer nil "-g" "-f" qfname)
139 (set-buffer url-working-buffer)
140 (erase-buffer)
141 (setq url-current-server server
142 url-current-port port
143 url-current-file dbase)
144 (insert-file-contents-literally qfname)
145 (goto-char (point-min))
146 (if (re-search-forward "(:question" nil t)
147 (delete-region (point-min) (match-beginning 0)))
148 (url-replace-regexp "Process.*finished.*" "")
149 (subst-char-in-region (point-min) (point-max) 35 32)
150 (goto-char (point-min))
151 (message "Done reading info - parsing results...")
152 (if (re-search-forward ":result-documents[^(]+" nil t)
153 (progn
154 (goto-char (match-end 0))
155 (while (eq results 'url-none-gotten)
156 (condition-case ()
157 (setq results (read (current-buffer)))
158 (error (progn
159 (setq results 'url-none-gotten)
160 (goto-char (match-end 0))))))
161 (erase-buffer)
162 (insert "<title>Results of WAIS search</title>\n"
163 "<h1>Searched " dbase " for " search "</h1>\n"
164 "<hr>\n"
165 "Found <b>" (int-to-string (length results))
166 "</b> matches.\n"
167 "<ol>\n<li>"
168 (mapconcat 'url-parse-wais-doc-id results "\n<li>")
169 "\n</ol>\n<hr>\n"))
170 (message "No results"))
171 (setq url-current-mime-type "text/html")
172 (condition-case ()
173 (delete-file qfname)
174 (error nil))
175 (condition-case ()
176 (delete-file dbfname)
177 (error nil)))))
178
179 (defun url-wais-anytostring (x)
180 ;; Convert a (:any ....) wais construct back into a string.
181 (mapconcat 'char-to-string (car (cdr (memq ':bytes x))) ""))
182
183 (defun url-parse-wais-doc-id (x)
184 ;; Return a list item that points at the doc-id specified by X
185 (let* ((document (car (cdr (memq ':document x))))
186 (doc-id (car (cdr (memq ':doc-id document))))
187 (score (car (cdr (memq ':score x))))
188 (title (car (cdr (memq ':headline document))))
189 (type (car (cdr (memq ':type document))))
190 (size (car (cdr (memq ':number-of-bytes document))))
191 (server (car (cdr (memq ':original-server doc-id))))
192 (dbase (car (cdr (memq ':original-database doc-id))))
193 (localid (car (cdr (memq ':original-local-id doc-id))))
194 (dist-server (car (cdr (memq ':distributor-server doc-id))))
195 (dist-dbase (car (cdr (memq ':distributor-database doc-id))))
196 (dist-id (car (cdr (memq ':distributor-local-id doc-id))))
197 (copyright (or (car (cdr (memq ':copyright-disposition doc-id))) 0)))
198 (format "<a href=\"wais://%s:%s/%s/%s/%d/1=%s;2=%s;3=%s;4=%s;5=%s;6=%s;7=%d;\">%s (Score = %s)</a>"
199 url-current-server url-current-port url-current-file
200 type size
201 (url-hexify-string (url-wais-anytostring server))
202 (url-hexify-string (url-wais-anytostring dbase))
203 (url-hexify-string (url-wais-anytostring localid))
204 (url-hexify-string (url-wais-anytostring dist-server))
205 (url-hexify-string (url-wais-anytostring dist-dbase))
206 (url-hexify-string (url-wais-anytostring dist-id))
207 copyright title score)))
208
209 (defun url-grok-wais-href (url)
210 "Return a list of server, port, database, search-term, doc-id"
211 (if (string-match "wais:/+\\([^/:]+\\):*\\([^/]*\\)/+\\(.*\\)" url)
212 (let ((host (url-match url 1))
213 (port (url-match url 2))
214 (data (url-match url 3)))
215 (list host port data))
216 (make-list 3 nil)))
217
218 (defun url-wais (url)
219 ;; Retrieve a document via WAIS
220 (if (and url-wais-gateway-server url-wais-gateway-port)
221 (url-retrieve
222 (format "http://%s:%s/%s"
223 url-wais-gateway-server
224 url-wais-gateway-port
225 (substring url (match-end 0) nil)))
226 (let ((href (url-grok-wais-href url)))
227 (url-clear-tmp-buffer)
228 (setq url-current-type "wais"
229 url-current-server (nth 0 href)
230 url-current-port (nth 1 href)
231 url-current-file (nth 2 href))
232 (cond
233 ((string-match "2=\\(.*\\);3=\\([^ ;]+\\)" (nth 2 href)); full link
234 (url-retrieve-wais-docid (nth 0 href) (nth 1 href)
235 (url-match (nth 2 href) 1)
236 (url-match (nth 2 href) 2)))
237 ((string-match "\\([^\\?]+\\)\\?\\(.*\\)" (nth 2 href)) ; stored query
238 (url-perform-wais-query (nth 0 href) (nth 1 href)
239 (url-match (nth 2 href) 1)
240 (url-match (nth 2 href) 2)))
241 (t
242 (insert "<title>WAIS search</title>\n"
243 "<h1>WAIS search of " (nth 2 href) "</h1>"
244 "<hr>\n"
245 (format "<form action=\"%s\" enctype=\"application/x-w3-wais\">\n" url)
246 "Enter search term: <input name=\"internal-wais\">\n"
247 "</form>\n"
248 "<hr>\n"))))))
249
250 (provide 'url-wais)
251