Mercurial > hg > xemacs-beta

comparison lisp/url/url-wais.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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"
243 "<form>\n"
244 "Enter search term: <input name=\"internal-wais\">\n"
245 "</form>\n"
246 "<hr>\n"))))))
247
248 (provide 'url-wais)
249