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