Auto-HREF utility for XEmacs mailing lists
Here's a little utility to add a list-archive.xemacs.org URL when
you have a Message ID and want to provide a hyperlink.
I'm sure other people have written utilities like this, but I haven't
seen any published. I finally got around to writing my own (I needed
to learn about w3/url.el anyway, so it wasn't a waste of time).
; Copyright 2001 Stephen Turnbull
; Maintained by Code That Sucks, Ltd.
; Licensed under the GNU GPL. Warranty? Heaven forbid!
; I keep the working buffer open in a short window. Normally only
; about 5 lines are needed.
(defvar sjt/working-buffer-name "sjt/temp-url"
"Working buffer to hold fetched documents.")
(defvar sjt/verbose t
"Non-nil enables verbose messages.")
(defvar sjt/truncate-id-length 24
"Truncate query strings to this length.
The wilma search engine at list-archive.xemacs.org doesn't like long queries
(or maybe just long words in the queries). The default is 24, but some
queries seem to work better with even less."
(defvar sjt/parse-url-regexp
"<A HREF=\"/cgi-bin/wilma_hiliter\\(/.*\\.html\\)\\?"
"Regexp to parse part of the URL, expected to be in group 1.")
(defvar sjt/parse-url-format "http://list-archive.xemacs.org%s"
"Format string to make a valid URL from the first match group of
`sjt/parse-url-regexp'.")
(defun sjt/wrap-link-around-message-id (begin end)
"Wrap an HTML HREF around a Message ID, doing a web search for the URL.
Leaves point at beginning and mark at end of the original text, "
(interactive "r")
(let ((url (buffer-substring begin end)))
(setq end (set-marker (make-marker) end))
(goto-char begin)
(insert "<a href=\"")
(insert (sjt/message-id-to-url url
""
"xemacs-beta"
"xemacs-nt"
"xemacs-patches"))
(insert "\">")
(setq begin (point))
(setq end (marker-position end)) ; freeze end
(goto-char end)
(insert "</a>")
(move-marker (mark-marker t) end)
(goto-char begin)))
(defun sjt/message-id-to-url (id &optional auth &rest lists)
"Return URL corresponding to message-id ID posted to LISTS.
AUTH is an authorization in the form USER:PASSWORD. It has no default.
LISTS defaults to (\"xemacs-beta\" \"xemacs-nt\"
\"xemacs-patches\"); each
is tried in order and the URL corresponding to the first match is returned."
(interactive (let ((args (list (if (region-active-p)
(buffer-substring (region-beginning)
(region-end))
(read-string "Message-ID: "))
(read-string "User:Password: "))))
(let ((l (read-string "List (null to terminate): ")))
(while (> (length l) 0)
(setq args (nconc args (list l)))
(setq l (read-string "List (null to terminate): "))))
args))
(setq auth (cond ((null auth) "")
((> (length auth) 0) (concat auth "＠"))
(t auth)))
(setq lists (or (and lists (> (length (car lists)) 0) lists)
'("xemacs-beta" "xemacs-nt"
"xemacs-patches")))
(if sjt/verbose (message id))
;; wilma doesn't like long queries
(let ((id (substring id 0 (min (length id) sjt/truncate-id-length)))
url)
(save-excursion ; url-retrieve leaves you in the buffer
(while lists
(let ((url-working-buffer sjt/working-buffer-name)
(ml (car lists)))
(url-retrieve
(concat "http://"
auth
"list-archive.xemacs.org"
"/cgi-bin/wilma_glimpse/"
ml
"?query="
(url-hexify-string id)
"&partial=on")))
(setq url (sjt/parse-url-from-response))
(if sjt/verbose (message url))
(if url
(setq lists nil)
(setq lists (cdr lists)))))
url))
(defun sjt/parse-url-from-response ()
"Parse an URL from the HTML returned by a web search on message-id.
Expects to be called in the HTML buffer."
(goto-char (point-min))
(if (let ((case-fold-search t))
(search-forward "Message-ID" nil t))
(let ((eol (progn (end-of-line) (point))))
(beginning-of-line)
(re-search-forward sjt/parse-url-regexp eol)
(format sjt/parse-url-format
(match-string 1)))))
--
University of Tsukuba Tennodai 1-1-1 Tsukuba 305-8573 JAPAN
Institute of Policy and Planning Sciences Tel/fax: +81 (298) 53-5091
_________________ _________________ _________________ _________________
What are those straight lines for? "XEmacs rules."