1 ;;; sxell.el --- Browse the Emacs Lisp List (SXEmacs version)
3 ;; Copyright (C) 2005 Steve Youngs
5 ;; Author: Steve Youngs <steve@sxemacs.org>
6 ;; Maintainer: Steve Youngs <steve@sxemacs.org>
7 ;; Created: Jul 4, 2005
9 ;; Download: ftp://ftp.youngs.au.com/pub/lisp/SXEmacs/sxell.el
11 ;; Redistribution and use in source and binary forms, with or without
12 ;; modification, are permitted provided that the following conditions
15 ;; 1. Redistributions of source code must retain the above copyright
16 ;; notice, this list of conditions and the following disclaimer.
18 ;; 2. Redistributions in binary form must reproduce the above copyright
19 ;; notice, this list of conditions and the following disclaimer in the
20 ;; documentation and/or other materials provided with the distribution.
22 ;; 3. Neither the name of the author nor the names of any contributors
23 ;; may be used to endorse or promote products derived from this
24 ;; software without specific prior written permission.
26 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
27 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
28 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
29 ;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
30 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
31 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
32 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
33 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
34 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
35 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
36 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
40 ;; The Emacs Lisp List is a list of links to a wide variety of
41 ;; emacs-lisp libraries around the globe. The list is maintained by
42 ;; Stephen Eglen and can be found at
43 ;; http://www.damtp.cam.ac.uk/user/sje30/emacs/ell.html. sxell.el
44 ;; allows you to view that list in a normal buffer inside SXEmacs
45 ;; (no, sxell.el does NOT work with XEmacs or GNU/Emacs).
47 ;; The data you see in the *sxell-packages* buffer originally comes
48 ;; from a .xml file from Stephen's site. This .xml is parsed and
49 ;; stored in a local PostgreSQL db. Most operations default to
50 ;; using the local PostgreSQL db. Remote operations are only done
51 ;; when explicitly requested.
53 ;; When checking for updates, to save on bandwidth, just the HTTP
54 ;; header of the .xml file is downloaded and a match against the
55 ;; "Etag" header is done. (this is also saved in the db). If the
56 ;; Etag hasn't changed, the .xml file isn't downloaded.
58 ;; Keeping a copy of the list in a local db allows for, amongst
59 ;; other things, "offline" operation and complex searching of the
62 ;; The idea for this comes from ell.el by Jean-Philippe Theberge et
67 (unless (featurep 'sxemacs)
68 (error "We're sorry, this library is for SXEmacs ONLY"))
72 (when (fboundp 'ffi-defun)
75 (unless (featurep '(and ffi postgresql))
76 (error 'unimplemented "FFI and/or PostgreSQL"))
79 "Browse the Emacs Lisp List."
83 (defcustom sxell-initialised-flag nil
84 "*When nil, initialise the PostgreSQL db and import the Ell.
86 This variable is set to non-nil and saved the first time you run
87 `sxell-packages', so in most cases you can leave this alone."
91 (defcustom sxell-remote-file
92 "http://www.damtp.cam.ac.uk/user/sje30/emacs/ell.xml"
93 "*URL to the Emacs Lisp List XML file."
97 (defcustom sxell-local-file (expand-file-name "ell.xml" (temp-directory))
98 "*Local version of the Emacs Lisp List XML file."
102 (defcustom sxell-download-directory
103 (file-name-as-directory (user-home-directory))
104 "*Directory for files downloaded from the *sxell-packages* buffer.
106 The default is $HOME."
107 :type '(directory :must-match t)
110 (defcustom sxell-use-font-lock t
111 "*If non-nil, we font-lock the ELL buffer."
115 (defcustom sxell-mode-hook nil
116 "*Hooks run after entering `sxell-mode'."
120 (defcustom sxell-download-hook nil
121 "*Hooks run after downloading a file from the *sxell-packages* buffer."
125 (defcustom sxell-fetch-remote-xml-hook nil
126 "*Hooks run after fetching the ELL xml file."
130 (defvar sxell-last-updated nil
131 "Date that the list was last updated.
133 Internal var, don't set it.")
135 (defvar sxell-current-etag nil
136 "ETag HTTP header of ell.xml.
138 Internal var, don't set it.")
140 (defun sxell-db-initialise ()
141 "Initialise the SXEll PostgreSQL database."
142 (let* ((initdb (pq-connectdb "dbname=template1"))
145 "SELECT * FROM pg_catalog.pg_database WHERE datname='ell';")))
146 (when (zerop (pq-ntuples ellres))
147 (pq-exec initdb "CREATE DATABASE ell;"))
149 (let* ((elldb (pq-connectdb "dbname=ell")))
151 (pq-exec elldb "CREATE TABLE ell (
152 filename text NOT NULL DEFAULT ''::text,
153 description text NOT NULL DEFAULT ''::text,
154 site text NOT NULL DEFAULT 'http://'::text,
155 contact text NOT NULL DEFAULT ''::text,
156 time_stamp date NOT NULL DEFAULT ('now'::text)::date,
157 note text NOT NULL DEFAULT ''::text,
158 installed_p bool NOT NULL DEFAULT false,
159 direct_link_p bool );"))
161 (pq-exec elldb "CREATE TABLE last_upd (
162 etag text NOT NULL DEFAULT ''::text,
163 last_date text NOT NULL DEFAULT ''::text );")
164 (pq-exec elldb "INSERT INTO last_upd VALUES (
165 'bogus-etag','Thu Jan 1 00:00:00 EST 1970' );"))
168 (defun sxell-get-pg-packages-list (&optional sql)
169 "Return a list of packages from the local PostgreSQL db.
171 Optional argument, SQL is the PostgreSQL SELECT statement to use. If
172 it is omitted, `SELECT * FROM ell ORDER by filename ;' is used."
173 (let* ((db (pq-connectdb "dbname=ell"))
174 (res (pq-exec db (or sql "SELECT * FROM ell ORDER by filename ;")))
175 (nrows (pq-ntuples res))
176 (nfields (pq-nfields res))
177 (upd-res (pq-exec db "SELECT last_date FROM last_upd ;"))
178 list-o-matic mega-list)
179 (loop for row from 0 to (1- nrows)
180 do (loop for field downfrom (1- nfields) to 0
181 do (push (pq-get-value res row field) list-o-matic))
182 do (push list-o-matic mega-list)
183 do (setq list-o-matic nil))
184 (setq sxell-last-updated (pq-get-value upd-res 0 0))
186 (nreverse mega-list)))
188 (defun sxell-fetch-ell-xml ()
189 (message "Fetching Emacs Lisp List. Please wait...")
190 (curl:download sxell-remote-file sxell-local-file)
191 (message "Fetching Emacs Lisp List. Done!")
192 (run-hooks 'sxell-fetch-remote-xml-hook))
194 (defun sxell-fetch-ell-etag ()
195 "Returns the \"ETag\" of ell.xml's HTTP header."
196 (let ((file (expand-file-name "ell.tag" (temp-directory)))
198 (curl:download sxell-remote-file file :header t :nobody t)
199 (setq etag (with-temp-buffer
200 (insert-file-contents-literally file)
201 (goto-char (point-min))
202 (re-search-forward "^ETag:\\s-\"\\(.*\\)\"" nil t)
207 (defun sxell-parse-ell-xml ()
208 "Parse the contents of the ELL site ell.xml file."
209 (let* ((xml (xml-parse-file sxell-local-file))
211 (entries (cadddr root)))
212 (setq sxell-last-updated (nth 2 (caddr root)))
213 (mapcar (lambda (entry)
214 (let ((attrs (cadr entry)))
216 (pq-escape-string (cdr (assoc 'filename attrs)))
217 (pq-escape-string (cdr (assoc 'description attrs)))
218 (pq-escape-string (cdr (assoc 'site attrs)))
219 (pq-escape-string (cdr (assoc 'contact attrs)))
220 (pq-escape-string (cdr (assoc 'timestamp attrs)))
221 (pq-escape-string (cdr (assoc 'note attrs))))))
224 (defun sxell-update-pg-from-xml ()
225 (let ((entries (sxell-parse-ell-xml))
226 (db (pq-connectdb "dbname=ell"))
227 (chk-entry-fmt (concat "SELECT * FROM ell WHERE "
228 "filename = '%s' AND ( description = '%s' OR "
229 "site = '%s' OR contact = '%s' OR "
230 "time_stamp = '%s' OR note = '%s' ) ;"))
231 (upd-fmt (concat "UPDATE ell "
232 "SET filename = '%s', description = '%s', "
233 "site = '%s', contact = '%s', time_stamp = '%s', "
235 "WHERE filename = '%1$s' AND ( description = '%2$s' "
236 "OR site = '%3$s' OR contact = '%4$s' OR "
237 "time_stamp = '%5$s' OR note = '%6$s' ) ;"))
240 ;; Check to see if we need to update or add an entry.
241 (setq existing (pq-exec db (apply #'format chk-entry-fmt (car entries))))
242 (if (zerop (pq-ntuples existing))
243 ;; This is a new entry
244 (pq-exec db (format "INSERT INTO ell VALUES (%s) ;"
245 (mapconcat #'(lambda (el)
248 ;; Existing entry, update it
249 (pq-exec db (apply #'format upd-fmt (car entries))))
250 (setq entries (cdr entries)))
251 ;; Update last updated date and etag
252 (pq-exec db (format "UPDATE last_upd SET last_date = '%s', etag = '%s' ;"
253 sxell-last-updated sxell-current-etag))
256 (defvar sxell-font-lock-keywords
257 '((" <\\(New\\)> " (1 font-lock-warning-face))
258 ("^Note: \\(.*$\\)" (1 font-lock-warning-face))
259 ("^\\(Note\\|Contact\\|Added\\):" (1 font-lock-keyword-face))
260 ("^\\*" . font-lock-warning-face)
261 ("^\\*?\\(\\w+.*\\(\\.el\\)?\\)\\s-\\(<\\|-\\)"
262 (1 font-lock-function-name-face)))
263 "Font lock keywords in sxell mode.")
265 (defun sxell-prepare-buffer ()
266 "Prepare to make the new *sxell-packages* buffer."
267 (switch-to-buffer (get-buffer-create "*sxell-packages*"))
269 (insert "==========================================")
270 (center-line)(insert "\n")
271 (insert "The Emacs Lisp List")(center-line)(insert "\n")
272 (insert "by Stephen Eglen: stephen@anc.ed.ac.uk")(center-line)(insert "\n")
273 (insert "==========================================")
274 (center-line)(insert "\n\n"))
276 (defun sxell-update-buffer (date)
277 "Update the counters at the top of the *sxell-packages* buffer.
278 DATE is the date when ELL was last updated."
279 (when sxell-last-updated
281 (insert (format "Last updated: %s" date))
285 (defun sxell-url-at-point ()
286 "Browse to a URL from the sxell buffer."
288 (when (extentp (extent-at (point)))
289 (browse-url (extent-string (extent-at (point))))))
291 (defun sxell-url-at-mouse (event)
292 "Browse to a URL at EVENT via the mouse from the sxell buffer."
294 (when (extentp (extent-at-event event))
295 (browse-url (extent-string (extent-at-event event)))))
297 (defun sxell-download-file-at-point ()
298 "Download the file from the URL in the sxell buffer."
300 (when (extentp (extent-at (point)))
301 (let* ((remote (extent-string (extent-at (point))))
302 (local (car (last (split-string-by-char remote ?/)))))
303 (if (string-match ".*\\.\\(el\\|t?gz\\|bz2\\)$" local)
304 (curl:download remote
305 (expand-file-name local sxell-download-directory))
306 (message "Nothing to download here :-(")))))
308 (defun sxell-download-file-at-mouse (event)
309 "Download the file from the URL in the sxell buffer."
311 (when (extentp (extent-at-event event))
312 (let* ((remote (extent-string (extent-at-event event)))
313 (local (car (last (split-string-by-char remote ?/)))))
314 (if (string-match ".*\\.\\(el\\|t?gz\\|bz2\\)$" local)
315 (curl:download remote
316 (expand-file-name local sxell-download-directory))
317 (message-or-box "Nothing to download here :-(")))))
319 (defun sxell-kill-buffer ()
322 (when (file-exists-p sxell-local-file)
323 (delete-file sxell-local-file)))
325 (defconst sxell-mode-map
326 (let* ((map (make-sparse-keymap 'sxell-mode-map)))
327 (define-key map [space] 'scroll-up)
328 (define-key map [delete] 'scroll-down)
329 (define-key map [q] 'bury-buffer)
330 (define-key map [Q] 'sxell-kill-buffer)
332 "A keymap for the sxell buffer.")
334 (defconst sxell-ext-map
335 (let* ((map (make-sparse-keymap 'sxell-ext-map)))
336 (define-key map [button2] 'sxell-url-at-mouse)
337 (define-key map [return] 'sxell-url-at-point)
338 (define-key map [d] 'sxell-download-file-at-point)
339 (define-key map [(control button2)] 'sxell-download-file-at-mouse)
341 "A keymap for the extents in sxell buffer.")
343 (defun sxell-make-url-extents ()
344 "Create extent objects for all the URLs in the buffer."
345 (goto-char (point-min))
347 (while (re-search-forward "^\\(ht\\|f\\)tp.*$" nil t)
348 (let ((extent (make-extent (match-beginning 0) (match-end 0)))
349 (echo "Visit: RET, button2; Download: d, C-button2"))
350 (set-extent-property extent 'face 'font-lock-comment-face)
351 (set-extent-property extent 'mouse-face 'highlight)
352 (set-extent-property extent 'keymap sxell-ext-map)
353 (set-extent-property extent 'help-echo echo)
354 (set-extent-property extent 'balloon-help echo)
355 (set-extent-property extent 'duplicable t)))))
357 (defun sxell-fix-quoting ()
358 (goto-char (point-min))
360 (while (re-search-forward """ nil t)
361 (replace-match "\""))))
364 "Major mode for browsing the Emacs Lisp List.
367 (kill-all-local-variables)
368 (set (make-local-variable 'font-lock-defaults)
369 '(sxell-font-lock-keywords t))
370 (use-local-map sxell-mode-map)
371 (setq major-mode 'sxell-mode
373 (when sxell-use-font-lock
375 (run-hooks 'sxell-mode-hook))
380 This _ONLY_ needs to be run _ONCE_. It initialises the PostgreSQL
381 database, and fills it from a fresh copy of the ELL."
382 (sxell-db-initialise)
383 (customize-save-variable 'sxell-initialised-flag t)
384 (sxell-packages 'remote))
386 (defun sxell-check-remote-update ()
387 "Check to see if the local Ell db needs updating from the remote."
388 (let* ((db (pq-connectdb "dbname=ell"))
389 (res (pq-exec db "SELECT etag FROM last_upd ;"))
391 (setq old-etag (pq-get-value res 0 0))
392 (setq sxell-current-etag (sxell-fetch-ell-etag))
394 (unless (string= old-etag sxell-current-etag)
395 (sxell-fetch-ell-xml)
396 (sxell-update-pg-from-xml))))
398 (defun sxell-mark-installed ()
399 "Mark ELL entries that are installed locally.
401 CAUTION: this can be a slow and CPU intensive operation, be patient."
403 (when (y-or-n-p "This can take considerable time, are you sure? ")
404 (let* ((db (pq-connectdb "dbname=ell"))
408 "SELECT DISTINCT filename FROM ell WHERE filename like '%.el' ;"))
409 (num (pq-ntuples res)))
410 (message "Finding installed libraries... Please wait.")
411 (loop for row from 0 to (1- num)
414 (format "UPDATE ell SET installed_p = '%s' WHERE filename = '%s';"
415 (if (locate-library (pq-get-value res row 0))
418 (pq-get-value res row 0))))
420 (message "Finding installed libraries... Done!"))))
422 (defun sxell-mark-downloadable ()
423 "Mark ELL db entries that have a URL to a .el that can be directly downloaded.
425 For example: http://www.foo.com/foo.el"
427 (let ((db (pq-connectdb "dbname=ell")))
428 (pq-exec db "UPDATE ell SET direct_link_p = 't' WHERE (
432 site LIKE '%.tgz' ) ;")
433 (pq-exec db "UPDATE ell SET direct_link_p = 'f' WHERE (
434 site NOT LIKE '%.el' AND
435 site NOT LIKE '%.gz' AND
436 site NOT LIKE '%.bz2' AND
437 site NOT LIKE '%.tgz' ) ;")
439 (message "Noted the directly downloadable files.")))
441 (defun sxell-sort-by-contact (&optional reverse remote)
442 "Display ELL, sorted by contact.
444 The default is to display in alphabetical ascending order, using the
445 local data. This behaviour can be changed by the use of prefix args:
447 0 prefix arg -- Sort ascending with local data \(default\)
448 1 prefix args -- Sort descending with local data
449 2 prefix args -- Sort ascending check remote updates
450 3 prefix args -- Sort descending check remote updates
452 To do the same thing non-interactively, use:
454 Optional arg, REVERSE, display in reverse order.
455 Optional arg, REMOTE, check remote ELL for updates."
457 (let* ((arg current-prefix-arg)
458 ;; Reset `current-prefix-arg' to nil because `sxell-packages'
459 ;; can use a prefix arg too.
460 (current-prefix-arg nil)
461 (sql "SELECT * FROM ell ORDER by contact "))
462 (if (not (interactive-p))
463 ;; When called non-interactively
465 (setq sql (concat sql
466 (when reverse "desc ")
469 (sxell-packages 'remote sql)
470 (sxell-packages nil sql)))
471 ;; When called interactively
474 (setq sql (concat sql "desc ;"))
475 (sxell-packages nil sql))
477 (setq sql (concat sql ";"))
478 (sxell-packages 'remote sql))
480 (setq sql (concat sql "desc ;"))
481 (sxell-packages 'remote sql))
483 (setq sql (concat sql ";"))
484 (sxell-packages nil sql))))))
486 (defun sxell-sort-by-date (&optional oldfirst remote)
487 "Display ELL, sorted by date.
489 The default is to display newest to oldest, using the local data.
490 This behaviour can be changed through the use of prefix args:
492 0 prefix arg -- newest to oldest with local data \(default\)
493 1 prefix args -- oldest to newest with local data
494 2 prefix args -- newest to oldest, check for remote updates
495 3 prefix args -- oldest to newest, check for remote updates
497 To do the same thing non-interactively, use:
499 Optional arg, OLDFIRST, display oldest to newest.
500 Optional arg, REMOTE, check for remote updates."
502 (let* ((arg current-prefix-arg)
503 ;; Reset `current-prefix-arg' to nil because `sxell-packages'
504 ;; can use a prefix arg too.
505 (current-prefix-arg nil)
506 (sql "SELECT * FROM ell order by time_stamp "))
507 (if (not (interactive-p))
508 ;; When called non-interactively
510 (setq sql (concat sql
511 (unless oldfirst "desc ")
514 (sxell-packages 'remote sql)
515 (sxell-packages nil sql)))
516 ;; When called interactively
519 (setq sql (concat sql ";"))
520 (sxell-packages nil sql))
522 (setq sql (concat sql "desc ;"))
523 (sxell-packages 'remote sql))
525 (setq sql (concat sql ";"))
526 (sxell-packages 'remote sql))
528 (setq sql (concat sql "desc ;"))
529 (sxell-packages nil sql))))))
531 (defun sxell-search ()
532 "Search records in ELL."
534 ;; write me... I'm thinking map-y-or-n-p shit
537 (defun sxell-packages (&optional remote sql)
538 "Display the Emacs Lisp List in a Emacs buffer.
540 The data for the list comes from the local PostgreSQL database. The
541 first time this is run, the PostgreSQL database is initialised and the
542 Ell is imported into it.
544 With non-nil prefix arg, REMOTE, check for updates to the Ell.
546 Optional argument, SQL is the SQL SELECT statement to use. If it is
547 omitted, `SELECT * FROM ell ORDER by filename ;' is used."
549 (unless sxell-initialised-flag
551 (when (or current-prefix-arg remote)
552 (sxell-check-remote-update))
553 (let ((packages (sxell-get-pg-packages-list sql)))
554 (sxell-prepare-buffer)
555 (insert "Files with an asterisk `*' "
556 "are already installed on your system.")
560 ;; NAME - DESCRIPTION
563 ;; Added: TIMESTAMP Note: NOTE
564 (let* ((name (car x))
565 (description (cadr x))
568 (timestamp (car (cddddr x)))
569 (note (cadr (cddddr x)))
570 (installed (caddr (cddddr x))))
571 ;(downloadable (cadddr (cddddr x))))
572 (insert (format "%s - %s\n%s\nContact: %s\nAdded: %s"
573 (if (string= installed "t")
576 description url author timestamp))
577 (if (not (string= note ""))
578 (insert (format "\nNote: %s\n\n" note))
581 (sxell-update-buffer sxell-last-updated)
583 (sxell-make-url-extents)
584 (sxell-fix-quoting)))
589 ;;; sxell.el ends here