Mercurial > hg > xemacs-beta

comparison lisp/w3/w3-annotat.el @ 20:859a2309aef8 r19-15b93

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b93
author cvs
date Mon, 13 Aug 2007 08:50:05 +0200
parents 0293115a14e9
children 131b0175ea99
comparison
equal deleted inserted replaced
19:ac1f612d5250 20:859a2309aef8
1 ;;; w3-annotat.el --- Annotation functions for Emacs-W3
2 ;; Author: wmperry
3 ;; Created: 1997/01/10 00:13:05
4 ;; Version: 1.6
5 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1993 - 1996 by William M. Perry (wmperry@cs.indiana.edu)
9 ;;; Copyright (c) 1996, 1997 Free Software Foundation, Inc.
10 ;;;
11 ;;; This file is part of GNU Emacs.
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
30 ;;; Private annotation support
31 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32 (defun w3-parse-personal-annotations ()
33 ;; Read in personal annotation file
34 (if (and
35 (file-exists-p (format "%s/LOG" w3-personal-annotation-directory))
36 (file-readable-p (format "%s/LOG" w3-personal-annotation-directory)))
37 (save-excursion
38 (setq w3-personal-annotations nil);; nuke the old list
39 (let ((start nil)
40 (end nil)
41 (txt nil)
42 (url nil)
43 (num nil))
44 (set-buffer (get-buffer-create " *panno*"))
45 (erase-buffer)
46 (insert-file-contents-literally
47 (format "%s/LOG" w3-personal-annotation-directory))
48 (goto-char (point-min))
49 (w3-replace-regexp "\n+" "\n")
50 (goto-char (point-min))
51 ;; nuke the header lines
52 (delete-region (point-min) (progn (forward-line 2) (point)))
53 (cond
54 ((eobp) nil) ; Empty LOG file
55 (t
56 (if (/= (char-after (1- (point-max))) ?\n)
57 (save-excursion
58 (goto-char (point-max))
59 (insert "\n")))
60 (while (not (eobp))
61 (setq start (point)
62 end (prog2 (end-of-line) (point) (forward-char 1))
63 txt (buffer-substring start end)
64 url (substring txt 0 (string-match " " txt))
65 num (url-split
66 (substring txt (1+ (string-match " " txt)) nil)
67 "[ \t]"))
68 (while num
69 (setq w3-personal-annotations
70 (cons
71 (list url
72 (list (car (car num))
73 (w3-grok-annotation-format
74 (car (car num)))))
75 w3-personal-annotations)
76 num (cdr num))))))
77 (kill-buffer " *panno*")))))
78
79 (defun w3-grok-annotation-format (anno)
80 ;; Grab the title from an annotation
81 (let ((fname (format "%s/PAN-%s.html"
82 w3-personal-annotation-directory anno)))
83 (save-excursion
84 (set-buffer (get-buffer-create " *annotmp*"))
85 (erase-buffer)
86 (if (file-exists-p fname)
87 (insert-file-contents-literally fname))
88 (goto-char (point-min))
89 (prog1
90 (if (re-search-forward "<title>\\(.*\\)</title>" nil t)
91 (buffer-substring (match-beginning 1) (match-end 1))
92 (concat "Annotation on "
93 (current-time-string (nth 5 (file-attributes fname)))))
94 (kill-buffer " *annotmp*")))))
95
96 (defun w3-is-personal-annotation (url)
97 ;; Is URL a personal annotation?
98 (string-match "file:/.*/PAN-.*\\.html" url))
99
100 (defun w3-delete-personal-annotation-internal (url num)
101 (save-excursion
102 (set-buffer (get-buffer-create " *annotmp*"))
103 (erase-buffer)
104 (insert-file-contents-literally (format "%s/LOG"
105 w3-personal-annotation-directory))
106 (replace-regexp (format "[ \t]+\\b%s\\b[ \t]*" num) " ")
107 (goto-char (point-min))
108 (delete-matching-lines (format "^%s +$" url))
109 (let ((make-backup-files nil)
110 (version-control nil)
111 (require-final-newline t))
112 (write-region (point-min) (point-max)
113 (format "%s/LOG"
114 w3-personal-annotation-directory)))
115 (kill-buffer " *annotmp*")
116 (let ((anno w3-personal-annotations))
117 (setq w3-personal-annotations nil)
118 (while anno
119 (if (not (string= num (car (car (cdr (car anno))))))
120 (setq w3-personal-annotations
121 (cons (car anno) w3-personal-annotations)))
122 (setq anno (cdr anno)))
123 (delete-file (format "%s/PAN-%s.html"
124 w3-personal-annotation-directory num)))))
125
126 (defun w3-delete-personal-annotation ()
127 "Delete a personal annotation."
128 (interactive)
129 (let ((url (url-view-url t)))
130 (cond
131 ((w3-is-personal-annotation (url-view-url t))
132 (let ((num nil)
133 (annotated-url nil)
134 (anno w3-personal-annotations))
135 (string-match "file:/.*/PAN-\\(.*\\)\\.html" url)
136 (setq num (match-string 1 url))
137 (while anno
138 (if (equal num (car (car (cdr (car anno)))))
139 (setq annotated-url (car (car anno))))
140 (setq anno (cdr anno)))
141 (if (not annotated-url)
142 (message "Couldn't find url that this is annotating!")
143 (w3-delete-personal-annotation-internal annotated-url num)
144 (w3-quit))))
145 (t
146 (let* ((tmp w3-personal-annotations)
147 (thelist nil)
148 (node nil)
149 (todel nil))
150 (if (not (assoc url tmp))
151 (message "No personal annotations.")
152 (while tmp
153 (setq node (car tmp))
154 (if (string= (car node) url)
155 (setq thelist (cons (cons (nth 1 (nth 1 node)) "") thelist)))
156 (setq tmp (cdr tmp)))
157 (setq todel (completing-read "Delete annotation: " thelist nil t))
158 ;; WORK ;;
159 (message "I should delete %s, but can't." todel)))))))
160
161 (defun w3-personal-annotation-add ()
162 "Add an annotation to this document."
163 (interactive)
164 (let ((url (url-view-url t))
165 (buf (get-buffer-create "*Personal Annotation*"))
166 (title (read-string "Title: "
167 (format "Annotation by %s on %s"
168 (user-real-login-name)
169 (current-time-string)))))
170 (set-buffer buf)
171 (switch-to-buffer buf)
172 (erase-buffer)
173 (if (and w3-annotation-mode (fboundp w3-annotation-mode))
174 (funcall w3-annotation-mode)
175 (message "%S is undefined, using %s" w3-annotation-mode
176 default-major-mode)
177 (funcall default-major-mode))
178 (w3-annotation-minor-mode 1)
179 (setq w3-current-annotation (cons url title))
180 (insert "<html>\n"
181 " <head>\n"
182 " <title>" (url-insert-entities-in-string title) "</title>"
183 " </head>\n"
184 " <h1>" (url-insert-entities-in-string title) "</h1>\n"
185 " <p>\n"
186 " <address>" (url-insert-entities-in-string (user-full-name))
187 (if (stringp url-personal-mail-address)
188 (concat " &lt;" (url-insert-entities-in-string
189 url-personal-mail-address) "&gt;")
190 "")
191 "</address>\n"
192 " <address>" (current-time-string) "</address>\n"
193 " </p>\n"
194 " <pre>\n")
195 (save-excursion
196 (insert "\n\n\n </pre>\n"
197 "</html>"))
198 (message "Hit C-cC-c to send this annotation.")))
199
200 (defun w3-annotation-minor-mode (&optional arg)
201 "Minimal minor mode for entering annotations. Just rebinds C-cC-c to
202 finish the annotation."
203 (interactive "P")
204 (cond
205 ((null arg) (setq w3-annotation-minor-mode (not w3-annotation-minor-mode)))
206 ((= 0 arg) (setq w3-annotation-minor-mode nil))
207 (t (setq w3-annotation-minor-mode t)))
208 (cond
209 ((or w3-running-FSF19 w3-running-xemacs))
210 (t (local-set-key "\C-c\C-c" 'w3-personal-annotation-finish)))
211 )
212
213 (defun w3-annotation-find-highest-number ()
214 ;; Find the highest annotation number in this buffer
215 (let (x)
216 (goto-char (point-min))
217 (while (re-search-forward "[^ \t\n]*[ \t]\\(.*\\)" nil t)
218 (setq x (nconc (mapcar (function (lambda (x) (string-to-int (car x))))
219 (url-split (buffer-substring (match-beginning 1)
220 (match-end 1))
221 "[ \t]")) x)))
222 (if (not x) (setq x '(0)))
223 (1+ (car (sort x '>)))))
224
225 (defun w3-personal-annotation-finish ()
226 "Finish doing a personal annotation."
227 (interactive)
228 (cond
229 ((or w3-running-FSF19 w3-running-xemacs))
230 (t (local-set-key "\C-c\C-c" 'undefined)))
231 (if (or (not w3-personal-annotation-directory)
232 (not (file-exists-p w3-personal-annotation-directory))
233 (not (file-directory-p w3-personal-annotation-directory)))
234 (error "No personal annotation directory!")
235 (let ((url (car w3-current-annotation))
236 (txt (buffer-string))
237 (title (cdr w3-current-annotation))
238 (fname nil)
239 (num nil))
240 (save-excursion
241 (not-modified)
242 (kill-buffer (current-buffer))
243 (set-buffer (get-buffer-create " *annotmp*"))
244 (erase-buffer)
245 (if (file-exists-p ; Insert current LOG file if
246 ; it exists.
247 (format "%s/LOG" w3-personal-annotation-directory))
248 (insert-file-contents-literally
249 (format "%s/LOG" w3-personal-annotation-directory))
250 (progn ; Otherwise, create a file
251 (goto-char (point-min)) ; that conforms to first
252 ; annotation format from NCSA
253 (insert "ncsa-mosaic-personal-annotation-log-format-1\n")
254 (insert "Personal\n")))
255 (goto-char (point-min))
256 (setq num (int-to-string (w3-annotation-find-highest-number))
257 fname (format "%s/PAN-%s.html"
258 w3-personal-annotation-directory num))
259 (goto-char (point-min))
260 (if (re-search-forward (regexp-quote url) nil t)
261 (progn
262 (end-of-line)
263 (insert " "))
264 (goto-char (point-max))
265 (insert "\n" url " "))
266 (insert num)
267 (let ((make-backup-files nil)
268 (version-control nil)
269 (require-final-newline t))
270 (write-region (point-min) (point-max)
271 (format "%s/LOG" w3-personal-annotation-directory))
272 (erase-buffer)
273 (insert w3-annotation-marker txt)
274 (write-region (point-min) (point-max) fname))
275 (setq w3-personal-annotations
276 (cons (list url (list num title)) w3-personal-annotations))))))
277
278 (defun w3-annotation-add ()
279 "Add an annotation to the current document."
280 (interactive)
281 (w3-personal-annotation-add))