?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Change key bind for quit image viewer
[navi2ch.git] / navi2ch-util.el
blobb45dcf30f32109ddf8683f3aaa9a59bb1c74e7b3
1 ;;; navi2ch-util.el --- useful utilities 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 ;; Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000 Free
7 ;; Software Foundation, Inc.
8
9 ;; Author: Taiki SUGAWARA <taiki@users.sourceforge.net>
10 ;; Keywords: network, 2ch
11
12 ;; This file is free software; you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version.
16
17 ;; This file is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs; see the file COPYING. If not, write to
24 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Commentary:
28
29 ;;
30
31 ;;; Code:
32 (defconst navi2ch-util-ident
33 "$Id$")
34
35 (eval-when-compile
36 (require 'cl-lib)
37 (require 'navi2ch-inline)
38 (require 'navi2ch-decls))
39 (require 'navi2ch-vars)
40
41 (require 'timezone)
42 (require 'browse-url)
43 (require 'base64)
44
45 (defun navi2ch-alist-to-hash (alist &rest keywords-args)
46 (let ((table (apply #'make-hash-table :size (length alist) keywords-args)))
47 (dolist (x alist table)
48 (puthash (car x) (cdr x) table))))
49
50 (defvar navi2ch-mode-line-identification nil)
51 (make-variable-buffer-local 'navi2ch-mode-line-identification)
52
53 (defvar navi2ch-replace-html-tag-alist
54 '(("&gt;" . ">")
55 ("&lt;" . "<")
56 ("&quot;" . "\"")
57 ("&nbsp;" . " ")
58 ("&amp;" . "&")
59 ("<br>" . "\n")
60 ("<hr>" . "\n--\n"))
61 "\e$BCV49$9$k\e(B html \e$B$N%?%0$NO"A[%j%9%H\e(B (\e$B@55,I=8=$O;H$($J$$\e(B)\e$B!#\e(B")
62
63 (defvar navi2ch-replace-html-tag-regexp-alist
64 '(("</?[?!a-zA-Z][^<>]*>" . "")
65 ("&[a-z][a-z0-9]*;" . navi2ch-entity-reference-to-str)
66 ("&#[0-9]+;?" . navi2ch-numeric-reference-to-str)
67 ("&#[xX][0-9a-fA-f]+;?" . navi2ch-hexadecimal-reference-to-str))
68 "\e$BCV49$9$k\e(B html \e$B$N%?%0$NO"A[%j%9%H\e(B(\e$B@55,I=8=\e(B)
69 \e$BCV49@h$,4X?t$@$H!"CV4985$r0z?t$H$7$F$=$N4X?t$r8F$S$@$7!"$=$NJV$jCM$GCV$-BX$($k!#\e(B
70 \e$B@55,I=8=$,I,MW$J$$>l9g$O\e(B `navi2ch-replace-html-tag-alist' \e$B$KF~$l$k\e(B")
71
72 (defvar navi2ch-replace-html-tag-regexp-internal nil
73 "\e$BCV49$9$k\e(B html \e$B$N%?%0$N@55,I=8=!#\e(B")
74
75 (defvar navi2ch-entity-table
76 (navi2ch-alist-to-hash
77 '(("iexcl" . 161) ("cent" . 162) ("pound" . 163)
78 ("curren" . 164) ("yen" . 165) ("brvbar" . 166)
79 ("sect" . 167) ("uml" . 168) ("copy" . 169)
80 ("ordf" . 170) ("laquo" . 171) ("not" . 172)
81 ("shy" . 173) ("reg" . 174) ("macr" . 175)
82 ("deg" . 176) ("plusmn" . 177) ("sup2" . 178)
83 ("sup3" . 179) ("acute" . 180) ("micro" . 181)
84 ("para" . 182) ("middot" . 183) ("cedil" . 184)
85 ("sup1" . 185) ("ordm" . 186) ("raquo" . 187)
86 ("frac14" . 188) ("frac12" . 189) ("frac34" . 190)
87 ("iquest" . 191) ("Agrave" . 192) ("Aacute" . 193)
88 ("Acirc" . 194) ("Atilde" . 195) ("Auml" . 196)
89 ("Aring" . 197) ("AElig" . 198) ("Ccedil" . 199)
90 ("Egrave" . 200) ("Eacute" . 201) ("Ecirc" . 202)
91 ("Euml" . 203) ("Igrave" . 204) ("Iacute" . 205)
92 ("Icirc" . 206) ("Iuml" . 207) ("ETH" . 208)
93 ("Ntilde" . 209) ("Ograve" . 210) ("Oacute" . 211)
94 ("Ocirc" . 212) ("Otilde" . 213) ("Ouml" . 214)
95 ("times" . 215) ("Oslash" . 216) ("Ugrave" . 217)
96 ("Uacute" . 218) ("Ucirc" . 219) ("Uuml" . 220)
97 ("Yacute" . 221) ("THORN" . 222) ("szlig" . 223)
98 ("agrave" . 224) ("aacute" . 225) ("acirc" . 226)
99 ("atilde" . 227) ("auml" . 228) ("aring" . 229)
100 ("aelig" . 230) ("ccedil" . 231) ("egrave" . 232)
101 ("eacute" . 233) ("ecirc" . 234) ("euml" . 235)
102 ("igrave" . 236) ("iacute" . 237) ("icirc" . 238)
103 ("iuml" . 239) ("eth" . 240) ("ntilde" . 241)
104 ("ograve" . 242) ("oacute" . 243) ("ocirc" . 244)
105 ("otilde" . 245) ("ouml" . 246) ("divide" . 247)
106 ("oslash" . 248) ("ugrave" . 249) ("uacute" . 250)
107 ("ucirc" . 251) ("uuml" . 252) ("yacute" . 253)
108 ("thorn" . 254) ("yuml" . 255) ("fnof" . 402)
109 ("Alpha" . 913) ("Beta" . 914) ("Gamma" . 915)
110 ("Delta" . 916) ("Epsilon" . 917) ("Zeta" . 918)
111 ("Eta" . 919) ("Theta" . 920) ("Iota" . 921)
112 ("Kappa" . 922) ("Lambda" . 923) ("Mu" . 924)
113 ("Nu" . 925) ("Xi" . 926) ("Omicron" . 927)
114 ("Pi" . 928) ("Rho" . 929) ("Sigma" . 931)
115 ("Tau" . 932) ("Upsilon" . 933) ("Phi" . 934)
116 ("Chi" . 935) ("Psi" . 936) ("Omega" . 937)
117 ("alpha" . 945) ("beta" . 946) ("gamma" . 947)
118 ("delta" . 948) ("epsilon" . 949) ("zeta" . 950)
119 ("eta" . 951) ("theta" . 952) ("iota" . 953)
120 ("kappa" . 954) ("lambda" . 955) ("mu" . 956)
121 ("nu" . 957) ("xi" . 958) ("omicron" . 959)
122 ("pi" . 960) ("rho" . 961) ("sigmaf" . 962)
123 ("sigma" . 963) ("tau" . 964) ("upsilon" . 965)
124 ("phi" . 966) ("chi" . 967) ("psi" . 968)
125 ("omega" . 969) ("thetasym" . 977) ("upsih" . 978)
126 ("piv" . 982) ("bull" . 8226) ("hellip" . 8230)
127 ("prime" . 8242) ("Prime" . 8243) ("oline" . 8254)
128 ("frasl" . 8260) ("weierp" . 8472) ("image" . 8465)
129 ("real" . 8476) ("trade" . 8482) ("alefsym" . 8501)
130 ("larr" . 8592) ("uarr" . 8593) ("rarr" . 8594)
131 ("darr" . 8595) ("harr" . 8596) ("crarr" . 8629)
132 ("lArr" . 8656) ("uArr" . 8657) ("rArr" . 8658)
133 ("dArr" . 8659) ("hArr" . 8660) ("forall" . 8704)
134 ("part" . 8706) ("exist" . 8707) ("empty" . 8709)
135 ("nabla" . 8711) ("isin" . 8712) ("notin" . 8713)
136 ("ni" . 8715) ("prod" . 8719) ("sum" . 8721)
137 ("minus" . 8722) ("lowast" . 8727) ("radic" . 8730)
138 ("prop" . 8733) ("infin" . 8734) ("ang" . 8736)
139 ("and" . 8743) ("or" . 8744) ("cap" . 8745)
140 ("cup" . 8746) ("int" . 8747) ("there4" . 8756)
141 ("sim" . 8764) ("cong" . 8773) ("asymp" . 8776)
142 ("ne" . 8800) ("equiv" . 8801) ("le" . 8804)
143 ("ge" . 8805) ("sub" . 8834) ("sup" . 8835)
144 ("nsub" . 8836) ("sube" . 8838) ("supe" . 8839)
145 ("oplus" . 8853) ("otimes" . 8855) ("perp" . 8869)
146 ("sdot" . 8901) ("lceil" . 8968) ("rceil" . 8969)
147 ("lfloor" . 8970) ("rfloor" . 8971) ("lang" . 9001)
148 ("rang" . 9002) ("loz" . 9674) ("spades" . 9824)
149 ("clubs" . 9827) ("hearts" . 9829) ("diams" . 9830)
150 ("OElig" . 338) ("oelig" . 339) ("Scaron" . 352)
151 ("scaron" . 353) ("Yuml" . 376) ("circ" . 710)
152 ("tilde" . 732) ("ensp" . 8194) ("emsp" . 8195)
153 ("thinsp" . 8201) ("zwnj" . 8204) ("zwj" . 8205)
154 ("lrm" . 8206) ("rlm" . 8207) ("ndash" . 8211)
155 ("mdash" . 8212) ("lsquo" . 8216) ("rsquo" . 8217)
156 ("sbquo" . 8218) ("ldquo" . 8220) ("rdquo" . 8221)
157 ("bdquo" . 8222) ("dagger" . 8224) ("Dagger" . 8225)
158 ("permil" . 8240) ("lsaquo" . 8249) ("rsaquo" . 8250)
159 ("euro" . 8364))
160 :test 'equal))
161
162 (defconst navi2ch-uuencode-begin-delimiter-regexp
163 "^begin \\([0-7]+\\) \\([^ \n]+\\)$"
164 "uuencode \e$B$5$l$?%3!<%I$NA0$N%G%j%_%?$K%^%C%A$9$k@55,I=8=!#\e(B")
165 (defconst navi2ch-uuencode-end-delimiter-regexp
166 "^end\\([ \t]*\\)$"
167 "uuencode \e$B$5$l$?%3!<%I$N8e$N%G%j%_%?$K%^%C%A$9$k@55,I=8=!#\e(B")
168
169 (defconst navi2ch-uuencode-line-regexp
170 "^[!-`]+$"
171 "uuencode \e$B$5$l$?%3!<%I$N$_$,4^$^$l$k9T$K%^%C%A$9$k@55,I=8=!#\e(B")
172
173 (defconst navi2ch-base64-begin-delimiter "----BEGIN BASE64----"
174 "base64 \e$B%3!<%I$NA0$KA^F~$9$k%G%j%_%?!#\e(B")
175 (defconst navi2ch-base64-end-delimiter "----END BASE64----"
176 "base64 \e$B%3!<%I$N8e$KA^F~$9$k%G%j%_%?!#\e(B")
177
178 (defconst navi2ch-base64-begin-delimiter-regexp
179 (format "^%s\\((\\([^\)]+\\))\\)?.*$"
180 (regexp-quote navi2ch-base64-begin-delimiter))
181 "base64 \e$B%3!<%I$NA0$N%G%j%_%?$K%^%C%A$9$k@55,I=8=!#\e(B")
182 (defconst navi2ch-base64-end-delimiter-regexp
183 (format "^%s.*$" (regexp-quote navi2ch-base64-end-delimiter))
184 "base64 \e$B%3!<%I$N8e$N%G%j%_%?$K%^%C%A$9$k@55,I=8=!#\e(B")
185 (defconst navi2ch-base64-susv3-begin-delimiter-regexp
186 "^begin-base64 \\([0-7]+\\) \\([^ \n]+\\)$"
187 "SUSv3 \e$B$N\e(B uuencode \e$B$G:n@.$5$l$k\e(B base64 \e$B%3!<%I$NA0$N%G%j%_%?$K%^%C%A$9$k@55,I=8=\e(B")
188 (defconst navi2ch-base64-susv3-end-delimiter-regexp
189 "^====$"
190 "SUSv3 \e$B$N\e(B uuencode \e$B$G:n@.$5$l$k\e(B base64 \e$B%3!<%I$N8e$N%G%j%_%?$K%^%C%A$9$k@55,I=8=\e(B")
191
192 (defconst navi2ch-base64-line-regexp
193 (concat
194 "^\\([+/0-9A-Za-z][+/0-9A-Za-z][+/0-9A-Za-z][+/0-9A-Za-z]\\)*"
195 "[+/0-9A-Za-z][+/0-9A-Za-z][+/0-9A-Za-z=][+/0-9A-Za-z=] *$")
196 "base64 \e$B%3!<%I$N$_$,4^$^$l$k9T$K%^%C%A$9$k@55,I=8=!#\e(B")
197
198 (defvar navi2ch-offline nil "\e$B%*%U%i%$%s%b!<%I$+$I$&$+!#\e(B")
199 (defvar navi2ch-online-indicator "[ON] ")
200 (defvar navi2ch-offline-indicator "[--] ")
201 (defvar navi2ch-modeline-online navi2ch-online-indicator)
202 (defvar navi2ch-modeline-offline navi2ch-offline-indicator)
203 (defvar navi2ch-modeline-be2ch-login "[BE] ")
204 (defvar navi2ch-modeline-be2ch-logout "")
205 (put 'navi2ch-modeline-online 'risky-local-variable t)
206 (put 'navi2ch-modeline-offline 'risky-local-variable t)
207 (put 'navi2ch-modeline-be2ch-login 'risky-local-variable t)
208 (put 'navi2ch-modeline-be2ch-logout 'risky-local-variable t)
209
210 ;; shut up XEmacs warnings
211 (eval-when-compile
212 (defvar minibuffer-allow-text-properties))
213 \f
214 ;; from apel
215
216 (defsubst navi2ch-cache-limit (cache)
217 (elt cache 0))
218
219 (defsubst navi2ch-cache-hash-table (cache)
220 (elt cache 1))
221
222 \f
223 ;;;; other misc stuff
224 (defun navi2ch-mouse-key (num)
225 (navi2ch-ifxemacs
226 (intern (format "button%d" num))
227 (vector (intern (format "mouse-%d" num)))))
228
229 (defun navi2ch-define-mouse-key (map num command)
230 (define-key map (navi2ch-mouse-key num) command))
231
232 (defvar navi2ch-delete-keys
233 (list "\d" [del] [delete] [backspace]
234 (navi2ch-ifxemacs
235 [(shift space)]
236 [(shift ? )])))
237
238 (defun navi2ch-define-delete-keys (map command)
239 (dolist (key navi2ch-delete-keys)
240 (define-key map key command)))
241
242 (eval-and-compile
243 (defalias 'navi2ch-set-buffer-multibyte
244 (if (fboundp 'set-buffer-multibyte)
245 #'set-buffer-multibyte
246 #'identity))
247
248 (defalias 'navi2ch-match-string-no-properties
249 (if (fboundp 'match-string-no-properties)
250 #'match-string-no-properties
251 #'match-string)))
252
253 (defun navi2ch-no-logging-message (fmt &rest args)
254 (navi2ch-ifxemacs
255 (apply #'lmessage 'no-log fmt args)
256 (let ((message-log-max nil))
257 (apply #'message fmt args))))
258
259 (defun navi2ch-replace-string (regexp rep string
260 &optional all fixedcase literal)
261 "STRING \e$B$K4^$^$l$k\e(B REGEXP \e$B$r\e(B REP \e$B$GCV49$9$k!#\e(B
262 REP \e$B$,4X?t$N>l9g$O!"%^%C%A$7$?J8;zNs$r0z?t$K$7$F$=$N4X?t$r8F$S=P$9!#\e(B
263
264 FIXEDCASE\e$B!"\e(BLITERAL \e$B$O\e(B `replace-match' \e$B$K$=$N$^$^EO$5$l$k!#\e(B
265
266 ALL \e$B$,\e(B non-nil \e$B$J$i$P!"%^%C%A$7$?%F%-%9%H$r$9$Y$FCV49$9$k!#\e(Bnil \e$B$J$i\e(B
267 \e$B:G=i$N\e(B1\e$B$D$@$1$rCV49$9$k!#\e(B
268
269 REGEXP \e$B$,8+$D$+$i$J$$>l9g!"\e(BSTRING \e$B$r$=$N$^$^JV$9!#\e(B"
270 (save-match-data
271 (if all
272 ;; Emacs 21 \e$B$N\e(B replace-regexp-in-string \e$B$N%Q%/$j!#\e(B
273 (let ((start 0)
274 (l (length string))
275 mb me str matches)
276 (while (and (< start l)
277 (string-match regexp string start))
278 (setq mb (match-beginning 0)
279 me (match-end 0))
280 (if (= mb me)
281 (setq me (min l (1+ mb))))
282 (string-match regexp (setq str (substring string mb me)))
283 (setq matches
284 (cons (replace-match (if (stringp rep)
285 rep
286 (funcall rep (match-string 0 str)))
287 fixedcase literal str)
288 (cons (substring string start mb)
289 matches)))
290 (setq start me))
291 (apply #'concat (nreverse (cons (substring string start l)
292 matches))))
293 (when (string-match regexp string)
294 (setq string (replace-match (if (stringp rep)
295 rep
296 (funcall rep (match-string 0 string)))
297 fixedcase literal string)))
298 string)))
299
300 (defun navi2ch-replace-string-regexp-alist
301 (regexp-alist string &optional all fixedcase literal)
302 "STRING \e$BCf$+$i!"\e(BREGEXP-ALIST \e$B$N3FMWAG$N\e(B car \e$B$r@55,I=8=$H$7!"\e(Bcdr \e$B$GCV49$9$k!#\e(B
303 cdr \e$B$,4X?t$N>l9g$O!"85J8;zNs$r0z?t$K$7$F$=$N4X?t$r8F$S=P$9!#\e(B
304
305 FIXEDCASE\e$B!"\e(BLITERAL \e$B$O\e(B `replace-match' \e$B$K$=$N$^$^EO$5$l$k!#\e(B
306
307 ALL \e$B$,\e(B non-nil \e$B$J$i$P!"%^%C%A$7$?%F%-%9%H$r$9$Y$FCV49$9$k!#\e(Bnil \e$B$J$i\e(B
308 \e$B:G=i$N\e(B1\e$B$D$@$1$rCV49$9$k!#\e(B
309
310 REGEXP \e$B$,8+$D$+$i$J$$>l9g!"\e(BSTRING \e$B$r$=$N$^$^JV$9!#\e(B"
311 (save-match-data
312 (let ((internal (navi2ch-regexp-alist-to-internal regexp-alist))
313 match rep)
314 (if all
315 ;; Emacs 21 \e$B$N\e(B replace-regexp-in-string \e$B$N%Q%/$j!#\e(B
316 (let ((start 0)
317 (l (length string))
318 mb me str matches)
319 (while (and (< start l)
320 (setq match (navi2ch-string-match-regexp-alist
321 internal string start)))
322 (setq mb (match-beginning 0)
323 me (match-end 0))
324 (if (= mb me)
325 (setq me (min l (1+ mb))))
326 (string-match
327 (car match)
328 (setq str (substring string mb me)))
329 (setq rep (cdr match))
330 (setq matches
331 (cons (replace-match (if (stringp rep)
332 rep
333 (funcall rep str))
334 fixedcase literal str)
335 (cons (substring string start mb)
336 matches)))
337 (setq start me))
338 (apply #'concat (nreverse (cons (substring string start l)
339 matches))))
340 (when (setq match (navi2ch-string-match-regexp-alist internal string))
341 (setq rep (cdr match))
342 (setq string (replace-match (if (stringp rep)
343 rep
344 (funcall rep string))
345 fixedcase literal string)))
346 string))))
347
348 (defun navi2ch-insert-file-contents (file &optional begin end coding-system)
349 (setq coding-system (or coding-system navi2ch-coding-system))
350 (let ((coding-system-for-read coding-system)
351 (coding-system-for-write coding-system))
352 (insert-file-contents file nil begin end)))
353
354 (defun navi2ch-expand-file-name (file)
355 (let ((result (expand-file-name
356 (mapconcat (lambda (ch)
357 (if (memq ch navi2ch-file-name-reserved-char-list)
358 (format "%%%02X" ch)
359 (char-to-string ch)))
360 (append file)
361 "")
362 navi2ch-directory)))
363 (if (string-match (concat "^"
364 (regexp-quote (file-name-as-directory
365 (expand-file-name navi2ch-directory))))
366 result)
367 result
368 (error "Wrong file name"))))
369
370 (eval-when-compile
371 (navi2ch-defalias-maybe 'assoc-string 'ignore))
372
373 (defun navi2ch-replace-html-tag (str)
374 (let ((case-fold-search t))
375 (navi2ch-replace-string-regexp-alist
376 navi2ch-replace-html-tag-regexp-internal
377 str t nil t)))
378
379 (defun navi2ch-replace-html-tag-with-buffer ()
380 (goto-char (point-min))
381 (let ((case-fold-search t)
382 match replace)
383 (while (setq match (navi2ch-re-search-forward-regexp-alist
384 navi2ch-replace-html-tag-regexp-internal nil t))
385 (setq replace (cdr match))
386 (replace-match (if (functionp replace)
387 (funcall replace nil)
388 replace)
389 nil t))))
390
391 (defun navi2ch-replace-html-tag-with-temp-buffer (str)
392 (with-temp-buffer
393 (insert str)
394 (navi2ch-replace-html-tag-with-buffer)
395 (buffer-string)))
396
397 (defun navi2ch-entity-reference-to-str (str)
398 "\e$BJ8;z<BBN;2>H$r%G%3!<%I!#\e(B"
399 (let ((ref (match-string 0 str)))
400 (save-match-data
401 (if (and navi2ch-decode-character-references
402 (string-match "&\\([^;]+\\)" ref))
403 (let ((code (gethash (match-string 1 ref) navi2ch-entity-table)))
404 (or (and code (navi2ch-ucs-to-str code))
405 ref))
406 ref))))
407
408 (defun navi2ch-numeric-reference-to-str (str)
409 "\e$B?tCMJ8;z;2>H$r%G%3!<%I!#\e(B"
410 (let ((ref (match-string 0 str)))
411 (save-match-data
412 (if (and navi2ch-decode-character-references
413 (string-match "&#\\([^;]+\\)" ref))
414 (or (navi2ch-ucs-to-str (string-to-number (match-string 1 ref))) "\e$B".\e(B")
415 ref))))
416
417 (defun navi2ch-hexadecimal-reference-to-str (str)
418 "16\e$B?J?tCMJ8;z;2>H$r%G%3!<%I!#\e(B"
419 (let ((ref (match-string 0 str)))
420 (save-match-data
421 (if (and navi2ch-decode-character-references
422 (string-match "&#[xX]\\([^;]+\\)" ref))
423 (let ((num))
424 (setq num (string-to-number (match-string 1 ref) 16))
425 (or (and num
426 (navi2ch-ucs-to-str num))
427 "\e$B".\e(B"))
428 ref))))
429
430 ;; shut up byte-compile warnings
431 (eval-when-compile
432 (navi2ch-defalias-maybe 'unicode-to-char 'ignore)
433 (navi2ch-defalias-maybe 'decode-char 'ignore))
434 (eval-and-compile
435 ;; (autoload 'ucs-to-char "unicode")
436 (defalias 'navi2ch-char-valid-p
437 (if (fboundp 'characterp) #'characterp #'char-valid-p)))
438
439 (defun navi2ch-ucs-to-str (code)
440 (let ((c (cond
441 ((featurep 'un-define)
442 (ucs-to-char code))
443 ((and (fboundp 'unicode-to-char)
444 (subrp (symbol-function 'unicode-to-char)))
445 (unicode-to-char code))
446 (navi2ch-on-emacs21
447 (decode-char 'ucs code)))))
448 (if (navi2ch-char-valid-p c)
449 (char-to-string c)
450 nil)))
451
452 (defun navi2ch-read-char (&optional prompt)
453 "PROMPT (non-nil \e$B$N>l9g\e(B) \e$B$rI=<($7$F\e(B `read-char' \e$B$r8F$S=P$9!#\e(B"
454 (let ((cursor-in-echo-area t)
455 c)
456 (if prompt
457 (navi2ch-no-logging-message "%s" prompt))
458 (setq c (read-char))
459 (if (and prompt
460 (navi2ch-char-valid-p c))
461 (navi2ch-no-logging-message "%s%c" prompt c))
462 c))
463
464 (defun navi2ch-read-char-with-retry (prompt retry-prompt list)
465 "PROMPT \e$B$rI=<(\e(B (non-nil \e$B$N>l9g\e(B) \e$B$7$F\e(B `read-char' \e$B$r8F$S=P$9!#\e(B
466 \e$BF~NO$5$l$?J8;z$,\e(B LIST \e$B$K4^$^$l$J$$>l9g!"\e(BRETRY-PROMPT (nil \e$B$N>l9g$O\e(B
467 PROMPT) \e$B$rI=<($7$F:FEY\e(B `read-char' \e$B$r8F$V!#\e(B"
468 (let ((retry t) c)
469 (while retry
470 (setq c (navi2ch-read-char prompt))
471 (cond ((memq c list)
472 (setq retry nil))
473 ((eq c 12)
474 (recenter))
475 (t
476 (ding)
477 (setq prompt (or retry-prompt prompt)))))
478 c))
479
480 (defun navi2ch-read-event (&optional prompt)
481 "PROMPT (non-nil \e$B$N>l9g\e(B) \e$B$rI=<($7$F\e(B event \e$B$rFI$`!#\e(B"
482 (let ((cursor-in-echo-area t)
483 e)
484 (if prompt
485 (navi2ch-no-logging-message "%s" prompt))
486 (navi2ch-ifxemacs
487 (setq e (next-command-event nil prompt))
488 (setq e (read-event prompt)))
489 (if prompt
490 (navi2ch-no-logging-message "%s%s" prompt (single-key-description e)))
491 e))
492
493 (defun navi2ch-y-or-n-p (prompt &optional quit-symbol)
494 (let* ((prompt (concat prompt "(y, n, or q) "))
495 (c (navi2ch-read-char-with-retry
496 prompt
497 (concat "Please answer y, n, or q. " prompt)
498 '(?q ?Q ?y ?Y ?\ ?n ?N ?\177))))
499 (cond ((memq c '(?q ?Q))
500 (or quit-symbol nil))
501 ((memq c '(?y ?Y ?\ ))
502 t)
503 ((memq c '(?n ?N ?\177))
504 nil))))
505
506 (eval-when-compile
507 (defvar browse-url-new-window-flag)
508 (defvar browse-url-new-window-p)
509 (declare-function navi2ch-net-send-request "navi2ch-net"
510 (url method &optional other-header content))
511 (declare-function navi2ch-net-get-status "navi2ch-net" (proc)))
512
513 (defun navi2ch-browse-url-internal (url &rest args)
514 (let ((browse-url-browser-function (or navi2ch-browse-url-browser-function
515 browse-url-browser-function))
516 (new-window-flag (cond ((boundp 'browse-url-new-window-flag)
517 browse-url-new-window-flag)
518 ((boundp 'browse-url-new-window-p)
519 browse-url-new-window-p)))
520 proc status)
521 (if (eq browse-url-browser-function 'navi2ch-browse-url)
522 (error "Set navi2ch-browse-url-browser-function correctly"))
523
524 ;;sssp\e$B$r\e(Bhttp\e$B$K=q$-49$(\e(B
525 (when (string= (substring url 0 4) "sssp")
526 (store-substring url 0 "http"))
527
528 ;;\e$BL5BL$r>J$/$?$a%V%i%&%:$9$kA0$K%?!<%2%C%H$N>uBV3NG'$9$k!#\e(B
529 ;;\e$B$A$g$C$H87$7$$$h$&$@$,!"\e(B302\e$B$@$HBgDq\e(B404\e$B$KHt$P$5$l$k$N$G!#\e(B
530 (when navi2ch-enable-status-check
531 (setq proc (navi2ch-net-send-request url "HEAD"))
532 (setq status (navi2ch-net-get-status proc))
533 (if (or (string= status "404")
534 (string= status "403")
535 (string= status "503")
536 (string= status "302"))
537 (error "\e$B%V%i%&%:$9$k$N$d$a$^$7$?\e(B return code %s" status)))
538
539 (cond ((and navi2ch-browse-url-image-program ; images
540 (file-name-extension url)
541 (member (downcase (file-name-extension url))
542 navi2ch-browse-url-image-extentions))
543 (navi2ch-browse-url-image url))
544 (t ; others
545 (setq args (or args (list new-window-flag)))
546 (apply 'browse-url url args)))))
547
548 (defvar navi2ch-browse-url-image-selection)
549 (add-hook 'navi2ch-hook (lambda () (setq navi2ch-browse-url-image-selection nil)))
550
551 ;; (defun navi2ch-create-fitted-image (file-or-data &optional type data-p &rest props)
552 ;; (let ((file-or-data (substring-no-properties file-or-data)))
553 ;; (when (and (plist-member props :width)
554 ;; (plist-member props :height))
555 ;; (let* ((new-props (navi2ch-plist-drop props '(:width :height)))
556 ;; (image (apply 'navi2ch-create-image
557 ;; file-or-data type data-p new-props))
558 ;; (size (image-size image))
559 ;; (width (car size))
560 ;; (height (cdr size)))
561 ;; (setq props
562 ;; (if (< (/ (float height) navi2ch-thumbnail-thumbsize-height)
563 ;; (/ (float width) navi2ch-thumbnail-thumbsize-width))
564 ;; (plist-put new-props :width navi2ch-thumbnail-thumbsize-width)
565 ;; (plist-put new-props :height navi2ch-thumbnail-thumbsize-height)))))
566 ;; (apply 'navi2ch-create-image
567 ;; file-or-data type data-p props)))
568
569 (defun navi2ch-browse-url-image (url &optional new-window)
570 ;; new-window ignored
571 "Ask the WWW browser defined by `browse-url-image-program' to load URL.
572 Default to the URL around or before point. A fresh copy of the
573 browser is started up in a new process with possible additional arguments
574 `navi2ch-browse-url-image-args'. This is appropriate for browsers which
575 don't offer a form of remote control."
576 (interactive (browse-url-interactive-arg "URL: "))
577 (cond ((and (string-prefix-p "/" url)
578 (fboundp 'imagemagick-types)
579 (let ((c navi2ch-browse-url-image-selection))
580 (while (not (memq c '(?e ?i)))
581 (setq c (read-char-from-minibuffer "\e$AMb2?%S%e\e$B!<\e$A%"\e(B(e) or \e$ADZ2?%S%e\e$B!<\e$A%"\e(B(i)? ")))
582 (setq navi2ch-browse-url-image-selection c)
583 (eq c ?i)))
584 (let ((buffer (find-file-noselect (file-truename url))))
585 (with-current-buffer buffer
586 (keymap-local-set "q" (lambda () (interactive) (kill-buffer buffer)))
587 (pop-to-buffer buffer (list #'display-buffer-full-frame)))))
588
589 (navi2ch-browse-url-image-program
590 (apply 'start-process (concat navi2ch-browse-url-image-program url) nil
591 navi2ch-browse-url-image-program
592 (append navi2ch-browse-url-image-args (list url))))
593 (t (error "No browser defined (`navi2ch-browse-url-image-program')"))))
594
595 (defun navi2ch-next-property (point prop)
596 (setq point (next-single-property-change point prop))
597 (when (and point
598 (null (get-text-property point prop)))
599 (setq point (next-single-property-change point prop)))
600 point)
601
602 (defun navi2ch-previous-property (point prop)
603 (when (> point (point-min))
604 (when (eq (get-text-property point prop)
605 (get-text-property (1- point) prop))
606 (setq point (previous-single-property-change point prop)))
607 (when (and point
608 (null (get-text-property (1- point) prop)))
609 (setq point (previous-single-property-change point prop)))
610 (when point
611 (or (previous-single-property-change point prop) (point-min)))))
612
613 (defun navi2ch-set-minor-mode (mode name map)
614 (make-variable-buffer-local mode)
615 (unless (assq mode minor-mode-alist)
616 (setq minor-mode-alist
617 (cons (list mode name) minor-mode-alist)))
618 (unless (assq mode minor-mode-map-alist)
619 (setq minor-mode-map-alist
620 (cons (cons mode map) minor-mode-map-alist))))
621
622 (defun navi2ch-call-process-buffer (program &rest args)
623 "\e$B:#$N\e(B buffer \e$B$G\e(B PROGRAM \e$B$r8F$s$GJQ99$9$k!#\e(B"
624 (let ((default-directory (navi2ch-default-directory)))
625 (apply 'call-process-region (point-min) (point-max) program t t nil args)))
626
627 (defun navi2ch-alist-list-to-alist (list key1 &optional key2)
628 (mapcar
629 (lambda (x)
630 (cons (cdr (assq key1 x))
631 (if key2
632 (cdr (assq key2 x))
633 x)))
634 list))
635
636 (defun navi2ch-write-region (begin end filename)
637 (write-region begin end filename nil 'no-msg))
638
639 (defun navi2ch-get-major-mode (buffer)
640 (when (get-buffer buffer)
641 (with-current-buffer buffer
642 major-mode)))
643
644 (defun navi2ch-set-mode-line-identification ()
645 (let ((offline '(navi2ch-offline navi2ch-modeline-offline navi2ch-modeline-online))
646 (belogin '(navi2ch-be2ch-login-flag navi2ch-modeline-be2ch-login
647 navi2ch-modeline-be2ch-logout)))
648
649 (unless navi2ch-mode-line-identification
650 (setq navi2ch-mode-line-identification
651 (default-value 'mode-line-buffer-identification)))
652 (setq mode-line-buffer-identification
653 (list offline
654 belogin
655 'navi2ch-message-samba24-mode-string
656 'navi2ch-mode-line-identification)))
657 (force-mode-line-update t))
658
659 (defun navi2ch-end-of-buffer ()
660 "\e$B%P%C%U%!$N:G=*9T$K0\F0!#\e(B"
661 (interactive)
662 (call-interactively 'end-of-buffer)
663 (when (eobp) (forward-line -1)))
664
665 (defun navi2ch-uudecode-region (start end &optional filename)
666 "START \e$B$H\e(B END \e$B$N4V$N%j!<%8%g%s$r\e(B uudecode \e$B$9$k!#\e(B
667 FILENAME \e$B$,;XDj$5$l$k$H!"\e(BFILENAME \e$B$K$b=q$-=P$9!#\e(B"
668 (interactive "r")
669 (let* ((coding-system-for-read 'binary)
670 (coding-system-for-write 'binary)
671 (mode "600")
672 (file (expand-file-name
673 (or filename
674 (make-temp-name (navi2ch-temp-directory)))))
675 (default-directory (file-name-directory file))
676 (buf (current-buffer))
677 rc)
678 (unwind-protect
679 (progn
680 (with-temp-buffer
681 (insert-buffer-substring buf start end)
682 (goto-char (point-min))
683 (when (re-search-forward navi2ch-uuencode-begin-delimiter-regexp
684 nil t)
685 (setq mode (navi2ch-match-string-no-properties 1))
686 (forward-line)
687 (delete-region (point-min) (point)))
688 (insert (format "begin %s %s\n"
689 mode (file-name-nondirectory file)))
690 (goto-char (point-max))
691 (when (re-search-backward navi2ch-uuencode-end-delimiter-regexp
692 nil t)
693 (delete-region (match-beginning 0) (point-max)))
694 (insert "end\n")
695 (setq rc (apply 'call-process-region
696 (point-min) (point-max)
697 navi2ch-uudecode-program
698 nil nil nil
699 navi2ch-uudecode-args)))
700 (when (and (= rc 0)
701 (file-exists-p file))
702 (delete-region start end)
703 (insert-file-contents-literally file)
704 (when filename
705 (message "Wrote %s" filename))))
706 (ignore-errors (unless filename (delete-file file))))
707 (when (not (= rc 0))
708 (error "uudecode error"))))
709
710 (eval-and-compile
711 (defalias 'navi2ch-line-beginning-position
712 (if (fboundp 'point-at-bol)
713 #'point-at-bol
714 #'line-beginning-position))
715
716 (defalias 'navi2ch-line-end-position
717 (if (fboundp 'point-at-eol)
718 #'point-at-eol
719 #'line-end-position)))
720
721 (defun navi2ch-uudecode-write-region (start end &optional filename)
722 "START \e$B$H\e(B END \e$B$N4V$N%j!<%8%g%s$r\e(B uudecode \e$B$7!"\e(BFILENAME \e$B$K=q$-=P$9!#\e(B
723
724 \e$B%j!<%8%g%sFb$K\e(B `navi2ch-uuencode-begin-delimiter-regexp' \e$B$K%^%C%A$9$k9T$,$"$k\e(B
725 \e$B>l9g$O$=$l0JA0$rL5;k$7!"\e(B`navi2ch-uuencode-end-delimiter-regexp' \e$B$K%^%C%A$9$k9T\e(B
726 \e$B$,$"$k>l9g$O:G8e$N$=$l0J9_$rL5;k$9$k!#\e(B
727 \e$B$5$i$K!"\e(Buuencode \e$B$N%U%)!<%^%C%H$K=>$C$F$$$J$$9T$bL5;k$9$k!#\e(B"
728 (interactive "r")
729 (let ((buf (current-buffer))
730 (default-filename nil))
731 (save-excursion
732 (goto-char start)
733 (when (re-search-forward navi2ch-uuencode-begin-delimiter-regexp end t)
734 (setq start (match-beginning 0)
735 default-filename (match-string 2)))
736 (goto-char end)
737 (when (re-search-backward navi2ch-uuencode-end-delimiter-regexp start t)
738 ;; exclude "end"
739 (setq end (match-beginning 0))))
740 (unless filename
741 (setq filename (expand-file-name
742 (read-file-name
743 (if default-filename
744 (format "Uudecode to file (default `%s'): "
745 default-filename)
746 "Uudecode to file: ")
747 nil default-filename))))
748 (when (file-directory-p filename)
749 (if default-filename
750 (setq filename (expand-file-name default-filename filename))
751 (error "%s is a directory" filename)))
752 (when (or (not (file-exists-p filename))
753 (y-or-n-p (format "File `%s' exists; overwrite? "
754 filename)))
755 (with-temp-buffer
756 (insert-buffer-substring buf start end)
757 (goto-char (point-min))
758 (while (search-forward "\e$B!)\e(B" nil t) ;for 2ch
759 (replace-match "&#" nil t))
760 (goto-char (point-min))
761 (forward-line)
762 (while (not (eobp))
763 (let* ((char (char-after))
764 (len (- (navi2ch-line-beginning-position 2) (point))))
765 (when (char-equal char ?`)
766 (setq char ? ))
767 (if (and (looking-at navi2ch-uuencode-line-regexp)
768 (< len 63)
769 (= len (- (* (/ char 3) 4) 38)))
770 (forward-line)
771 (delete-region (point) (navi2ch-line-beginning-position 2)))))
772 (insert "end\n")
773 (navi2ch-uudecode-region (point-min) (point-max) filename)))))
774
775 (defun navi2ch-base64-write-region (start end &optional filename)
776 "START \e$B$H\e(B END \e$B$N4V$N%j!<%8%g%s$r\e(B base64 \e$B%G%3!<%I$7!"\e(BFILENAME \e$B$K=q$-=P$9!#\e(B
777
778 \e$B%j!<%8%g%sFb$K\e(B `navi2ch-base64-begin-delimiter-regexp' \e$B$+\e(B
779 `navi2ch-base64-susv3-begin-delimiter-regexp' \e$B$K%^%C%A$9$k9T$,$"$k>l9g$O\e(B
780 \e$B$=$l0JA0$rL5;k$7!"\e(B
781 `navi2ch-base64-end-delimiter-regexp' \e$B$+\e(B
782 `navi2ch-base64-susv3-end-delimiter-regexp' \e$B$K%^%C%A$9$k9T\e(B
783 \e$B$,$"$k>l9g$O:G8e$N$=$l0J9_$rL5;k$9$k!#\e(B
784 \e$B$5$i$K!"\e(B`navi2ch-base64-line-regexp' \e$B$K%^%C%A$7$J$$9T$bL5;k$9$k!#\e(B
785
786 base64\e$B%G%3!<%I$9$Y$-FbMF$,$J$$>l9g$O%(%i!<$K$J$k!#\e(B"
787 (interactive "r")
788 (save-excursion
789 (let ((buf (current-buffer))
790 (default-filename nil)
791 (mode nil)
792 (susv3 nil))
793 ;; insert\e$B$7$?8e$K:o$k$N$OL5BL$J$N$G$"$i$+$8$a9J$j9~$s$G$*$/\e(B
794 (goto-char start)
795 (cond
796 ((re-search-forward navi2ch-base64-begin-delimiter-regexp end t)
797 (setq default-filename (match-string 2))
798 (goto-char (match-end 0)))
799 ((re-search-forward navi2ch-base64-susv3-begin-delimiter-regexp end t)
800 (setq default-filename (match-string 2)
801 mode (string-to-number (match-string 1) 8)
802 susv3 t)
803 (goto-char (match-end 0))))
804 (if (re-search-forward navi2ch-base64-line-regexp end t)
805 (setq start (match-beginning 0))
806 (error "No base64 data"))
807 (goto-char end)
808 (if (or (and susv3 (re-search-backward
809 navi2ch-base64-susv3-end-delimiter-regexp start t))
810 (re-search-backward navi2ch-base64-end-delimiter-regexp start t))
811 (goto-char (match-beginning 0)))
812 (if (re-search-backward navi2ch-base64-line-regexp start t)
813 (setq end (match-end 0)))
814 (unless filename
815 (setq filename (expand-file-name
816 (read-file-name
817 (if default-filename
818 (format "Base64-decode to file (default `%s'): "
819 default-filename)
820 "Base64-decode to file: ")
821 nil default-filename))))
822 (when (file-directory-p filename)
823 (if default-filename
824 (setq filename (expand-file-name default-filename filename))
825 (error "%s is a directory" filename)))
826 (when (or (not (file-exists-p filename))
827 (y-or-n-p (format "File `%s' exists; overwrite? "
828 filename)))
829 (with-temp-buffer
830 (let ((buffer-file-coding-system 'binary)
831 (coding-system-for-write 'binary)
832 ;; auto-compress-mode\e$B$r\e(Bdisable\e$B$K$9$k\e(B
833 (inhibit-file-name-operation 'write-region)
834 (inhibit-file-name-handlers (cons 'jka-compr-handler
835 inhibit-file-name-handlers)))
836 (insert-buffer-substring buf start end)
837 (goto-char (point-min))
838 (while (not (eobp))
839 (if (looking-at navi2ch-base64-line-regexp)
840 (forward-line)
841 (delete-region (point) (navi2ch-line-beginning-position 2))))
842 (base64-decode-region (point-min) (point-max))
843 (write-region (point-min) (point-max) filename)
844 (if (and susv3 mode)
845 (condition-case nil
846 ;; 511 = (string-to-number "0777" 8)
847 (set-file-modes filename (logand mode 511))
848 (error nil)))))))))
849
850 (defun navi2ch-base64-insert-file (filename)
851 "FILENAME \e$B$r\e(B base64 \e$B%(%s%3!<%I$7!"8=:_$N%]%$%s%H$KA^F~$9$k!#\e(B"
852 (interactive "fEncode and insert file: ")
853 (save-excursion
854 (let ((str nil))
855 (with-temp-buffer
856 (let ((buffer-file-coding-system 'binary))
857 (insert-file-contents-literally filename)
858 (base64-encode-region (point-min) (point-max))
859 (goto-char (point-min))
860 (while (search-forward "\n" nil t)
861 (replace-match ""))
862 (goto-char (point-min))
863 (insert (format "%s(%s)\n" navi2ch-base64-begin-delimiter
864 (file-name-nondirectory filename)))
865 (while (= (move-to-column navi2ch-base64-fill-column)
866 navi2ch-base64-fill-column)
867 (insert "\n"))
868 (goto-char (point-max))
869 (insert (format "\n%s\n" navi2ch-base64-end-delimiter))
870 (setq str (buffer-string))))
871 (insert str))))
872
873 (defun navi2ch-url-to-host (url)
874 (when url
875 (cond
876 ((string-match "^https?://\\([^/]+\\)" url)
877 (match-string 1 url))
878 ((string-match "^x-localbbs://" url)
879 "localhost"))))
880
881 (defun navi2ch-read-string (prompt &optional initial-input history)
882 (let ((minibuffer-allow-text-properties nil))
883 (read-string prompt initial-input history)))
884
885 (defun navi2ch-temp-directory ()
886 (let ((dir (expand-file-name "tmp" navi2ch-directory)))
887 (or (file-directory-p dir)
888 (make-directory dir))
889 dir))
890
891 (defun navi2ch-strip-properties (obj)
892 "OBJ \e$BCf$NJ8;zNs$r:F5"E*$KC5$7!"%F%-%9%HB0@-$r30$7$?%*%V%8%'%/%H$rJV$9!#\e(B
893 \e$B85$N\e(B OBJ \e$B$OJQ99$7$J$$!#\e(B"
894 (cond
895 ((consp obj)
896 (let* ((ret (cons (car obj) (cdr obj)))
897 (seq ret))
898 ;; \e$BD9$$%j%9%H$r%3%T!<$9$k:]$K%9%?%C%/%*!<%P!<%U%m!<$K$J$k$N$G\e(B
899 ;; \e$B:F5"$r%k!<%W$KE83+!#\e(B
900 (while (consp seq)
901 (setcar seq (navi2ch-strip-properties (car seq)))
902 (if (consp (cdr seq))
903 (setcdr seq (cons (cadr seq) (cddr seq)))
904 (setcdr seq (navi2ch-strip-properties (cdr seq))))
905 (setq seq (cdr seq)))
906 ret))
907 ((stringp obj)
908 (let ((str (copy-sequence obj)))
909 (set-text-properties 0 (length str) nil str)
910 str))
911 ((vectorp obj)
912 (vconcat (mapcar 'navi2ch-strip-properties obj)))
913 (t obj)))
914
915 (defun navi2ch-update-html-tag-regexp ()
916 "`navi2ch-replace-html-tag-regexp-internal' \e$B$r99?7$9$k!#\e(B"
917 (setq navi2ch-replace-html-tag-regexp-internal
918 (navi2ch-regexp-alist-to-internal
919 (nconc (mapcar (lambda (x)
920 (cons (regexp-quote (car x))
921 (cdr x)))
922 navi2ch-replace-html-tag-alist)
923 navi2ch-replace-html-tag-regexp-alist))))
924
925 (defun navi2ch-add-replace-html-tag (tag value)
926 "TAG \e$B$rI=<($9$k:]$K\e(B VALUE \e$B$GCV$-49$($k!#\e(B"
927 (let ((as-regexp (condition-case nil
928 (progn
929 ;; \e$BJ8;zNs$K$h$C$F$O\e(B regexp-opt-group() \e$B$,L58B\e(B
930 ;; \e$B:F5"$K$J$k\e(B
931 (regexp-opt (list "\e$B$"\e(B" tag))
932 nil)
933 (error t))))
934 (if as-regexp
935 (navi2ch-add-replace-html-tag-regexp (regexp-quote tag) value)
936 (add-to-list 'navi2ch-replace-html-tag-alist
937 (cons tag value))
938 (navi2ch-update-html-tag-regexp))))
939
940 (defun navi2ch-add-replace-html-tag-regexp (regexp value)
941 "REGEXP \e$B$K%^%C%A$9$k\e(B tag \e$B$rI=<($9$k:]$K\e(B VALUE \e$B$GCV$-49$($k!#\e(B"
942 (add-to-list 'navi2ch-replace-html-tag-regexp-alist
943 (cons regexp value))
944 (navi2ch-update-html-tag-regexp))
945
946 (defsubst navi2ch-filename-to-url (filename)
947 (concat "file://" (expand-file-name filename)))
948
949 (defun navi2ch-chop-/ (dirname)
950 (save-match-data
951 (if (string-match "/\\'" dirname)
952 (replace-match "" nil t dirname)
953 dirname)))
954
955 (defsubst navi2ch-rename-file (file newname &optional ok-if-already-exists)
956 (rename-file (navi2ch-chop-/ file)
957 (navi2ch-chop-/ newname) ok-if-already-exists))
958
959 (eval-and-compile
960 (defalias 'navi2ch-set-keymap-default-binding
961 (if (fboundp 'set-keymap-default-binding)
962 #'set-keymap-default-binding
963 (lambda (map command)
964 "\e$B%-!<%^%C%W$N%G%U%)%k%H%P%$%s%I$r@_Dj$9$k!#\e(B"
965 (define-key map [t] command)))))
966
967 ;;; \e$B%m%C%/\e(B
968 ;; \e$B:G$bHFMQE*$J\e(B mkdir \e$B%m%C%/$r<BAu$7$F$_$?!#\e(B
969 ;; DIRECTORY \e$B$K\e(B LOCKNAME \e$B$H$$$&%G%#%l%/%H%j$,$"$k>l9g$O$=$N%G%#%l%/%H%j$O\e(B
970 ;; \e$B%m%C%/$5$l$F$$$k$H$$$&$3$H$K$J$k!#\e(B
971 (defun navi2ch-lock-directory (directory &optional lockname)
972 "LOCKNAME \e$B$r;H$$!"\e(BDIRECTORY \e$B$r%m%C%/$9$k!#\e(B
973 LOCKNAME \e$B$,>JN,$5$l$?>l9g$O\e(B \"lockdir\" \e$B$r;HMQ$9$k!#\e(B
974 LOCKNAME \e$B$,@dBP%Q%9$G$O$J$$>l9g!"\e(BDIRECTORY \e$B$+$i$NAjBP%Q%9$H$7$F07$&!#\e(B
975 \e$B%m%C%/$K@.8y$7$?$i\e(B non-nil \e$B$r!"<:GT$7$?$i\e(B nil \e$B$rJV$9!#\e(B"
976 (setq lockname (navi2ch-chop-/ (expand-file-name (or lockname "lockdir")
977 directory))
978 directory (file-name-directory lockname))
979 (let ((make-directory-function (if (fboundp 'make-directory-internal)
980 #'make-directory-internal
981 #'make-directory)))
982 (if (not (file-exists-p lockname)) ; lockdir \e$B$,$9$G$K$"$k$H<:GT\e(B
983 (condition-case error
984 (and (progn
985 ;; \e$B$^$:!"?F%G%#%l%/%H%j$r:n$C$F$*$/!#\e(B
986 (unless (file-directory-p directory)
987 (make-directory directory t))
988 (file-directory-p directory))
989 (progn
990 ;; file-name-handler-alist \e$B$,$"$k$H\e(B mkdir \e$B$,D>@\8F\e(B
991 ;; \e$B$P$l$J$$2DG=@-$,$"$k!#\e(B
992 (let ((file-name-handler-alist nil))
993 (funcall make-directory-function lockname))
994 (file-exists-p lockname))) ; \e$BG0$N$?$a!"3NG'$7$F$*$/\e(B
995 (error
996 (message "%s" (error-message-string error))
997 (sit-for 3)
998 (discard-input)
999 nil)))))
1000
1001 (defun navi2ch-unlock-directory (directory &optional lockname)
1002 "LOCKNAME \e$B$r;H$$!"\e(BDIRECTORY \e$B$N%m%C%/$r2r=|$9$k!#\e(B
1003 LOCKNAME \e$B$,>JN,$5$l$?>l9g$O\e(B \"lockdir\" \e$B$r;HMQ$9$k!#\e(B
1004 LOCKNAME \e$B$,@dBP%Q%9$G$O$J$$>l9g!"\e(BDIRECTORY \e$B$+$i$NAjBP%Q%9$H$7$F07$&!#\e(B
1005 \e$B%m%C%/$N2r=|$K@.8y$7$?$i\e(B non-nil \e$B$r!"<:GT$7$?$i\e(B nil \e$B$rJV$9!#\e(B"
1006 (setq lockname (navi2ch-chop-/ (expand-file-name (or lockname "lockdir")
1007 directory)))
1008 (ignore-errors
1009 (delete-directory lockname))
1010 (not (file-exists-p lockname)))
1011
1012 (defsubst navi2ch-count-lines-file (file)
1013 "\e$B$=$N%U%!%$%k$N9T?t$r?t$($k!#\e(B"
1014 (with-temp-buffer
1015 (insert-file-contents file)
1016 (count-lines (point-min) (point-max))))
1017
1018 (eval-and-compile
1019 (defalias 'navi2ch-float-time
1020 (if (fboundp 'float-time)
1021 'float-time
1022 (lambda (&optional specified-time)
1023 "Return the current time, as a float number of seconds since the epoch.
1024 If an argument is given, it specifies a time to convert to float
1025 instead of the current time."
1026 (apply (lambda (high low &optional usec)
1027 (+ (* high 65536.0) low (/ (or usec 0) 1000000.0)))
1028 (or specified-time (current-time))))))
1029 (defalias 'navi2ch-make-local-hook
1030 (if (>= emacs-major-version 22)
1031 #'ignore
1032 #'make-local-hook))
1033 (defalias 'navi2ch-cache-p #'vectorp))
1034
1035 (defun navi2ch-compare-times (t1 t2)
1036 "T1 \e$B$,\e(B T2 \e$B$h$j?7$7$1$l$P\e(B non-nil \e$B$rJV$9!#\e(B"
1037 (> (navi2ch-float-time t1) (navi2ch-float-time t2)))
1038
1039 (defun navi2ch-add-days-to-time (time days)
1040 "TIME \e$B$N\e(B DAYS \e$BF|8e\e(B (\e$BIi$N>l9g$OA0\e(B) \e$B$N\e(B TIME \e$B$rJV$9!#\e(B"
1041 (let ((decoded (decode-time time)))
1042 (setf (nth 3 decoded) (+ (nth 3 decoded) days))
1043 (apply #'encode-time decoded)))
1044
1045 (defun navi2ch-which (file)
1046 (when (stringp file)
1047 (catch 'loop
1048 (dolist (path exec-path)
1049 (setq path (expand-file-name file path))
1050 (dolist (candidate (list path (concat path ".exe")))
1051 (when (and (file-exists-p candidate)
1052 (file-executable-p candidate)
1053 (not (file-directory-p candidate)))
1054 (throw 'loop candidate)))))))
1055
1056 (defun navi2ch-union (list1 list2)
1057 "Combine LIST1 and LIST2.
1058 This function is a cutdown version of cl-seq's one."
1059 (cond ((null list1) list2) ((null list2) list1)
1060 ((equal list1 list2) list1)
1061 (t (dolist (x list2)
1062 (unless (member x list1)
1063 (setq list1 (cons x list1))))
1064 list1)))
1065
1066 (defun navi2ch-set-difference (list1 list2)
1067 "Combine LIST1 and LIST2.
1068 This function is a cutdown version of cl-seq's one."
1069 (if (or (null list1) (null list2)) list1
1070 (let ((res nil))
1071 (dolist (x list1)
1072 (unless (member x list2)
1073 (setq res (cons x res))))
1074 res)))
1075
1076 (defun navi2ch-expand-newtext (newtext original)
1077 (substring (replace-match newtext (not case-fold-search) nil original)
1078 (match-beginning 0)
1079 (and (< (match-end 0) (length original))
1080 (- (match-end 0) (length original)))))
1081
1082 (defun navi2ch-fuzzy-regexp (string &optional kana-fold-search regexp)
1083 "STRING \e$B$KBP$7!"A43Q$HH>3Q$r6hJL$;$:%^%C%A$9$k$h$&$J@55,I=8=$rJV$9!#\e(B
1084 \e$B$=$N:]\e(B `case-fold-search' \e$B$,\e(B non-nil \e$B$J$i!"A43Q1Q;z$bBgJ8;z$H>.J8;z$N\e(B
1085 \e$BN>J}$r4^$`$b$N$r@8@.$9$k!#\e(B
1086
1087 KANA-FOLD-SEARCH \e$B$K\e(B non-nil \e$B$r;XDj$9$k$H!"$R$i$,$J$H%+%?%+%J$b6hJL$7$J\e(B
1088 \e$B$$@55,I=8=$rJV$9!#\e(B
1089
1090 REGEXP \e$B$r;XDj$9$k$H!"@55,I=8=$N@8@.$K@hN)$A\e(B REGEXP \e$B$K%^%C%A$7$?J8;zNs\e(B
1091 \e$B$r\e(B REGEXP \e$B$KCV$-49$($k!#\e(B
1092 \e$B$=$l$K$h$j!"Nc$($P\e(B REGEXP \e$B$K\e(B \"[\e$B!!\e(B \\f\\t\\n\\r\\v]+\" \e$B$rM?$($k$H6uGr$d2~9T$N\e(B
1093 \e$BB?>/$rL5;k$7$F%^%C%A$9$k$h$&$J@55,I=8=$r@8@.$9$k!#\e(B"
1094 (let ((default-case-fold-search case-fold-search))
1095 (with-current-buffer (get-buffer-create " *Navi2ch fuzzy work*")
1096 (erase-buffer)
1097 (insert string)
1098 (goto-char (point-min))
1099 (let ((last (point)))
1100 (while (progn
1101 (while (and regexp
1102 (not (eobp))
1103 (looking-at regexp)
1104 (< last (match-end 0)))
1105 (insert "\\(?:" regexp "\\)")
1106 (delete-char (- (match-end 0) (match-beginning 0)))
1107 (setq last (point)))
1108 (not (eobp)))
1109 (let ((char (following-char))
1110 prop next slot)
1111 (cond
1112 ((and (setq prop (get-char-code-property char 'kana-composition))
1113 (setq next (or (char-after (1+ (point))) 0))
1114 (setq slot (assq next prop)))
1115 (cond
1116 ((eq (char-charset char) 'katakana-jisx0201)
1117 ;; (char = \e$BH>3Q%+%J\e(B) + (next = \e$BH>3QByE@Ey\e(B)
1118 ;; (cdr slot) = \e$BA43Q%+%J\e(B
1119 (let (hira)
1120 (if (and kana-fold-search
1121 (setq hira
1122 (get-char-code-property (cdr slot) 'hiragana)))
1123 (if (stringp hira)
1124 (insert "\\(?:" char next
1125 "\\|" (cdr slot) "\\|" hira "\\)")
1126 (insert "\\(?:" char next
1127 "\\|[" (cdr slot) hira "]\\)"))
1128 (insert "\\(?:" char next "\\|" (cdr slot) "\\)")))
1129 (delete-char 2))
1130 (kana-fold-search
1131 ;; (char = \e$B$R$i$,$J\e(B) + (next = \e$BA43QByE@Ey\e(B)
1132 ;; (cdr slot) = \e$BA43Q%+%J\e(B
1133 (insert "\\(?:" char next "\\|"
1134 (get-char-code-property char 'jisx0201)
1135 (get-char-code-property next 'jisx0201)
1136 "\\|" (cdr slot) "\\)")
1137 (delete-char 2))
1138 (t
1139 (forward-char))))
1140 ((or (setq prop (get-char-code-property char 'jisx0201))
1141 (eq (char-charset char) 'katakana-jisx0201))
1142 (let (kata)
1143 (cond
1144 ((null prop)
1145 ;; char = \e$BH>3Q%+%J\e(B
1146 (setq kata (get-char-code-property char 'jisx0208))
1147 (let (hira)
1148 (if (and kana-fold-search
1149 (setq hira (get-char-code-property char
1150 'hiragana)))
1151 (insert ?\[ char kata hira ?\])
1152 (insert ?\[ char kata ?\])))
1153 (delete-char 1))
1154 ((null (setq kata (get-char-code-property char 'katakana)))
1155 ;; char = \e$BA43Q%+%J!"\e(Bprop = \e$BH>3Q%+%J\e(B
1156 (let (hira)
1157 (if (and kana-fold-search
1158 (setq hira (get-char-code-property char
1159 'hiragana)))
1160 (cond
1161 ((stringp hira)
1162 (insert "\\(?:" char "\\|" hira "\\|" prop "\\)"))
1163 ((stringp prop)
1164 (insert "\\(?:[" char hira "]\\|" prop "\\)"))
1165 (t
1166 (insert ?\[ char hira prop ?\])))
1167 (if (stringp prop)
1168 (insert "\\(?:" char "\\|" prop "\\)")
1169 (insert ?\[ char prop ?\]))))
1170 (delete-char 1))
1171 (kana-fold-search
1172 ;; char = \e$B$R$i$,$J!"\e(Bprop = \e$BH>3Q%+%J!"\e(Bkata = \e$BA43Q%+%J\e(B
1173 (if (stringp prop)
1174 (insert "\\(?:[" char kata "]\\|" prop "\\)")
1175 (insert ?\[ char kata prop ?\]))
1176 (delete-char 1))
1177 (t
1178 (forward-char)))))
1179 ((and (eq (char-charset char) 'ascii)
1180 (setq prop (get-char-code-property char 'jisx0208)))
1181 ;; char = \e$BH>3Q1Q?t!"\e(Bprop = \e$BA43Q1Q?t\e(B
1182 (if (or (not case-fold-search)
1183 (eq (upcase char) (downcase char)))
1184 (if (memq char '(?- ?^))
1185 (insert ?\[ prop char ?\])
1186 (insert ?\[ char prop ?\]))
1187 (insert ?\[ char
1188 (get-char-code-property (upcase char) 'jisx0208)
1189 (get-char-code-property (downcase char) 'jisx0208)
1190 ?\]))
1191 (delete-char 1))
1192 ((setq prop (get-char-code-property char 'ascii))
1193 ;; char = \e$BA43Q1Q?t!"\e(Bprop = \e$BH>3Q1Q?t\e(B
1194 (if (or (not case-fold-search)
1195 (eq (upcase prop) (downcase prop)))
1196 (if (eq prop ?\])
1197 (insert ?\[ prop char ?\])
1198 (insert ?\[ char prop ?\]))
1199 (insert ?\[
1200 (get-char-code-property (upcase prop) 'jisx0208)
1201 (get-char-code-property (downcase prop) 'jisx0208)
1202 prop ?\]))
1203 (delete-char 1))
1204 (t
1205 (forward-char))))))
1206 (buffer-string))))
1207
1208 (defun navi2ch-apply-filters (board filter-list)
1209 (dolist (filter filter-list)
1210 (if (stringp (car-safe filter))
1211 (apply 'navi2ch-call-process-buffer
1212 (mapcar (lambda (x)
1213 (if (eq x 'board)
1214 (cdr (assq 'id board))
1215 x))
1216 filter))
1217 (funcall filter))))
1218
1219 ;; shut up byte-compile warnings
1220 (eval-when-compile
1221 (navi2ch-defalias-maybe 'keywordp 'ignore)
1222 (navi2ch-defalias-maybe 'characterp 'ignore))
1223
1224 (defun navi2ch-quote-maybe (sexp)
1225 "Quote SEXP iff it is not self quoting."
1226 ;; `custom-quote'\e$B$N%Q%/$j!#\e(B
1227 (if (or (memq sexp '(t nil))
1228 (if (fboundp 'keywordp)
1229 (keywordp sexp)
1230 (and (symbolp sexp)
1231 (eq (aref (symbol-name sexp) 0) ?:)))
1232 (eq (car-safe sexp) 'lambda)
1233 (stringp sexp)
1234 (numberp sexp)
1235 (and (fboundp 'characterp)
1236 (characterp sexp))
1237 (vectorp sexp)
1238 (navi2ch-ifxemacs
1239 (bit-vector-p sexp)))
1240 sexp
1241 (list 'quote sexp)))
1242
1243 (defun navi2ch-right-align-strings (s1 s2)
1244 (let* ((l (max (length s1) (length s2)))
1245 (f (format "%%%ds" l)))
1246 (list (format f s1) (format f s2))))
1247
1248 (defun navi2ch-right-aligned-string< (s1 s2)
1249 (apply #'string< (navi2ch-right-align-strings s1 s2)))
1250
1251 (cl-defstruct (navi2ch-regexp-internal
1252 (:constructor navi2ch-make-regexp-internal)
1253 (:copier nil) (:type vector))
1254 number-list
1255 regexp
1256 table)
1257
1258 (eval-and-compile
1259 (defalias 'navi2ch-regexp-internal-p #'vectorp))
1260
1261 (defun navi2ch-regexp-alist-to-internal (regexp-alist)
1262 (if (navi2ch-regexp-internal-p regexp-alist)
1263 regexp-alist
1264 (let ((alist (let ((n 1))
1265 (mapcar (lambda (elt)
1266 (let ((r (concat "\\(" (car elt) "\\)")))
1267 (prog1
1268 (list n r elt)
1269 (setq n (+ n (regexp-opt-depth r))))))
1270 regexp-alist))))
1271 (navi2ch-make-regexp-internal
1272 :number-list (mapcar #'car alist)
1273 :regexp (mapconcat #'cadr alist "\\|")
1274 :table (navi2ch-alist-to-hash
1275 (mapcar (lambda (x)
1276 (cons (car x)
1277 (caddr x)))
1278 alist))))))
1279
1280 (defun navi2ch-match-regexp-alist-subr (match-function regexp-alist)
1281 "REGEXP-ALIST \e$B$N3FMWAG$N\e(B car \e$B$r@55,I=8=$H$7!"\e(BMATCH-FUNCTION \e$B$r8F$S=P$9!#\e(B
1282 \e$B%^%C%A$7$?MWAG$rJV$9!#\e(B
1283 REGEXP-ALIST \e$BCf$N@55,I=8=$OO"7k$5$l$k$?$a!"@55,I=8=Cf$N\e(B \\\e$B?t;zEy$N\e(B
1284 back reference \e$B$OM-8z$KF0:n$7$J$$!#\e(B
1285 `navi2ch-regexp-alist-to-internal' \e$B$r;HMQ$7$F\e(B REGEXP-ALIST \e$B$r\e(B
1286 \e$B$"$i$+$8$aFbIt7A<0$KJQ49$7$F$*$/$3$H$b2DG=!#\e(B"
1287 (let* ((internal (navi2ch-regexp-alist-to-internal regexp-alist))
1288 (number-list (navi2ch-regexp-internal-number-list internal))
1289 (combined-regexp (navi2ch-regexp-internal-regexp internal)))
1290 (when (funcall match-function combined-regexp)
1291 (cl-dolist (n number-list)
1292 (when (match-beginning n)
1293 (cl-return (gethash n (navi2ch-regexp-internal-table internal))))))))
1294
1295 (defun navi2ch-string-match-regexp-alist (regexp-alist string &optional start)
1296 "REGEXP-ALIST \e$B$N3FMWAG$N\e(B car \e$B$r@55,I=8=$H$7!"\e(B`string-match' \e$B$r8F$S=P$9!#\e(B
1297 `match-data' \e$B$r%^%C%A$7$?@55,I=8=$NJ*$K$7!"%^%C%A$7$?MWAG$rJV$9!#\e(B
1298 REGEXP-ALIST \e$B$K$D$$$F$O\e(B `navi2ch-match-regexp-alist-subr' \e$B$r;2>H!#\e(B
1299 STRING START \e$B$O\e(B `string-match' \e$B$K$=$N$^$^EO$5$l$k!#\e(B"
1300 (let ((matched-elt
1301 ;; (lexical-let ((string string)
1302 ;; (start start))
1303 (navi2ch-match-regexp-alist-subr (lambda (regexp)
1304 (string-match regexp string start))
1305 regexp-alist)));)
1306 (when matched-elt
1307 (string-match (car matched-elt) string start))
1308 matched-elt))
1309
1310
1311 (defun navi2ch-re-search-forward-regexp-alist
1312 (regexp-alist &optional bound noerror count)
1313 "REGEXP-ALIST \e$B$N3FMWAG$N\e(B car \e$B$r@55,I=8=$H$7!"\e(B`re-search-forward' \e$B$r8F$S=P$9!#\e(B
1314 `match-data' \e$B$r%^%C%A$7$?@55,I=8=$NJ*$K$7!"%^%C%A$7$?MWAG$rJV$9!#\e(B
1315 REGEXP-ALIST \e$B$K$D$$$F$O\e(B `navi2ch-match-regexp-alist-subr' \e$B$r;2>H!#\e(B
1316 BOUND NOERROR COUNT \e$B$O\e(B `re-search-forward' \e$B$K$=$N$^$^EO$5$l$k!#\e(B"
1317 (let ((matched-elt
1318 ;; (lexical-let
1319 ;; ((bound bound)
1320 ;; (noerror noerror)
1321 ;; (count count))
1322 (navi2ch-match-regexp-alist-subr
1323 (lambda (regexp)
1324 (re-search-forward regexp bound noerror count))
1325 regexp-alist)));)
1326 (when matched-elt
1327 (goto-char (match-beginning 0))
1328 (re-search-forward (car matched-elt) bound noerror count))
1329 matched-elt))
1330
1331 ;; XEmacs \e$B$G$O\e(B `char-width' \e$B$r9MN8$7$F$/$l$J$$$N$G!#\e(B
1332 (defun navi2ch-truncate-string-to-width
1333 (str end-column &optional start-column padding)
1334 "`truncate-string-to-width' \e$B$HF1Ey!#\e(B"
1335 (let ((col 0)
1336 (start-column (or start-column 0))
1337 r)
1338 (dolist (c (string-to-list str))
1339 (when (and (>= col start-column)
1340 (< col end-column))
1341 (push c r)
1342 (setq col (+ col (char-width c)))))
1343 (when padding
1344 (while (and (>= col start-column)
1345 (< col end-column))
1346 (push padding r)
1347 (setq col (+ col (char-width padding)))))
1348 (concat (nreverse r))))
1349
1350 (defun navi2ch-disabled-key ()
1351 (interactive)
1352 (ding)
1353 (let ((key (this-command-keys)))
1354 (message "%s (%s) is disabled in Navi2ch."
1355 (key-description key)
1356 (lookup-key (current-global-map) key))))
1357
1358 (defun navi2ch-verify-signature-file (signature-file file)
1359 "FILE \e$B$r\e(B SIGNATURE-FILE \e$B$G8!>Z$9$k!#\e(B
1360 \e$B@5$7$/8!>Z$G$-$k$H\e(B non-nil \e$B$rJV$9!#\e(B"
1361 (interactive "f\e$B=pL>%U%!%$%k\e(B: \nf\e$B8!>Z%U%!%$%k\e(B: ")
1362 (let (exitcode)
1363 (with-temp-buffer
1364 (setq exitcode
1365 (let ((default-directory (navi2ch-default-directory)))
1366 (call-process shell-file-name nil t nil
1367 shell-command-switch
1368 (format navi2ch-pgp-verify-command-line
1369 signature-file file))))
1370 (goto-char (point-min))
1371 ;; \e$B8e$+$i\e(B *Message* \e$B%P%C%U%!$G;2>H$G$-$k$h$&!"%3%^%s%I=PNO$r$9$Y\e(B
1372 ;; \e$B$FI=<($7$F$*$/\e(B
1373 (while (not (eobp))
1374 (let ((s (buffer-substring (navi2ch-line-beginning-position)
1375 (navi2ch-line-end-position))))
1376 (when (> (length s) 0)
1377 (message "%s" s)))
1378 (forward-line)))
1379 (= exitcode 0)))
1380
1381 (defun navi2ch-decode-coding-region-linewise (start end coding-system)
1382 (save-restriction
1383 (narrow-to-region start end)
1384 (let ((bol (point-min)))
1385 (while (< bol (point-max))
1386 (goto-char bol)
1387 ;; decode \e$BA08e$G\e(B (navi2ch-line-end-position) \e$B$NCM$,$:$l$k$N$KCm0U\e(B
1388 (decode-coding-region bol (navi2ch-line-end-position) coding-system)
1389 (goto-char bol) ; \e$BG0$N$?$a\e(B
1390 (setq bol (1+ (navi2ch-line-end-position))))))
1391 (goto-char start))
1392
1393 (eval-and-compile
1394 (if (fboundp 'propertize)
1395 (defalias 'navi2ch-propertize 'propertize)
1396 (defun navi2ch-propertize (string &rest properties)
1397 "Return a copy of STRING with text properties added.
1398 First argument is the string to copy.
1399 Remaining arguments form a sequence of PROPERTY VALUE pairs for text
1400 properties to add to the result."
1401 (let ((str (copy-sequence string)))
1402 (add-text-properties 0 (length str)
1403 properties
1404 str)
1405 str))))
1406
1407 (defsubst navi2ch-read-only-string (string &optional front-nonsticky)
1408 (navi2ch-propertize string
1409 'read-only t
1410 'front-sticky (not front-nonsticky)
1411 'rear-nonsticky t))
1412
1413 (defsubst navi2ch-make-cache (&optional limit test)
1414 (vector limit
1415 (apply #'make-hash-table
1416 (append (list :rehash-threshold 0.9)
1417 (and limit
1418 (integerp limit)
1419 (not (zerop limit))
1420 (list :size (1+ limit)))
1421 (and test
1422 (list :test test))))))
1423
1424 (defun navi2ch-cache-put (key val cache)
1425 (let ((limit (navi2ch-cache-limit cache))
1426 (table (navi2ch-cache-hash-table cache)))
1427 (prog1
1428 (puthash key val table)
1429 (when (and limit
1430 (<= (hash-table-count table) limit))
1431 (clrhash table)))))
1432
1433 (defsubst navi2ch-cache-remove (key cache)
1434 (remhash key (navi2ch-cache-hash-table cache)))
1435
1436 ;; from emacs-w3m
1437 (defun navi2ch-url-encode-string (str &optional coding encode-space)
1438 (apply (function concat)
1439 (mapcar
1440 (lambda (ch)
1441 (cond
1442 ((eq ch ?\n) ; newline
1443 "%0D%0A")
1444 ((string-match "[-a-zA-Z0-9_:/.]" (char-to-string ch)) ; xxx?
1445 (char-to-string ch)) ; printable
1446 ((and (char-equal ch ?\x20); space
1447 encode-space)
1448 "+")
1449 (t
1450 (format "%%%02X" ch)))) ; escape
1451 ;; Coerce a string into a list of chars.
1452 (append (encode-coding-string (or str "")
1453 (or coding
1454 navi2ch-coding-system
1455 'shift_jis))
1456 nil))))
1457
1458 ;; log fuctions
1459
1460 (defvar navi2ch-log-buffer-name "*navi2ch log*")
1461 (defvar navi2ch-log-max-lines 2000)
1462
1463 (defun navi2ch-util--get-logbuffer ()
1464 (let ((buffer-name navi2ch-log-buffer-name))
1465 (or (get-buffer buffer-name)
1466 (with-current-buffer (get-buffer-create buffer-name)
1467 (view-mode)
1468 (setq truncate-lines t)
1469 (buffer-disable-undo)
1470 (set (make-local-variable 'log-level) navi2ch-log-default-level)
1471 (current-buffer)))))
1472
1473 (defun navi2ch-log (&optional level str &rest objs)
1474 (let ((level (or level 'LOG_INFO))
1475 (str (or str (format "%s" (current-message))))
1476 (objs (and str objs)))
1477 (with-current-buffer (navi2ch-util--get-logbuffer)
1478 (when (>= log-level (cdr (assq level navi2ch-log-levels)))
1479 (widen)
1480 (goto-char (point-max))
1481 (setq buffer-read-only nil)
1482 (let ((tag (substring (symbol-name level) 4)))
1483 (dolist (msg (string-split (apply #'format str objs) "\n"))
1484 (insert (format " %-8s %s\n" tag msg))))
1485 (let ((lines-to-kill (- (line-number-at-pos) navi2ch-log-max-lines)))
1486 (when (cl-plusp lines-to-kill)
1487 (goto-char (point-min))
1488 (beginning-of-line (1+ lines-to-kill))
1489 (delete-region (point-min) (point))
1490 (goto-char (point-max))))
1491 (setq buffer-read-only t)))))
1492
1493 (defun navi2ch-log-level (&optional level)
1494 "set or get log level"
1495 (interactive
1496 (let ((tag (completing-read
1497 "Log Level: "
1498 (mapcar (lambda (e) (cons (car e) (car e))) navi2ch-log-levels))))
1499 (list (intern tag))))
1500
1501 (with-current-buffer (navi2ch-util--get-logbuffer)
1502 (let ((prev log-level))
1503 (when level (setq log-level (cdr (assoc level navi2ch-log-levels))))
1504 prev)))
1505
1506 (eval-and-compile
1507 (defalias 'navi2ch-number-sequence
1508 (if (fboundp 'number-sequence)
1509 #'number-sequence
1510 (lambda (from to)
1511 (let ((n from)
1512 result)
1513 (while (<= n to)
1514 (setq result (cons n result))
1515 (setq n (1+ n)))
1516 (nreverse result))))))
1517
1518 (defsubst navi2ch-eq-or-memq (item maybe-list)
1519 (if (listp maybe-list)
1520 (memq item maybe-list)
1521 (eq item maybe-list)))
1522
1523 (navi2ch-update-html-tag-regexp)
1524
1525 (provide 'navi2ch-util)
1526 (run-hooks 'navi2ch-util-load-hook)
1527 ;;; navi2ch-util.el ends here