?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Change README.md
[navi2ch.git] / navi2ch-article.el
blobd83211052fb131298bc6cb9ca7ea96ee5027a464
1 ;;; navi2ch-article.el --- article view module for navi2ch -*- coding: iso-2022-7bit; lexical-binding: t; -*-
2
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
4 ;; 2009 by Navi2ch Project
5
6 ;; Author: Taiki SUGAWARA <taiki@users.sourceforge.net>
7 ;; Keywords: network, 2ch
8
9 ;; This file is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; This file is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;
27
28 ;;; Code:
29 (provide 'navi2ch-article)
30 (defconst navi2ch-article-ident
31 "$Id$")
32
33 (eval-when-compile
34 (require 'cl-lib)
35 (require 'navi2ch-decls)
36 (require 'navi2ch-inline)
37 (require 'wid-edit))
38
39 (require 'navi2ch-vars)
40
41 (require 'base64)
42 (require 'widget)
43
44 (defvar navi2ch-article-mode-map nil)
45 (unless navi2ch-article-mode-map
46 (let ((map (make-sparse-keymap)))
47 (set-keymap-parent map navi2ch-global-view-map)
48 (define-key map "q" 'navi2ch-article-exit)
49 (define-key map "Q" 'navi2ch-article-goto-current-board)
50 (define-key map "s" 'navi2ch-article-sync)
51 (define-key map "S" 'navi2ch-article-sync-disable-diff)
52 (define-key map "r" 'navi2ch-article-redraw-range)
53 (define-key map "j" 'navi2ch-article-few-scroll-up)
54 (define-key map "k" 'navi2ch-article-few-scroll-down)
55 (define-key map " " 'navi2ch-article-scroll-up)
56 (navi2ch-define-delete-keys map 'navi2ch-article-scroll-down)
57 (define-key map "w" 'navi2ch-article-write-message)
58 (define-key map "W" 'navi2ch-article-write-sage-message)
59 (define-key map "\r" 'navi2ch-article-select-current-link)
60 (unless (featurep 'xemacs)
61 (define-key map [follow-link] 'mouse-face))
62 (navi2ch-define-mouse-key map 2 'navi2ch-article-mouse-select)
63 (define-key map "g" 'navi2ch-article-goto-number-or-board)
64 ;; (define-key map "g" 'navi2ch-article-goto-number)
65 (define-key map "l" 'navi2ch-article-pop-point)
66 (define-key map "L" 'navi2ch-article-pop-poped-point)
67 (define-key map "m" 'navi2ch-article-push-point)
68 (define-key map "R" 'navi2ch-article-rotate-point)
69 (define-key map "U" 'navi2ch-article-show-url)
70 (define-key map "." 'navi2ch-article-redisplay-current-message)
71 (define-key map "p" 'navi2ch-article-previous-message)
72 (define-key map "n" 'navi2ch-article-next-message)
73 (define-key map "P" 'navi2ch-article-through-previous)
74 (define-key map "N" 'navi2ch-article-through-next)
75 (define-key map [(shift tab)] 'navi2ch-article-previous-link)
76 (define-key map [(iso-left-tab)] 'navi2ch-article-previous-link)
77 (define-key map [(shift iso-lefttab)] 'navi2ch-article-previous-link)
78 (define-key map "\e\C-i" 'navi2ch-article-previous-link)
79 (define-key map "\C-\i" 'navi2ch-article-next-link)
80 (define-key map "i" 'navi2ch-article-fetch-link)
81 (define-key map ">" 'navi2ch-article-goto-last-message)
82 (define-key map "<" 'navi2ch-article-goto-first-message)
83 (define-key map "\ed" 'navi2ch-article-decode-message)
84 (define-key map "\ei" 'navi2ch-article-auto-decode-toggle-text)
85 (define-key map "v" 'navi2ch-article-view-aa)
86 (define-key map "f" 'navi2ch-article-forward-buffer)
87 (define-key map "b" 'navi2ch-article-backward-buffer)
88 (define-key map "d" 'navi2ch-article-hide-message)
89 (define-key map "a" 'navi2ch-article-add-important-message)
90 (define-key map "h" 'navi2ch-article-toggle-hide)
91 (define-key map "$" 'navi2ch-article-toggle-important)
92 (define-key map "A" 'navi2ch-article-add-global-bookmark)
93 (define-key map "\C-c\C-m" 'navi2ch-message-pop-message-buffer)
94 (define-key map "G" 'navi2ch-article-goto-board)
95 (define-key map "e" 'navi2ch-article-textize-article)
96 (define-key map "?" 'navi2ch-article-search)
97 (define-key map "\C-o" 'navi2ch-article-save-dat-file)
98 (define-key map "F" 'navi2ch-article-toggle-message-filter)
99 (define-key map "x" 'undefined)
100 (define-key map "!" 'navi2ch-article-add-message-filter-cus)
101 (define-key map "\C-c\C-r" 'navi2ch-article-remove-article)
102 (navi2ch-ifxemacs
103 (define-key map "\C-c\C- " 'navi2ch-article-toggle-sticky)
104 (define-key map [(control c) (control ? )] 'navi2ch-article-toggle-sticky))
105 (define-key map "u" 'navi2ch-show-url-at-point)
106 (define-key map "\C-c\C-y" 'navi2ch-article-write-cite-message)
107 (when (featurep 'navi2ch-thumbnail)
108 (define-key map "," 'navi2ch-thumbnail-select-current-link)
109 (define-key map "V" 'navi2ch-thumbnail-save-content)
110 (define-key map "\e\r" 'navi2ch-article-select-current-link)
111 (define-key map "\C-c\C-d" 'navi2ch-thumbnail-image-delete-cache)
112 (define-key map "T" 'navi2ch-thumbnail-all-show))
113 (setq navi2ch-article-mode-map map)))
114
115 (defvar navi2ch-article-mode-menu-spec
116 '("Article"
117 ["Toggle offline" navi2ch-toggle-offline]
118 ["Sync" navi2ch-article-sync]
119 ["Sync (no diff)" navi2ch-article-sync-disable-diff]
120 ["Exit" navi2ch-article-exit]
121 ["Write message" navi2ch-article-write-message]
122 ["Write message (sage)" navi2ch-article-write-sage-message]
123 ["Select Range" navi2ch-article-redraw-range]))
124
125 (defvar navi2ch-article-view-range nil
126 "\e$BI=<($9$k%9%l%C%I$NHO0O!#\e(B
127 \e$B=q<0$O\e(B '(first . last) \e$B$G!"\e(B
128 first \e$B$,:G=i$+$i$$$/$DI=<($9$k$+!"\e(B
129 last \e$B$,:G8e$+$i$$$/$DI=<($9$k$+!#\e(B
130 \e$BNc$($P!"\e(B(10 . 50) \e$B$G!":G=i$N\e(B10\e$B$H:G8e$N\e(B50\e$B$rI=<(\e(B")
131
132 (defvar navi2ch-article-buffer-name-prefix "*navi2ch article ")
133 (defvar navi2ch-article-current-article nil)
134 (defvar navi2ch-article-current-board nil)
135 (defvar navi2ch-article-message-list nil)
136 (defvar navi2ch-article-point-stack nil "\e$B0LCV$r3P$($H$/\e(B stack")
137 (defvar navi2ch-article-poped-point-stack nil)
138 (defvar navi2ch-article-hide-mode nil)
139 (defvar navi2ch-article-through-next-function 'navi2ch-article-through-next)
140 (defvar navi2ch-article-through-previous-function 'navi2ch-article-through-previous)
141 (defvar navi2ch-article-through-forward-line-function 'navi2ch-bm-forward-line
142 "\e$BA08e$N%9%l$K0\F0$9$k$?$a$K<B9T$5$l$k4X?t!#\e(B
143 \e$B0l$D$N@0?t$r0z?t$K$H$j!"$=$N?t$@$18e$m\e(B(\e$B0z?t$,Ii$N$H$-$OA0\e(B)\e$B$N%9%l$K0\F0$7!"\e(B
144 \e$B0\F0$G$-$?$i\e(B 0\e$B!"$G$-$J$1$l$P\e(B 0 \e$B0J30$N@0?t$rJV$94X?t$G$"$k$3$H!#\e(B")
145
146 (defvar navi2ch-article-save-info-keys
147 '(number name time hide important unfilter mail kako response down compressed))
148
149 (defvar navi2ch-article-insert-message-separator-function
150 (if (and window-system
151 (eq emacs-major-version 20)
152 (not (featurep 'xemacs)))
153 'navi2ch-article-insert-message-separator-by-face
154 'navi2ch-article-insert-message-separator-by-char)
155 "\e$B%;%Q%l!<%?$rA^F~$9$k4X?t!#\e(B")
156
157 (defvar navi2ch-article-summary-file-name "article-summary")
158 (defvar navi2ch-article-local-dat-regexp "[0-9]+\\.dat\\(?:.gz\\)?\\'"
159 "\e$B%m!<%+%k$K$"$k\e(B dat \e$B%U%!%$%k$rI=$o$9@55,I=8=!#\e(B
160 \e$B%5!<%P$K$"$k\e(B dat \e$B%U%!%$%k$K$O$3$NJQ?t$r;H$C$F$O$$$1$J$$!#\e(B")
161
162 (defvar navi2ch-article-link-internal nil)
163
164 (defconst navi2ch-article-separator " *<> *")
165
166 ;; important mode
167 (defvar navi2ch-article-important-mode nil)
168 (defvar navi2ch-article-important-mode-map nil)
169 (unless navi2ch-article-important-mode-map
170 (setq navi2ch-article-important-mode-map (make-sparse-keymap))
171 (define-key navi2ch-article-important-mode-map "d" 'navi2ch-article-delete-important-message)
172 (define-key navi2ch-article-important-mode-map "a" 'undefined))
173
174 ;; hide mode
175 (defvar navi2ch-article-hide-mode nil)
176 (defvar navi2ch-article-hide-mode-map nil)
177 (unless navi2ch-article-hide-mode-map
178 (setq navi2ch-article-hide-mode-map (make-sparse-keymap))
179 (define-key navi2ch-article-hide-mode-map "d" 'navi2ch-article-cancel-hide-message)
180 (define-key navi2ch-article-hide-mode-map "a" 'undefined))
181
182 ;; filter mode
183 (defvar navi2ch-article-message-filter-mode nil)
184 (defvar navi2ch-article-message-filter-mode-map nil)
185 (unless navi2ch-article-message-filter-mode-map
186 (setq navi2ch-article-message-filter-mode-map (make-sparse-keymap))
187 (define-key navi2ch-article-message-filter-mode-map "x" 'navi2ch-article-toggle-replace-message))
188
189 (defvar navi2ch-article-message-filter-cache nil)
190 (defvar navi2ch-article-save-message-filter-cache-keys
191 '(cache replace hide important))
192
193 ;; sticky mode
194 (defvar navi2ch-article-sticky-mode nil)
195 (make-variable-buffer-local 'navi2ch-article-sticky-mode)
196 (add-to-list 'minor-mode-alist '(navi2ch-article-sticky-mode " Sticky"))
197
198 (defvar navi2ch-article-message-filter-default-rule-alist
199 '((?n
200 :var navi2ch-article-message-filter-by-name-alist
201 :string navi2ch-article-get-current-name)
202 (?m
203 :var navi2ch-article-message-filter-by-mail-alist
204 :string navi2ch-article-get-current-mail)
205 (?i
206 :var navi2ch-article-message-filter-by-id-alist
207 :string navi2ch-article-get-current-id
208 :scope board-local
209 :date t)
210 (?h
211 :var navi2ch-article-message-filter-by-hostname-alist
212 :string navi2ch-article-get-current-hostname)
213 (?b
214 :var navi2ch-article-message-filter-by-message-alist
215 :string (lambda ()
216 (or (navi2ch-article-get-current-word-in-body)
217 "")))
218 (?s
219 :var navi2ch-article-message-filter-by-subject-alist
220 :string navi2ch-article-get-current-subject)
221 (t :match-method "s")))
222
223 (defvar navi2ch-article-message-filter-wid-string)
224 (defvar navi2ch-article-message-filter-wid-rule)
225 (defvar navi2ch-article-message-filter-wid-method)
226 (defvar navi2ch-article-message-filter-wid-case)
227 (defvar navi2ch-article-message-filter-wid-invert)
228 (defvar navi2ch-article-message-filter-wid-scope)
229 (defvar navi2ch-article-message-filter-wid-float)
230 (defvar navi2ch-article-message-filter-wid-var)
231 (defvar navi2ch-article-message-filter-wid-date)
232 (defvar navi2ch-article-message-filter-wid-window-configuration)
233
234 ;; JIT
235 (defvar navi2ch-article-jit-interval 0.1)
236 (defvar navi2ch-article-jit-timer nil)
237 (defvar navi2ch-article-use-jit nil)
238 (defvar navi2ch-article-jit-buffers nil)
239 (defvar navi2ch-article-jit-need-insert nil)
240
241 ;; local variables
242 (make-variable-buffer-local 'navi2ch-article-current-article)
243 (make-variable-buffer-local 'navi2ch-article-current-board)
244 (make-variable-buffer-local 'navi2ch-article-message-list)
245 (make-variable-buffer-local 'navi2ch-article-message-filter-cache)
246 (make-variable-buffer-local 'navi2ch-article-point-stack)
247 (make-variable-buffer-local 'navi2ch-article-poped-point-stack)
248 (make-variable-buffer-local 'navi2ch-article-view-range)
249 (make-variable-buffer-local 'navi2ch-article-through-next-function)
250 (make-variable-buffer-local 'navi2ch-article-through-previous-function)
251
252 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-string)
253 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-rule)
254 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-method)
255 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-case)
256 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-invert)
257 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-scope)
258 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-float)
259 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-var)
260 (make-variable-buffer-local 'navi2ch-article-message-filter-wid-date)
261
262 (make-variable-buffer-local 'navi2ch-article-jit-need-insert)
263
264 ;; add hook
265 (defun navi2ch-article-kill-emacs-hook ()
266 (navi2ch-article-expunge-buffers -1))
267
268 (add-hook 'navi2ch-kill-emacs-hook 'navi2ch-article-kill-emacs-hook)
269
270 ;;; navi2ch-article functions
271 (defun navi2ch-article-get-url (board article &optional no-kako)
272 (let ((artid (cdr (assq 'artid article)))
273 (url (navi2ch-board-get-uri board)))
274 (if (and (not no-kako)
275 (cdr (assq 'kako article)))
276 (navi2ch-article-get-kako-url board article)
277 (concat url "dat/" artid ".dat"))))
278
279
280 ;; 2023/7\e$B$N\e(BAPI\e$BDd;_$KH<$$!"\e(Boyster\e$B$+$i$N2a5n%m%0<hF@$,2DG=$K$J$C$?$N$GBP1~$9$k\e(B
281 ;; https://info.5ch.net/index.php/Monazilla/develop
282 ;; https://megalodon.jp/2023-1102-1155-39/https://info.5ch.net:443/index.php/Monazilla/develop
283 (defun navi2ch-article-board-disable-capability (board category &optional capability)
284 (when board
285 (when capability
286 (navi2ch-log 'LOG_INFO "add disable-capability %s:%s" category capability))
287 (let* ((disabled
288 (cond ((assq 'disabled board))
289 (t
290 (nconc board (list (list 'disabled))))
291 (assq 'disabled board)))
292 (category
293 (cond ((assoc category board))
294 (t
295 (nconc disabled (list (list category)))))))
296 (when (and capability
297 (null (memq capability (cdr category))))
298 (nconc category (list capability)))
299 (cdr category))))
300
301 (defun navi2ch-article-get-kako-url (board article &optional disabled)
302 (let* ((disabled (append disabled
303 (navi2ch-article-board-disable-capability board 'oyster)))
304 (artid (cdr (assq 'artid article)))
305 (url (if (memq 'https disabled)
306 (replace-regexp-in-string
307 "^https:" "http:" (navi2ch-board-get-uri board))
308 (navi2ch-board-get-uri board))))
309 (concat url "oyster/" (substring artid 0 4)
310 "/" artid ".dat" (unless (memq 'gz disabled) ".gz"))))
311
312 (defun navi2ch-article-url-to-article (url)
313 "URL \e$B$+$i\e(B article \e$B$KJQ49!#\e(B"
314 (navi2ch-multibbs-url-to-article url))
315
316 (defun navi2ch-article-to-url (board article &optional start end nofirst)
317 "BOARD, ARTICLE \e$B$+$i\e(B url \e$B$KJQ49!#\e(B
318 START, END, NOFIRST \e$B$GHO0O$r;XDj$9$k\e(B"
319 (navi2ch-multibbs-article-to-url board article start end nofirst))
320
321 (defun navi2ch-article-cleanup-message ()
322 (let (re)
323 (when navi2ch-article-cleanup-trailing-newline ; \e$B%l%9KvHx$N6uGr$r<h$j=|$/\e(B
324 (goto-char (point-min))
325 (when (re-search-forward "\\(<br> *\\)+<>" nil t)
326 (replace-match "<>")))
327 (when navi2ch-article-cleanup-white-space-after-old-br
328 (goto-char (point-min))
329 (unless (re-search-forward "<br>[^ ]" nil t)
330 (setq re "<br> ")))
331 (when navi2ch-article-cleanup-trailing-whitespace
332 (setq re (concat " *" (or re "<br>"))))
333 (unless (or (not re)
334 (string= re "<br>"))
335 (goto-char (point-min))
336 (while (re-search-forward re nil t)
337 (replace-match "<br>"))))) ; "\n" \e$B$G$b$$$$$+$b!#\e(B
338
339 (defun navi2ch-article-parse-message (str)
340 (unless (string= str "")
341 (let ((board navi2ch-article-current-board)
342 (article navi2ch-article-current-article))
343 (with-temp-buffer
344 (let ((syms '(name mail date data subject))
345 alist max)
346 (insert str)
347 (navi2ch-article-cleanup-message)
348 (setq max (point-max-marker))
349 (goto-char (point-min))
350 (setq alist (mapcar
351 (lambda (sym)
352 (cons sym
353 (cons (point-marker)
354 (if (re-search-forward navi2ch-article-separator nil t)
355 (copy-marker (match-beginning 0))
356 (goto-char max)
357 max))))
358 syms))
359 (let ((start (car (cdr (assq 'name alist))))
360 (end (cdr (cdr (assq 'name alist)))))
361 (when (and start end)
362 (goto-char start)
363 (while (re-search-forward "\\(</b>[^<]+<b>\\)\\|\\(<font[^>]+>[^<]+</font>\\)" end t)
364 ;; fusianasan \e$B$d%H%j%C%W$J$I\e(B
365 (replace-match (navi2ch-propertize (match-string 0)
366 'navi2ch-fusianasan-flag t)
367 t t))))
368 (navi2ch-replace-html-tag-with-buffer)
369 (dolist (x alist)
370 (setcdr x (buffer-substring (cadr x) (cddr x))))
371 alist)))))
372
373 (defun navi2ch-article-get-separator ()
374 (save-excursion
375 (let ((string (buffer-substring (navi2ch-line-beginning-position)
376 (navi2ch-line-end-position))))
377 (if (or (string-match "<>.*<>.*<>" string)
378 (not (string-match ",.*,.*," string)))
379 " *<> *"
380 " *, *"))))
381
382 (defun navi2ch-article-get-first-message ()
383 "current-buffer \e$B$N\e(B article \e$B$N:G=i$N\e(B message \e$B$rJV$9!#\e(B"
384 (goto-char (point-min))
385 (navi2ch-article-parse-message
386 (buffer-substring-no-properties (point)
387 (progn (forward-line 1)
388 (1- (point))))))
389
390 (defun navi2ch-article-get-first-message-from-file (file &optional board)
391 "FILE \e$B$G;XDj$5$l$?\e(B article \e$B$N:G=i$N\e(B message \e$B$rJV$9!#\e(B
392 BOARD non-nil \e$B$J$i$P!"$=$NHD$N\e(B coding-system \e$B$r;H$&!#\e(B"
393 (with-temp-buffer
394 (navi2ch-board-insert-file-contents board file)
395 (navi2ch-apply-filters board navi2ch-article-filter-list)
396 (navi2ch-article-get-first-message)))
397
398 (defun navi2ch-article-get-message-list (file &optional begin end)
399 "FILE \e$B$N\e(B BEGIN \e$B$+$i\e(B END \e$B$^$G$NHO0O$+$i%9%l$N\e(B list \e$B$r:n$k!#\e(B
400 \e$B6u9T$O\e(B nil\e$B!#\e(B"
401 (when (file-exists-p file)
402 (let ((board navi2ch-article-current-board)
403 message-list)
404 (with-temp-buffer
405 (navi2ch-board-insert-file-contents board file begin end)
406 (run-hooks 'navi2ch-article-get-message-list-hook)
407 (let ((i 1))
408 (navi2ch-apply-filters board navi2ch-article-filter-list)
409 (message "Splitting current messages...")
410 (goto-char (point-min))
411 (while (not (eobp))
412 (setq message-list
413 (cons (cons i
414 (let ((str (buffer-substring-no-properties
415 (point)
416 (progn (forward-line 1)
417 (1- (point))))))
418 (unless (string= str "") str)))
419 message-list))
420 (setq i (1+ i)))
421 (message "Splitting current messages...done")))
422 (nreverse message-list))))
423
424 (defun navi2ch-article-append-message-list (list1 list2)
425 (let ((num (length list1)))
426 (append list1
427 (mapcar
428 (lambda (x)
429 (setq num (1+ num))
430 (cons num (cdr x)))
431 list2))))
432
433 (defun navi2ch-article-update-previous-message-separator ()
434 "\e$B8=:_0LCV$ND>A0$N%l%96h@Z$r99?7$9$k!#\e(B"
435 (let ((old-pos (point-marker)))
436 (set-marker-insertion-type old-pos t)
437 (save-excursion
438 (let ((buffer-read-only nil)
439 end beg)
440 (if (= (point) (point-max))
441 (setq end (point))
442 (setq end (previous-single-property-change (point) 'message-separator)))
443 (when end
444 (if (get-text-property (max (1- end) (point-min)) 'message-separator)
445 (setq beg (previous-single-property-change end 'message-separator))
446 (setq beg end)
447 (setq end (next-single-property-change beg 'message-separator))))
448 (when (and beg end)
449 (let ((number (get-text-property beg 'message-separator)))
450 (goto-char beg)
451 (delete-region beg end)
452 (navi2ch-article-insert-message-separator number)))))
453 (goto-char old-pos)))
454
455 (defun navi2ch-article-insert-message-separator (number)
456 "\e$B%l%96h@Z$rA^F~$9$k!#\e(B"
457 (let ((p (point)))
458 (funcall navi2ch-article-insert-message-separator-function)
459 (when (and navi2ch-article-message-separator-insert-hide-number-p
460 (navi2ch-article-insert-hide-number-following number))
461 (funcall navi2ch-article-insert-message-separator-function))
462 (when navi2ch-article-message-separator-insert-trailing-newline-p
463 (insert "\n"))
464 (put-text-property p (point) 'message-separator number)))
465
466 (defun navi2ch-article-insert-hide-number-following (number)
467 "\e$B%l%9HV9f\e(B NUMBER \e$B$N8e$KB3$/\e(B hide \e$B$5$l$?%l%9?t$rA^F~$9$k!#\e(B
468 \e$BA^F~$7$?>l9g$O\e(B non-nil \e$B$rJV$9!#\e(B"
469 (unless (or navi2ch-article-hide-mode navi2ch-article-important-mode)
470 (let (hide beg end cnt)
471 ;; hide \e$B>pJs$O\e(B filter mode \e$B$+$I$&$+$GJQ$o$C$F$/$k\e(B
472 (setq hide
473 (funcall
474 (if navi2ch-article-message-filter-mode
475 'navi2ch-union
476 'navi2ch-set-difference)
477 (cdr (assq 'hide navi2ch-article-current-article))
478 (cdr (assq 'hide navi2ch-article-message-filter-cache))))
479 (setq beg (car (memq (1+ number) hide)))
480 (when beg
481 (setq end beg)
482 (while (memq (1+ end) hide)
483 (setq end (1+ end)))
484 (setq cnt (1+ (- end beg)))
485 (let ((number-str (if (= cnt 1)
486 (format "%d" beg)
487 (format "%d-%d" beg end))))
488 (insert (format "[%d hidden message(s) (" cnt))
489 (let ((pos (point)))
490 (insert ">>" number-str)
491 (navi2ch-article-set-link-property-subr pos (point)
492 'number number-str)
493 (insert ")]")))
494 'found))))
495
496 (defun navi2ch-article-insert-message-separator-by-face ()
497 (let ((p (point)))
498 (insert "\n")
499 (put-text-property p (point) 'face 'underline)))
500
501 (defun navi2ch-article-insert-message-separator-by-char ()
502 (let ((pos (point)))
503 (insert (make-string (max 0
504 (- (eval navi2ch-article-message-separator-width)
505 (current-column)))
506 navi2ch-article-message-separator))
507 (put-text-property pos (point) 'face 'navi2ch-article-message-separator-face)
508 (insert "\n")))
509
510 (defun navi2ch-article-set-link-property-subr (start end type value
511 &optional object)
512 (let ((face (cond ((eq type 'number) 'navi2ch-article-link-face)
513 ((eq type 'url) 'navi2ch-article-url-face))))
514 (add-text-properties start end
515 (list 'face face
516 'help-echo #'navi2ch-article-help-echo
517 'navi2ch-link-type type
518 'navi2ch-link value
519 'mouse-face navi2ch-article-mouse-face)
520 object)))
521
522 (defun navi2ch-article-link-regexp-alist-to-internal ()
523 (navi2ch-regexp-alist-to-internal
524 (append
525 navi2ch-article-link-regexp-alist
526 (list (cons (concat navi2ch-article-number-prefix-regexp
527 navi2ch-article-number-number-regexp)
528 (lambda (match)
529 (navi2ch-article-set-link-property-subr
530 (match-beginning 0) (match-end 0)
531 'number (navi2ch-match-string-no-properties 1))
532 (while (looking-at (concat
533 navi2ch-article-number-separator-regexp
534 navi2ch-article-number-number-regexp))
535 (navi2ch-article-set-link-property-subr
536 (match-beginning 1) (match-end 1)
537 'number (navi2ch-match-string-no-properties 1))
538 (goto-char (max (1+ (match-beginning 0))
539 (match-end 0))))))
540 (cons navi2ch-article-url-regexp
541 (lambda (url)
542 (if (string-match "\\`\\(http\\)\\(s?:\\)" url)
543 (replace-match "http\\2" nil nil url)
544 url)))))))
545
546 (defun navi2ch-article-set-link-property ()
547 ">>1 \e$B$H$+\e(B http:// \e$B$K\e(B property \e$B$rIU$1$k!#\e(B"
548 (goto-char (point-min))
549 (let* ((reg-internal (or navi2ch-article-link-internal
550 (navi2ch-article-link-regexp-alist-to-internal)))
551 match rep literal)
552 (while (setq match (navi2ch-re-search-forward-regexp-alist reg-internal nil t))
553 (setq rep (cdr match)
554 literal nil)
555 (when (functionp rep)
556 (save-match-data
557 (setq rep (funcall rep (navi2ch-match-string-no-properties 0))
558 literal t)))
559 (when (stringp rep)
560 (let ((start (match-beginning 0))
561 (end (match-end 0))
562 (url (navi2ch-match-string-no-properties 0)))
563 (when (string-match (concat "\\`" (car match) "\\'") url)
564 (setq url (replace-match rep nil literal url))
565 (navi2ch-article-set-link-property-subr
566 start end 'url url))
567 (goto-char (max (1+ start) end)))))))
568
569 (defun navi2ch-article-put-cite-face ()
570 (goto-char (point-min))
571 (while (re-search-forward navi2ch-article-citation-regexp nil t)
572 (put-text-property (match-beginning 0)
573 (match-end 0)
574 'face 'navi2ch-article-citation-face)))
575
576 (defun navi2ch-article-arrange-message ()
577 (goto-char (point-min))
578 (let ((id (cdr (assq 'id navi2ch-article-current-board))))
579 (when (or (member id navi2ch-article-enable-fill-list)
580 (and (not (member id navi2ch-article-disable-fill-list))
581 navi2ch-article-enable-fill))
582 (set-hard-newline-properties (point-min) (point-max))
583 (let ((fill-column (- (window-width) 5))
584 (use-hard-newlines t))
585 (fill-region (point-min) (point-max)))))
586 (run-hooks 'navi2ch-article-arrange-message-hook))
587
588 (defun navi2ch-article-insert-message (num alist)
589 (let ((p (point)))
590 (insert (funcall navi2ch-article-header-format-function
591 num
592 (cdr (assq 'name alist))
593 (cdr (assq 'mail alist))
594 (cdr (assq 'date alist))))
595 (put-text-property p (1+ p) 'current-number num)
596 (setq p (point))
597 (insert (cdr (assq 'data alist)) "\n")
598 (save-excursion
599 (save-restriction
600 (narrow-to-region p (point))
601 ;; (navi2ch-article-cleanup-message) ; \e$B$d$C$QCY$$\e(B
602 (put-text-property (point-min) (point-max) 'face
603 'navi2ch-article-face)
604 (navi2ch-article-put-cite-face)
605 (navi2ch-article-set-link-property)
606 (if navi2ch-article-auto-decode-p
607 (navi2ch-article-auto-decode-encoded-section))
608 (navi2ch-article-arrange-message)
609 ;; \e$B%5%`%M%$%k2hA|$N%-%c%C%7%e$,$"$C$?$iI=<(\e(B
610 (when (featurep 'navi2ch-thumbnail)
611 (navi2ch-thumbnail-insert-image-reload)))))
612 (navi2ch-article-insert-message-separator num))
613
614 (defun navi2ch-article-insert-messages (list range)
615 "LIST \e$B$r@07A$7$FA^F~$9$k!#\e(B"
616 (let ((msg (if navi2ch-article-message-filter-mode
617 "Filtering and inserting current messages..."
618 "Inserting current messages..."))
619 (len (length list))
620 (hide (cdr (assq 'hide navi2ch-article-current-article)))
621 (imp (cdr (assq 'important navi2ch-article-current-article)))
622 (unfilter (cdr (assq 'unfilter navi2ch-article-current-article)))
623 (cache (cdr (assq 'cache navi2ch-article-message-filter-cache)))
624 (rep (cdr (assq 'replace navi2ch-article-message-filter-cache)))
625 (orig (cdr (assq 'original navi2ch-article-message-filter-cache)))
626 (progress 0)
627 (percent 0)
628 (navi2ch-article-link-internal (navi2ch-article-link-regexp-alist-to-internal)))
629 (unless navi2ch-article-use-jit (message msg))
630 (let ((func (if navi2ch-article-message-filter-mode
631 #'navi2ch-union
632 #'navi2ch-set-difference)))
633 (setq hide (funcall func
634 hide
635 (cdr (assq 'hide
636 navi2ch-article-message-filter-cache))))
637 (setq imp (funcall func
638 imp
639 (cdr (assq 'important
640 navi2ch-article-message-filter-cache)))))
641 (setq navi2ch-article-current-article
642 (navi2ch-put-alist 'hide hide navi2ch-article-current-article))
643 (setq navi2ch-article-current-article
644 (navi2ch-put-alist 'important imp navi2ch-article-current-article))
645 (dolist (x list)
646 (let* ((num (car x))
647 (alist (cdr x))
648 (rep-alist (cdr (assq num rep)))
649 (orig-alist (cdr (assq num orig)))
650 suppress)
651 (when (and alist
652 (cond (navi2ch-article-hide-mode
653 (memq num hide))
654 (navi2ch-article-important-mode
655 (memq num imp))
656 (t
657 (and (navi2ch-article-inside-range-p num range len)
658 (not (memq num hide))))))
659 (if (stringp alist)
660 (progn
661 (setq alist (navi2ch-article-parse-message alist))
662 (cond
663 ((and (string= "\e$B$"$\!<$s\e(B" (cdr (assq 'date alist)))
664 (memq num cache))
665 ;; \e$B?7$7$/!V$"$\!<$s!W$5$l$?%l%9$O%-%c%C%7%e$r%/%j%"\e(B
666 (setq unfilter (delq num unfilter))
667 (setq navi2ch-article-current-article
668 (navi2ch-put-alist
669 'unfilter
670 unfilter
671 navi2ch-article-current-article))
672 (setq cache (delq num cache))
673 (setq navi2ch-article-message-filter-cache
674 (navi2ch-put-alist
675 'cache
676 cache
677 navi2ch-article-message-filter-cache)))
678 (rep-alist
679 ;; \e$BCV498e$N%-%c%C%7%e$,$"$k>l9g$OCV49A0$N%l%9$rB`Hr\e(B
680 (setq orig-alist (mapcar
681 (lambda (x)
682 (cons (car x)
683 (cdr (assq (car x) alist))))
684 rep-alist))
685 (setq orig (navi2ch-put-alist num orig-alist orig))
686 (setq navi2ch-article-message-filter-cache
687 (navi2ch-put-alist
688 'original
689 orig
690 navi2ch-article-message-filter-cache)))))
691 (dolist (slot alist)
692 (when (stringp (cdr slot))
693 (set-text-properties 0 (length (cdr slot)) nil (cdr slot)))))
694 (if (and navi2ch-article-message-filter-mode
695 (not (memq num unfilter)))
696 (if (and navi2ch-article-use-message-filter-cache
697 (memq num cache))
698 ;; \e$BCV498e$N%l%9$r%-%c%C%7%e$+$iCj=P\e(B
699 (dolist (slot rep-alist)
700 (when (cdr slot)
701 (navi2ch-put-alist (car slot) (cdr slot) alist)))
702 ;; \e$B%U%#%k%?=hM}$NK\BN\e(B
703 (let ((result (navi2ch-article-apply-message-filters
704 (navi2ch-put-alist 'number num alist))))
705 (when (and (eq result 'hide)
706 (not navi2ch-article-hide-mode))
707 (setq suppress t))))
708 ;; \e$BCV49A0$N%l%9$r%-%c%C%7%e$+$iI|85\e(B
709 (dolist (slot orig-alist)
710 (when (cdr slot)
711 (navi2ch-put-alist (car slot) (cdr slot) alist))))
712 (setq alist (navi2ch-put-alist 'point (point-marker) alist))
713 (setcdr x alist)
714 ;; (setcdr x (navi2ch-put-alist 'point (point) alist))
715 (if suppress
716 (navi2ch-article-update-previous-message-separator)
717 (navi2ch-article-insert-message num alist)
718 (set-marker-insertion-type (cdr (assq 'point alist)) t)))
719 ;; \e$B?JD=I=<(\e(B
720 (unless navi2ch-article-use-jit
721 (and (> (setq progress (+ progress 100)) 10000)
722 (/= (/ progress len) percent)
723 (navi2ch-no-logging-message
724 "%s%d%%" msg (setq percent (/ progress len)))))))
725 (unless navi2ch-article-use-jit (message "%sdone" msg))))
726
727 (defsubst navi2ch-article-get-message (num)
728 "NUM \e$BHVL\$N%l%9$rF@$k!#\e(B"
729 (cdr (assq num navi2ch-article-message-list)))
730
731 (defun navi2ch-article-reinsert-partial-messages (start &optional end)
732 "START \e$BHVL\$+$i!":G8e$^$?$O\e(B END \e$BHVL\$^$G$N%l%9$rA^F~$7$J$*$9!#\e(B"
733 (let* ((nums (mapcar #'car navi2ch-article-message-list))
734 (len (length nums))
735 (last (car (last nums)))
736 list visible start-point end-point)
737 (when (< start 0)
738 (setq start (+ start last 1)))
739 (if (null end)
740 (setq end last)
741 (when (< end 0)
742 (setq end (+ end last 1)))
743 (when (> start end)
744 (setq start (prog1 end
745 (setq end start)))))
746 (catch 'loop
747 (dolist (num (nreverse nums))
748 (cond
749 ((< num start)
750 (throw 'loop nil))
751 ((and (<= num end)
752 (or navi2ch-article-hide-mode
753 navi2ch-article-important-mode
754 (navi2ch-article-inside-range-p num
755 navi2ch-article-view-range
756 len)))
757 (let ((slot (assq num navi2ch-article-message-list)))
758 (when slot
759 (setq list (cons slot list))))))))
760 (setq visible (navi2ch-article-get-visible-numbers))
761 (while (and visible
762 (< (car visible) start))
763 (setq visible (cdr visible)))
764 (when visible
765 (setq start-point
766 (cdr (assq 'point (navi2ch-article-get-message (car visible))))))
767 (while (and visible
768 (<= (car visible) end))
769 (setq visible (cdr visible)))
770 (when visible
771 (setq end-point
772 (cdr (assq 'point (navi2ch-article-get-message (car visible))))))
773 (if (null start-point)
774 (goto-char (point-max))
775 (goto-char start-point)
776 (delete-region start-point (or end-point (point-max))))
777 (navi2ch-article-insert-messages list nil)))
778
779 (defun navi2ch-article-apply-message-filters (alist)
780 (let* ((num (cdr (assq 'number alist)))
781 (orig (cdr (assq 'original navi2ch-article-message-filter-cache))))
782 ;; \e$BCV49A0$N%l%9$r%-%c%C%7%e$+$iI|85\e(B
783 (dolist (slot (cdr (assq num orig)))
784 (when (cdr slot)
785 (navi2ch-put-alist (car slot) (cdr slot) alist)))
786 (let ((old-alist (copy-alist alist))
787 score result)
788 (catch 'loop
789 (dolist (filter navi2ch-article-message-filter-list)
790 (setq result (funcall filter alist))
791 (cond ((numberp result)
792 (setq score (+ (or score 0) result)))
793 (result
794 (throw 'loop nil)))))
795 (when score
796 (cond
797 ((and navi2ch-article-message-add-important-above
798 (> score navi2ch-article-message-add-important-above))
799 (setq result 'important))
800 ((and navi2ch-article-message-replace-below
801 navi2ch-article-message-hide-below
802 (< score (car navi2ch-article-message-replace-below))
803 (< score navi2ch-article-message-hide-below))
804 ;; `navi2ch-article-message-replace-below' \e$B$H\e(B
805 ;; `navi2ch-article-message-hide-below' \e$B$,N>J}$H$b\e(B
806 ;; \e$BE,MQ$5$l$&$k>l9g!"$7$-$$CM$NDc$$J}$rM%@h\e(B
807 (if (< navi2ch-article-message-hide-below
808 (car navi2ch-article-message-replace-below))
809 (setq result 'hide)
810 (setq result (cdr navi2ch-article-message-replace-below))))
811 ((and navi2ch-article-message-replace-below
812 (< score (car navi2ch-article-message-replace-below)))
813 (setq result (cdr navi2ch-article-message-replace-below)))
814 ((and navi2ch-article-message-hide-below
815 (< score navi2ch-article-message-hide-below))
816 (setq result 'hide))))
817 (cond
818 ((stringp result)
819 (let ((case-fold-search nil))
820 (navi2ch-put-alist 'name result alist)
821 (navi2ch-put-alist 'data result alist)
822 (navi2ch-put-alist 'mail
823 (if (string-match "sage"
824 (cdr (assq 'mail alist)))
825 "sage"
826 "")
827 alist)
828 (navi2ch-put-alist 'date
829 (navi2ch-replace-string " ID:.*"
830 ""
831 (cdr (assq 'date alist)))
832 alist)))
833 ((memq result '(hide important unfilter))
834 (let ((nums (cdr (assq result navi2ch-article-current-article))))
835 (unless (memq num nums)
836 (setq navi2ch-article-current-article
837 (navi2ch-put-alist result
838 (cons num nums)
839 navi2ch-article-current-article))))))
840 (unless (equal old-alist alist)
841 (setq navi2ch-article-message-filter-cache
842 (navi2ch-put-alist
843 'original
844 (navi2ch-put-alist
845 num
846 (navi2ch-set-difference old-alist alist)
847 orig)
848 navi2ch-article-message-filter-cache)))
849 (when navi2ch-article-use-message-filter-cache
850 (unless (equal alist old-alist)
851 (setq navi2ch-article-message-filter-cache
852 (navi2ch-put-alist
853 'replace
854 (navi2ch-put-alist
855 num
856 (copy-alist (navi2ch-set-difference alist old-alist))
857 (cdr (assq 'replace navi2ch-article-message-filter-cache)))
858 navi2ch-article-message-filter-cache)))
859 (unless (or (memq result '(nil cache replace original unfilter))
860 (stringp result))
861 (setq navi2ch-article-message-filter-cache
862 (navi2ch-put-alist
863 result
864 (cons num
865 (cdr (assq result navi2ch-article-message-filter-cache)))
866 navi2ch-article-message-filter-cache)))
867 (setq navi2ch-article-message-filter-cache
868 (navi2ch-put-alist
869 'cache
870 (cons num
871 (cdr (assq 'cache navi2ch-article-message-filter-cache)))
872 navi2ch-article-message-filter-cache)))
873 result)))
874
875 (defun navi2ch-article-extract-date (str)
876 (cond
877 ((not (stringp str))
878 nil)
879 ((string-match "^[0-9][0-9][0-9][0-9]/[0-9][0-9]/[0-9][0-9]" str)
880 (match-string 0 str))
881 ((string-match "^[0-9][0-9]/[0-9][0-9]/[0-9][0-9]" str)
882 (concat "20" (match-string 0 str)))
883 (t nil)))
884
885 (defun navi2ch-article-message-filter-by-name (alist)
886 (when navi2ch-article-message-filter-by-name-alist
887 (navi2ch-article-message-filter-subr
888 navi2ch-article-message-filter-by-name-alist
889 (cdr (assq 'name alist))
890 (navi2ch-article-extract-date (cdr (assq 'date alist))))))
891
892 (defun navi2ch-article-message-filter-by-message (alist)
893 (when navi2ch-article-message-filter-by-message-alist
894 (navi2ch-article-message-filter-subr
895 navi2ch-article-message-filter-by-message-alist
896 (cdr (assq 'data alist))
897 (navi2ch-article-extract-date (cdr (assq 'date alist))))))
898
899 (defun navi2ch-article-message-filter-by-id (alist)
900 (let ((case-fold-search nil))
901 (when (and navi2ch-article-message-filter-by-id-alist
902 (string-match " ID:\\([^ ]+\\)"
903 (cdr (assq 'date alist))))
904 (navi2ch-article-message-filter-subr
905 navi2ch-article-message-filter-by-id-alist
906 (match-string 1 (cdr (assq 'date alist)))
907 (navi2ch-article-extract-date (cdr (assq 'date alist)))))))
908
909 (defun navi2ch-article-message-filter-by-mail (alist)
910 (when navi2ch-article-message-filter-by-mail-alist
911 (navi2ch-article-message-filter-subr
912 navi2ch-article-message-filter-by-mail-alist
913 (cdr (assq 'mail alist))
914 (navi2ch-article-extract-date (cdr (assq 'date alist))))))
915
916 (defun navi2ch-article-message-filter-by-subject (alist)
917 (when navi2ch-article-message-filter-by-subject-alist
918 (navi2ch-article-message-filter-subr
919 navi2ch-article-message-filter-by-subject-alist
920 (if (equal (or (cdr (assq 'subject alist)) "") "")
921 (navi2ch-article-get-current-subject)
922 (cdr (assq 'subject alist)))
923 (navi2ch-article-extract-date (cdr (assq 'date alist))))))
924
925 (defun navi2ch-article-message-filter-by-hostname (alist)
926 (let ((case-fold-search nil)
927 (date (cdr (assq 'date alist))))
928 (when (and navi2ch-article-message-filter-by-hostname-alist
929 (or (string-match "\\[ \\([^ ]+\\) \\]" date)
930 (string-match "\e$BH/?.85\e(B:\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" date)))
931 (navi2ch-article-message-filter-subr
932 navi2ch-article-message-filter-by-hostname-alist
933 (match-string 1 date)
934 (navi2ch-article-extract-date (cdr (assq 'date alist)))))))
935
936 (defun navi2ch-article-message-filter-subr (rules string date)
937 (let ((board-id (cdr (assq 'id navi2ch-article-current-board)))
938 (artid (cdr (assq 'artid navi2ch-article-current-article)))
939 score)
940 (catch 'loop
941 (dolist (rule rules)
942 (when (or (not (consp (car rule)))
943 (and (equal (or (plist-get (car rule) :board-id) board-id)
944 (and (equal (or (plist-get (car rule) :artid) artid)
945 artid)
946 board-id))
947 (or (null (and date (plist-get (car rule) :date)))
948 (equal date (plist-get (car rule) :date)))))
949 (let* ((char (and (consp (car rule))
950 (stringp (car (car rule)))
951 (string-to-char (symbol-name (cadr (car rule))))))
952 (case-fold-search (and char
953 (eq char
954 (setq char (downcase char)))))
955 (regexp (cond
956 ((null char)
957 (regexp-quote (car rule)))
958 ((eq char ?r)
959 (car (car rule)))
960 ((eq char ?s)
961 (regexp-quote (car (car rule))))
962 ((eq char ?e)
963 (concat "\\`" (regexp-quote (car (car rule))) "\\'"))
964 ((eq char ?f)
965 (navi2ch-fuzzy-regexp (car (car rule))
966 case-fold-search
967 "[\e$B!!\e(B \f\t\n\r\v]*"))
968 (t
969 ""))))
970 (when (if (and char
971 (plist-get (car rule) :invert))
972 (not (string-match regexp string))
973 (string-match regexp string))
974 ;; \e$BE,MQ$7$?%U%#%k%?>r7o$r\e(B age
975 (when (and (not (eq rule (car rules)))
976 (> (or (and char
977 (plist-get (car rule) :float))
978 (if navi2ch-article-sort-message-filter-rules
979 1
980 0))
981 0))
982 (setcdr rules (cons (car rules) (delq rule (cdr rules))))
983 (setcar rules rule))
984 (if (numberp (cdr rule))
985 (setq score (+ (or score 0) (cdr rule)))
986 (throw 'loop
987 (if (and char
988 (stringp (cdr rule))
989 (not (plist-get (car rule) :invert)))
990 (navi2ch-expand-newtext (cdr rule) string)
991 (cdr rule))))))))
992 score)))
993
994 (defun navi2ch-article-separator-filter ()
995 "\e$B5l7A<0$N%;%Q%l!<%?$r;HMQ$7$F$$$k%9%l$r?77A<0$KJQ49$9$k%U%#%k%?!#\e(B"
996 (save-excursion
997 (goto-char (point-min))
998 (when (looking-at "^.*,.*,.*,")
999 (while (re-search-forward ",\\|\e$B!w!.\e(B" nil t)
1000 (if (string= (match-string 0) ",")
1001 (replace-match "<>")
1002 (replace-match ","))))))
1003
1004 (defun navi2ch-article-date-format-be2ch (date)
1005 "BE \e$B$K%j%s%/$rIU$1$k!#\e(B"
1006 (when (string-match "BE:\\([0-9]*\\)-[^(]*([0-9]*)" date)
1007 (set-text-properties (match-beginning 0) (match-end 0)
1008 (list 'mouse-face navi2ch-article-mouse-face
1009 'navi2ch-link (concat "http://be.2ch.net/test/p.php?i="
1010 (match-string 1 date))
1011 'navi2ch-link-type 'url
1012 'help-echo #'navi2ch-article-help-echo)
1013 date))
1014 date)
1015
1016
1017 (defun navi2ch-article-default-header-format-function (number name mail date)
1018 "\e$B%G%U%)%k%H$N%X%C%@$r%U%)!<%^%C%H$9$k4X?t!#\e(B
1019 \e$B%X%C%@$N\e(B face \e$B$rIU$1$k$N$b$3$3$G!#\e(B"
1020 (when (string-match (concat "\\`" navi2ch-article-number-number-regexp
1021 "\\'")
1022 name)
1023 (navi2ch-article-set-link-property-subr (match-beginning 0)
1024 (match-end 0)
1025 'number
1026 (match-string 0 name)
1027 name))
1028 (let ((from-header (navi2ch-propertize "From: "
1029 'face 'navi2ch-article-header-face))
1030 (from (navi2ch-propertize (concat (format "[%d] " number)
1031 name
1032 (format " <%s>\n" mail))
1033 'face 'navi2ch-article-header-contents-face))
1034 (date-header (navi2ch-propertize "Date: "
1035 'face 'navi2ch-article-header-face))
1036 (date (navi2ch-propertize (funcall navi2ch-article-date-format-function date)
1037 'face
1038 'navi2ch-article-header-contents-face))
1039 (start 0) next)
1040 (while start
1041 (setq next
1042 (next-single-property-change start 'navi2ch-fusianasan-flag from))
1043 (when (get-text-property start 'navi2ch-fusianasan-flag from)
1044 (add-text-properties start (or next (length from))
1045 '(face navi2ch-article-header-fusianasan-face)
1046 from))
1047 (setq start next))
1048 (concat from-header from date-header date "\n\n")))
1049
1050 (defun navi2ch-article-appendweek (d)
1051 "YY/MM/DD\e$B7A<0$NF|IU$KMKF|$rB-$9!#\e(B"
1052 (let ((youbi '("\e$BF|\e(B" "\e$B7n\e(B" "\e$B2P\e(B" "\e$B?e\e(B" "\e$BLZ\e(B" "\e$B6b\e(B" "\e$BEZ\e(B"))
1053 year month day et dt time date)
1054 ;; "\e$B$"$\!<$s\e(B"\e$B$H$+\e(BID\e$B$H$+5l7A<0$NF|IU$K$bBP1~$7$F$$$k$O$:!%\e(B
1055 ;; \e$B@55,I=8=$K9)IW$,I,MW$+$b!D\e(B
1056 (if (string-match "^\\([0-9][0-9]/[0-9][0-9]/[0-9][0-9]\\) \\([A-Za-z0-9: +/?]+\\)$" d)
1057 (progn
1058 (setq time (match-string 2 d))
1059 (setq date (match-string 1 d))
1060 (string-match "\\(.+\\)/\\(.*\\)/\\(.*\\)" date)
1061 (setq year (+ (string-to-number (match-string 1 date)) 2000))
1062 (setq month (string-to-number (match-string 2 date)))
1063 (setq day (string-to-number (match-string 3 date)))
1064 (setq et (encode-time 0 0 0 day month year))
1065 (setq dt (decode-time et))
1066 ;; \e$BF,$K\e(B20\e$B$rB-$7$F\e(BYYYY\e$B7A<0$K$9$k\e(B(2100\e$BG/LdBj%\%C%Q%DM=Dj\e(B)
1067 (concat "20" date "(" (nth (nth 6 dt) youbi) ") " time ))
1068 d)))
1069
1070 (defun navi2ch-article-expunge-buffers (&optional num)
1071 "\e$B%9%l$N%P%C%U%!$r:o=|$7$F\e(B NUM \e$B8D$K$9$k!#\e(B
1072 NUM \e$B$r;XDj$7$J$$>l9g$O\e(B `navi2ch-article-max-buffers' \e$B$r;HMQ!#\e(B
1073 NUM \e$B$,\e(B 0 \e$B0J>e$N$H$-$O\e(B sticky \e$B%P%C%U%!$O:o=|$7$J$$!#\e(B
1074 NUM \e$B$,\e(B -1 \e$B$N$H$-$O\e(B sticky \e$B%P%C%U%!$b4^$a$F$9$Y$F:o=|!#\e(B"
1075 (interactive "P")
1076 (when (not (numberp num)) ; C-u \e$B$N$_$N;~\e(B4\e$B8D$K$7$?$$$o$1$8$c$J$$$H;W$o$l\e(B
1077 (setq num navi2ch-article-max-buffers))
1078 (let* ((buffer-list (navi2ch-article-buffer-list))
1079 (buffer-num (length buffer-list)))
1080 (when (> buffer-num num)
1081 (unless (< num 0)
1082 (save-excursion
1083 (setq buffer-list
1084 (nreverse
1085 (apply 'append
1086 (mapcar (lambda (buf)
1087 (set-buffer buf)
1088 (and (not navi2ch-article-sticky-mode)
1089 (list buf)))
1090 buffer-list))))))
1091 (catch 'loop
1092 (dolist (buf buffer-list)
1093 (kill-buffer buf)
1094 (setq buffer-num (1- buffer-num))
1095 (when (<= buffer-num num)
1096 (throw 'loop nil)))))))
1097
1098 (defun navi2ch-article-view-article (board
1099 article
1100 &optional force number max-line dont-display)
1101 "\e$B%9%l$r8+$k!#\e(BFORCE \e$B$G6/@)FI$_9~$_\e(B MAX-LINE \e$B$GFI$_9~$`9T?t$r;XDj!#\e(B
1102 \e$B$?$@\e(B `navi2ch-article-max-line' \e$B$H$O5U$G\e(B t \e$B$GA4ItFI$_9~$_!#\e(B
1103 DONT-DISPLAY \e$B$,\e(B non-nil \e$B$N$H$-$O%9%l%P%C%U%!$rI=<($;$:$K<B9T!#\e(B"
1104 (let ((buf-name (navi2ch-article-get-buffer-name board article))
1105 (navi2ch-article-max-line (cond ((numberp max-line) max-line)
1106 (max-line nil)
1107 (t navi2ch-article-max-line)))
1108 (window-configuration (current-window-configuration))
1109 buffer list)
1110 (unwind-protect
1111 (progn
1112 (when (and (null (get-buffer buf-name))
1113 navi2ch-article-auto-expunge
1114 (> navi2ch-article-max-buffers 0))
1115 (navi2ch-article-expunge-buffers (1- navi2ch-article-max-buffers)))
1116 (setq buffer (get-buffer-create buf-name))
1117 (if dont-display
1118 (set-buffer buffer)
1119 (switch-to-buffer buffer))
1120 (if (eq major-mode 'navi2ch-article-mode)
1121 (setq list (navi2ch-article-sync force nil))
1122 (setq navi2ch-article-current-board board
1123 navi2ch-article-current-article article)
1124 (when navi2ch-article-auto-range
1125 (if (file-exists-p (navi2ch-article-get-file-name board article))
1126 (setq navi2ch-article-view-range
1127 navi2ch-article-exist-message-range)
1128 (setq navi2ch-article-view-range
1129 navi2ch-article-new-message-range)))
1130 (when navi2ch-article-auto-activate-message-filter
1131 (setq navi2ch-article-message-filter-mode t
1132 navi2ch-article-message-filter-cache
1133 (navi2ch-article-load-message-filter-cache)))
1134 (setq list (navi2ch-article-sync force 'first))
1135 (navi2ch-article-mode))
1136 (when (and number
1137 (not (equal (navi2ch-article-get-current-number) number)))
1138 (navi2ch-article-goto-number number t))
1139 (navi2ch-history-add navi2ch-article-current-board
1140 navi2ch-article-current-article)
1141 (navi2ch-bm-update-article navi2ch-article-current-board
1142 navi2ch-article-current-article))
1143 (when (and (buffer-live-p buffer)
1144 (or (not (eq (navi2ch-get-major-mode buffer)
1145 'navi2ch-article-mode))
1146 (null (with-current-buffer buffer
1147 navi2ch-article-message-list))))
1148 (set-window-configuration window-configuration)
1149 (kill-buffer buffer)
1150 (setq list nil)))
1151 list))
1152
1153 (defun navi2ch-article-view-article-from-file (file)
1154 "FILE \e$B$+$i%9%l$r8+$k!#\e(B"
1155 (setq file (expand-file-name file))
1156 (let* ((board (list (cons 'id "navi2ch")
1157 (cons 'uri (navi2ch-filename-to-url
1158 (file-name-directory file)))
1159 (cons 'name navi2ch-board-name-from-file)))
1160 (article (list (cons 'artid
1161 (navi2ch-article-file-name-to-artid file))))
1162 (buf-name (navi2ch-article-get-buffer-name board article)))
1163 (if (get-buffer buf-name)
1164 (progn
1165 (switch-to-buffer buf-name)
1166 nil)
1167 (if (and navi2ch-article-auto-expunge
1168 (> navi2ch-article-max-buffers 0))
1169 (navi2ch-article-expunge-buffers (1- navi2ch-article-max-buffers)))
1170 (switch-to-buffer (get-buffer-create buf-name))
1171 (setq navi2ch-article-current-board board
1172 navi2ch-article-current-article article)
1173 (when navi2ch-article-auto-range
1174 (setq navi2ch-article-view-range
1175 navi2ch-article-new-message-range))
1176 (when navi2ch-article-auto-activate-message-filter
1177 (setq navi2ch-article-message-filter-mode t
1178 navi2ch-article-message-filter-cache
1179 (navi2ch-article-load-message-filter-cache)))
1180 (prog1
1181 (navi2ch-article-sync-from-file)
1182 (navi2ch-article-set-mode-line)
1183 (navi2ch-article-mode)))))
1184
1185 (easy-menu-define navi2ch-article-mode-menu
1186 navi2ch-article-mode-map
1187 "Menu used in navi2ch-article"
1188 navi2ch-article-mode-menu-spec)
1189
1190 (defun navi2ch-article-setup-menu ()
1191 (easy-menu-add navi2ch-article-mode-menu))
1192
1193 (defun navi2ch-article-mode ()
1194 "\\{navi2ch-article-mode-map}"
1195 (interactive)
1196 (setq major-mode 'navi2ch-article-mode)
1197 (setq mode-name "Navi2ch Article")
1198 (setq buffer-read-only t)
1199 (buffer-disable-undo)
1200 (make-local-variable 'truncate-partial-width-windows)
1201 (setq truncate-partial-width-windows nil)
1202 (use-local-map navi2ch-article-mode-map)
1203 (navi2ch-article-setup-menu)
1204 (setq navi2ch-article-point-stack nil)
1205 (navi2ch-make-local-hook 'kill-buffer-hook)
1206 (add-hook 'kill-buffer-hook 'navi2ch-article-kill-buffer-hook t t)
1207 (navi2ch-make-local-hook 'post-command-hook)
1208 (add-hook 'post-command-hook 'navi2ch-article-display-link-minibuffer nil t)
1209 (run-hooks 'navi2ch-article-mode-hook))
1210
1211 (defun navi2ch-article-kill-buffer-hook ()
1212 ;; update \e$B$G$"$l$P\e(B cache \e$B$K$7$J$$\e(B
1213 ;; view \e$B$G$"$C$?$b$N$,\e(B update \e$B$K$J$C$?8e$K\e(B kill \e$B$5$l$?;~$NBP:v\e(B
1214 (setq navi2ch-article-jit-buffers (delq (current-buffer) navi2ch-article-jit-buffers))
1215 (unless navi2ch-article-jit-buffers
1216 (when navi2ch-article-jit-timer
1217 (cancel-timer navi2ch-article-jit-timer)
1218 (setq navi2ch-article-jit-timer nil)))
1219 (let ((status (navi2ch-bm-get-state-from-article navi2ch-article-current-board
1220 navi2ch-article-current-article)))
1221 (cond
1222 ((eq status 'update))
1223 ((eq status 'down)
1224 (navi2ch-bm-update-article navi2ch-article-current-board
1225 navi2ch-article-current-article
1226 'down))
1227 (t
1228 (navi2ch-bm-update-article navi2ch-article-current-board
1229 navi2ch-article-current-article
1230 'cache))))
1231 (navi2ch-article-save-info))
1232
1233 (defun navi2ch-article-exit (&optional kill)
1234 (interactive "P")
1235 ;; (navi2ch-article-add-number)
1236 (run-hooks 'navi2ch-article-exit-hook)
1237 (navi2ch-article-save-info)
1238 (let ((buf (current-buffer)))
1239 (if (or kill
1240 (null navi2ch-article-message-list))
1241 (progn
1242 (delete-windows-on buf)
1243 (kill-buffer buf))
1244 (unless (eq (selected-window)
1245 (next-window (selected-window) 'never))
1246 (delete-windows-on buf)))
1247 ;; (bury-buffer navi2ch-article-buffer-name)
1248 (let ((board-win (get-buffer-window navi2ch-board-buffer-name))
1249 (board-buf (get-buffer navi2ch-board-buffer-name)))
1250 (cond (board-win (select-window board-win))
1251 (board-buf (switch-to-buffer board-buf))
1252 (t (navi2ch-list))))))
1253
1254 (defun navi2ch-article-goto-current-board (&optional kill)
1255 "\e$B%9%l%C%I$HF1$8HD$X0\F0$9$k!#\e(B"
1256 (interactive "P")
1257 (let ((board navi2ch-article-current-board))
1258 (navi2ch-article-exit kill)
1259 (navi2ch-board-select-board board)))
1260
1261 (defun navi2ch-article-fix-range (num)
1262 "navi2ch-article-view-range \e$B$r\e(B NUM \e$B$,4^$^$l$kHO0O$KJQ99!#\e(B"
1263 (let ((len (length navi2ch-article-message-list))
1264 (range navi2ch-article-view-range))
1265 (unless (navi2ch-article-inside-range-p num range len)
1266 (let ((first (car range))
1267 (last (+ navi2ch-article-fix-range-diff (- len num))))
1268 (setq navi2ch-article-view-range (cons first last))))))
1269
1270 (defun navi2ch-article-sync (&optional force first number)
1271 "\e$B%9%l$r99?7$9$k!#\e(BFORCE \e$B$,\e(B non-nil \e$B$J$i6/@)!#\e(B
1272 FIRST \e$B$,\e(B nil \e$B$J$i$P!"%U%!%$%k$,99?7$5$l$F$J$1$l$P2?$b$7$J$$!#\e(B"
1273 (interactive "P")
1274 (when (not (navi2ch-board-from-file-p navi2ch-article-current-board))
1275 (run-hooks 'navi2ch-article-before-sync-hook)
1276 (let* ((list navi2ch-article-message-list)
1277 (article navi2ch-article-current-article)
1278 (board navi2ch-article-current-board)
1279 (navi2ch-net-force-update (or navi2ch-net-force-update
1280 force))
1281 (file (navi2ch-article-get-file-name board article))
1282 (old-size (navi2ch-file-size file))
1283 header start)
1284 (when first
1285 (setq article (navi2ch-article-load-info)))
1286 (navi2ch-article-set-mode-line)
1287 (if (and (or (cdr (assq 'kako article))
1288 (cdr (assq 'down article)))
1289 (file-exists-p file)
1290 (not (and force ; force \e$B$,;XDj$5$l$J$$8B$j\e(Bsync\e$B$7$J$$\e(B
1291 (y-or-n-p "Re-sync kako/down article? "))))
1292 (setq navi2ch-article-current-article article)
1293 (let ((ret (navi2ch-article-update-file board article force)))
1294 (setq article (nth 0 ret)
1295 navi2ch-article-current-article article
1296 header (nth 1 ret))))
1297 (prog1
1298 ;; \e$B99?7$G$-$?$i\e(B
1299 (when (or (and first (file-exists-p file))
1300 (and header
1301 (not (navi2ch-net-get-state 'not-updated header))
1302 (not (navi2ch-net-get-state 'error header))))
1303 (if (or first
1304 (navi2ch-net-get-state 'aborn header)
1305 (navi2ch-net-get-state 'kako header)
1306 (not navi2ch-article-enable-diff))
1307 (setq list (navi2ch-article-get-message-list file))
1308 (setq start (max 1
1309 (- (1+ (length list))
1310 (or (cdr navi2ch-article-view-range) 0))))
1311 (setq list (navi2ch-article-append-message-list
1312 list (navi2ch-article-get-message-list
1313 file old-size))))
1314 (setq navi2ch-article-message-list list)
1315 (let ((num (or number (cdr (assq 'number article)))))
1316 (when (and navi2ch-article-fix-range-when-sync num)
1317 (navi2ch-article-fix-range num)
1318 (when (and navi2ch-article-view-range
1319 start)
1320 (setq start
1321 (min start
1322 (max 1
1323 (- (1+ (length list))
1324 (cdr navi2ch-article-view-range))))))))
1325 (unless first
1326 (navi2ch-article-save-number))
1327 (when (or (eq start 1)
1328 navi2ch-article-hide-mode
1329 navi2ch-article-important-mode)
1330 (setq start nil))
1331 (setq navi2ch-article-hide-mode nil
1332 navi2ch-article-important-mode nil)
1333 (let ((buffer-read-only nil))
1334 (if start
1335 (funcall
1336 (if navi2ch-article-use-jit
1337 'navi2ch-article-jit-reinsert-partial-messages
1338 'navi2ch-article-reinsert-partial-messages)
1339 start)
1340 (erase-buffer)
1341 (if navi2ch-article-use-jit
1342 (navi2ch-article-jit-insert-messages
1343 list
1344 navi2ch-article-view-range
1345 (or number
1346 (cdr (assq 'number navi2ch-article-current-article))
1347 1))
1348 (navi2ch-article-insert-messages list
1349 navi2ch-article-view-range))))
1350 (navi2ch-article-load-number)
1351 (navi2ch-article-save-info board article first)
1352 (navi2ch-article-thread-stop-p)
1353 (navi2ch-article-set-mode-line)
1354 (run-hooks 'navi2ch-article-after-sync-hook)
1355 list)
1356 (when (and navi2ch-article-fix-range-when-sync number)
1357 (navi2ch-article-fix-range number)
1358 (navi2ch-article-redraw))
1359 (navi2ch-article-goto-number (or number
1360 (navi2ch-article-get-current-number)))
1361 (navi2ch-article-set-summary-element board article nil)))))
1362
1363 (defun navi2ch-article-fetch-article (board article &optional force)
1364 (if (get-buffer (navi2ch-article-get-buffer-name board article))
1365 (save-excursion
1366 (navi2ch-article-view-article board article force nil nil t))
1367 (let (ret header file)
1368 (setq article (navi2ch-article-load-info board article)
1369 file (navi2ch-article-get-file-name board article))
1370 (unless (and (or (cdr (assq 'kako article))
1371 (cdr (assq 'down article)))
1372 (file-exists-p file)
1373 (not (and force ; force \e$B$,;XDj$5$l$J$$8B$j\e(B sync \e$B$7$J$$\e(B
1374 (y-or-n-p "Re-sync kako/down article? "))))
1375 (setq ret (navi2ch-article-update-file board article force)
1376 article (nth 0 ret)
1377 header (nth 1 ret))
1378 (when (and header
1379 (not (navi2ch-net-get-state 'not-updated header))
1380 (not (navi2ch-net-get-state 'error header)))
1381 (navi2ch-article-save-info board article)
1382 (navi2ch-article-set-summary-element board article t)
1383 t)))))
1384
1385 (defun navi2ch-article-check-message-suppression (board article start
1386 &optional end)
1387 (let ((buffer (get-buffer (navi2ch-article-get-buffer-name board article)))
1388 suppressed)
1389 (if buffer
1390 (with-current-buffer buffer
1391 (when navi2ch-article-message-filter-mode
1392 (let ((res (length navi2ch-article-message-list)))
1393 (when (and (>= res start)
1394 (or (null end)
1395 (<= res end)))
1396 (let ((hide (cdr (assq 'hide navi2ch-article-current-article)))
1397 (i start))
1398 (while (memq i hide)
1399 (setq i (1+ i)))
1400 (when (> i res)
1401 (setq suppressed res)))))))
1402 (when navi2ch-article-auto-activate-message-filter
1403 (with-temp-buffer
1404 (setq navi2ch-article-current-board board)
1405 (setq navi2ch-article-message-list
1406 (navi2ch-article-get-message-list
1407 (navi2ch-article-get-file-name
1408 navi2ch-article-current-board
1409 article)))
1410 (message "Filtering current messages...")
1411 (let ((res (length navi2ch-article-message-list)))
1412 (when (and (>= res start)
1413 (or (null end)
1414 (<= res end)))
1415 (setq navi2ch-article-current-article
1416 (navi2ch-article-load-info
1417 navi2ch-article-current-board
1418 article))
1419 (setq navi2ch-article-message-filter-cache
1420 (navi2ch-article-load-message-filter-cache
1421 navi2ch-article-current-board
1422 navi2ch-article-current-article))
1423 (catch 'loop
1424 (dolist (x (nthcdr (1- start) navi2ch-article-message-list))
1425 (unless (eq (navi2ch-article-apply-message-filters
1426 (navi2ch-put-alist
1427 'number
1428 (car x)
1429 (navi2ch-article-parse-message (cdr x))))
1430 'hide)
1431 (throw 'loop nil)))
1432 (setq suppressed res))
1433 (navi2ch-article-save-info
1434 navi2ch-article-current-board
1435 navi2ch-article-current-article)
1436 (navi2ch-article-save-message-filter-cache
1437 navi2ch-article-current-board
1438 navi2ch-article-current-article
1439 navi2ch-article-message-filter-cache)))
1440 (message "Filtering current messages...done"))))
1441 suppressed))
1442
1443 (defun navi2ch-article-get-last-read-number (board article)
1444 (let ((buffer (get-buffer (navi2ch-article-get-buffer-name board article)))
1445 hide num)
1446 (if buffer
1447 (with-current-buffer buffer
1448 (setq hide (cdr (assq 'hide navi2ch-article-current-article))
1449 num (if (or navi2ch-article-hide-mode
1450 navi2ch-article-important-mode)
1451 (cdr (assq 'number navi2ch-article-current-article))
1452 (navi2ch-article-get-current-number))))
1453 (setq article (navi2ch-article-load-info board (copy-alist article)))
1454 (setq hide (cdr (assq 'hide article))
1455 num (cdr (assq 'number article))))
1456 (when num
1457 (while (memq (1+ num) hide)
1458 (setq num (1+ num)))
1459 num)))
1460
1461 (defun navi2ch-article-update-file (board article &optional force)
1462 "BOARD, ARTICLE \e$B$KBP1~$9$k%U%!%$%k$r99?7$9$k!#\e(B
1463 \e$BJV$jCM$O\e(B \(article header) \e$B$N%j%9%H!#\e(B"
1464 (let (header)
1465 (unless navi2ch-offline
1466 (let ((navi2ch-net-force-update (or navi2ch-net-force-update
1467 force))
1468 (file (navi2ch-article-get-file-name board article))
1469 start)
1470 (when (and (file-exists-p file)
1471 navi2ch-article-enable-diff)
1472 (setq start (1+ (navi2ch-count-lines-file file))))
1473 (setq header (navi2ch-multibbs-article-update board article start))
1474 (when header
1475 (unless (or (navi2ch-net-get-state 'not-updated header)
1476 (navi2ch-net-get-state 'error header))
1477 (setq article (navi2ch-put-alist 'time
1478 (or (cdr (assq 'last-modified
1479 header))
1480 (cdr (assq 'date
1481 header)))
1482 article)))
1483 (when (navi2ch-net-get-state 'kako header)
1484 (setq article (navi2ch-put-alist 'kako t article)))
1485 (when (and (cdr (assq 'down article))
1486 (or (navi2ch-net-get-state 'not-updated header)
1487 (not (navi2ch-net-get-state 'error header))))
1488 (setq article (navi2ch-put-alist 'down nil article))
1489 (navi2ch-article-uncompress board article)
1490 (navi2ch-article-save-info board article))
1491 (when (and (file-exists-p file)
1492 (file-readable-p file))
1493 (with-temp-buffer
1494 (navi2ch-insert-file-contents file)
1495 (setq article
1496 (navi2ch-put-alist
1497 'response
1498 (number-to-string (count-lines (point-min) (point-max)))
1499 article)))))))
1500 (list article header)))
1501
1502 (defun navi2ch-article-sync-from-file ()
1503 "from-file \e$B$J%9%l$r99?7$9$k!#\e(B"
1504 (let ((file (navi2ch-article-get-file-name navi2ch-article-current-board
1505 navi2ch-article-current-article)))
1506 (when (and (navi2ch-board-from-file-p navi2ch-article-current-board)
1507 (file-exists-p file))
1508 (let ((list (navi2ch-article-get-message-list file))
1509 (range navi2ch-article-view-range)
1510 (buffer-read-only nil))
1511 (erase-buffer)
1512 (navi2ch-article-insert-messages list range)
1513 (prog1
1514 (setq navi2ch-article-message-list list)
1515 (navi2ch-article-goto-number 1))))))
1516
1517 (defun navi2ch-article-set-mode-line ()
1518 (let ((article navi2ch-article-current-article)
1519 (x (cdr (car navi2ch-article-message-list))))
1520 (unless (assq 'subject article)
1521 (setq article (navi2ch-put-alist
1522 'subject
1523 (cdr (assq 'subject
1524 (if (stringp x)
1525 (navi2ch-article-parse-message x)
1526 x)))
1527 article)
1528 navi2ch-article-current-article article))
1529 (setq navi2ch-mode-line-identification
1530 (navi2ch-article-make-mode-line-identification article)))
1531 (navi2ch-set-mode-line-identification))
1532
1533 (defvar navi2ch-article-mode-line-format "%a (%n/%N) [%b] [%s]"
1534 "\e$B%9%lI=<(%P%C%U%!$N\e(B mode-line \e$B$N%U%)!<%^%C%H\e(B
1535
1536 \e$B0J2<$N$b$N$,CV$-49$($i$l$k!#\e(B
1537 %a - \e$B%9%l%C%IL>\e(B
1538 %b - \e$BHDL>\e(B
1539 %n - \e$B<B:]$N%l%9?t\e(B
1540 %N - \e$B%9%l0lMw$+$i<hF@$7$?%l%9?t\e(B
1541 %s - \e$B%9%l%9%H\e(B
1542 %% - %")
1543 (defun navi2ch-article-make-mode-line-identification (article)
1544 (navi2ch-replace-string
1545 "%."
1546 (lambda (str)
1547 (let ((char (aref str 1)))
1548 (cond
1549 ((eq char ?s)
1550 (if (cdr (assq 'stop article))
1551 "\e$B%9%l%9%H\e(B"
1552 ""))
1553 ((eq char ?a)
1554 (or (cdr (assq 'subject article))
1555 navi2ch-bm-empty-subject))
1556 ((eq char ?b)
1557 (or (cdr (assq 'name navi2ch-article-current-board))
1558 "-"))
1559 ((eq char ?n)
1560 (let ((l (length navi2ch-article-message-list)))
1561 (if (zerop l )
1562 "-"
1563 (number-to-string l))))
1564 ((eq char ?N)
1565 (or (cdr (assq 'response article)) "-"))
1566 ((eq char ?%) "%")
1567 (t ""))))
1568 navi2ch-article-mode-line-format t t t))
1569
1570 (defun navi2ch-article-thread-stop-p ()
1571 (if (cdr (assq 'stop navi2ch-article-current-article))
1572 t
1573 ;; \e$B%9%l%9%H$5$l$F$$$k%9%l\e(B(\e$BF|IUMs\e(B=\e$BDd;_$GH=CG\e(B)
1574 (when (string-match "^\e$BDd;_\e(B" (cdr (assq 'date (navi2ch-article-get-message (length navi2ch-article-message-list)))))
1575 (setq navi2ch-article-current-article
1576 (navi2ch-put-alist 'stop t navi2ch-article-current-article))
1577 (navi2ch-article-save-info
1578 navi2ch-article-current-board navi2ch-article-current-article))))
1579
1580 (defun navi2ch-article-sync-disable-diff (&optional force)
1581 (interactive "P")
1582 (let ((navi2ch-article-enable-diff nil))
1583 (navi2ch-article-sync force)))
1584
1585 (defun navi2ch-article-redraw ()
1586 "\e$B8=:_I=<($7$F$k%9%l$rI=<($7$J$*$9!#\e(B"
1587 (let ((buffer-read-only nil))
1588 (navi2ch-article-save-number)
1589 (erase-buffer)
1590 (navi2ch-article-insert-messages navi2ch-article-message-list
1591 navi2ch-article-view-range)
1592 (navi2ch-article-load-number)))
1593
1594 (defun navi2ch-article-select-view-range-subr ()
1595 "\e$BI=<($9$kHO0O$r%-!<%\!<%I%a%K%e!<$GA*Br$9$k!#\e(B"
1596 (save-window-excursion
1597 (delete-other-windows)
1598 (let (buf
1599 (range navi2ch-article-view-range))
1600 (unwind-protect
1601 (progn
1602 (setq buf (get-buffer-create "*select view range*"))
1603 (with-current-buffer buf
1604 (erase-buffer)
1605 (insert (format " %8s %8s\n" "first" "last"))
1606 (insert (format "0: %17s\n" "all range"))
1607 (let ((i 1))
1608 (dolist (x navi2ch-article-view-range-list)
1609 (insert (format "%d: %8d %8d\n" i (car x) (cdr x)))
1610 (setq i (1+ i)))))
1611 (display-buffer buf)
1612 (let (n)
1613 (setq n (navi2ch-read-char "Input: "))
1614 (when (or (< n ?0) (> n ?9))
1615 (error "%c is bad key" n))
1616 (setq n (- n ?0))
1617 (setq range
1618 (if (eq n 0) nil
1619 (nth (1- n) navi2ch-article-view-range-list)))))
1620 (if (bufferp buf)
1621 (kill-buffer buf)))
1622 range)))
1623
1624 (defun navi2ch-article-redraw-range ()
1625 "\e$BI=<($9$kHO0O$r;XDj$7$?8e\e(B redraw \e$B$9$k!#\e(B"
1626 (interactive)
1627 (setq navi2ch-article-view-range
1628 (navi2ch-article-select-view-range-subr))
1629 (sit-for 0)
1630 (navi2ch-article-redraw))
1631
1632 (defun navi2ch-article-save-number ()
1633 (unless (or navi2ch-article-hide-mode
1634 navi2ch-article-important-mode)
1635 (let ((num (navi2ch-article-get-current-number)))
1636 (when num
1637 (setq navi2ch-article-current-article
1638 (navi2ch-put-alist 'number
1639 num
1640 navi2ch-article-current-article))))))
1641
1642 (defun navi2ch-article-load-number ()
1643 (let ((num (cdr (assq 'number navi2ch-article-current-article)))
1644 (list (cond
1645 (navi2ch-article-hide-mode
1646 (cdr (assq 'hide navi2ch-article-current-article)))
1647 (navi2ch-article-important-mode
1648 (cdr (assq 'important navi2ch-article-current-article)))
1649 (t nil))))
1650 (when list
1651 (let (nearest_len nearest_n)
1652 (dolist (n list)
1653 (let ((len (abs (- n num))))
1654 (when (or (null nearest_len)
1655 (< len nearest_len))
1656 (setq nearest_len len
1657 nearest_n n))))
1658 (setq num nearest_n)))
1659 (when (or list
1660 (not (or navi2ch-article-hide-mode
1661 navi2ch-article-important-mode)))
1662 (navi2ch-article-goto-number (or num 1)))))
1663
1664 (defun navi2ch-article-save-info (&optional board article first)
1665 (let (ignore)
1666 (when (eq major-mode 'navi2ch-article-mode)
1667 (if (navi2ch-board-from-file-p (or board navi2ch-article-current-board))
1668 (setq ignore t)
1669 (when (and navi2ch-article-message-list (not first))
1670 (navi2ch-article-save-number))
1671 (or board (setq board navi2ch-article-current-board))
1672 (or article (setq article navi2ch-article-current-article))))
1673 (when (and (not ignore) board article)
1674 (let* ((article-tmp (if navi2ch-article-save-info-wrapper-func
1675 (funcall navi2ch-article-save-info-wrapper-func article)
1676 article))
1677 (alist (mapcar
1678 (lambda (x)
1679 (assq x article-tmp))
1680 navi2ch-article-save-info-keys)))
1681 (navi2ch-save-info (navi2ch-article-get-info-file-name board article) alist)
1682 (navi2ch-article-save-message-filter-cache board article)))))
1683
1684 (defun navi2ch-article-load-info (&optional board article)
1685 (let (ignore alist)
1686 (if (navi2ch-board-from-file-p (or board navi2ch-article-current-board))
1687 (setq ignore t)
1688 (or board (setq board navi2ch-article-current-board))
1689 (or article (setq article navi2ch-article-current-article)))
1690 (when (and (not ignore) board article)
1691 (setq alist (navi2ch-load-info
1692 (navi2ch-article-get-info-file-name board article)))
1693 (dolist (x alist)
1694 (setq article (navi2ch-put-alist (car x) (cdr x) article)))
1695 article)))
1696
1697 (defun navi2ch-article-write-message (&optional sage cite)
1698 (interactive)
1699 (if (cdr (assq 'stop navi2ch-article-current-article))
1700 (error "\e$B%9%l%9%H$5$l$?%9%l$K$O=q$-9~$a$^$;$s\e(B"))
1701 (when (not (navi2ch-board-from-file-p navi2ch-article-current-board))
1702 (navi2ch-article-save-number)
1703 (navi2ch-message-write-message navi2ch-article-current-board
1704 navi2ch-article-current-article
1705 nil sage cite)))
1706
1707 (defun navi2ch-article-write-sage-message ()
1708 (interactive)
1709 (navi2ch-article-write-message 'sage))
1710
1711 (defun navi2ch-article-write-cite-message ()
1712 (interactive)
1713 (navi2ch-article-write-message 'sage 'cite))
1714
1715 (defun navi2ch-article-str-to-num (str)
1716 "\e$B%l%9;2>H$NJ8;zNs$r?t;z$+?t;z$N\e(B list \e$B$KJQ49!#\e(B"
1717 (cond ((string-match "\\([0-9]+\\)-\\([0-9]+\\)" str)
1718 (let* ((n1 (string-to-number (match-string 1 str)))
1719 (n2 (string-to-number (match-string 2 str)))
1720 (min (max (min n1 n2) 1))
1721 (i (min (max n1 n2)
1722 (1+ (navi2ch-article-get-article-length))))
1723 list)
1724 (while (>= i min)
1725 (push i list)
1726 (setq i (1- i)))
1727 list))
1728 ((string-match "\\([0-9]+,\\)+[0-9]+" str)
1729 (mapcar 'string-to-number (split-string str ",")))
1730 (t (string-to-number str))))
1731
1732 (defun navi2ch-article-get-article-length ()
1733 (let* ((board (or navi2ch-article-current-board
1734 navi2ch-popup-article-current-board))
1735 (article (or navi2ch-article-current-article
1736 navi2ch-popup-article-current-article))
1737 (buffer-name (navi2ch-article-get-buffer-name board article)))
1738 (with-current-buffer (or (get-buffer buffer-name)
1739 (progn
1740 (navi2ch-article-view-article board article nil nil nil t)
1741 buffer-name))
1742 (length navi2ch-article-message-list))))
1743
1744 (defun navi2ch-article-get-number-list (number-property &optional limit)
1745 (or (and (string-match "[^ ][^ ][^ ][^ ][^ ][^ ][^ ][^ ]" number-property)
1746 (let (nums)
1747 (cl-dolist (msg navi2ch-article-message-list (nreverse nums))
1748 (when (listp (cdr msg))
1749 (let ((date (cdr (assq 'date (cdr msg))))
1750 (name (cdr (assq 'name (cdr msg)))))
1751 (when (or (and date
1752 (string-match " ID:\\([^ ][^ ][^ ][^ ]+\\)"
1753 ;; ID:??? \e$B$O%9%k!<\e(B
1754 date)
1755 (string-match (regexp-quote
1756 (match-string 1 date))
1757 number-property))
1758 (and name
1759 (string-match "\e$B"!\e(B\\([^ ]+\\)" name)
1760 (string-match (regexp-quote
1761 (match-string 1 name))
1762 number-property)))
1763 (if (and (numberp limit)
1764 (>= (car msg) limit)
1765 nums)
1766 (cl-return (car nums))
1767 (push (car msg) nums))))))))
1768 (navi2ch-article-str-to-num (japanese-hankaku number-property))))
1769
1770 (defun navi2ch-article-select-current-link (&optional browse-p)
1771 (interactive "P")
1772 (let ((type (get-text-property (point) 'navi2ch-link-type))
1773 (prop (get-text-property (point) 'navi2ch-link)))
1774 (cond ((eq type 'number)
1775 (navi2ch-article-select-current-link-number
1776 (navi2ch-article-get-number-list prop)
1777 browse-p))
1778 ((eq type 'url)
1779 (navi2ch-article-select-current-link-url prop browse-p nil))
1780 ((and (eq type 'image)
1781 (featurep 'navi2ch-thumbnail))
1782 (navi2ch-thumbnail-browse-image-in-message (point)))
1783 ((eq type 'content)
1784 (navi2ch-article-save-content)))))
1785
1786 (defun navi2ch-article-number-list-to-url (number-list)
1787 (navi2ch-article-to-url navi2ch-article-current-board
1788 navi2ch-article-current-article
1789 (if (numberp number-list)
1790 number-list
1791 (apply #'min number-list))
1792 (if (numberp number-list)
1793 number-list
1794 (apply #'max number-list))
1795 t))
1796
1797 (defun navi2ch-article-select-current-link-number (prop browse-p)
1798 ;; prop \e$B$O!V?t$N\e(B list\e$B!W$+!V?t!W!#\e(B
1799 (cond (browse-p
1800 (navi2ch-browse-url-internal
1801 (navi2ch-article-number-list-to-url prop)))
1802 ((eq navi2ch-article-select-current-link-number-style 'popup)
1803 (navi2ch-popup-article (if (listp prop) prop (list prop))))
1804 ((eq navi2ch-article-select-current-link-number-style 'jump)
1805 (let ((navi2ch-article-redraw-when-goto-number t))
1806 (navi2ch-article-goto-number (if (listp prop) (car prop) prop)
1807 t t)))
1808 ;; (eq navi2ch-article-select-current-link-number-style 'auto)
1809 ((numberp prop)
1810 (let ((hide (cdr (assq 'hide navi2ch-article-current-article)))
1811 (imp (cdr (assq 'important navi2ch-article-current-article)))
1812 (range navi2ch-article-view-range)
1813 (len (length navi2ch-article-message-list)))
1814 (if (cond (navi2ch-article-hide-mode
1815 (memq prop hide))
1816 (navi2ch-article-important-mode
1817 (memq prop imp))
1818 (t
1819 (and (navi2ch-article-inside-range-p prop range len)
1820 (not (memq prop hide)))))
1821 (navi2ch-article-goto-number prop t t)
1822 (navi2ch-popup-article (list prop)))))
1823 (t
1824 (navi2ch-popup-article prop))))
1825
1826 (defun navi2ch-article-select-current-link-url (url browse-p popup)
1827 (if (and (not browse-p)
1828 (navi2ch-2ch-url-p url))
1829 (progn
1830 (if popup
1831 (navi2ch-popup-article-exit)
1832 (and (get-text-property (point) 'help-echo)
1833 (let ((buffer-read-only nil))
1834 (navi2ch-article-change-help-echo-property
1835 (point) (function navi2ch-article-help-echo)))))
1836 (navi2ch-goto-url url))
1837 (navi2ch-browse-url-internal url)))
1838
1839 (defun navi2ch-article-mouse-select (e)
1840 (interactive "e")
1841 (mouse-set-point e)
1842 (navi2ch-article-select-current-link))
1843
1844 (defun navi2ch-article-recenter (num)
1845 "NUM \e$BHVL\$N%l%9$r2hLL$N0lHV>e$K!#\e(B"
1846 (let ((win (if (eq (window-buffer) (current-buffer))
1847 (selected-window)
1848 (get-buffer-window (current-buffer)))))
1849 (if (and win (numberp num))
1850 (set-window-start
1851 win (cdr (assq 'point (navi2ch-article-get-message num)))))))
1852
1853 (defun navi2ch-article-goto-number-or-board ()
1854 "\e$BF~NO$5$l$??t;z$N0LCV$K0\F0$9$k$+!"F~NO$5$l$?HD$rI=<($9$k!#\e(B
1855 \e$BL>A0$,?t;z$J$i$P%G%U%)%k%H$O$=$NL>A0$N?t;z!#\e(B"
1856 (interactive)
1857 (let (default alist ret)
1858 (setq default
1859 (let* ((msg (navi2ch-article-get-message
1860 (navi2ch-article-get-current-number)))
1861 (from (cdr (assq 'name msg)))
1862 (data (cdr (assq 'data msg))))
1863 (or (and from
1864 (string-match "^[^\e$B"!\e(B0-9\e$B#0\e(B-\e$B#9\e(B]*\\([0-9\e$B#0\e(B-\e$B#9\e(B]+\\)" from)
1865 (japanese-hankaku (match-string 1 from)))
1866 (and data
1867 (string-match "[0-9\e$B#0\e(B-\e$B#9\e(B]+" data)
1868 (japanese-hankaku (match-string 0 data)))
1869 nil)))
1870 (setq alist (mapcar (lambda (x) (cons (cdr (assq 'id x)) x))
1871 navi2ch-list-board-name-list))
1872 (setq ret (completing-read
1873 (concat "Input number or board"
1874 (and default (format "(%s)" default))
1875 ": ")
1876 alist nil nil))
1877 (setq ret (if (string= ret "") default ret))
1878 (if ret
1879 (let ((num (string-to-number ret)))
1880 (if (and (> num 0)
1881 (equal ret (number-to-string num)))
1882 (navi2ch-article-goto-number num t t)
1883 (let (board board-id)
1884 (setq board-id (try-completion ret alist))
1885 (and (eq board-id t) (setq board-id ret))
1886 (setq board (cdr (assoc board-id alist)))
1887 (if board
1888 (progn
1889 (when (eq (navi2ch-get-major-mode
1890 navi2ch-board-buffer-name)
1891 'navi2ch-board-mode)
1892 (navi2ch-board-save-info navi2ch-board-current-board))
1893 (navi2ch-article-exit)
1894 (navi2ch-bm-select-board board))
1895 (error "No such board"))))))))
1896
1897 (defun navi2ch-article-goto-number (num &optional save pop)
1898 "NUM \e$BHVL\$N%l%9$K0\F0!#\e(B"
1899 (interactive "nInput number: ")
1900 (when (and num (> num 0)
1901 navi2ch-article-message-list)
1902 (when (or (interactive-p) save)
1903 (navi2ch-article-push-point))
1904 (catch 'break
1905 (let ((len (length navi2ch-article-message-list))
1906 (range navi2ch-article-view-range)
1907 (first (caar navi2ch-article-message-list))
1908 (last (caar (last navi2ch-article-message-list))))
1909 (setq num (max first (min last num)))
1910 (unless (or navi2ch-article-hide-mode
1911 navi2ch-article-important-mode
1912 (if navi2ch-article-use-jit
1913 (condition-case nil
1914 (cdr (assq 'point (navi2ch-article-get-message num)))
1915 (error nil))
1916 (navi2ch-article-inside-range-p num range len)))
1917 (if navi2ch-article-redraw-when-goto-number
1918 (if navi2ch-article-use-jit
1919 (let (buffer-read-only)
1920 (navi2ch-article-reinsert-partial-messages num num))
1921 (navi2ch-article-fix-range num)
1922 (navi2ch-article-redraw))
1923 (if (or (interactive-p) pop)
1924 (progn (when (or (interactive-p) save)
1925 (navi2ch-article-pop-point))
1926 (navi2ch-popup-article (list num))
1927 (throw 'break nil))
1928 (setq num (1+ (- len (cdr range))))))))
1929 (condition-case nil
1930 (goto-char (cdr (assq 'point (navi2ch-article-get-message num))))
1931 (error nil))
1932 (if navi2ch-article-goto-number-recenter
1933 (navi2ch-article-recenter (navi2ch-article-get-current-number))))
1934 (force-mode-line-update t)))
1935
1936 (defun navi2ch-article-goto-board (&optional board)
1937 "BOARD \e$B$G;XDj$5$l$?HD$K0\F0!#\e(B
1938 BOARD \e$B$,\e(B nil \e$B$J$i$P!"8=:_3+$$$F$$$k%9%l$NHD$K0\F0!#\e(B"
1939 (interactive)
1940 (navi2ch-list-goto-board (or board
1941 navi2ch-article-current-board)))
1942
1943 (defun navi2ch-article-get-point (&optional point)
1944 (save-window-excursion
1945 (save-excursion
1946 (if point (goto-char point) (setq point (point)))
1947 (let ((num (navi2ch-article-get-current-number)))
1948 (navi2ch-article-goto-number num)
1949 (cons num (- point (point)))))))
1950
1951 (defun navi2ch-article-pop-point ()
1952 "stack \e$B$+$i\e(B pop \e$B$7$?0LCV$K0\F0$9$k!#\e(B"
1953 (interactive)
1954 (let ((point (pop navi2ch-article-point-stack)))
1955 (if point
1956 (progn
1957 (push (navi2ch-article-get-point (point)) navi2ch-article-poped-point-stack)
1958 (navi2ch-article-goto-number (car point))
1959 (forward-char (cdr point)))
1960 (message "Stack is empty"))))
1961
1962 (defun navi2ch-article-push-point (&optional point)
1963 "\e$B8=:_0LCV$+\e(B POINT \e$B$r\e(B stack \e$B$K\e(B push \e$B$9$k!#\e(B"
1964 (interactive)
1965 (setq navi2ch-article-poped-point-stack nil)
1966 (push (navi2ch-article-get-point point) navi2ch-article-point-stack)
1967 (message "Push current point"))
1968
1969 (defun navi2ch-article-pop-poped-point () ; \e$BL>A0$@$;$'!"$C$F$+2?$+0c$&!#\e(B
1970 (interactive)
1971 (let ((point (pop navi2ch-article-poped-point-stack)))
1972 (if point
1973 (progn
1974 (push (navi2ch-article-get-point (point)) navi2ch-article-point-stack)
1975 (navi2ch-article-goto-number (car point))
1976 (forward-char (cdr point)))
1977 (message "Stack is empty"))))
1978
1979 (defun navi2ch-article-rotate-point ()
1980 "stack \e$B$X\e(B push \e$B$7$?0LCV$r=d2s$9$k!#\e(B"
1981 (interactive)
1982 (let ((cur (navi2ch-article-get-point nil)) ; \e$B8=:_CO\e(B
1983 (top (pop navi2ch-article-point-stack))) ; \e$B%H%C%W\e(B
1984 (if top
1985 (progn
1986 (setq navi2ch-article-point-stack
1987 (append navi2ch-article-point-stack (list cur))) ; \e$B:G8eHx$XJ]B8\e(B
1988 (navi2ch-article-goto-number (car top)) ; \e$B%H%C%W$N\e(B
1989 (forward-char (cdr top))) ; \e$B0JA0$$$?J8;z$X\e(B
1990 (message "Stack is empty"))))
1991
1992 (defun navi2ch-article-goto-last-message ()
1993 "\e$B:G8e$N%l%9$X0\F0!#\e(B"
1994 (interactive)
1995 (navi2ch-article-goto-number
1996 (save-excursion
1997 (goto-char (point-max))
1998 (navi2ch-article-get-current-number)) t))
1999
2000 (defun navi2ch-article-goto-first-message ()
2001 "\e$B:G=i$N%l%9$X0\F0!#\e(B"
2002 (interactive)
2003 (navi2ch-article-goto-number
2004 (save-excursion
2005 (goto-char (point-min))
2006 (navi2ch-article-get-current-number)) t))
2007
2008 (defun navi2ch-article-few-scroll-up (n)
2009 (interactive "P")
2010 (scroll-up (or n 1)))
2011
2012 (defun navi2ch-article-few-scroll-down (n)
2013 (interactive "P")
2014 (scroll-down (or n 1)))
2015
2016 (defun navi2ch-article-scroll-up ()
2017 (interactive)
2018 (condition-case nil
2019 (scroll-up)
2020 (end-of-buffer
2021 (funcall navi2ch-article-through-next-function)))
2022 (force-mode-line-update t))
2023
2024 (defun navi2ch-article-scroll-down ()
2025 (interactive)
2026 (condition-case nil
2027 (scroll-down)
2028 (beginning-of-buffer
2029 (funcall navi2ch-article-through-previous-function)))
2030 (force-mode-line-update t))
2031
2032 (defun navi2ch-article-through-ask-y-or-n-p (num title)
2033 "\e$B<!$N%9%l$K0\F0$9$k$H$-$K\e(B \"y or n\" \e$B$G3NG'$9$k!#\e(B"
2034 (if title
2035 (navi2ch-y-or-n-p
2036 (concat title " --- Through " (if (< num 0) "previous" "next")
2037 " article or quit? ")
2038 'quit)
2039 (when (navi2ch-y-or-n-p
2040 (concat " --- The " (if (< num 0) "first" "last")
2041 " article. Quit? ")
2042 t)
2043 'quit)))
2044
2045 (defun navi2ch-article-through-ask-n-or-p-p (num title)
2046 "\e$B<!$N%9%l$K0\F0$9$k$H$-$K\e(B \"n\" \e$B$+\e(B \"p\" \e$B$G3NG'$9$k!#\e(B"
2047 (let* ((accept-key (if (< num 0) '(?p ?P ?\177) '(?n ?N ?\ )))
2048 (accept-value (if title t 'quit))
2049 (prompt (if title
2050 (format "%s --- Through %s article or quit? (%c or q) "
2051 title (if (< num 0) "previous" "next")
2052 (car accept-key))
2053 (format " --- The %s article. Quit? (%c or q) "
2054 (if (< num 0) "first" "last")
2055 (car accept-key))))
2056 (c (navi2ch-read-char prompt)))
2057 (if (memq c accept-key)
2058 accept-value
2059 (push (navi2ch-ifxemacs (character-to-event c) c)
2060 unread-command-events)
2061 nil)))
2062
2063 (defun navi2ch-article-through-ask-last-command-p (num title)
2064 "\e$B<!$N%9%l$K0\F0$9$k$H$-$K!"D>A0$N%3%^%s%I$HF1$8$+$G3NG'$9$k!#\e(B"
2065 (let* ((accept-value (if title t 'quit))
2066 (prompt (if title
2067 (format "Type %s for %s "
2068 (single-key-description last-command-event)
2069 title)
2070 (format "The %s article. Type %s for quit "
2071 (if (< num 0) "first" "last")
2072 (single-key-description last-command-event))))
2073 (e (navi2ch-read-event prompt)))
2074 (if (equal e last-command-event)
2075 accept-value
2076 (push e unread-command-events)
2077 nil)))
2078
2079 (defun navi2ch-article-through-ask (no-ask num)
2080 "\e$B<!$N%9%l$K0\F0$9$k$+J9$/!#\e(B
2081 \e$B<!$N%9%l$K0\F0$9$k$J$i\e(B t \e$B$rJV$9!#\e(B
2082 \e$B0\F0$7$J$$$J$i\e(B nil \e$B$rJV$9!#\e(B
2083 article buffer \e$B$+$iH4$1$k$J$i\e(B 'quit \e$B$rJV$9!#\e(B"
2084 (if (or (eq navi2ch-article-enable-through 'ask-always)
2085 (and (not no-ask)
2086 (eq navi2ch-article-enable-through 'ask)))
2087 (funcall navi2ch-article-through-ask-function
2088 num
2089 (with-current-buffer navi2ch-board-buffer-name
2090 (save-excursion
2091 (when (zerop
2092 (funcall
2093 navi2ch-article-through-forward-line-function num))
2094 (cdr (assq 'subject
2095 (navi2ch-bm-get-article-internal
2096 (navi2ch-bm-get-property-internal
2097 (point)))))))))
2098 (or no-ask
2099 navi2ch-article-enable-through)))
2100
2101 (defun navi2ch-article-through-subr (interactive-flag num)
2102 "\e$BA08e$N%9%l$K0\F0$9$k!#\e(B
2103 NUM \e$B$,\e(B 1 \e$B$N$H$-$O<!!"\e(B-1 \e$B$N$H$-$OA0$N%9%l$K0\F0!#\e(B
2104 \e$B8F$S=P$9:]$O\e(B INTERACTIVE-FLAG \e$B$K\e(B (interactive-p) \e$B$rF~$l$k!#\e(B"
2105 (interactive)
2106 (or num (setq num 1))
2107 (if (and (not (eq num 1))
2108 (not (eq num -1)))
2109 (error "Arg error"))
2110 (let ((mode (navi2ch-get-major-mode navi2ch-board-buffer-name)))
2111 (if (and mode
2112 (or (not (eq mode 'navi2ch-board-mode))
2113 (and (eq mode 'navi2ch-board-mode)
2114 (navi2ch-board-equal navi2ch-article-current-board
2115 navi2ch-board-current-board))))
2116 (let ((ret (navi2ch-article-through-ask interactive-flag num)))
2117 (cond ((eq ret 'quit)
2118 ;;; (goto-char (if (> num 0) (point-max) (point-min)))
2119 (navi2ch-article-exit))
2120 (ret
2121 ;;; (goto-char (if (> num 0) (point-max) (point-min)))
2122 (let ((window (get-buffer-window navi2ch-board-buffer-name)))
2123 (if window
2124 (progn
2125 (delete-window)
2126 (select-window window))
2127 (switch-to-buffer navi2ch-board-buffer-name)))
2128 (if (zerop
2129 (funcall navi2ch-article-through-forward-line-function
2130 num))
2131 (progn
2132 (recenter (/ navi2ch-board-window-height 2))
2133 (navi2ch-bm-select-article))
2134 (message "Can't through article")))
2135 (t
2136 (message "Don't through article"))))
2137 (message "Don't through article"))))
2138
2139 (defun navi2ch-article-through-next ()
2140 "\e$B<!$N%9%l$K0\F0$9$k!#\e(B"
2141 (interactive)
2142 (navi2ch-article-through-subr (interactive-p) 1))
2143
2144 (defun navi2ch-article-through-previous ()
2145 "\e$BA0$N%9%l$K0\F0$9$k!#\e(B"
2146 (interactive)
2147 (navi2ch-article-through-subr (interactive-p) -1))
2148
2149 (defun navi2ch-article-get-current-number ()
2150 "\e$B:#$N0LCV$N%l%9$NHV9f$rF@$k!#\e(B"
2151 (condition-case nil
2152 (or (get-text-property (point) 'current-number)
2153 (get-text-property
2154 (navi2ch-previous-property (point) 'current-number)
2155 'current-number))
2156 (error nil)))
2157
2158 (defsubst navi2ch-article-get-current-name ()
2159 (cdr (assq 'name (cdr (assq (navi2ch-article-get-current-number)
2160 navi2ch-article-message-list)))))
2161
2162 (defsubst navi2ch-article-get-current-mail ()
2163 (cdr (assq 'mail (cdr (assq (navi2ch-article-get-current-number)
2164 navi2ch-article-message-list)))))
2165
2166 (defun navi2ch-article-get-current-date ()
2167 (let ((date (cdr (assq 'date (cdr (assq (navi2ch-article-get-current-number)
2168 navi2ch-article-message-list))))))
2169 (if (string-match " ID:.*" date)
2170 (replace-match "" nil t date)
2171 date)))
2172
2173 (defun navi2ch-article-get-current-id ()
2174 (let ((date (cdr (assq 'date (cdr (assq (navi2ch-article-get-current-number)
2175 navi2ch-article-message-list))))))
2176 (if (string-match " ID:\\([^ ]+\\)" date)
2177 (match-string 1 date)
2178 nil)))
2179
2180 (defun navi2ch-article-get-current-hostname ()
2181 (let ((date (cdr (assq 'date (cdr (assq (navi2ch-article-get-current-number)
2182 navi2ch-article-message-list))))))
2183 (if (or (string-match "\\[ \\([^ ]+\\) \\]" date)
2184 (string-match "\e$BH/?.85\e(B:\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" date))
2185 (match-string 1 date)
2186 nil)))
2187
2188 (defun navi2ch-article-get-current-word-in-body ()
2189 (let ((case-fold-search nil)
2190 (word (if (eq (get-text-property (point) 'navi2ch-link-type) 'url)
2191 (buffer-substring-no-properties
2192 (if (eq (get-text-property (1- (point)) 'navi2ch-link-type) 'url)
2193 (previous-single-property-change (point) 'navi2ch-link)
2194 (point))
2195 (next-single-property-change (point) 'navi2ch-link))
2196 (current-word))))
2197 (when (and word
2198 (string-match
2199 (regexp-quote word)
2200 (navi2ch-article-get-message-string
2201 (navi2ch-article-get-current-number))))
2202 word)))
2203
2204 (defun navi2ch-article-get-current-subject ()
2205 (or (cdr (assq 'subject navi2ch-article-current-article))
2206 (cdr (assq 'subject
2207 (let ((msg (navi2ch-article-get-message 1)))
2208 (if (stringp msg)
2209 (navi2ch-article-parse-message msg)
2210 msg))))
2211 ""))
2212
2213 (defun navi2ch-article-get-visible-numbers ()
2214 "\e$BI=<(Cf$N%l%9$NHV9f$N%j%9%H$rF@$k!#\e(B"
2215 (let (list prev)
2216 (save-excursion
2217 (goto-char (point-max))
2218 (unless (bobp)
2219 (while (setq prev (navi2ch-previous-property (point) 'current-number))
2220 (goto-char prev)
2221 (setq list (cons (get-text-property (point) 'current-number) list)))))
2222 list))
2223
2224 (defun navi2ch-article-show-url ()
2225 "url \e$B$rI=<($7$F!"$=$N\e(B url \e$B$r8+$k$+\e(B kill ring \e$B$K%3%T!<$9$k!#\e(B"
2226 (interactive)
2227 (let ((url (navi2ch-article-to-url navi2ch-article-current-board
2228 navi2ch-article-current-article)))
2229 (let ((char (navi2ch-read-char-with-retry
2230 (format "c)opy v)iew t)itle? URL: %s: " url)
2231 nil '(?c ?v ?t))))
2232 (if (eq char ?t)
2233 (navi2ch-article-copy-title navi2ch-article-current-board
2234 navi2ch-article-current-article)
2235 (funcall (cond ((eq char ?c)
2236 (lambda (x)
2237 (kill-new x)
2238 (message "Copy: %s" x)))
2239 ((eq char ?v)
2240 (lambda (x)
2241 (navi2ch-browse-url-internal x)
2242 (message "View: %s" x))))
2243 (navi2ch-article-show-url-subr))))))
2244
2245 (defun navi2ch-article-show-url-subr ()
2246 "\e$B%a%K%e!<$rI=<($7$F!"\e(Burl \e$B$rF@$k!#\e(B"
2247 (let* ((prompt (format "a)ll c)urrent r)egion b)oard l)ast%d: "
2248 navi2ch-article-show-url-number))
2249 (char (navi2ch-read-char-with-retry prompt
2250 nil '(?a ?c ?r ?b ?l))))
2251 (if (eq char ?b)
2252 (navi2ch-board-to-url navi2ch-article-current-board)
2253 (apply 'navi2ch-article-to-url
2254 navi2ch-article-current-board navi2ch-article-current-article
2255 (cond ((eq char ?a) nil)
2256 ((eq char ?l)
2257 (let ((l (format "l%d"
2258 navi2ch-article-show-url-number)))
2259 (list l l nil)))
2260 ((eq char ?c) (list (navi2ch-article-get-current-number)
2261 (navi2ch-article-get-current-number)
2262 t))
2263 ((eq char ?r)
2264 (let ((rb (region-beginning)) (re (region-end)))
2265 (save-excursion
2266 (list (progn (goto-char rb)
2267 (navi2ch-article-get-current-number))
2268 (progn (goto-char re)
2269 (navi2ch-article-get-current-number))
2270 t)))))))))
2271
2272 (defun navi2ch-article-copy-title (board article)
2273 "\e$B%a%K%e!<$rI=<($7$F!"%?%$%H%k$rF@$k!#\e(B"
2274 (let* ((char (navi2ch-read-char-with-retry
2275 "b)oard a)rticle B)oard&url A)rticle&url: "
2276 nil '(?b ?a ?B ?A)))
2277 (title (cond ((eq char ?b)
2278 (cdr (assq 'name board)))
2279 ((eq char ?a)
2280 (when article
2281 (cdr (assq 'subject article))))
2282 ((eq char ?B)
2283 (concat (cdr (assq 'name board))
2284 "\n"
2285 (navi2ch-board-to-url board)))
2286 ((eq char ?A)
2287 (when article
2288 (concat (cdr (assq 'subject article))
2289 "\n"
2290 (navi2ch-article-to-url board article)))))))
2291 (if (not title)
2292 (message "Can't select this line!")
2293 (kill-new title)
2294 (message "Copy: %s" title))))
2295
2296 (defun navi2ch-article-redisplay-current-message ()
2297 "\e$B:#$$$k%l%9$r2hLL$NCf?4\e(B (\e$B>e\e(B?) \e$B$K!#\e(B"
2298 (interactive)
2299 (navi2ch-article-recenter
2300 (navi2ch-article-get-current-number)))
2301
2302 (defun navi2ch-article-next-message ()
2303 "\e$B<!$N%a%C%;!<%8$X0\F0!#\e(B"
2304 (interactive)
2305 (run-hooks 'navi2ch-article-next-message-hook)
2306 (condition-case nil
2307 (progn
2308 (goto-char (navi2ch-next-property (point) 'current-number))
2309 (navi2ch-article-goto-number
2310 (navi2ch-article-get-current-number)))
2311 (error
2312 (funcall navi2ch-article-through-next-function))))
2313
2314 (defun navi2ch-article-previous-message ()
2315 "\e$BA0$N%a%C%;!<%8$X0\F0!#\e(B"
2316 (interactive)
2317 (run-hooks 'navi2ch-article-previous-message-hook)
2318 (condition-case nil
2319 (progn
2320 (goto-char (navi2ch-previous-property (point) 'current-number))
2321 (navi2ch-article-goto-number
2322 (navi2ch-article-get-current-number)))
2323 (error
2324 (funcall navi2ch-article-through-previous-function))))
2325
2326 (defun navi2ch-article-get-message-string (num)
2327 "NUM \e$BHVL\$N%l%9$NJ8>O$rF@$k!#\e(B"
2328 (let ((msg (navi2ch-article-get-message num)))
2329 (when (stringp msg)
2330 (setq msg (navi2ch-article-parse-message msg)))
2331 (cdr (assq 'data msg))))
2332
2333 (defun navi2ch-article-cached-subject-minimum-size (board article)
2334 "\e$B%9%l%?%$%H%k$rF@$k$N$K==J,$J%U%!%$%k%5%$%:$r5a$a$k!#\e(B"
2335 (with-temp-buffer
2336 (let ((beg 0) (end 0) (n 1))
2337 (while (and (= (point) (point-max))
2338 (> n 0))
2339 (setq beg end)
2340 (setq end (+ end 1024))
2341 (setq n (car (cdr (navi2ch-board-insert-file-contents
2342 board
2343 (navi2ch-article-get-file-name board article)
2344 beg end))))
2345 (forward-line))
2346 end)))
2347
2348 (defun navi2ch-article-cached-subject (board article)
2349 "\e$B%-%c%C%7%e$5$l$F$$$k\e(B dat \e$B%U%!%$%k$+$i%9%l%?%$%H%k$rF@$k!#\e(B"
2350 ;; "\e$B%-%c%C%7%e$5$l$F$$$k\e(B dat \e$B%U%!%$%k$d%9%l0lMw$+$i%9%l%?%$%H%k$rF@$k!#\e(B"
2351 (let ((state (navi2ch-article-check-cached board article))
2352 subject)
2353 (if (eq state 'view)
2354 (with-current-buffer (navi2ch-article-get-buffer-name board article)
2355 (setq subject ; nil \e$B$K$J$k$3$H$,$"$k\e(B
2356 (cdr (assq 'subject
2357 navi2ch-article-current-article)))))
2358 (when (not subject)
2359 (if (eq state 'cache)
2360 (let* ((file (navi2ch-article-get-file-name board article))
2361 (msg-list (navi2ch-article-get-message-list
2362 file
2363 0
2364 (navi2ch-article-cached-subject-minimum-size board article))))
2365 (setq subject
2366 (cdr (assq 'subject
2367 (navi2ch-article-parse-message (cdar msg-list))))))))
2368 (when (not subject)
2369 (let ((subject-list
2370 (if (equal (cdr (assq 'name board))
2371 (cdr (assq 'name navi2ch-board-current-board)))
2372 navi2ch-board-subject-list
2373 ;;; (navi2ch-board-get-subject-list
2374 ;;; (navi2ch-board-get-file-name board))
2375 )))
2376 (setq subject
2377 (catch 'subject
2378 (dolist (s subject-list)
2379 (if (equal (cdr (assq 'artid article))
2380 (cdr (assq 'artid s)))
2381 (throw 'subject (cdr (assq 'subject s)))))))))
2382 (when (not subject)
2383 (setq subject "navi2ch: ???")) ; \e$BJQ?t$K$7$F\e(B navi2ch-vars.el \e$B$KF~$l$k$Y$-\e(B?
2384 subject))
2385
2386 (eval-when-compile
2387 (defvar mark-active)
2388 (defvar deactivate-mark))
2389
2390 (defun navi2ch-article-get-link-text-subr (&optional point)
2391 "POINT (\e$B>JN,;~$O%+%l%s%H%]%$%s%H\e(B) \e$B$N%j%s%/@h$rF@$k!#\e(B"
2392 (setq point (or point (point)))
2393 (let (mark-active deactivate-mark) ; transient-mark-mode \e$B$,@Z$l$J$$$h$&\e(B
2394 (catch 'ret
2395 (when (or (eq major-mode 'navi2ch-article-mode)
2396 (eq major-mode 'navi2ch-popup-article-mode))
2397 (let ((type (get-text-property point 'navi2ch-link-type))
2398 (prop (get-text-property point 'navi2ch-link))
2399 num-list num)
2400 (cond
2401 ((eq type 'number)
2402 (setq num-list (navi2ch-article-get-number-list
2403 prop (navi2ch-article-get-current-number)))
2404 (cond ((numberp num-list)
2405 (setq num num-list))
2406 (t
2407 (setq num (car num-list))))
2408 (let ((msg (navi2ch-article-get-message-string num)))
2409 (when msg
2410 (setq msg (navi2ch-replace-string
2411 navi2ch-article-citation-regexp "" msg t))
2412 (setq msg (navi2ch-replace-string
2413 "\\(\\cj\\)\n+\\(\\cj\\)" "\\1\\2" msg t))
2414 (setq msg (navi2ch-replace-string "\n+" " " msg t))
2415 (throw
2416 'ret
2417 (format "%s" (truncate-string-to-width
2418 (format "[%d]: %s" num msg)
2419 (eval navi2ch-article-display-link-width)))))))
2420 ((and navi2ch-article-get-url-text
2421 (eq type 'url))
2422 (if (navi2ch-2ch-url-p prop)
2423 (let ((board (navi2ch-board-url-to-board prop))
2424 (article (navi2ch-article-url-to-article prop)))
2425 (throw
2426 'ret
2427 (format "%s"
2428 (truncate-string-to-width
2429 (if article
2430 (format "[%s]: %s"
2431 (cdr (assq 'name board))
2432 (navi2ch-article-cached-subject board article))
2433 (format "[%s]" (cdr (assq 'name board))))
2434 (eval navi2ch-article-display-link-width))))))))))
2435 nil)))
2436
2437 (defun navi2ch-article-get-link-text (&optional point)
2438 "POINT (\e$B>JN,;~$O%+%l%s%H%]%$%s%H\e(B) \e$B$N%j%s%/@h$rF@$k!#\e(B
2439 \e$B7k2L$r\e(B help-echo \e$B%W%m%Q%F%#$K@_Dj$7$F%-%c%C%7%e$9$k!#\e(B"
2440 (setq point (or point (point)))
2441 (let ((help-echo-prop (get-text-property point 'help-echo))
2442 mark-active deactivate-mark) ; transient-mark-mode \e$B$,@Z$l$J$$$h$&\e(B
2443 (unless (or (null help-echo-prop)
2444 (stringp help-echo-prop))
2445 (setq help-echo-prop (navi2ch-article-get-link-text-subr point))
2446 (let ((buffer-read-only nil))
2447 (navi2ch-article-change-help-echo-property point help-echo-prop)))
2448 help-echo-prop))
2449
2450 (defun navi2ch-article-change-help-echo-property (point value)
2451 (unless (get-text-property point 'help-echo)
2452 (error "POINT (%d) does not have property help-echo" point))
2453 (let* ((end (or (min (next-single-property-change point 'help-echo)
2454 (or (navi2ch-next-property point 'navi2ch-link)
2455 (point-max)))
2456 point))
2457 (start (or (max (previous-single-property-change end 'help-echo)
2458 (or (navi2ch-previous-property end 'navi2ch-link)
2459 (point-min)))
2460 point)))
2461 (put-text-property start end 'help-echo value)))
2462
2463 (defvar navi2ch-article-disable-display-link-commands
2464 '(navi2ch-show-url-at-point
2465 navi2ch-article-select-current-link
2466 eval-expression)
2467 "\e$B$3$N%3%^%s%I$N8e$G$O\e(B minibuffer \e$B$K%j%s%/@h$rI=<($7$J$$!#\e(B")
2468
2469 (defvar navi2ch-article-info-cache nil)
2470 (defvar navi2ch-article-info-cache-limit 100)
2471
2472 (defun navi2ch-article-display-link-minibuffer (&optional point)
2473 "POINT (\e$B>JN,;~$O%+%l%s%H%]%$%s%H\e(B) \e$B$N%j%s%/@h$r\e(B minibuffer \e$B$KI=<(!#\e(B"
2474 (unless (or isearch-mode
2475 (memq this-command
2476 navi2ch-article-disable-display-link-commands))
2477 (save-match-data
2478 (save-excursion
2479 (let ((text (navi2ch-article-get-link-text point)))
2480 (if (stringp text)
2481 (message "%s" text)))))))
2482
2483 (defun navi2ch-article-help-echo (window-or-extent &optional object position)
2484 (save-match-data
2485 (save-excursion
2486 (navi2ch-ifxemacs
2487 (when (extentp window-or-extent)
2488 (setq object (extent-object window-or-extent))
2489 (setq position (extent-start-position window-or-extent))))
2490 (when (buffer-live-p object)
2491 (with-current-buffer object
2492 (navi2ch-article-get-link-text position))))))
2493
2494 (defsubst navi2ch-article-load-article-summary (board)
2495 (navi2ch-load-info (navi2ch-board-get-file-name
2496 board
2497 navi2ch-article-summary-file-name)))
2498
2499 (defsubst navi2ch-article-save-article-summary (board summary)
2500 (navi2ch-save-info (navi2ch-board-get-file-name
2501 board
2502 navi2ch-article-summary-file-name)
2503 summary))
2504
2505 (defun navi2ch-article-next-link ()
2506 "\e$B<!$N%j%s%/$X0\F0!#\e(B"
2507 (interactive)
2508 (let ((point (navi2ch-next-property (point) 'navi2ch-link)))
2509 (if point
2510 (goto-char point))))
2511
2512 (defun navi2ch-article-previous-link ()
2513 "\e$BA0$N%j%s%/$X0\F0!#\e(B"
2514 (interactive)
2515 (let ((point (navi2ch-previous-property (point) 'navi2ch-link)))
2516 (if point
2517 (goto-char point))))
2518
2519 (defun navi2ch-article-fetch-link (&optional force)
2520 (interactive)
2521 (let ((type (get-text-property (point) 'navi2ch-link-type))
2522 (url (get-text-property (point) 'navi2ch-link)))
2523 (and (eq type 'url)
2524 url
2525 (navi2ch-2ch-url-p url)
2526 (let ((article (navi2ch-article-url-to-article url))
2527 (board (navi2ch-board-url-to-board url)))
2528 (when article
2529 (and (get-text-property (point) 'help-echo)
2530 (let ((buffer-read-only nil))
2531 (navi2ch-article-change-help-echo-property
2532 (point)
2533 (function navi2ch-article-help-echo))))
2534 (let (summary artid element seen)
2535 (when (and navi2ch-board-check-article-update-suppression-length
2536 (not (navi2ch-bm-fetched-article-p board article)))
2537 (setq summary (navi2ch-article-load-article-summary board))
2538 (setq artid (cdr (assq 'artid article)))
2539 (setq element (cdr (assoc artid summary)))
2540 (setq seen (or (navi2ch-article-summary-element-seen element)
2541 (cdr (assoc artid navi2ch-board-last-seen-alist))
2542 0)))
2543 (and (navi2ch-article-fetch-article board article force)
2544 (if (and seen
2545 (setq seen
2546 (navi2ch-article-check-message-suppression
2547 board
2548 article
2549 (1+ seen)
2550 (+ seen
2551 navi2ch-board-check-article-update-suppression-length))))
2552 (progn
2553 (navi2ch-article-summary-element-set-seen element seen)
2554 (navi2ch-article-save-article-summary board summary))
2555 (navi2ch-bm-remember-fetched-article board article)))))))))
2556
2557 (defun navi2ch-article-detect-encoded-regions (&optional sort)
2558 "\e$B%P%C%U%!$+$i\e(B uuencode \e$B$^$?$O\e(B base64 \e$B%(%s%3!<%I$5$l$?NN0h$rC5$9!#\e(B
2559 \(list (list type fname start end)) \e$B$rJV$9!#\e(B
2560 SORT \e$B$,\e(B non-nil \e$B$N$H$-$O\e(B start \e$B$G%=!<%H$7$?7k2L$rJV$9!#\e(B
2561 \e$B$?$@$7!"\e(B
2562 type: 'uuencode \e$B$+\e(B 'base64
2563 fname: \e$B%G%3!<%I$9$k$H$-$N%G%U%)%k%H$N%U%!%$%kL>\e(B
2564 start: \e$B%(%s%3!<%I$5$l$?NN0h$N@hF,\e(B(\e$B%G%j%_%?$r4^$`\e(B)\e$B$N%]%$%s%H\e(B
2565 end: \e$B%(%s%3!<%I$5$l$?NN0h$NKvHx\e(B(\e$B%G%j%_%?$N<!$N9T$N9TF,\e(B)\e$B$N%]%$%s%H\e(B
2566 \e$B$G$"$k!#\e(B
2567 end \e$B$,\e(B nil \e$B$N>l9gKvHx$N%G%j%_%?$,L5$/@hF,$N%G%j%_%?$N$_$"$k$3$H$r0UL#$9$k!#\e(B"
2568 ;; start \e$B$,\e(B nil \e$B$N>l9g@hF,$N%G%j%_%?$,L5$/KvHx$N%G%j%_%?$N$_$"$k$3$H$r0UL#$7!"\e(B
2569 ;; \e$B",\e(B \e$B$9$k$H!"8mH=Dj$,B?$=$&$J$N$G$d$a!#\e(B
2570 (let ((dels (list (cons 'base64
2571 (cons navi2ch-base64-begin-delimiter-regexp
2572 navi2ch-base64-end-delimiter-regexp))
2573 (cons 'base64
2574 (cons navi2ch-base64-susv3-begin-delimiter-regexp
2575 navi2ch-base64-susv3-end-delimiter-regexp))
2576 (cons 'uudecode
2577 (cons navi2ch-uuencode-begin-delimiter-regexp
2578 navi2ch-uuencode-end-delimiter-regexp))))
2579 regions type fname start end)
2580 (save-excursion
2581 (dolist (d dels)
2582 (goto-char (point-min))
2583 (while (re-search-forward (cadr d) nil t)
2584 (setq type (car d)
2585 start (match-beginning 0)
2586 fname (navi2ch-match-string-no-properties 2)
2587 end (and (re-search-forward (cddr d) nil t)
2588 (navi2ch-line-beginning-position 2))
2589 regions (cons (list type fname start end) regions)))))
2590 (when sort
2591 (setq regions (sort regions (lambda (r1 r2) (< (nth 2 r1) (nth 2 r2)))))
2592 ;; end \e$B$,\e(B nil \e$B$O!":G8e$N$_5v$9!#\e(B
2593 (let ((r regions))
2594 (while (> (length r) 1)
2595 (when (null (nth 3 (car r)))
2596 (setq regions (delete (car r) regions)))
2597 (setq r (cdr r)))))
2598 regions))
2599
2600 (defun navi2ch-article-decode-message (prefix)
2601 "\e$B8=:_$N%l%9$r%G%3!<%I$9$k!#\e(B
2602 PREFIX \e$B$r;XDj$7$?>l9g$O!"\e(Bmark \e$B$N$"$k%l%9$H8=:_$N%l%9$N4V$NHO0O$,BP>]$K$J$k!#\e(B
2603
2604 \e$BJ#?t%l%9$KJ,3d$5$l$?%(%s%3!<%I%;%/%7%g%s$r%G%3!<%I$7$?$$>l9g$O!"\e(B
2605 \e$B%(%s%3!<%I%;%/%7%g%s$N@hF,$N%l%9$G!"\e(BPREFIX \e$B$r;XDj$;$:$K<B9T$9$k$3$H!#\e(B
2606 \e$B8=:_$N%l%9Fb$K;O$a$N%G%j%_%?$N$_$,$"$k>l9g!"BP1~$9$kKvHx$N%G%j%_%?$,\e(B
2607 \e$B8=$l$k%l%9$^$G%G%3!<%I$9$kNN0h$r3HD%$9$k!#\e(B
2608
2609 \e$B%G%j%_%?$H$_$J$9$N$O!"\e(B
2610 `navi2ch-base64-begin-delimiter-regexp'
2611 `navi2ch-base64-end-delimiter-regexp'
2612
2613 `navi2ch-base64-susv3-begin-delimiter-regexp'
2614 `navi2ch-base64-susv3-end-delimiter-regexp'
2615
2616 `navi2ch-uuencode-begin-delimiter-regexp'
2617 `navi2ch-uuencode-end-delimiter-regexp'
2618
2619 \e$B$N\e(B3\e$BAH$N$$$:$l$+$K%^%C%A$9$k9T$H$9$k!#\e(B"
2620 (interactive "P")
2621 (let* ((num (navi2ch-article-get-current-number))
2622 (num2 (or (and prefix
2623 (car (navi2ch-article-get-point (mark))))
2624 num))
2625 (abuf (current-buffer))
2626 (nmax (caar (last navi2ch-article-message-list)))
2627 end regions)
2628 (when (> num num2)
2629 (setq num (prog1 num2
2630 (setq num2 num))))
2631 (with-temp-buffer
2632 (while (<= num num2)
2633 (insert (or (with-current-buffer abuf
2634 (navi2ch-article-get-message-string num))
2635 "")
2636 "\n")
2637 (setq num (1+ num)))
2638 (setq end (point))
2639 (setq regions (navi2ch-article-detect-encoded-regions 'sort))
2640 ;; \e$BJ#?t%l%9$KJ,3d$5$l$?$b$N$rC5$9!#\e(B
2641 (when (and (not prefix) regions)
2642 (while (and (null (nth 3 (car (last regions))))
2643 (< (nth 2 (car (last regions))) end)
2644 (<= num nmax))
2645 (insert (or (with-current-buffer abuf
2646 (navi2ch-article-get-message-string num))
2647 "")
2648 "\n")
2649 (setq num (1+ num))
2650 (setq regions (navi2ch-article-detect-encoded-regions 'sort)))
2651 (while (and regions
2652 (>= (nth 2 (car (last regions))) end))
2653 (setq regions (delete (car (last regions)) regions))))
2654 (unless regions
2655 (let ((c (navi2ch-read-char-with-retry
2656 "(u)udecode or (b)ase64: "
2657 "Please answer u, or b. (u)udecode or (b)ase64: "
2658 '(?u ?U ?b ?B))))
2659 (cond
2660 ((memq c '(?u ?U))
2661 (setq regions (list (list 'uudecode nil nil nil))))
2662 ((memq c '(?b ?B))
2663 (setq regions (list (list 'base64 nil nil nil)))))))
2664 (dolist (r regions)
2665 (condition-case err
2666 (cond
2667 ((eq (car r) 'uudecode)
2668 (navi2ch-uudecode-write-region (or (nth 2 r) (point-min))
2669 (or (nth 3 r) end)))
2670 ((eq (car r) 'base64)
2671 (navi2ch-base64-write-region (or (nth 2 r) (point-min))
2672 (or (nth 3 r) end))))
2673 (error (ding)
2674 (message "%s" (error-message-string err))
2675 (sit-for 1)))))))
2676
2677 (defun navi2ch-article-auto-decode-encoded-section ()
2678 "\e$B%(%s%3!<%I$5$l$?%;%/%7%g%s$r%G%3!<%I$7$?$b$N$X$N%"%s%+!<$K$9$k!#\e(B"
2679 (let ((regions (delq nil
2680 (mapcar (lambda (r)
2681 (when (and (nth 2 r) (nth 3 r))
2682 (list (nth 0 r)
2683 (nth 1 r)
2684 (copy-marker (nth 2 r))
2685 ;; line-end
2686 (copy-marker (1- (nth 3 r))))))
2687 (navi2ch-article-detect-encoded-regions))))
2688 type filename begin end encoded decoded)
2689 (dolist (r regions)
2690 (setq type (nth 0 r)
2691 filename (nth 1 r)
2692 begin (nth 2 r)
2693 end (nth 3 r)
2694 encoded (cond
2695 ((eq type 'uudecode)
2696 (buffer-substring-no-properties
2697 begin
2698 (progn (goto-char end)
2699 (navi2ch-line-beginning-position 2))))
2700 ((eq type 'base64)
2701 (buffer-substring-no-properties
2702 (progn (goto-char begin)
2703 (navi2ch-line-beginning-position 2))
2704 (progn (goto-char end)
2705 (navi2ch-line-end-position 0)))))
2706 decoded nil)
2707 (with-temp-buffer
2708 (insert encoded)
2709 (condition-case nil
2710 (progn
2711 (cond
2712 ((eq type 'uudecode)
2713 (goto-char (point-min))
2714 (while (search-forward "\e$B!)\e(B" nil t) ;for 2ch
2715 (replace-match "&#" nil t))
2716 (navi2ch-uudecode-region (point-min) (point-max)))
2717 ((eq type 'base64)
2718 (base64-decode-region (point-min) (point-max))))
2719 (setq decoded (buffer-string)))
2720 (error nil)))
2721 (when decoded
2722 (let ((fname (unless (or (null filename) (equal filename ""))
2723 filename))
2724 part-begin)
2725 (delete-region begin end)
2726 (goto-char begin)
2727 (insert (navi2ch-propertize
2728 "> " 'face 'navi2ch-article-auto-decode-face)
2729 (navi2ch-propertize
2730 (format "%s" (or fname "\e$BL>L5$7%U%!%$%k$5$s\e(B"))
2731 'face '(navi2ch-article-url-face
2732 navi2ch-article-auto-decode-face)
2733 'link t
2734 'mouse-face navi2ch-article-mouse-face
2735 'file-name fname
2736 'navi2ch-link-type 'content
2737 'navi2ch-link decoded))
2738 (put-text-property begin (1+ begin) 'auto-decode-text 'off)
2739 (put-text-property (+ 2 begin) (+ 3 begin) 'link-head t)
2740 (setq part-begin (point))
2741 (insert (format " (%.1fKB)\n" (/ (length decoded) 1024.0)))
2742 (put-text-property part-begin (point)
2743 'face 'navi2ch-article-auto-decode-face)
2744 (add-text-properties begin (point) (list 'auto-decode t
2745 'hard t))
2746 (when navi2ch-article-auto-decode-insert-text
2747 (forward-line -1)
2748 (navi2ch-article-auto-decode-text-on))))
2749 (set-marker begin nil)
2750 (set-marker end nil))))
2751
2752 (defun navi2ch-article-auto-decode-text-on (&optional coding-system compress)
2753 (save-excursion
2754 (beginning-of-line)
2755 (let* ((point (next-single-property-change
2756 (point) 'navi2ch-link nil (navi2ch-line-end-position)))
2757 (content (get-text-property point 'navi2ch-link))
2758 (filename (get-text-property point 'file-name))
2759 ret)
2760 (when (and (eq (get-text-property (point) 'auto-decode-text) 'off)
2761 content)
2762 (with-temp-buffer
2763 (let ((buffer-file-coding-system 'binary)
2764 (coding-system-for-read 'binary)
2765 (coding-system-for-write 'binary)
2766 exit-status)
2767 (insert content)
2768 ;; extract
2769 (cond
2770 ((or (eq compress 'gzip)
2771 (and (null compress)
2772 filename
2773 (string-match "\\.t?gz$" filename)))
2774 (setq exit-status
2775 (let ((default-directory (navi2ch-default-directory)))
2776 (apply 'call-process-region (point-min) (point-max)
2777 navi2ch-net-gunzip-program t t nil
2778 navi2ch-net-gunzip-args)))
2779 (unless (= exit-status 0)
2780 (erase-buffer)
2781 (insert content)))
2782 ((or (eq compress 'bzip2)
2783 (and (null compress)
2784 filename
2785 (string-match "\\.bz2$" filename)
2786 (navi2ch-which navi2ch-bzip2-program)))
2787 (setq exit-status
2788 (let ((default-directory (navi2ch-default-directory)))
2789 (apply 'call-process-region (point-min) (point-max)
2790 navi2ch-bzip2-program t t nil
2791 navi2ch-bzip2-args)))
2792 (unless (= exit-status 0)
2793 (erase-buffer)
2794 (insert content))))
2795 ;; decode
2796 (unless coding-system
2797 (let ((detect (detect-coding-region (point-min) (point-max)))
2798 name)
2799 (setq coding-system (or (car-safe detect) detect)
2800 name (navi2ch-ifxemacs
2801 (coding-system-name
2802 (coding-system-base coding-system))
2803 (coding-system-base coding-system)))
2804 (when (memq name '(raw-text binary)) ;\e$BE,Ev\e(B
2805 (setq ret 'binary
2806 coding-system nil
2807 content nil))))
2808 (when coding-system
2809 (decode-coding-region (point-min) (point-max) coding-system)
2810 (setq content (buffer-string)))))
2811 (when content
2812 (setq ret t)
2813 (let ((buffer-read-only nil))
2814 (put-text-property (point) (1+ (point)) 'auto-decode-text 'on)
2815 (forward-line)
2816 (setq point (point))
2817 (insert content)
2818 (add-text-properties point (point)
2819 (list 'auto-decode t
2820 'hard t
2821 'face 'navi2ch-article-auto-decode-face))
2822 (set-buffer-modified-p nil))))
2823 ret)))
2824
2825 (defun navi2ch-article-auto-decode-text-off ()
2826 (when (get-text-property (point) 'auto-decode)
2827 (let ((buffer-read-only nil)
2828 (start (or (and (get-text-property (point) 'auto-decode-text)
2829 (point))
2830 (navi2ch-previous-property (point) 'auto-decode-text)))
2831 bs be)
2832 (when (eq (get-text-property start 'auto-decode-text) 'on)
2833 (put-text-property start (1+ start) 'auto-decode-text 'off)
2834 (save-excursion
2835 (goto-char start)
2836 (forward-line)
2837 (setq bs (point)
2838 be (min (next-single-property-change bs 'auto-decode
2839 nil (point-max))
2840 (next-single-property-change bs 'auto-decode-text
2841 nil (point-max)))))
2842 (delete-region bs be)
2843 (when (>= (point) bs)
2844 (forward-line -1))
2845 (set-buffer-modified-p nil)))))
2846
2847 (defun navi2ch-article-auto-decode-toggle-text (&optional ask)
2848 "\e$B%(%s%3!<%I$5$l$?%;%/%7%g%s$r%G%3!<%I$7$?$b$N$NI=<($r@Z$j49$($k!#\e(B
2849 ASK \e$B$,\e(B non-nil \e$B$@$H!"%G%3!<%I$7$?$b$N$NJ8;z%3!<%I$H05=L7A<0$rJ9$$$F$/$k!#\e(B"
2850 (interactive "P")
2851 (if (not (get-text-property (point) 'auto-decode))
2852 (error "Decoded text is not here")
2853 (if (eq (or (get-text-property (point) 'auto-decode-text)
2854 (get-text-property (navi2ch-previous-property
2855 (point) 'auto-decode-text)
2856 'auto-decode-text))
2857 'on)
2858 (navi2ch-article-auto-decode-text-off)
2859 (let* ((cs (and ask (read-coding-system "Coding-system (guess): ")))
2860 (ch (and ask (navi2ch-read-char
2861 "Compression type (guess): g)zip b)zip2 n)one: ")))
2862 (cmp (cond ((eq ch ?g) 'gzip)
2863 ((eq ch ?b) 'bzip2)
2864 ((eq ch ?n) t)))
2865 ret)
2866 (message "Inserting decoded content...")
2867 (setq ret (navi2ch-article-auto-decode-text-on cs cmp))
2868 (cond ((eq ret 'binary)
2869 (message "Content may be a binary"))
2870 (ret
2871 (message "Inserting decoded content...done"))
2872 (t
2873 (message "Not inserted")))))))
2874
2875 (defun navi2ch-article-save-content ()
2876 (interactive)
2877 (let ((prop (get-text-property (point) 'navi2ch-link))
2878 (default-filename (get-text-property (point) 'file-name))
2879 filename)
2880 (when default-filename
2881 (setq default-filename (file-name-nondirectory default-filename)))
2882 (setq filename (read-file-name
2883 (if default-filename
2884 (format "Save file (default `%s'): "
2885 default-filename)
2886 "Save file: ")
2887 nil default-filename))
2888 (when (file-directory-p filename)
2889 (if default-filename
2890 (setq filename (expand-file-name default-filename filename))
2891 (error "%s is a directory" filename)))
2892 (if (not (file-writable-p filename))
2893 (error "File not writable: %s" filename)
2894 (with-temp-buffer
2895 (let ((buffer-file-coding-system 'binary)
2896 (coding-system-for-write 'binary)
2897 ;; auto-compress-mode \e$B$r\e(B disable \e$B$K$9$k\e(B
2898 (inhibit-file-name-operation 'write-region)
2899 (inhibit-file-name-handlers (cons 'jka-compr-handler
2900 inhibit-file-name-handlers)))
2901 (insert prop)
2902 (if (or (not (file-exists-p filename))
2903 (y-or-n-p (format "File `%s' exists; overwrite? "
2904 filename)))
2905 (write-region (point-min) (point-max) filename)))))))
2906
2907 (defun navi2ch-article-textize-article (&optional dir-or-file buffer)
2908 (interactive)
2909 (let* ((article navi2ch-article-current-article)
2910 (board navi2ch-article-current-board)
2911 (id (cdr (assq 'id board)))
2912 (subject (cdr (assq 'subject article)))
2913 (basename (format "%s_%s.txt" id (cdr (assq 'artid article))))
2914 dir file)
2915 (and dir-or-file
2916 (file-directory-p dir-or-file)
2917 (setq dir dir-or-file))
2918 (setq file
2919 (if (or (not dir-or-file)
2920 (and dir (interactive-p)))
2921 (expand-file-name
2922 (read-file-name "Write thread to file: " dir nil nil basename))
2923 (expand-file-name basename dir)))
2924 (and buffer
2925 (with-current-buffer buffer
2926 (goto-char (point-max))
2927 (insert (format "<a href=\"%s\">%s</a><br>\n" file subject))))
2928 (when navi2ch-article-view-range
2929 (setq navi2ch-article-view-range nil)
2930 (navi2ch-article-redraw))
2931 (let ((coding-system-for-write navi2ch-coding-system))
2932 (navi2ch-write-region (point-min) (point-max)
2933 file))
2934 (message "Wrote %s" file)))
2935
2936 ;; shut up XEmacs warnings
2937 (eval-when-compile
2938 (defvar w32-start-process-show-window))
2939
2940 (defun navi2ch-article-call-aadisplay (str)
2941 (let* ((coding-system-for-write navi2ch-article-aadisplay-coding-system)
2942 (file (expand-file-name (make-temp-name (navi2ch-temp-directory)))))
2943 (unwind-protect
2944 (progn
2945 (with-temp-file file
2946 (insert str))
2947 (let ((w32-start-process-show-window t) ; for meadow
2948 (default-directory (navi2ch-default-directory)))
2949 (call-process navi2ch-article-aadisplay-program
2950 nil nil nil file)))
2951 (ignore-errors (delete-file file)))))
2952
2953 (defun navi2ch-article-popup-dialog (str)
2954 (navi2ch-ifxemacs
2955 (ignore str) ; \e$B$H$j$"$($:2?$b$7$J$$\e(B
2956 (x-popup-dialog
2957 t (cons "navi2ch"
2958 (mapcar (lambda (x)
2959 (cons (if (string= x "") " " x) t))
2960 (split-string str "\n"))))))
2961
2962 (defun navi2ch-article-view-aa ()
2963 (interactive)
2964 (funcall navi2ch-article-view-aa-function
2965 (cdr (assq 'data
2966 (navi2ch-article-get-message
2967 (navi2ch-article-get-current-number))))))
2968
2969 (defun navi2ch-article-set-summary-element (board article remove-seen)
2970 "BOARD, ARTICLE \e$B$KBP1~$7$?>pJs$r\e(B article-summary \e$B$KJ]B8$9$k!#\e(B"
2971 (let* ((summary (navi2ch-article-load-article-summary board))
2972 (artid (cdr (assq 'artid article)))
2973 (element (cdr (assoc artid summary))))
2974 (navi2ch-article-summary-element-set-seen
2975 element
2976 (unless remove-seen
2977 (with-current-buffer (navi2ch-article-get-buffer-name board article)
2978 (length navi2ch-article-message-list))))
2979 (navi2ch-article-summary-element-set-access-time element (current-time))
2980 (setq summary (navi2ch-put-alist artid element summary))
2981 (navi2ch-article-save-article-summary board summary)))
2982
2983 (defun navi2ch-article-add-board-bookmark ()
2984 (interactive)
2985 (navi2ch-board-add-bookmark-subr navi2ch-article-current-board
2986 navi2ch-article-current-article))
2987
2988 (defun navi2ch-article-add-global-bookmark (bookmark-id)
2989 (interactive (list (navi2ch-bookmark-read-id "Bookmark ID: ")))
2990 (navi2ch-bookmark-add
2991 bookmark-id
2992 navi2ch-article-current-board
2993 navi2ch-article-current-article))
2994
2995 (defun navi2ch-article-buffer-list ()
2996 "`navi2ch-article-mode' \e$B$N\e(B buffer \e$B$N\e(B list \e$B$rJV$9!#\e(B"
2997 (let (list)
2998 (dolist (x (buffer-list))
2999 (when (with-current-buffer x
3000 (eq major-mode 'navi2ch-article-mode))
3001 (setq list (cons x list))))
3002 (nreverse list)))
3003
3004 (defun navi2ch-article-toggle-sticky ()
3005 "\e$B8=:_$N%P%C%U%!$N\e(B sticky \e$B%b!<%I$r\e(B toggle \e$B$9$k!#\e(B"
3006 (interactive)
3007 (setq navi2ch-article-sticky-mode
3008 (not navi2ch-article-sticky-mode))
3009 (force-mode-line-update)
3010 (if navi2ch-article-sticky-mode
3011 (message "Marked as sticky")
3012 (message "Marked as non-sticky")))
3013
3014 (defun navi2ch-article-current-buffer (&optional sticky)
3015 "BUFFER-LIST \e$B$N0lHV:G=i$N\e(B `navi2ch-article-mode' \e$B$N\e(B buffer \e$B$rJV$9!#\e(B
3016 STICKY \e$B$,\e(B non-nil \e$B$N$H$-$O0lHV:G=i$N\e(B sticky article buffer \e$B$rJV$9!#\e(B"
3017 (let ((list (buffer-list)))
3018 (catch 'loop
3019 (while list
3020 (when (with-current-buffer (car list)
3021 (and (eq major-mode 'navi2ch-article-mode)
3022 (or (not sticky)
3023 navi2ch-article-sticky-mode)))
3024 (throw 'loop (car list)))
3025 (setq list (cdr list)))
3026 nil)))
3027
3028 (defun navi2ch-article-forward-buffer (&optional sticky)
3029 "\e$B<!$N\e(B article buffer \e$B$K@Z$jBX$($k!#\e(B
3030 STICKY \e$B$,\e(B non-nil \e$B$N$H$-$O<!$N\e(B sticky article buffer \e$B$K@Z$jBX$($k!#\e(B"
3031 (interactive "P")
3032 (let (buf)
3033 (dolist (x (buffer-list))
3034 (when (with-current-buffer x
3035 (and (eq major-mode 'navi2ch-article-mode)
3036 (or (not sticky)
3037 navi2ch-article-sticky-mode)))
3038 (setq buf x)))
3039 (if buf
3040 (progn
3041 (navi2ch-split-window 'article)
3042 (switch-to-buffer buf))
3043 (if sticky
3044 (message "No sticky aritcle buffer")
3045 (message "No aritcle buffer"))
3046 nil)))
3047
3048 (defun navi2ch-article-backward-buffer (&optional sticky)
3049 "\e$BA0$N\e(B article buffer \e$B$K@Z$jBX$($k!#\e(B
3050 STICKY \e$B$,\e(B non-nil \e$B$N$H$-$OA0$N\e(B sticky article buffer \e$B$K@Z$jBX$($k!#\e(B"
3051 (interactive "P")
3052 (let ((orig (current-buffer))
3053 buf)
3054 (when (setq buf (navi2ch-article-current-buffer))
3055 (bury-buffer buf))
3056 (setq buf (navi2ch-article-current-buffer sticky))
3057 (if buf
3058 (progn
3059 (navi2ch-split-window 'article)
3060 (switch-to-buffer buf))
3061 (switch-to-buffer orig)
3062 (if sticky
3063 (message "No sticky aritcle buffer")
3064 (message "No aritcle buffer"))
3065 nil)))
3066
3067 (defun navi2ch-article-forward-sticky-buffer (&optional no-sync)
3068 "\e$B<!$N\e(B sticky article buffer \e$B$K@Z$jBX$(!"\e(Bsync \e$B$9$k!#\e(B
3069 NO-SYNC \e$B$,\e(B non-nil \e$B$N$H$-$O\e(B sync \e$B$7$J$$!#\e(B"
3070 (interactive "P")
3071 (and (navi2ch-article-forward-buffer t)
3072 (not no-sync)
3073 (navi2ch-article-sync)))
3074
3075 (defun navi2ch-article-backward-sticky-buffer (&optional no-sync)
3076 "\e$BA0$N\e(B sticky article buffer \e$B$K@Z$jBX$(!"\e(Bsync \e$B$9$k!#\e(B
3077 NO-SYNC \e$B$,\e(B non-nil \e$B$N$H$-$O\e(B sync \e$B$7$J$$!#\e(B"
3078 (interactive "P")
3079 (and (navi2ch-article-backward-buffer t)
3080 (not no-sync)
3081 (navi2ch-article-sync)))
3082
3083 (defun navi2ch-article-delete-message (sym func msg &optional perm)
3084 "\e$B3:Ev0LCV$N%l%9$r\e(B buffer \e$B$+$i:o=|$9$k!#\e(B
3085 `navi2ch-article-current-article' \e$B$N\e(B SYM \e$B$G;XDj$5$l$k\e(B list \e$B$KBP$7$F!"\e(BFUNC \e$B$r8F$S$@$9!#\e(B
3086 PERM \e$B$,\e(B non-nil \e$B$N>l9g$O!"$=$N%l%9$r\e(B unfilter \e$B$H$7$F5-O?$9$k!#\e(B
3087 FUNC \e$B$O\e(B (NUMBER, LIST) \e$B$r0z?t$K<h$k4X?t$G$"$k;v!#\e(B"
3088 (let* ((article navi2ch-article-current-article)
3089 (list (cdr (assq sym article)))
3090 (num (navi2ch-article-get-current-number)))
3091 (setq list (funcall func num list))
3092 (setq article (navi2ch-put-alist sym list article))
3093 (unless (memq num list)
3094 (let ((cache navi2ch-article-message-filter-cache)
3095 (unfilter (cdr (assq 'unfilter article))))
3096 (setq cache (navi2ch-put-alist sym
3097 (delq num (cdr (assq sym cache)))
3098 cache))
3099 (setq cache (navi2ch-put-alist 'cache
3100 (delq num (cdr (assq 'cache cache)))
3101 cache))
3102 (setq navi2ch-article-message-filter-cache cache)
3103 (when (and perm
3104 (not (memq num unfilter)))
3105 (setq article (navi2ch-put-alist 'unfilter
3106 (cons num unfilter)
3107 article)))))
3108 (setq navi2ch-article-current-article article)
3109 (when num
3110 (save-excursion
3111 (let ((buffer-read-only nil))
3112 (delete-region
3113 (if (get-text-property (point) 'current-number)
3114 (point)
3115 (navi2ch-previous-property (point) 'current-number))
3116 (or (navi2ch-next-property (point) 'current-number)
3117 (point-max)))))
3118 (message msg))))
3119
3120 ;;; hide mode
3121 (navi2ch-set-minor-mode 'navi2ch-article-hide-mode
3122 " Hide"
3123 navi2ch-article-hide-mode-map)
3124
3125 (defun navi2ch-article-hide-message ()
3126 (interactive)
3127 (run-hooks 'navi2ch-article-hide-message-hook)
3128 (navi2ch-article-delete-message
3129 'hide
3130 (lambda (num list)
3131 (if (memq num list)
3132 list
3133 (cons num list)))
3134 "Hide message")
3135 (navi2ch-article-update-previous-message-separator))
3136
3137 (defun navi2ch-article-cancel-hide-message (&optional prefix)
3138 (interactive "P")
3139 (run-hooks 'navi2ch-article-cancel-hide-message-hook)
3140 (navi2ch-article-delete-message 'hide 'delq
3141 "Cancel hide message"
3142 prefix))
3143
3144 (defun navi2ch-article-toggle-hide ()
3145 (interactive)
3146 (setq navi2ch-article-hide-mode
3147 (if navi2ch-article-hide-mode
3148 nil
3149 (navi2ch-article-save-number)
3150 t))
3151 (setq navi2ch-article-important-mode nil)
3152 (force-mode-line-update)
3153 (let ((buffer-read-only nil))
3154 (save-excursion
3155 (erase-buffer)
3156 (navi2ch-article-insert-messages
3157 navi2ch-article-message-list
3158 navi2ch-article-view-range)))
3159 (navi2ch-article-load-number))
3160
3161 ;;; important mode
3162 (navi2ch-set-minor-mode 'navi2ch-article-important-mode
3163 " Important"
3164 navi2ch-article-important-mode-map)
3165
3166 (defun navi2ch-article-add-important-message (&optional prefix)
3167 (interactive "P")
3168 (run-hooks 'navi2ch-article-add-important-message-hook)
3169 (if prefix
3170 (navi2ch-article-add-board-bookmark)
3171 (let* ((article navi2ch-article-current-article)
3172 (list (cdr (assq 'important article)))
3173 (num (navi2ch-article-get-current-number)))
3174 (unless (memq num list)
3175 (setq list (cons num list))
3176 (setq navi2ch-article-current-article
3177 (navi2ch-put-alist 'important list article))
3178 (message "Add important message")))))
3179
3180 (defun navi2ch-article-delete-important-message (&optional prefix)
3181 (interactive "P")
3182 (run-hooks 'navi2ch-article-delete-important-message-hook)
3183 (navi2ch-article-delete-message 'important 'delq
3184 "Delete important message"
3185 prefix))
3186
3187 (defun navi2ch-article-toggle-important ()
3188 (interactive)
3189 (setq navi2ch-article-important-mode
3190 (if navi2ch-article-important-mode
3191 nil
3192 (navi2ch-article-save-number)
3193 t))
3194 (setq navi2ch-article-hide-mode nil)
3195 (force-mode-line-update)
3196 (let ((buffer-read-only nil))
3197 (save-excursion
3198 (erase-buffer)
3199 (navi2ch-article-insert-messages
3200 navi2ch-article-message-list
3201 navi2ch-article-view-range)))
3202 (navi2ch-article-load-number))
3203
3204 (defun navi2ch-article-search ()
3205 "\e$B%a%C%;!<%8$r8!:w$9$k!#\e(B
3206 \e$BL>A0\e(B (name)\e$B!"%a!<%k\e(B (mail)\e$B!"F|IU\e(B (date)\e$B!"\e(BID (id)\e$B!"%[%9%H\e(B
3207 \e$BL>\e(B(hostname)\e$B!"K\J8\e(B (body)\e$B!";2>H\e(B(reference) \e$B$+$i8!:w>r7o$rA*$V$3$H\e(B
3208 \e$B$,$G$-$^$9!#\e(B
3209
3210 \e$B%Q!<%::Q$_$N%a%C%;!<%8$N$_$r8!:wBP>]$H$9$k$N$G!"$"$i$+$8$a\e(B
3211 `navi2ch-article-redraw-range' \e$B$r;H$&$J$I$7$F8!:w$7$?$$%a%C%;!<%8$r\e(B
3212 \e$BI=<($7$F$*$/$3$H!#\e(B"
3213 (interactive)
3214 (let* ((has-id (navi2ch-article-get-current-id))
3215 (has-hostname (navi2ch-article-get-current-hostname))
3216 (ch (navi2ch-read-char-with-retry
3217 (concat "Search for: n)ame m)ail d)ate "
3218 (and has-id "i)d ")
3219 (and has-hostname "h)ostname ")
3220 "b)ody s)ubject r)eference: ")
3221 nil
3222 (append '(?n ?m ?b ?s ?d ?r)
3223 (and has-id (list ?i))
3224 (and has-hostname (list ?h))))))
3225 (cond
3226 ((eq ch ?n) (navi2ch-article-search-name))
3227 ((eq ch ?m) (navi2ch-article-search-mail))
3228 ((eq ch ?d) (navi2ch-article-search-date))
3229 ((eq ch ?i) (navi2ch-article-search-id))
3230 ((eq ch ?h) (navi2ch-article-search-hostname))
3231 ((eq ch ?b) (navi2ch-article-search-body))
3232 ((eq ch ?r) (navi2ch-article-search-reference)))))
3233
3234 (defun navi2ch-article-search-name (&optional name)
3235 (interactive)
3236 (unless name
3237 (setq name (navi2ch-read-string "Name: "
3238 (navi2ch-article-get-current-name)
3239 'navi2ch-search-history)))
3240 (navi2ch-article-search-subr 'name (regexp-quote name)))
3241
3242 (defun navi2ch-article-search-mail (&optional mail)
3243 (interactive)
3244 (unless mail
3245 (setq mail (navi2ch-read-string "Mail: "
3246 (navi2ch-article-get-current-mail)
3247 'navi2ch-search-history)))
3248 (navi2ch-article-search-subr 'mail (regexp-quote mail)))
3249
3250 (defun navi2ch-article-search-date (&optional date)
3251 (interactive)
3252 (unless date
3253 (setq date (navi2ch-read-string "Date: "
3254 (navi2ch-article-get-current-date)
3255 'navi2ch-search-history)))
3256 (navi2ch-article-search-subr 'date
3257 (concat (regexp-quote date)
3258 (if (navi2ch-article-get-current-id)
3259 ".* ID:" ""))))
3260
3261 (defun navi2ch-article-search-id (&optional id)
3262 (interactive)
3263 (unless id
3264 (setq id (navi2ch-read-string "ID: "
3265 (navi2ch-article-get-current-id)
3266 'navi2ch-search-history)))
3267 (navi2ch-article-search-subr 'date
3268 (concat " ID:[^ ]*" (regexp-quote id))))
3269
3270 (defun navi2ch-article-search-hostname (&optional host)
3271 (interactive)
3272 (unless host
3273 (setq host (navi2ch-read-string "Host: "
3274 (navi2ch-article-get-current-hostname)
3275 'navi2ch-search-history)))
3276 (navi2ch-article-search-subr 'date
3277 (concat "\\(?:\\[ \\|\e$BH/?.85\e(B:\\)"
3278 (regexp-quote host))))
3279
3280 (defun navi2ch-article-search-body (&optional body)
3281 (interactive)
3282 (unless body
3283 (setq body (navi2ch-read-string "Body: "
3284 (navi2ch-article-get-current-word-in-body)
3285 'navi2ch-search-history)))
3286 (navi2ch-article-search-subr 'data (regexp-quote body)))
3287
3288 (defun navi2ch-article-search-reference (&optional num)
3289 (interactive)
3290 (unless (and num (numberp num))
3291 (setq num (read-number "Reference: "
3292 (navi2ch-article-get-current-number))))
3293 (let ((num-regexp (navi2ch-fuzzy-regexp (number-to-string num)))
3294 (board navi2ch-article-current-board)
3295 (article navi2ch-article-current-article)
3296 num-list len)
3297 (dolist (msg navi2ch-article-message-list)
3298 (when (and (listp (cdr msg))
3299 (or (string-match num-regexp (or (cdr (assq 'name (cdr msg))) ""))
3300 (catch 'result
3301 (with-temp-buffer
3302 (setq navi2ch-article-current-board board
3303 navi2ch-article-current-article article)
3304 (insert (or (cdr (assq 'data (cdr msg))) ""))
3305 (goto-char (point-min))
3306 (while (re-search-forward
3307 (concat navi2ch-article-number-prefix-regexp
3308 navi2ch-article-number-number-regexp)
3309 nil t)
3310 (when (navi2ch-eq-or-memq
3311 num
3312 (navi2ch-article-str-to-num
3313 (japanese-hankaku (match-string 1))))
3314 (throw 'result t))
3315 (while (looking-at (concat
3316 navi2ch-article-number-separator-regexp
3317 navi2ch-article-number-number-regexp))
3318 (when (navi2ch-eq-or-memq
3319 num
3320 (navi2ch-article-str-to-num
3321 (japanese-hankaku (match-string 1))))
3322 (throw 'result t))
3323 (goto-char (max (1+ (match-beginning 0))
3324 (match-end 0))))))
3325 nil)))
3326 (setq num-list (cons (car msg) num-list))))
3327 (setq len (length num-list))
3328 (if (= len 0)
3329 (message "No message found")
3330 (navi2ch-popup-article (nreverse num-list))
3331 (message (format "%d message%s found"
3332 len
3333 (if (= len 1) "" "s"))))))
3334
3335 (defun navi2ch-article-search-subr (field regexp)
3336 (let (num-list len)
3337 (dolist (msg navi2ch-article-message-list)
3338 (when (and (listp (cdr msg))
3339 (string-match regexp (or (cdr (assq field (cdr msg))) "")))
3340 (setq num-list (cons (car msg) num-list))))
3341 (setq len (length num-list))
3342 (if (= len 0)
3343 (message "No message found")
3344 (navi2ch-popup-article (nreverse num-list))
3345 (message (format "%d message%s found"
3346 len
3347 (if (= len 1) "" "s"))))))
3348
3349 (defun navi2ch-article-save-dat-file (board article)
3350 (interactive (list navi2ch-article-current-board
3351 navi2ch-article-current-article))
3352 (let ((file (navi2ch-article-get-file-name board article)))
3353 (cond ((not (file-exists-p file))
3354 (message ".dat \e$B%U%!%$%k$,$"$j$^$;$s!#$^$:%9%l$r<hF@$7$F$/$@$5$$!#\e(B")
3355 (ding))
3356 ((not (file-readable-p file))
3357 (message ".dat \e$B%U%!%$%k$rFI$a$^$;$s!#\e(B")
3358 (ding))
3359 (t
3360 (let ((newname (read-file-name
3361 (format "Save .dat file to (default `%s'): "
3362 (file-name-nondirectory file))
3363 nil
3364 (file-name-nondirectory file))))
3365 (if (file-directory-p newname)
3366 (setq newname (expand-file-name (file-name-nondirectory file)
3367 newname)))
3368 (when (or (not (file-exists-p newname))
3369 (y-or-n-p "\e$B$9$G$KB8:_$7$^$9!#>e=q$-$7$^$9$+\e(B? "))
3370 (copy-file file newname t)
3371 (message "`%s' \e$B$KJ]B8$7$^$7$?!#\e(B" newname)))))))
3372
3373 ;;; filter mode
3374 (navi2ch-set-minor-mode 'navi2ch-article-message-filter-mode
3375 " Filter"
3376 navi2ch-article-message-filter-mode-map)
3377
3378 (defsubst navi2ch-article-get-message-filter-cache-file-name (board article)
3379 (concat (navi2ch-article-get-info-file-name board article) ".filter"))
3380
3381 (defun navi2ch-article-save-message-filter-cache (&optional board article cache)
3382 (unless (and board article cache)
3383 (let ((buffer (get-buffer (navi2ch-article-get-buffer-name board article))))
3384 (when buffer
3385 (with-current-buffer buffer
3386 (or board (setq board navi2ch-article-current-board))
3387 (or article (setq article navi2ch-article-current-article))
3388 (or cache (setq cache navi2ch-article-message-filter-cache))))))
3389 (when cache
3390 (let ((file (navi2ch-article-get-message-filter-cache-file-name board
3391 article))
3392 (alist (delq nil
3393 (mapcar
3394 (lambda (key)
3395 (let ((slot (assq key cache)))
3396 (and (cdr slot)
3397 slot)))
3398 navi2ch-article-save-message-filter-cache-keys))))
3399 (if (and (null alist)
3400 (file-exists-p file))
3401 (condition-case nil
3402 (delete-file file)
3403 (error nil))
3404 (navi2ch-save-info file alist)))))
3405
3406 (defun navi2ch-article-load-message-filter-cache (&optional board article)
3407 (navi2ch-load-info
3408 (navi2ch-article-get-message-filter-cache-file-name
3409 (or board navi2ch-article-current-board)
3410 (or article navi2ch-article-current-article))))
3411
3412 (defun navi2ch-article-toggle-replace-message (&optional prefix)
3413 "\e$B8=:_$N%l%9$NCV49$NM-8z!&L58z$r@Z$jBX$($k!#\e(B"
3414 (interactive "P")
3415 (let ((unfilter (cdr (assq 'unfilter navi2ch-article-current-article)))
3416 (rep (cdr (assq 'replace navi2ch-article-message-filter-cache)))
3417 (num (navi2ch-article-get-current-number))
3418 (msg "No replacement cached"))
3419 (when (cdr (assq num rep))
3420 (if (memq num unfilter)
3421 (setq unfilter (delq num unfilter)
3422 msg "Replace message")
3423 (setq unfilter (cons num unfilter)
3424 msg "Undo replace message"))
3425 (setq navi2ch-article-current-article
3426 (navi2ch-put-alist 'unfilter
3427 unfilter
3428 navi2ch-article-current-article))
3429 (let ((buffer-read-only nil))
3430 (navi2ch-article-save-view
3431 (navi2ch-article-reinsert-partial-messages num num)))
3432 (when (and prefix
3433 (memq num unfilter))
3434 (setq navi2ch-article-message-filter-cache
3435 (navi2ch-put-alist 'replace
3436 (delq (assq num rep) rep)
3437 navi2ch-article-message-filter-cache))
3438 (let ((orig (cdr (assq 'original navi2ch-article-message-filter-cache)))
3439 (cache (cdr (assq 'cache navi2ch-article-message-filter-cache))))
3440 (setq navi2ch-article-message-filter-cache
3441 (navi2ch-put-alist 'original
3442 (delq (assq num orig) orig)
3443 navi2ch-article-message-filter-cache))
3444 (setq navi2ch-article-message-filter-cache
3445 (navi2ch-put-alist 'cache
3446 (delq (assq num cache) cache)
3447 navi2ch-article-message-filter-cache)))))
3448 (message msg)))
3449
3450 (defun navi2ch-article-toggle-message-filter (&optional prefix)
3451 "\e$B%U%#%k%?5!G=$N\e(B on/off \e$B$r@Z$jBX$($k!#\e(B
3452 PREFIX \e$B$,M?$($i$l$?>l9g$O!"\e(B
3453 \e$B%-%c%C%7%e$r%/%j%"$7!"%U%#%k%?5!G=$r\e(B on \e$B$K$7$F%9%l$rI=<($7$J$*$9!#\e(B"
3454 (interactive "P")
3455 (if (null prefix)
3456 (progn
3457 (setq navi2ch-article-message-filter-mode
3458 (not navi2ch-article-message-filter-mode))
3459 (when (and navi2ch-article-message-filter-mode
3460 (null navi2ch-article-message-filter-cache))
3461 (setq navi2ch-article-message-filter-cache
3462 (navi2ch-article-load-message-filter-cache))))
3463 (when navi2ch-article-message-filter-cache
3464 ;; \e$B%U%#%k%?A0$N%l%9$N>uBV$r%-%c%C%7%e$+$iI|85\e(B
3465 (when navi2ch-article-message-filter-mode
3466 (dolist (slots (cdr (assq 'original
3467 navi2ch-article-message-filter-cache)))
3468 (let ((alist (navi2ch-article-get-message (car slots))))
3469 (dolist (slot (cdr slots))
3470 (when (cdr slot)
3471 (navi2ch-put-alist (car slot) (cdr slot) alist))))))
3472 (setq navi2ch-article-current-article
3473 (navi2ch-put-alist
3474 'hide
3475 (navi2ch-set-difference
3476 (cdr (assq 'hide navi2ch-article-current-article))
3477 (cdr (assq 'hide navi2ch-article-message-filter-cache)))
3478 navi2ch-article-current-article))
3479 (setq navi2ch-article-current-article
3480 (navi2ch-put-alist
3481 'important
3482 (navi2ch-set-difference
3483 (cdr (assq 'important navi2ch-article-current-article))
3484 (cdr (assq 'important navi2ch-article-message-filter-cache)))
3485 navi2ch-article-current-article))
3486 ;; \e$B%-%c%C%7%e$r%/%j%"\e(B
3487 (setq navi2ch-article-message-filter-cache nil))
3488 (setq navi2ch-article-message-filter-mode t))
3489 (force-mode-line-update)
3490 (let ((buffer-read-only nil)
3491 (navi2ch-article-sort-message-filter-rules nil))
3492 (navi2ch-article-save-view
3493 (erase-buffer)
3494 (navi2ch-article-insert-messages
3495 navi2ch-article-message-list
3496 navi2ch-article-view-range)))
3497 navi2ch-article-message-filter-mode)
3498
3499 (defun navi2ch-article-add-message-filter-rule (&optional prefix)
3500 "\e$B%l%9$N%U%#%k%?>r7o$rBPOCE*$KDI2C$9$k!#\e(B"
3501 (interactive "P")
3502 (let* ((has-id (navi2ch-article-get-current-id))
3503 (has-hostname (navi2ch-article-get-current-hostname))
3504 (char (navi2ch-read-char-with-retry
3505 (concat "Filter by: n)ame m)ail "
3506 (and has-id "i)d ")
3507 (and has-hostname "h)ostname ")
3508 "b)ody s)ubject: ")
3509 nil
3510 (append '(?n ?m ?b ?s)
3511 (and has-id (list ?i))
3512 (and has-hostname (list ?h))))))
3513 (cond
3514 ((eq char ?n) (navi2ch-article-add-message-filter-by-name prefix))
3515 ((eq char ?m) (navi2ch-article-add-message-filter-by-mail prefix))
3516 ((eq char ?i) (navi2ch-article-add-message-filter-by-id prefix))
3517 ((eq char ?h) (navi2ch-article-add-message-filter-by-hostname prefix))
3518 ((eq char ?b) (navi2ch-article-add-message-filter-by-message prefix))
3519 ((eq char ?s) (navi2ch-article-add-message-filter-by-subject prefix)))))
3520
3521 (defun navi2ch-article-add-message-filter-cus (&optional prefix)
3522 "\e$B%l%9$N%U%#%k%?>r7o$r%+%9%?%`%(%G%#%?7A<0$GDI2C$9$k!#\e(B"
3523 (interactive "P")
3524 (let* ((has-id (navi2ch-article-get-current-id))
3525 (has-hostname (navi2ch-article-get-current-hostname))
3526 (char (navi2ch-read-char-with-retry
3527 (concat "Filter by: n)ame m)ail "
3528 (and has-id "i)d ")
3529 (and has-hostname "h)ostname ")
3530 "b)ody s)ubject: ")
3531 nil
3532 (append '(?n ?m ?b ?s)
3533 (and has-id (list ?i))
3534 (and has-hostname (list ?h)))))
3535 (rule (cdr (assq char navi2ch-article-message-filter-default-rule-alist)))
3536 (default-rule (cdr (assq t navi2ch-article-message-filter-default-rule-alist)))
3537 (str (if prefix
3538 (buffer-substring-no-properties (region-beginning) (region-end))
3539 (or (plist-get rule :string)
3540 (plist-get default-rule :string))))
3541 (date (navi2ch-article-extract-date (navi2ch-article-get-current-date)))
3542 (article navi2ch-article-current-article)
3543 (board navi2ch-article-current-board))
3544 (setq str (cond
3545 ((stringp str) str)
3546 ((functionp str) (funcall str))
3547 (t (error "rule type missmatch: string")))
3548 navi2ch-article-message-filter-wid-window-configuration
3549 (current-window-configuration))
3550 (kill-buffer (get-buffer-create "*navi2ch Add filter*"))
3551 (pop-to-buffer (get-buffer-create "*navi2ch Add filter*"))
3552 (kill-all-local-variables)
3553 (buffer-disable-undo)
3554 (setq navi2ch-article-message-filter-wid-var (or (plist-get rule :var)
3555 (plist-get default-rule :var))
3556 navi2ch-article-current-article article
3557 navi2ch-article-current-board board)
3558 (insert "navi2ch Filter Editor\n\nString: ")
3559 (setq navi2ch-article-message-filter-wid-string
3560 (widget-create 'editable-field str))
3561 (insert "\nRule:\n")
3562 (setq navi2ch-article-message-filter-wid-rule
3563 (widget-create 'radio-button-choice
3564 :value (or (plist-get rule :rule)
3565 (plist-get default-rule :rule))
3566 '(editable-field :tag "replace" :format "%t: %v" "\e$B$"$\$\!<$s\e(B")
3567 '(item :tag "hide" :value hide)
3568 '(item :tag "important" :value important)
3569 '(editable-field :tag "score" :format "%t: %v" "0")))
3570 (insert "\n")
3571 (widget-create 'push-button
3572 :notify 'navi2ch-article-add-message-filter-cus-done
3573 "Done")
3574 (insert "\n\nMatch method:\n")
3575 (setq navi2ch-article-message-filter-wid-method
3576 (widget-create 'radio-button-choice
3577 :value (or (plist-get rule :match-method)
3578 (plist-get default-rule :match-method))
3579 '(item :tag "substring" :value "s")
3580 '(item :tag "fuzzy" :value "f")
3581 '(item :tag "exact" :value "e")
3582 '(item :tag "regexp" :value "r")))
3583 (insert "\nIgnore case: ")
3584 (setq navi2ch-article-message-filter-wid-case
3585 (widget-create 'toggle
3586 :value (or (plist-get rule :ignore-case)
3587 (plist-get default-rule :ignore-case))))
3588 ;;; (widget-create 'radio-button-choice
3589 ;;; :value nil
3590 ;;; '(item :tag "On" :value t)
3591 ;;; '(item :tag "Off" :value nil)))
3592 (insert "Invert match: ")
3593 (setq navi2ch-article-message-filter-wid-invert
3594 ;;; (widget-create 'radio-button-choice
3595 ;;; :value nil
3596 ;;; '(item :tag "On" :value t)
3597 ;;; '(item :tag "Off" :value nil)))
3598 (widget-create 'toggle
3599 :value (or (plist-get rule :invert-match)
3600 (plist-get default-rule :invert-match))))
3601 (insert "\nScope:\n")
3602 (setq navi2ch-article-message-filter-wid-scope
3603 (widget-create 'radio-button-choice
3604 :value (or (plist-get rule :scope)
3605 (plist-get default-rule :scope))
3606 '(item :tag "board local" :value board-local)
3607 '(item :tag "article local" :value article-local)
3608 '(item :tag "global" :value nil)))
3609 (insert "\nFloating:\n")
3610 (setq navi2ch-article-message-filter-wid-float
3611 (widget-create 'radio-button-choice
3612 :value (or (plist-get rule :floating)
3613 (plist-get default-rule :floating))
3614 '(item :tag "never" :value 0)
3615 '(item :tag "always" :value 1)
3616 '(item :tag "default" :value nil)))
3617 (insert "\nDate:\n")
3618 (setq navi2ch-article-message-filter-wid-date
3619 (widget-create 'radio-button-choice
3620 :value (and (or (plist-get rule :date)
3621 (plist-get default-rule :date))
3622 date)
3623 `(editable-field :tag "date local" :format "%t: %v" ,date)
3624 '(item :tag "none specified" :value nil)))
3625 (insert "\n")
3626 (widget-create 'push-button
3627 :notify 'navi2ch-article-add-message-filter-cus-done
3628 "Done")
3629 (insert "\n")
3630 (use-local-map widget-keymap)
3631 (widget-setup)
3632 (goto-char (point-min))
3633 (when (or (plist-get rule :auto)
3634 (plist-get default-rule :auto))
3635 (navi2ch-article-add-message-filter-cus-done))))
3636
3637 (defun navi2ch-article-add-message-filter-cus-done (&rest ignore)
3638 (let* ((variable navi2ch-article-message-filter-wid-var)
3639 (char (widget-value navi2ch-article-message-filter-wid-method))
3640 (scope (widget-value navi2ch-article-message-filter-wid-scope))
3641 (match (list
3642 (widget-value navi2ch-article-message-filter-wid-string)
3643 (intern
3644 (if (widget-value navi2ch-article-message-filter-wid-case)
3645 char
3646 (upcase char)))
3647 :invert (widget-value navi2ch-article-message-filter-wid-invert)
3648 :board-id (and (or (eq scope 'board-local)
3649 (eq scope 'article-local))
3650 (cdr (assq 'id navi2ch-article-current-board)))
3651 :artid (and (eq scope 'article-local)
3652 (cdr (assq 'artid
3653 navi2ch-article-current-article)))
3654 :float (widget-value navi2ch-article-message-filter-wid-float)
3655 :date (widget-value navi2ch-article-message-filter-wid-date)))
3656 (res (widget-value navi2ch-article-message-filter-wid-rule))
3657 (rule-children (widget-get
3658 navi2ch-article-message-filter-wid-rule
3659 :children))
3660 (result (cond ((or (eq res 'hide)
3661 (eq res 'important)
3662 (widget-apply
3663 (nth 0 rule-children)
3664 :active))
3665 res)
3666 ((widget-apply (nth 3 rule-children) :active)
3667 (string-to-number res))
3668 (t (error "You should select rule."))))
3669 (current (assoc match (symbol-value variable))))
3670 (set variable (cons (cons match result)
3671 (delq current (symbol-value variable))))
3672 (navi2ch-auto-modify-variables (list variable))
3673 (bury-buffer)
3674 (set-window-configuration
3675 navi2ch-article-message-filter-wid-window-configuration)
3676 (if (y-or-n-p "Apply new rules to current messages now? ")
3677 (navi2ch-article-toggle-message-filter t)
3678 (message "Don't apply now"))))
3679
3680 (defun navi2ch-article-add-message-filter-by-name (&optional prefix)
3681 (interactive "P")
3682 (navi2ch-article-add-message-filter-rule-subr
3683 'navi2ch-article-message-filter-by-name-alist
3684 "Name: "
3685 (if prefix
3686 (buffer-substring-no-properties (region-beginning) (region-end))
3687 (navi2ch-article-get-current-name))))
3688
3689 (defun navi2ch-article-add-message-filter-by-mail (&optional prefix)
3690 (interactive "P")
3691 (navi2ch-article-add-message-filter-rule-subr
3692 'navi2ch-article-message-filter-by-mail-alist
3693 "Mail: "
3694 (if prefix
3695 (buffer-substring-no-properties (region-beginning) (region-end))
3696 (navi2ch-article-get-current-mail))))
3697
3698 (defun navi2ch-article-add-message-filter-by-id (&optional prefix)
3699 (interactive "P")
3700 (navi2ch-article-add-message-filter-rule-subr
3701 'navi2ch-article-message-filter-by-id-alist
3702 "ID: "
3703 (if prefix
3704 (buffer-substring-no-properties (region-beginning) (region-end))
3705 (navi2ch-article-get-current-id))))
3706
3707 (defun navi2ch-article-add-message-filter-by-message (&optional prefix)
3708 (interactive "P")
3709 (navi2ch-article-add-message-filter-rule-subr
3710 'navi2ch-article-message-filter-by-message-alist
3711 "Body: "
3712 (if prefix
3713 (buffer-substring-no-properties (region-beginning) (region-end))
3714 (navi2ch-article-get-current-word-in-body))))
3715
3716 (defun navi2ch-article-add-message-filter-by-subject (&optional prefix)
3717 (interactive "P")
3718 (navi2ch-article-add-message-filter-rule-subr
3719 'navi2ch-article-message-filter-by-subject-alist
3720 "Subject: "
3721 (if prefix
3722 (buffer-substring-no-properties (region-beginning) (region-end))
3723 (navi2ch-article-get-current-subject))))
3724
3725 (defun navi2ch-article-add-message-filter-by-hostname (&optional prefix)
3726 (interactive "P")
3727 (navi2ch-article-add-message-filter-rule-subr
3728 'navi2ch-article-message-filter-by-hostname-alist
3729 "Hostname: "
3730 (if prefix
3731 (buffer-substring-no-properties (region-beginning) (region-end))
3732 (navi2ch-article-get-current-hostname))))
3733
3734 (defun navi2ch-article-add-message-filter-rule-subr (variable
3735 prompt
3736 &optional initial-input)
3737 (let* ((match (navi2ch-article-read-message-filter-match prompt
3738 initial-input))
3739 (current (assoc match (symbol-value variable)))
3740 (result (navi2ch-article-read-message-filter-result (cdr current))))
3741 (set variable (cons (cons match result)
3742 (delq current (symbol-value variable))))
3743 (navi2ch-auto-modify-variables (list variable))
3744 (if (y-or-n-p "Apply new rules to current messages now? ")
3745 (navi2ch-article-toggle-message-filter t)
3746 (message "Don't apply now"))))
3747
3748 (defun navi2ch-article-read-message-filter-match (prompt
3749 &optional initial-input)
3750 (let (str list)
3751 (when (y-or-n-p "Use extended matching? ")
3752 (let ((char (navi2ch-read-char-with-retry
3753 "Type: s)ubstring f)uzzy e)xact r)egxp: "
3754 nil
3755 '(?s ?f ?e ?r))))
3756 (when (and (eq char ?r)
3757 initial-input)
3758 (setq initial-input (regexp-quote initial-input)))
3759 (unless (y-or-n-p "Ignore case? ")
3760 (setq char (upcase char)))
3761 (setq list (list initial-input (intern (char-to-string char))))
3762 (when (y-or-n-p "Invert match? ")
3763 (setq list (plist-put list :invert t)))))
3764 (setq str (navi2ch-read-string prompt
3765 initial-input
3766 'navi2ch-search-history))
3767 (if (null list)
3768 str
3769 (setcar list str)
3770 (let ((options '("s)cope" "f)loating" "d)ate")))
3771 (while (and options
3772 (y-or-n-p "Set other options? "))
3773 (let ((char (navi2ch-read-char-with-retry
3774 (concat "Options: "
3775 (mapconcat #'identity options " ")
3776 ": ")
3777 nil
3778 (mapcar
3779 (lambda (x) (aref x (1- (string-match ")" x))))
3780 options))))
3781 (cond
3782 ((eq char ?s)
3783 (let ((char (navi2ch-read-char-with-retry
3784 "Scope: b)oard-local a)rticle-local d)efault: "
3785 nil
3786 '(?b ?a ?d))))
3787 (when (memq char '(?b ?a))
3788 (setq list
3789 (plist-put
3790 list
3791 :board-id
3792 (cdr (assq 'id navi2ch-article-current-board))))
3793 (when (eq char ?a)
3794 (setq list
3795 (plist-put
3796 list
3797 :artid
3798 (cdr (assq 'artid
3799 navi2ch-article-current-article))))))
3800 (setq options (delete "s)cope" options))))
3801 ((eq char ?f)
3802 (let ((char (navi2ch-read-char-with-retry
3803 "Floating: n)ever a)lways d)efault: "
3804 nil
3805 '(?n ?a ?d))))
3806 (cond
3807 ((eq char ?n)
3808 (setq list (plist-put list :float 0)))
3809 ((eq char ?a)
3810 (setq list (plist-put list :float 1))))
3811 (setq options (delete "f)loating" options))))
3812 ((eq char ?d)
3813 (when (y-or-n-p "Set the rule date local? ")
3814 (let ((date (navi2ch-read-string "Date local: "
3815 (navi2ch-article-extract-date
3816 (navi2ch-article-get-current-date)))))
3817 (when (not (string= date ""))
3818 (setq list
3819 (plist-put list :date date))))))))))
3820 list)))
3821
3822 (defun navi2ch-article-read-message-filter-result (&optional initial-input)
3823 (let ((char (navi2ch-read-char-with-retry
3824 "Result: r)eplace h)ide i)mportant s)core: "
3825 nil
3826 '(?r ?h ?i ?s))))
3827 (cond
3828 ((eq char ?r)
3829 (navi2ch-read-string "Relace with: "
3830 (if (stringp initial-input)
3831 initial-input
3832 "\e$B$"$\$\!<$s\e(B")))
3833 ((eq char ?h)
3834 'hide)
3835 ((eq char ?i)
3836 'important)
3837 ((eq char ?s)
3838 (string-to-number
3839 (navi2ch-read-string "Score: "
3840 (if (numberp initial-input)
3841 (number-to-string initial-input)
3842 "0")))))))
3843
3844 (defun navi2ch-article-remove-article ()
3845 (interactive)
3846 (let ((board navi2ch-article-current-board)
3847 (article navi2ch-article-current-article))
3848 (when (and board article)
3849 (navi2ch-article-exit)
3850 (navi2ch-bm-remove-article-subr board article))))
3851
3852 (defun navi2ch-article-orphan-p (board article)
3853 "BOARD \e$B$H\e(B ARTICLE \e$B$G;XDj$5$l$k%9%l$,%*%k%U%!%s$J>l9g!"\e(Bnon-nil \e$B$rJV$9!#\e(B"
3854 (cond ((navi2ch-bookmark-exist-all board article) nil)
3855 ((let ((subject-list (navi2ch-board-get-subject-list
3856 (navi2ch-board-get-file-name board)))
3857 (artid (cdr (assq 'artid article))))
3858 (catch 'break
3859 (dolist (s subject-list)
3860 (if (equal (cdr (assq 'artid s)) artid)
3861 (throw 'break t)))))
3862 nil)
3863 (t t)))
3864
3865 (defun navi2ch-article-url-at-point (point)
3866 "POINT \e$B$N2<$N%j%s%/$r;X$9\e(B URL \e$B$rF@$k!#\e(B"
3867 (let ((type (get-text-property point 'navi2ch-link-type))
3868 (prop (get-text-property point 'navi2ch-link)))
3869 (cond ((eq type 'number)
3870 (navi2ch-article-number-list-to-url
3871 (navi2ch-article-get-number-list prop)))
3872 ((eq type 'url)
3873 prop))))
3874
3875 (defsubst navi2ch-article-jit-insert-1 (n cur diffpos wintop-pos start end)
3876 (when (and (<= start n) (<= n end))
3877 (let* ((alist (cdr (assq n navi2ch-article-message-list)))
3878 (p (and (listp alist)
3879 (cdr (assq 'point (assq n navi2ch-article-message-list))))))
3880 (when (or (null p) (= p (point-max)))
3881 (navi2ch-article-reinsert-partial-messages n n)
3882 (when (and cur diffpos)
3883 (let ((navi2ch-article-goto-number-recenter t))
3884 (navi2ch-article-goto-number cur))
3885 (goto-char (+ (point) diffpos 1))
3886 (when wintop-pos
3887 (set-window-start (selected-window)
3888 (- (point) wintop-pos))))
3889 (redisplay)))))
3890
3891 (defun navi2ch-article-jit-insert ()
3892 (let ((buffer
3893 (if (memq (current-buffer)
3894 navi2ch-article-jit-buffers)
3895 (current-buffer)
3896 (car navi2ch-article-jit-buffers))))
3897 (if (buffer-live-p buffer)
3898 (let ((wintop-pos (and (eq (window-buffer) buffer)
3899 (- (point) (window-start)))))
3900 (with-current-buffer buffer
3901 (let ((n (navi2ch-article-get-current-number))
3902 diffpos)
3903 (if (get-text-property (point) 'current-number)
3904 (setq diffpos -1)
3905 (setq diffpos
3906 (previous-single-property-change (point) 'current-number))
3907 (when diffpos
3908 (setq diffpos (- (point) diffpos))))
3909 (let ((i 1)
3910 (start (car navi2ch-article-jit-need-insert))
3911 (end (cdr navi2ch-article-jit-need-insert))
3912 (buffer-read-only nil)
3913 (repeat t))
3914 (while (and repeat
3915 (or (and (<= start (- n i)) (<= (- n i) end))
3916 (and (<= start (+ n i)) (<= (+ n i) end))))
3917 (navi2ch-article-jit-insert-1 (+ n i) n diffpos wintop-pos start end)
3918 (navi2ch-article-jit-insert-1 (- n i) n diffpos wintop-pos start end)
3919 (setq i (1+ i))
3920 (setq repeat (not (input-pending-p))))
3921 (when repeat
3922 (setq navi2ch-article-jit-buffers
3923 (delq (current-buffer) navi2ch-article-jit-buffers))
3924 (unless navi2ch-article-jit-buffers
3925 (when navi2ch-article-jit-timer
3926 (cancel-timer navi2ch-article-jit-timer)
3927 (setq navi2ch-article-jit-timer nil))))))))
3928 (setq navi2ch-article-jit-buffers
3929 (delq buffer navi2ch-article-jit-buffers)))))
3930
3931 (defun navi2ch-article-jit-reinsert-partial-messages (start &optional end)
3932 (let* ((nums (mapcar #'car navi2ch-article-message-list))
3933 (len (length nums))
3934 (last (car (last nums)))
3935 (cur-res (navi2ch-article-get-current-number))
3936 range-list)
3937 (when (< start 0)
3938 (setq start (+ start last 1)))
3939 (if (null end)
3940 (setq end last)
3941 (when (< end 0)
3942 (setq end (+ end last 1)))
3943 (when (> start end)
3944 (setq start (prog1 end
3945 (setq end start)))))
3946 (navi2ch-article-reinsert-partial-messages start start)
3947 (navi2ch-article-reinsert-partial-messages end end)
3948 (setq navi2ch-article-jit-need-insert (if navi2ch-article-jit-need-insert
3949 (cons (min (car navi2ch-article-jit-need-insert)
3950 start)
3951 (max (cdr navi2ch-article-jit-need-insert)
3952 end))
3953 (cons start end)))
3954 (push (current-buffer) navi2ch-article-jit-buffers)
3955 (unless navi2ch-article-jit-timer
3956 (setq navi2ch-article-jit-timer
3957 (run-with-idle-timer navi2ch-article-jit-interval
3958 t
3959 'navi2ch-article-jit-insert)))))
3960
3961 (defun navi2ch-article-jit-insert-messages (list range number)
3962 (let ((len (length list)))
3963 (if (navi2ch-article-inside-range-p number range len)
3964 (progn
3965 (navi2ch-article-reinsert-partial-messages 1 1)
3966 (navi2ch-article-reinsert-partial-messages number number)
3967 (navi2ch-article-reinsert-partial-messages len len)
3968 (setq navi2ch-article-jit-need-insert (cons 1 len))
3969 (push (current-buffer) navi2ch-article-jit-buffers)
3970 (unless navi2ch-article-jit-timer
3971 (setq navi2ch-article-jit-timer
3972 (run-with-idle-timer navi2ch-article-jit-interval
3973 t
3974 'navi2ch-article-jit-insert))))
3975 ;; \e$BI=<(3+;O>l=j$,I=<(HO0O$K$J$$;~$O$^$k$J$2\e(B
3976 (navi2ch-article-insert-messages list range))))
3977
3978 (defun navi2ch-article-compress (&optional board article)
3979 (let (ignore)
3980 (when (eq major-mode 'navi2ch-article-mode)
3981 (if (navi2ch-board-from-file-p (or board navi2ch-article-current-board))
3982 (setq ignore t)
3983 (or board (setq board navi2ch-article-current-board))
3984 (or article (setq article navi2ch-article-current-article))))
3985 (when (and (not ignore) board article (not (cdr (assq 'compressed article))))
3986 (let* ((file (navi2ch-article-get-file-name board article))
3987 (gzfile (concat file ".gz")))
3988 (when (file-exists-p file)
3989 (with-temp-file gzfile
3990 (navi2ch-set-buffer-multibyte nil)
3991 (insert-file-contents file))
3992 (delete-file file))
3993 (setq article (navi2ch-put-alist 'compressed t article))
3994 (navi2ch-article-save-info board article)))))
3995
3996 (defun navi2ch-article-uncompress (&optional board article)
3997 (let (ignore)
3998 (when (eq major-mode 'navi2ch-article-mode)
3999 (if (navi2ch-board-from-file-p (or board navi2ch-article-current-board))
4000 (setq ignore t)
4001 (or board (setq board navi2ch-article-current-board))
4002 (or article (setq article navi2ch-article-current-article))))
4003 (when (and (not ignore) board article (cdr (assq 'compressed article)))
4004 (let* ((gzfile (navi2ch-article-get-file-name board article))
4005 (file (file-name-sans-extension gzfile)))
4006 (when (file-exists-p gzfile)
4007 (with-temp-file file
4008 (navi2ch-set-buffer-multibyte nil)
4009 (insert-file-contents gzfile))
4010 (delete-file gzfile))
4011 (setq article (navi2ch-put-alist 'compressed nil article))
4012 (navi2ch-article-save-info board article)))))
4013
4014 (run-hooks 'navi2ch-article-load-hook)
4015 ;;; navi2ch-article.el ends here
Navi2ch, Navigator for 2ch for Emacsen