buf2html-with-number
buf2html
ini2css-file
ini2css-buffer

---

1. ;;; -*- Mode: Lisp -*-
2. ;;;
3. ;;; buf2html.l --- convert text of buffer to HTML
5. ;;; Copyright (C) 2001 OHKUBO Hiroshi
7. ;;; Author: OHKUBO Hiroshi <konata_o@hotmail.com>
8. ;;; Version: 0.0.0.5
9. ;;; Time-stamp: <2001/12/15 11:47:34 +0900>
10. ;;; Xyzzy: 0.2.2.220
12. ;;; buf2html:
13. ;;;
14. ;;;     なるべくバッファの表示を再現するような HTML を生成します。
15. ;;;     キーワード、正規表現キーワード、text-attribute に対応していますが、
16. ;;;     一行反転表示には対応していません。
17. ;;;
18. ;;;     勘で書いている部分があるのでおかしな変換があると思います。
19. ;;;     気がついた点を知らせて頂けるとありがたいです。
20. ;;;
22. ;;; Install:
23. ;;;
24. ;;;     1. 解凍して buf2html.l を、~/site-lispにコピーします。
25. ;;;
26. ;;;     2. 必要ならばバイトコンパイルします。
27. ;;;
28. ;;;             M-x byte-compile-file
29. ;;;
30. ;;;     3. .xyzzy または siteinit.l に以下のコードを追加します。
31. ;;;
32. ;;;             (load-library "buf2html")
33. ;;;
34. ;;;     4. 上記の設定を反映させるために、xyzzyを再起動します。
35. ;;;
37. ;;; Usage:
38. ;;;
39. ;;;     1. M-x ini2css-file または M-x ini2css-buffer で xyzzy の
40. ;;;        INI ファイル (標準では xyzzy.ini) からスタイルシートを生成し、
41. ;;;        xyzzy.css というファイル名で保存。
42. ;;;
43. ;;;     2. 変換元のバッファで M-x buf2html または M-x buf2html-with-number し、
44. ;;;        HTML の出力されたバッファを xyzzy.css を保存したフォルダに保存。
45. ;;;
47. ;;; Changes:
48. ;;;     [Version 0.0.0.5]
49. ;;;     Sat, 15 Dec 2001 11:19:03 +0900
50. ;;;             ・ML で亀井さんに教えていただいたキーワード検索の方法に変更。
51. ;;;               ・タグをハイライトするかどうかを html-highlight-mode の値で判定
52. ;;;               ・syntax-symbol-prefix-p が non-nil の場合のハイライト
53. ;;;               ・syntax-table の option に *syntax-option-c-preprocessor* が
54. ;;;                 指定されていた場合の動作
55. ;;;               上記 3 点について xyzzy と同様の動作になったと思います。
56. ;;;
57. ;;;     [Version 0.0.0.4]
58. ;;;     Fri, 14 Dec 2001 18:25:03 +0900
59. ;;;             ・tag のあるモードかどうかを syntax-table で判断するように。
60. ;;;
61. ;;;     Tue, 11 Dec 2001 10:30:34 +0900
62. ;;;             ・Memo 修正。
63. ;;;             ・<TITLE></TITLE> の間では半角スペースを &nbsp; に変換
64. ;;;               しないように変更。
65. ;;;
66. ;;;     [Version 0.0.0.3]
67. ;;;     Mon, 10 Dec 2001 17:58:20 +0900
68. ;;;             ・context をパースする際の message の位置を変更。
69. ;;;             ・行番号付き出力 buf2html-with-number 追加。
70. ;;;             ・HTML 出力後バッファの modify flag を nil に。
71. ;;;             ・その他修正。
72. ;;;
73. ;;;     [Version 0.0.0.2]
74. ;;;     Fri, 07 Dec 2001 07:40:23 +0900
75. ;;;             ・message の位置を修正。
76. ;;;             ・bgr2rgb を buf2html-bgr2rgb に名称変更。
77. ;;;             ・余分な HTML タグの削減。
78. ;;;             ・キーワードが大文字小文字を区別するかの判定。
79. ;;;             ・tag 文字 (syntax-open-tag-p, syntax-close-tag-p) を
80. ;;;               キーワードより優先させるように修正。
81. ;;;             ・その他修正。
82. ;;;
83. ;;;     [Version 0.0.0.1]
84. ;;;     Fri, 07 Dec 2001 02:37:41 +0900
85. ;;;             ・門田さんの mode2htm.l, ini2css.l を参考にして初版作成。
86. ;;;
88. ;;; Todo:
89. ;;;     ・できれば行反転表示への対応
90. ;;;     ・制御文字の表示
91. ;;;     ・改行、タブ、EOF、全角スペース、半角スペースの表示
92. ;;;     ・行間への対応
93. ;;;     ・固定幅 bold 表示
94. ;;;     ・lang や charset へのまともな対応
95. ;;;     ・余分な HTML タグの削減
96. ;;;     ・TAB 文字への対処
97. ;;;     ・速度改善
98. ;;;
100. ;;; Memo:
101. ;;;     ・正規表現キーワードよりもキーワードの方が優先される。
102. ;;;       色が重ならないだけでなく、キーワード自体が重ならない。
103. ;;;     ・キーワードの色よりもタグの開始・終了の色の方が優先される。
104. ;;;       ただしタグの開始・終了文字の部分はキーワード構成部分となり得る。
105. ;;;     ・html-highlight-mode が non-nil の場合は :tag の中でしか context は
106. ;;;       切り替わらない。
107. ;;;     ・context が nil 中での :string は 終了の " 自体までだが、
108. ;;;       context が :tag 中での :string は終了の " の前まで。
109. ;;;       "abcdefghijklmn"    "abcdefghijklmn"
110. ;;;        ^^^^^^^^^^^^^^^ と  ^^^^^^^^^^^^^^ の違い。
111. ;;;     ・正規表現キーワードは指定されたコンテキスト内であれば、隣接した
112. ;;;       コンテキストをまたいでもよい。
113. ;;;       単一のコンテキスト内でキーワードが完結する必要はない。
114. ;;;       ("abc \"\" def" t (:color 1 0 :underline) (:string))
115. ;;;       は 2 つの :string コンテキストによる「"abc "" def"」 をキーワードと
116. ;;;       認識する。
117. ;;;     ・正規表現キーワードにて個々の色設定がなされていても、begin end により除外
118. ;;;       されている場合色はつかない。
119. ;;;     ・("123\\(45\\(67\\)89\\)0" nil ((1 . (:color 1)) (2 . (:color 2))) t 1 1)
120. ;;;       では、(:color 1) の色で 456789 に色がつくのではなく、67 には
121. ;;;       (:color 2) の色で色がつく。
122. ;;;       最後の begin end は色をつける point の範囲を group 番号で指定している。
123. ;;;     ・text-attribute に (:underline nil) 等を指定しても、
124. ;;;       (正規表現)キーワードで underline 等が指定されている場合は
125. ;;;       それらは無効化されない。
126. ;;;     ・color の nil と (:color nil) は異なる。
127. ;;;     ・color に nil を指定するとその色指定は無視されるよう。
128. ;;;
129. ;;;
130. ;;;     ・html-highlight-mode が non-nil の場合は基本的にキーワードは
131. ;;;       タグ内部のみだが、0.2.2.207 で追加された記述方法で
132. ;;;       nil context の中にもキーワード指定ができる。
133. ;;;       keyword-hash-table をよくみていないがもしかしたら、キーワードファイル
134. ;;;       自体を読んで parse しなければならない？
135. ;;;     ・ed::regexp-keyword-list は必ず (compile-regexp-keyword-list) されている？
136. ;;;     ・「正規表現のキーワード色分けの、グループごとの色指定」における
137. ;;;       「colorがnilなら、同一範囲にマッチした若いグループ番号の色。tなら元の色。」
138. ;;;       は具体的にどういうことなのか。「元の色」とは何か。
139. ;;;       「元の色」は「地の色」（「文字色」「背景色」）であっているのか。
140. ;;;       context は考慮する必要はないのか。
141. ;;;
143. ;;; Data structure:
144. ;;;
145. ;;;     <UNITS>  : (<UNIT>*)
146. ;;;     <UNIT>   : (<TYPE> . <RANGE>)
147. ;;;     <RANGES> : (<RANGE>*)
148. ;;;     <RANGE>  : (<FROM> . <TO>)
149. ;;;     <TYPE>   : (<keyword> . <INFO>)
150. ;;;     <FROM>   : <POINT>
151. ;;;     <TO>     : <POINT>
152. ;;;     <POINT>  : <number>
153. ;;;
154. ;;;     <number> : /[0-9]+/
155. ;;;     <keyword>: nil
156. ;;;              | :string
157. ;;;              | :comment
158. ;;;              | :tag
159. ;;;              | :buf2html-keyword
160. ;;;              | :buf2html-regexp-keyword
161. ;;;              | :buf2html-regexp-keyword-group
162. ;;;              | :buf2html-text-attribute
163. ;;;              | :buf2html-line-feed
164. ;;;
165. ;;;     <INFO>   : <TYPE> の <keyword> 毎に色々。
166. ;;;
167. ;;;       <keyword> == nil | :string | :comment | :tag
168. ;;;              : nil
169. ;;;
170. ;;;       <keyword> == :buf2html-keyword
171. ;;;              : compiled-color
172. ;;;
173. ;;;       <keyword> == :buf2html-regexp-keyword
174. ;;;              : regexp-keyword-group-units
175. ;;;
176. ;;;       <keyword> == :buf2html-regexp-keyword-group
177. ;;;              : compiled-color
178. ;;;
179. ;;;       <keyword> == :buf2html-text-attribute
180. ;;;              : (btag . etag)
181. ;;;
182. ;;;       <keyword> == :buf2html-line-feed
183. ;;;              : nil
184. ;;;
185. ;;;
186. ;;;     ・<UNITS> を構成する <UNIT> は (<TYPE> . (<FROM> . <TO>)) の
187. ;;;       <FROM> で昇順ソートされていなければならない。
188. ;;;
189. ;;;     ・<TO> は実際には範囲に含まれない。
190. ;;;       <FROM>, <TO> は (buffer-substring <FROM> <TO>) となる値。
191. ;;;
193. ;;; Code:
195. (provide "buf2html")
197. (defconstant *buf2html-version* "0.0.0.5"
198.   "buf2html: Version")
200. (defvar *buf2html-color-context* t
201.   "buf2html: context の解析を行う")
202. (defvar *buf2html-color-keyword* t
203.   "buf2html: キーワードの解析を行う")
204. (defvar *buf2html-color-regexp-keyword* t
205.   "buf2html: 正規表現キーワードの解析を行う")
206. (defvar *buf2html-color-text-attribute* t
207.   "buf2html: text-attribute の解析を行う")
209. (defvar *buf2html-auto-mode-parameter-string* "Mode: html"
210.   "buf2html: HTML 文書に含める xyzzy 用のモード指定")
211. (defvar *buf2html-date-format* "%a, %d %b %Y %H:%M:%S %Z"
212.   "buf2html: HTML 文書に含める日付書式")
213. (defvar *buf2html-time-stamp-start* "Last updated: <"
214.   "buf2html: 日付の前の文字列")
215. (defvar *buf2html-time-stamp-end* ">"
216.   "buf2html: 日付の後の文字列")
218. (defvar *buf2html-buffer-tmp* "*buf2html: Tmp*"
219.   "buf2html: 作業バッファ名")
220. (defvar *buf2html-buffer-css* "*buf2html: CSS*"
221.   "buf2html: スタイルシート出力バッファ名")
222. (defvar *buf2html-buffer-html* "*buf2html: HTML*"
223.   "buf2html: HTML 文書出力バッファ名")
225. (defvar *buf2html-convert-half-space* nil
226.   "buf2html: 半角スペースを必ず   に変換")
227. (defvar *buf2html-number-link* t
228.   "buf2html: 行番号出力時、行番号の <A> タグを付加")
230. (defvar *buf2html-string-encode-alist*
231.   '(("&" . "&")
232.     ("<" . "&lt;")
233.     (">" . ">")
234.     ( "\"" . """)
235. ;   " " は状況に応じて変換
236. ;   (" " . " ")
237.     )
238.   "buf2html: 変換する文字参照リスト")
240. (defvar *buf2html-char-code-limit* 128
241.   "buf2html: syntax-table を調べる char-code の限界
242. 全て調べる場合は lisp:char-code-limit を指定")
244. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
245. ;; buf2html-with-number
246. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
247. (defun buf2html-with-number ()
248.   "buf2html: xyzzy の表示に従ってバッファを行番号つきで HTML に変換"
249.   (interactive)
250.   (buf2html t))
252. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
253. ;; buf2html
254. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255. (defun buf2html (&optional line-number-p)
256.   "buf2html: xyzzy の表示に従ってバッファを HTML に変換"
257.   (interactive)
258.   (let ((point-max (point-max))
259.         (compiled-color-tag-table (make-hash-table))
260.         all-units keyword-units regexp-keyword-units text-attribute-units
261.         tag-char-units line-feed-units
262.         opitimized-keyword-color-list line-feed-p
263.         (source-buffer (selected-buffer)))
264.     (long-operation
265.       (save-excursion
266.         (buf2html-set-buffer *buf2html-buffer-html*)
267.         (with-output-to-buffer (*buf2html-buffer-html*)
268.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
269.           ;; context
270.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
271.           (if *buf2html-color-context*
272.               (setq all-units (buf2html-get-units-context))
273.             (setq all-units (cons nil (cons (point-min) (point-max)))))
275.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
276.           ;; tag-char
277.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
278.           (if html-highlight-mode
279.               (setq tag-char-units
280.                     (buf2html-get-units-tag-char
281.                      (buf2html-get-ranges-if-context all-units '(:tag)))))
283.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
284.           ;; keyword
285.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286.           (when (and *buf2html-color-context*
287.                      *buf2html-color-keyword*
288.                      (boundp 'ed::keyword-hash-table))
290.             (setq keyword-units
291.                   (buf2html-get-units-keyword
292.                    (buf2html-range-concatenate
293.                     (if html-highlight-mode
294.                         (buf2html-get-ranges-if-context all-units '(:tag))
295.                       (buf2html-get-ranges-if-not-context all-units '(:string :comment))))))
297.             ;; keyword の compiled-color の値(数)にあった HTML タグの登録
298.             (buf2html-add-compiled-color-tag-hash-table
299.              compiled-color-tag-table (mapcar #'cdar keyword-units))
301.             ;; keyword の範囲を適用
302.             (message "Merge keyword range.")
303.             (setq all-units (buf2html-unit-cover all-units keyword-units))
305.             ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
306.             ;; c-preprocessor 用の特殊キーワード検索
307.             (when (not (zerop (logand (get-syntax-option (syntax-table))
308.                                       *syntax-option-c-preprocessor*)))
309.               (setq keyword-units
310.                     (buf2html-get-units-keyword-c-preprocessor
311.                      (buf2html-range-concatenate
312.                       (if html-highlight-mode
313.                           (buf2html-get-ranges-if-context all-units '(:tag))
314.                         (buf2html-get-ranges-if-not-context all-units '(:string :comment))))))
316.               ;; keyword の compiled-color の値(数)にあった HTML タグの登録
317.               (buf2html-add-compiled-color-tag-hash-table
318.                compiled-color-tag-table (mapcar #'cdar keyword-units))
320.               ;; keyword の範囲を適用
321.               (message "Merge c preprocessor keyword range.")
322.               (setq all-units (buf2html-unit-cover all-units keyword-units))
323.               )
324.             )
326.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
327.           ;; regexp-keyword
328.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
329.           (when (and *buf2html-color-context*
330.                      *buf2html-color-regexp-keyword*
331.                      (boundp 'ed::regexp-keyword-list))
332.             ;; 正規表現キーワードの compiled-color の値にあった HTML タグの登録
333.             (buf2html-add-compiled-color-tag-hash-table
334.              compiled-color-tag-table
335.              (buf2html-make-regexp-keyword-color-list ed::regexp-keyword-list))
337.             (let (regexp colors compiled-context begin end (i 0)
338.                   (regexp-keyword-list-length (length ed::regexp-keyword-list)))
339.               (dolist (regexp-keyword ed::regexp-keyword-list)
340.                 (incf i)
341.                 (message "Parse regexp keyword: ~D/~D" i regexp-keyword-list-length)
342. ;               (setq regexp (car regexp-keyword))
343. ;               (setq colors (cadr regexp-keyword))
344.                 (setq compiled-context (caddr regexp-keyword))
345. ;               (setq begin (cadddr regexp-keyword))
346. ;               (setq end (car (cddddr regexp-keyword)))
347.                 (setq regexp-keyword-units
348.                       (buf2html-get-units-regexp-keyword
349.                        (buf2html-range-concatenate
350.                         (buf2html-get-ranges-if-context
351.                          all-units
352.                          (buf2html-decode-compiled-context compiled-context)))
353.                        regexp-keyword))
354.                 ;; regexp-keyword の範囲を適用
355.                 (message "Merge regexp keyword range: ~D/~D"
356.                          i regexp-keyword-list-length)
357.                 (setq all-units
358.                       (buf2html-unit-cover all-units regexp-keyword-units))))
359.             )
360.           
361.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
362.           ;; tag-char をキーワードよりも優先
363.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
364.           (when html-highlight-mode
365.             (message "Merge tag-char range.")
366.             (setq all-units (buf2html-unit-cover all-units tag-char-units)))
367.           
368.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
369.           ;; 最適化
370.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
371.           (setq all-units (buf2html-unit-concatenate all-units))
373.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
374.           ;; 行分割 (line-feed)
375.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
376.           (setq line-feed-p line-number-p)
377.           (when line-feed-p
378.             (setq line-feed-units (buf2html-get-units-line-feed))
379.             (setq all-units (buf2html-unit-cover all-units line-feed-units)))
381.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
382.           ;; text-attribute
383.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
384.           (when *buf2html-color-text-attribute*
385.             (message "Parse text attribute.")
386.             (setq text-attribute-units (buf2html-get-units-text-attribute)))
388.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
389.           ;; 出力
390.           ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
391.           (buf2html-print-header line-number-p)
392.           (buf2html-print-body all-units compiled-color-tag-table
393.                                text-attribute-units line-number-p)
394.           (buf2html-print-footer line-number-p)
395.           (message "Output HTML: done."))
396.         (set-buffer-modified-p nil *buf2html-buffer-html*))
397.       (pop-to-buffer *buf2html-buffer-html*)
398.       (set-buffer-fileio-encoding (buffer-fileio-encoding source-buffer))
399.       (set-buffer-eol-code (buffer-eol-code source-buffer))
400.       (html-mode)
401.       )))
403. (defun buf2html-get-units-context (&key begin end nomsg)
404.   "buf2html: context の範囲のリストを作成"
405.   (let ((point-max (point-max)) rate pre-rate
406.         all-units context pre-context from to range)
407.     (save-excursion
408.       (unless begin
409.         (setq begin (point-min)))
410.       (unless end
411.         (setq end (point-max)))
412.       (setq from begin)
413.       (goto-char from)
414.       (if (= begin 0)
415.           (setq context nil)
416.         (setq context (parse-point-syntax (1- (point)))))
417.       (setq rate -1)
418.       (while (and (<= (point) end) (not (eobp)))
419.         (setq pre-context context)
420.         (setq context (parse-point-syntax (point)))
421.         (unless nomsg
422.           (setq pre-rate rate)
423.           (setq rate (floor (* 100 (/ (point) point-max))))
424.           (if (/= pre-rate rate)
425.               (message "Parse context: ~2D%" rate)))
426.         (unless (eq pre-context context)
427.           (do-events)
428. ;         (unless nomsg
429. ;           (message "Parse context: ~2D%" (floor (* 100 (/ (point) point-max)))))
430.           ;; とりあえず 0.2.2.219 での context を元に適当にやってみる
431.           (cond
432.            ; nil から context が切り替わる際は一つ前から
433.            ((eq pre-context nil)
434.             (setq to (1- (point))))
435.            ; nil に切り替わる際はそのまま
436.            ((eq context nil)
437.             (setq to (point)))
438.            ;; :tag については html(+)-mode でしか試していないのであってないかも
439.            ((eq pre-context :tag)
440.             (setq to (1- (point))))
441.            ((and (eq context :tag)
442.                  (eq pre-context :string))
443.             (setq to (1+ (point))))
444.            (t
445.             (setq to (point))))
447.           (setq range (cons from to))
448.           (when (< from to)
449.             (push (cons (cons pre-context nil) range) all-units)
450.             (setq from to))
451. #|
452.           ; こんな感じのことをすると少しは早くなるかも。でもバグの元かも。
453.           (cond
454.            ((eq context :string)
455.             (skip-syntax-spec-forward "^\"")
456.             (backward-char)))
457. |#
458.           )
459.         (forward-char))
460.       (setq range (cons from end))
461.       (if (< from end)
462.           (push (cons (cons pre-context nil) range) all-units)))
463.     (unless nomsg
464.       (message "Parse context: done."))
465.     (nreverse all-units)))
467. (defun buf2html-get-units-line-feed ()
468.   "buf2html: 改行文字の範囲（位置）のリストを作成"
469.   (let (line-feed-units point)
470.     (goto-char (point-min))
471.     (while (scan-buffer "\n" :tail t)
472.       (setq point (1- (point)))
473.       (push (cons (cons :buf2html-line-feed nil) (cons point (1+ point)))
474.             line-feed-units))
475.     (nreverse line-feed-units)))
477. (defun buf2html-get-units-tag-char (ranges)
478.   "buf2html: タグの開始、終了文字の範囲（位置）のリストを作成"
479.   (let (tag-char-units from to c)
480.     (dolist (range ranges)
481.       (setq from (car range))
482.       (setq to (cdr range))
483.       (when (< from to)
484.         (setq c (char (buffer-substring from (1+ from)) 0))
485.         (if (or (syntax-open-tag-p c) (syntax-close-tag-p c))
486.             (push (cons (cons :tag nil) (cons from (1+ from))) tag-char-units))
487.         (when (< from (1- to))
488.           (setq c (char (buffer-substring (1- to) to) 0))
489.           (if (or (syntax-open-tag-p c) (syntax-close-tag-p c))
490.               (push (cons (cons :tag nil) (cons (1- to) to)) tag-char-units)))))
491.     (nreverse tag-char-units)))
493. (defun buf2html-get-units-text-attribute ()
494.   "buf2html: text-attribute の範囲のリストを作成"
495.   (let (text-attribute-units btag etag range key value)
496.     (dolist (text-attributes (list-text-attributes (point-min) (point-max)))
497.       (setq range (cons (car text-attributes) (cadr text-attributes)))
498.       (setq text-attributes (cdddr text-attributes))
499.       (setq btag "")
500.       (setq etag "")
501.       (while text-attributes
502.         (setq key (car text-attributes))
503.         (setq value (cadr text-attributes))
504.         (setq text-attributes (cddr text-attributes))
505.         (case key
506.           (:foreground
507.            (setq btag (format nil "~A<SPAN class=\"fg~D\">" btag value))
508.            (setq etag (format nil "</SPAN>~A" etag)))
509.           (:background
510.            (setq btag (format nil "~A<SPAN class=\"bg~D\">" btag value))
511.            (setq etag (format nil "</SPAN>~A" etag)))
512.           (:bold
513.            (when value
514.              (setq btag (concat btag "<SPAN class=\"bold\">"))
515.              (setq etag (concat "</SPAN>" etag))))
516.           (:underline
517.            (when value
518.              (setq btag (concat btag "<SPAN class=\"underline\">"))
519.              (setq etag (concat "</SPAN>" etag))))
520.           (:strike-out
521.            (when value
522.              (setq btag (concat btag "<SPAN class=\"strike-out\">"))
523.              (setq etag (concat "</SPAN>" etag))))))
524.       (push (cons (cons :buf2html-text-attribute (cons btag etag)) range)
525.             text-attribute-units))
526.     (nreverse text-attribute-units)))
528. (defun buf2html-get-units-keyword (ranges)
529.   "buf2html: キーワードの範囲のリストを作成"
530.   (let ((point-max (point-max)) keyword-units from to regexp compiled-color
531.         str begin end)
532.     (dolist (range ranges)
533.       (setq from (car range))
534.       (setq to (cdr range))
535.       (goto-char from)
536.       (message "Parse keyword: ~2D%" (floor (* 100 (/ from point-max))))
537.       (setq regexp (compile-regexp "\\(\\s@\\|\\s{\\|\\s\\\\)?\\(\\sw\\|\\s_\\)+"))
538.       (while (scan-buffer regexp :limit to)
539.         (setq str (match-string 0))
540.         (setq begin (match-beginning 0))
541.         (setq end (match-end 0))
542.         (when (syntax-symbol-prefix-p (char str 0))
543.           (setq str (substring 1 str))
544.           (setq begin (1- begin)))
545.         (multiple-value-bind (compiled-color init)
546.             (gethash str ed::keyword-hash-table)
547.           (when init
548.             (push (cons (cons :buf2html-keyword compiled-color)
549.                         (cons begin end)) keyword-units)))
550.         (goto-char end)))
551.     (message "Parse keyword: done.")
552.     (nreverse keyword-units)))
554. (defun buf2html-get-units-keyword-c-preprocessor (ranges)
555.   "buf2html: C preprocessor 用キーワードの範囲のリストを作成"
556.   (let ((point-max (point-max)) keyword-units from to regexp compiled-color
557.         str begin end)
558.     (dolist (range ranges)
559.       (setq from (car range))
560.       (setq to (cdr range))
561.       (goto-char from)
562.       (message "Parse c preprocessor keyword: ~2D%" (floor (* 100 (/ from point-max))))
563.       (setq regexp (compile-regexp "#[ \t]*\\(\\(\\sw\\|\\s_\\)+\\)"))
564.       (while (scan-buffer regexp :limit to)
565.         (setq str (concat "#" (match-string 1)))
566.         (setq begin (match-beginning 0))
567.         (setq end (match-end 0))
568.         (multiple-value-bind (compiled-color init)
569.             (gethash str ed::keyword-hash-table)
570.           (when init
571.             (push (cons (cons :buf2html-keyword compiled-color)
572.                         (cons begin end)) keyword-units)))
573.         (goto-char end)))
574.     (message "Parse c preprocessor keyword: done.")
575.     (nreverse keyword-units)))
577. (defun buf2html-get-units-regexp-keyword (ranges regexp-keyword)
578.   "buf2html: 正規表現キーワードの範囲のリストを作成"
579.   (let ((regexp (car regexp-keyword))
580.         (colors (cadr regexp-keyword))
581.         (compiled-context (caddr regexp-keyword))
582.         (begin (cadddr regexp-keyword))
583.         (end (car (cddddr regexp-keyword)))
584.         regexp-keyword-units from to
585.         (point-max (point-max))
586.         whole-range enable-range regexp-keyword-group-units
587.         group-number group-range compiled-color)
588.     (dolist (range ranges)
589.       (setq from (car range))
590.       (setq to (cdr range))
591.       (goto-char from)
592.       (while (scan-buffer regexp :tail t :limit to)
593.         (setq whole-range (cons (match-beginning 0) (match-end 0)))
594.         (setq enable-range
595.               (cons (if (minusp begin) (match-end (* -1 begin)) (match-beginning begin))
596.                     (if (minusp end) (match-beginning (* -1 end)) (match-end end))))
597.         (setq whole-range enable-range)
598.         (setq regexp-keyword-group-units
599.               (list (cons (cons :buf2html-regexp-keyword-group nil)
600.                           (copy-list whole-range))))
601.         (cond
602.          ((not (consp colors))
603.           (setq compiled-color colors)
604.           (setq regexp-keyword-group-units
605.                 (buf2html-unit-cover
606.                  regexp-keyword-group-units
607.                  (list (cons (cons :buf2html-regexp-keyword-group compiled-color)
608.                              enable-range)))))
609.          (t
610.           (dolist (color (sort colors #'< :key #'car)); group 順にソート
611.             (setq group-number (car color))
612.             (setq compiled-color (cdr color))
613.             (setq group-range (cons (match-beginning group-number)
614.                                     (match-end group-number)))
615.             
616.             (when (and compiled-color                 ; compiled-color が nil でない
617.                        (buf2html-in-range-p group-range enable-range))
618.               (setq regexp-keyword-group-units
619.                     (buf2html-unit-cover
620.                      regexp-keyword-group-units
621.                      (list (cons (cons :buf2html-regexp-keyword-group compiled-color)
622.                                  group-range))))))))
623.         (push (cons (cons :buf2html-regexp-keyword regexp-keyword-group-units) whole-range)
624.               regexp-keyword-units)))
625.     (nreverse regexp-keyword-units)))
627. (defun buf2html-make-regexp-keyword-color-list (regexp-keyword-list)
628.   "buf2html: regexp-keyword-list から color のリストを作成"
629.   (let (compiled-color-list)
630.     (when regexp-keyword-list
631.       ;; nil は使うので必ずいれておく。
632.       (pushnew nil compiled-color-list :test 'eql)
633.       (dolist (compiled-colors (mapcar #'cadr regexp-keyword-list))
634.         (cond
635.          ((consp compiled-colors)
636.           (dolist (compiled-color (mapcar #'cdr compiled-colors))
637.             (pushnew compiled-color compiled-color-list :test 'eql)))
638.          ((numberp compiled-colors)
639.           (pushnew compiled-colors compiled-color-list :test 'eql))
640.          (t
641.           (pushnew compiled-colors compiled-color-list :test 'eql)))))
642.     compiled-color-list))
644. (defun buf2html-add-compiled-color-tag-hash-table (hash-table compiled-colors)
645.   "buf2html: compiled-colors に対応する HTML タグを hash-table に登録"
646.   (when (hash-table-p hash-table)
647.     (dolist (compiled-color compiled-colors)
648.       (multiple-value-bind (value init)
649.           (gethash compiled-color hash-table)
650.         (unless init
651.           (setf (gethash compiled-color hash-table)
652.                 (buf2html-make-compiled-color-tag compiled-color)))))
653.     hash-table))
655. ;; 正規表現キーワードのグループ毎の色指定での
656. ;; color 部分が t の場合の動作がよくわからない。
657. ;; nil のときは、compiled-color は nil
658. ;; t   のときは、compiled-color は 0
659. (defun buf2html-make-compiled-color-tag (compiled-color)
660.   "buf2html: compiled-color に対応する HTML タグを作成"
661.   (unless (numberp compiled-color)
662.     (return-from buf2html-make-compiled-color-tag (cons "" "")))
663.   (let ((fg-bg-p (= (logand compiled-color #x1) #x1))
664.         (line-p (= (logand compiled-color #x2) #x2))
665.         (bold-p (= (logand compiled-color #x200000) #x200000))
666.         (underline-p (= (logand compiled-color #x800000) #x800000))
667.         (strike-out-p (= (logand compiled-color #x1000000) #x1000000))
668.         (color (logand compiled-color (lognot #x1)
669.                        (lognot #x2) (lognot #x200000) (lognot #x800000) (lognot #x1000000)))
670.         (btag "") (etag ""))
672.     (cond
673.      (fg-bg-p
674.       (setq btag (format nil "<SPAN class=\"fg~D bg~D\">"
675.                          (floor (logand color #x1f00) #x200)
676.                          (floor (logand color #x1f0000) #x20000)))
677.       (setq etag "</SPAN>"))
678.      (t
679.       (cond
680.        ((= color 0)
681.         (setq btag "" etag ""))
682.        ((= color (gethash #\0 ed::*keyword-translate-hash-table*));keyword1
683.         (setq btag "<SPAN class=\"keyword1\">" etag "</SPAN>"))
684.        ((= color (gethash #\1 ed::*keyword-translate-hash-table*));keyword2
685.         (setq btag "<SPAN class=\"keyword2\">" etag "</SPAN>"))
686.        ((= color (gethash #\2 ed::*keyword-translate-hash-table*));keyword3
687.         (setq btag "<SPAN class=\"keyword3\">" etag "</SPAN>"))
688.        ((= color (gethash #\3 ed::*keyword-translate-hash-table*));keyword1 反転
689.         (setq btag "<SPAN class=\"keyword1inverse\">" etag "</SPAN>"))
690.        ((= color (gethash #\4 ed::*keyword-translate-hash-table*));keyword2 反転
691.         (setq btag "<SPAN class=\"keyword2inverse\">" etag "</SPAN>"))
692.        ((= color (gethash #\5 ed::*keyword-translate-hash-table*));keyword3 反転
693.         (setq btag "<SPAN class=\"keyword3inverse\">" etag "</SPAN>"))
694.        ((= color (gethash #\S ed::*keyword-translate-hash-table*));string
695.         (setq btag "<SPAN class=\"string\">" etag "</SPAN>"))
696.        ((= color (gethash #\T ed::*keyword-translate-hash-table*));tag
697.         (setq btag "<SPAN class=\"tag\">" etag "</SPAN>"))
698.        ((= color (gethash #\C ed::*keyword-translate-hash-table*));comment
699.         (setq btag "<SPAN class=\"comment\">" etag "</SPAN>")))))
701.     ;; bold
702.     (when bold-p
703.       (setq btag (concat btag "<SPAN class=\"bold\">"))
704.       (setq etag (concat "</SPAN>" etag)))
705.     ;; underline
706.     (when underline-p
707.       (setq btag (concat btag "<SPAN class=\"underline\">"))
708.       (setq etag (concat "</SPAN>" etag)))
709.     ;; strike-out
710.     (when strike-out-p
711.       (setq btag (concat btag "<SPAN class=\"strike-out\">"))
712.       (setq etag (concat "</SPAN>" etag)))
713.     ;; line (どうすればよい？)
714.     (when line-p
715.       t)
716.     (cons btag etag)))
718. (defun buf2html-decode-compiled-context (compiled-context)
719.   "buf2html: compiled-context をデコードし context のリストを作成"
720.   (let (context-list)
721.     (if (= (logand compiled-context #x1) #x1)
722.         (push nil context-list))
723.     (if (= (logand compiled-context #x2) #x2)
724.         (push :string context-list))
725.     (if (= (logand compiled-context #x4) #x4)
726.         (push :tag context-list))
727.     (if (= (logand compiled-context #x8) #x8)
728.         (push :comment context-list))
729.     context-list))
731. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
732. ;; range, unit 操作関連
733. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
734. (defun buf2html-in-range-p (position_or_range range)
735.   "buf2html: range に position_or_range が含まれるかどうか"
736.   (if (null range)
737.       nil
738.     (cond
739.      ((numberp position_or_range)
740.       (if (and (<= (car range) position_or_range)
741.                (<= position_or_range (cdr range)))
742.           range
743.         nil))
744.      ((consp position_or_range)
745.       (if (and (<= (car range) (car position_or_range))
746.                (<= (cdr position_or_range) (cdr range)))
747.           range
748.         nil))
749.      (t nil))))
751. (defun buf2html-range-concatenate (ranges)
752.   "buf2html: 隣接した range を連結"
753.   (let (return-ranges work-range)
754.     (unless ranges
755.       (return-from buf2html-range-concatenate nil))
756.     (setq work-range (car ranges))
757.     (dolist (range (cdr ranges))
758.       (cond
759.        ((= (cdr work-range) (car range))
760.         (setq work-range (cons (car work-range) (cdr range))))
761.        (t
762.         (push work-range return-ranges)
763.         (setq work-range range))))
764.     (push work-range return-ranges)
765.     (nreverse return-ranges)))
767. (defun buf2html-unit-concatenate (units)
768.   "buf2html: 隣接した同じ type の unit を連結"
769.   (let (return-units work-unit)
770.     (unless units
771.       (return-from buf2html-unit-concatenate nil))
772.     (setq work-unit (car units))
773.     (dolist (unit (cdr units))
774.       (cond
775.        ((and (equal (car work-unit) (car unit))
776.              (= (cddr work-unit) (cadr unit)))
777.         (setq work-unit (cons (car work-unit)
778.                               (cons (cadr work-unit) (cddr unit)))))
779.        (t
780.         (push work-unit return-units)
781.         (setq work-unit unit))))
782.     (push work-unit return-units)
783.     (nreverse return-units)))
785. (defun buf2html-unit-cover (base-units priority-units)
786.   "buf2html: base-units に priority-units をかぶせる"
787.   (let (return-units base-type-range priority-type-range base-unit priority-unit start)
788.     (setq start 0)
789.     (setq base-unit (car base-units))
790.     (setq base-units (cdr base-units))
791.     (setq priority-unit (car priority-units))
792.     (setq priority-units (cdr priority-units))
793.     (while (and base-unit priority-unit)
794.       (cond
795.        ;; 重ならず base が前
796.        ((<= (cddr base-unit) (cadr priority-unit))
797.         (if (< (cadr base-unit) (cddr base-unit))
798.             (push base-unit return-units))
799.         (setq start (cddr base-unit)))
800.        ;; 重ならず priority が前
801.        ((<= (cddr priority-unit) (cadr base-unit))
802.         (if (< (cadr priority-unit) (cddr priority-unit))
803.             (push priority-unit return-units))
804.         (setq start (cddr priority-unit))
805.         (setq priority-unit nil))
806.        ;; priority が base を含む
807.        ((and (<= (cadr priority-unit) (cadr base-unit))
808.              (<= (cddr base-unit) (cddr priority-unit)))
809.         (if (< (cadr priority-unit) (cddr priority-unit))
810.             (push priority-unit return-units))
811.         (setq start (cddr priority-unit))
812.         (setq priority-unit nil))
813.        ;; base が priority を含む
814.        ((and (<= (cadr base-unit) (cadr priority-unit))
815.              (<= (cddr priority-unit) (cddr base-unit)))
816.         (if (< (cadr base-unit) (cadr priority-unit))
817.             (push (cons (car base-unit)
818.                         (cons (cadr base-unit) (cadr priority-unit))) return-units))
819.         (if (< (cadr priority-unit) (cddr priority-unit))
820.             (push priority-unit return-units))
821.         (setq start (cddr priority-unit))
822.         (setq priority-unit nil))
823.        ;; 重なり priority が前
824.        ((<= (cadr priority-unit) (cadr base-unit))
825.         (if (< (cadr priority-unit) (cddr priority-unit))
826.             (push priority-unit return-units))
827.         (setq start (cddr priority-unit))
828.         (setq priority-unit nil))
829.        ;; 重なり priority が後
830.        (t
831.         (if (< (cadr base-unit) (cadr priority-unit))
832.             (push (cons (car base-unit)
833.                         (cons (cadr base-unit) (cadr priority-unit))) return-units))
834.         (if (< (cadr priority-unit) (cddr priority-unit))
835.             (push priority-unit return-units))
836.         (setq start (cddr priority-unit))
837.         (setq priority-unit nil)))
839.       (unless priority-unit
840.         (setq priority-unit (car priority-units))
841.         (setq priority-units (cdr priority-units)))
842.       (while (and base-unit (<= (cddr base-unit) start))
843.         (setq base-unit (car base-units))
844.         (setq base-units (cdr base-units)))
845.       (if (and base-unit (< (cadr base-unit) start))
846.           (setq base-unit (cons (car base-unit) (cons start (cddr base-unit)))))
847.       )
848.     (cond
849.      (base-unit
850.       (while base-unit
851.         (if (< (cadr base-unit) (cddr base-unit))
852.             (push base-unit return-units))
853.         (setq base-unit (car base-units))
854.         (setq base-units (cdr base-units))))
855.      (priority-unit
856.       (while priority-unit
857.         (if (< (cadr priority-unit) (cddr priority-unit))
858.             (push priority-unit return-units))
859.         (setq priority-unit (car priority-units))
860.         (setq priority-units (cdr priority-units)))))
861.     (nreverse return-units)))
863. (defun buf2html-get-ranges-if-context (units contexts)
864.   "buf2html: contexts に含まれる context である unit の range のリストを返す"
865.   (mapcar #'cdr
866.           (remove contexts units
867.                   :test #'(lambda (contexts context)
868.                             (not (position context contexts)))
869.                   :key #'caar)))
871. (defun buf2html-get-ranges-if-not-context (units contexts)
872.   "buf2html: contexts に含まれない context である unit の range のリストを返す"
873.   (mapcar #'cdr
874.           (remove contexts units
875.                   :test #'(lambda (contexts context)
876.                             (position context contexts))
877.                   :key #'caar)))
880. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
881. ;; 出力関連
882. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
883. (defun buf2html-protect-string (body &optional convert-half-space-p)
884.   "buf2html: 文字参照を変換した文字列を返す"
885.   (dolist (cell *buf2html-string-encode-alist*)
886.     (setq body (substitute-string body (car cell) (cdr cell))))
887.   (if convert-half-space-p
888.       (setq body (substitute-string body " " " ")))
889.   body)
891. (defun buf2html-print-header (&optional line-number-p)
892.   "buf2html: HTML の開始部分を出力"
893.   (let (lang title charset encoding-display-name)
894.     (if (setq title (get-buffer-file-name))
895.         (setq title (concat (pathname-name title)
896.                             (if (pathname-type title)
897.                                 (concat "." (pathname-type title)) "")))
898.       (setq title (buffer-name (selected-buffer))))
899.     (setq encoding-display-name (char-encoding-display-name (buffer-fileio-encoding)))
900.     (cond
901.      ((string-match "日本語" encoding-display-name)
902.       (setq lang "ja"))
903.      ((string-match "中国語" encoding-display-name)
904.       nil)
905.      ((string-match "韓国語" encoding-display-name)
906.       nil)
907.      (t
908.       nil))
909.     (cond
910.      ((string-match "Shift_JIS" encoding-display-name)
911.       (setq charset "Shift_JIS"))
912.      ((string-match "EUC-JP" encoding-display-name)
913.       (setq charset "EUC-JP"))
914.      ((string-match "ISO-2022-JP" encoding-display-name)
915.       (setq charset "ISO-2022-JP"))
916.      ((string-match "UTF-8" encoding-display-name)
917.       (setq charset "UTF-8"))
918.      (t
919.       nil))
920.      
921.     (format t "~A~%" "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">")
922.     (if (stringp *buf2html-auto-mode-parameter-string* )
923.         (format t "~A~A~A~%" "<!-- -*- "
924.                 *buf2html-auto-mode-parameter-string* " -*- -->"))
925.     (if (and (stringp *buf2html-date-format*)
926.              (stringp *buf2html-time-stamp-start*)
927.              (stringp *buf2html-time-stamp-end*))
928.         (format t "~A~A~A~A~A~%"
929.                 "<!-- " *buf2html-time-stamp-start*
930.                 (format-date-string *buf2html-date-format*)
931.                 *buf2html-time-stamp-end* " -->"))
932.     (format t "~A~A~A~%" "<!-- Created by buf2html-" *buf2html-version* " -->")
933.     (if lang
934.         (format t "~A~A~A~%" "<HTML lang=\"" lang "\">")
935.       (format t "~A~%" "<HTML>"))
936.     (format t "~A~%" "  <HEAD>")
937.     (format t "~A~A~A~%" "    <META name=\"GENERATOR\" content=\"buf2html-"
938.             *buf2html-version* "\">")
939.     (if charset
940.         (format t "~A~A~A~%" "    <META http-equiv=\"Content-Type\" content=\"text/html; charset=" charset "\">"))
941.     (format t "~A~%" "    <LINK href=\"xyzzy.css\" rel=\"stylesheet\" type=\"text/css\">")
942.     (format t "~A~A~A~%" "    <TITLE>" (buf2html-protect-string title) "</TITLE>")
943.     (format t "~A~%" "  </HEAD>")
944.     (format t "~A~%" "  <BODY class=\"bgcolor\">")
945.     (if line-number-p
946.         (if *buf2html-number-link*
947.             (format t "~A" "<OL>\n<LI><CODE><A name=\"1\">")
948.           (format t "~A" "<OL>\n<LI><CODE>"))
949.       (format t "~A~%" "    <PRE>"))
950.     ))
952. (defun buf2html-print-footer (&optional line-number-p)
953.   "buf2html: HTML の終了部分を出力"
954.   (if line-number-p
955.       (format t "~A~%" "</OL>")
956.     (format t "~A~%" "</PRE>"))
957.   (format t "~A~%" "  </BODY>")
958.   (format t "~A~%" "</HTML>"))
960. (defun buf2html-print-body (all-units compiled-color-tag-table text-attribute-units
961.                             &optional line-number-p)
962.   "buf2html: HTML のメイン部分を出力"
963.   (let ((point-max (point-max)) btag etag
964.         type range tags (line-number 1)
965.         regexp-keyword-group-units regexp-keyword-group-range)
966.     (flet ((print-range (range btag etag text-attribute-units)
967.              (let (text-attribute-unit
968.                    text-attribute-tags
969.                    text-attribute-range
970.                    (convert-half-space-p (or *buf2html-convert-half-space* line-number-p)))
971. ;              ;; 念のため前の部分を除外
972. ;              (while (and text-attribute-units
973. ;                          (<= (cddar text-attribute-units) (car range)))
974. ;                (setq text-attribute-units (cdr text-attribute-units)))
976.                ;; text-attribute-units の先頭を取得（先頭には残したまま）
977.                (when text-attribute-units
978.                  (setq text-attribute-unit (car text-attribute-units))
979.                  (setq text-attribute-tags (cdar text-attribute-unit))
980.                  (setq text-attribute-range (cdr text-attribute-unit))
981.                  (if (< (car text-attribute-range) (car range))
982.                      (setq text-attribute-range
983.                            (cons (car range) (cdr text-attribute-range)))))
984.                
985.                (while (< (car range) (cdr range))
986.                  (cond
987.                   ;; text-attribute-range と関係がない場合
988.                   ((or (null text-attribute-range)
989.                        (<= (cdr range) (car text-attribute-range)))
990.                    (format t "~A~A~A"
991.                            btag
992.                            (buf2html-protect-string
993.                             (buffer-substring (car range) (cdr range))
994.                             convert-half-space-p)
995.                            etag)
996.                    (return))
997.                   ;; text-attribute-range が range の終端以降まである場合
998.                   ((< (cdr range) (cdr text-attribute-range))
999.                    (format t "~A" btag)
1000.                    (if (< (car range) (car text-attribute-range))
1001.                        (format t "~A"
1002.                                (buf2html-protect-string
1003.                                 (buffer-substring (car range) (car text-attribute-range))
1004.                                 convert-half-space-p)))
1005.                    (format t "~A~A~A~A"
1006.                            (car text-attribute-tags)
1007.                            (buf2html-protect-string
1008.                             (buffer-substring (car text-attribute-range) (cdr range))
1009.                             convert-half-space-p)
1010.                            (cdr text-attribute-tags) etag)
1011.                    (return))
1012.                   ;; text-attribute-range が range に含まれる場合
1013.                   (t
1014.                    (format t "~A" btag)
1015.                    (if (< (car range) (car text-attribute-range))
1016.                        (format t "~A"
1017.                                (buf2html-protect-string
1018.                                 (buffer-substring (car range) (car text-attribute-range))
1019.                                 convert-half-space-p)))
1020.                    (format t "~A~A~A~A"
1021.                            (car text-attribute-tags)
1022.                            (buf2html-protect-string
1023.                             (buffer-substring (car text-attribute-range)
1024.                                               (cdr text-attribute-range))
1025.                             convert-half-space-p)
1026.                            (cdr text-attribute-tags)
1027.                            etag)
1028.                    (setq range (cons (cdr text-attribute-range) (cdr range)))
1030.                    ;; 使用済みの text-attribute-unit を先頭から除外
1031.                    (setq text-attribute-units (cdr text-attribute-units))
1032.                    (if text-attribute-units
1033.                        (progn
1034.                          (setq text-attribute-unit (car text-attribute-units))
1035.                          (setq text-attribute-tags (cdar text-attribute-unit))
1036.                          (setq text-attribute-range (cdr text-attribute-unit)))
1037.                      (progn
1038.                        (setq text-attribute-unit nil)
1039.                        (setq text-attribute-tags nil)
1040.                        (setq text-attribute-range nil)))))))
1041.              text-attribute-units))
1042.       
1043.       (dolist (all-unit all-units)
1044.         (setq type (car all-unit))
1045.         (setq range (cdr all-unit))
1046.         (message "Output HTML: ~2D%" (floor (* 100 (/ (car range) point-max))))
1047.         (case (car type)
1048.           ((nil)
1049.            (setq text-attribute-units
1050.                  (print-range range "" "" text-attribute-units)))
1051.           (:string
1052.            (setq text-attribute-units
1053.                  (print-range range "<SPAN class=\"string\">" "</SPAN>"
1054.                               text-attribute-units)))
1055.           (:comment
1056.            (setq text-attribute-units
1057.                  (print-range range "<SPAN class=\"comment\">" "</SPAN>"
1058.                               text-attribute-units)))
1059.           (:tag
1060.            (setq text-attribute-units
1061.                  (print-range range "<SPAN class=\"tag\">" "</SPAN>"
1062.                               text-attribute-units)))
1063.           (:buf2html-keyword
1064.            (setq tags (gethash (cdr type) compiled-color-tag-table))
1065.            (setq text-attribute-units
1066.                  (print-range range (car tags) (cdr tags) text-attribute-units)))
1067.           (:buf2html-regexp-keyword
1068.            (setq regexp-keyword-group-units (cdr type))
1069.            (dolist (regexp-keyword-group-unit regexp-keyword-group-units)
1070.              (setq tags (gethash (cdar regexp-keyword-group-unit)
1071.                                  compiled-color-tag-table))
1072.              (setq regexp-keyword-group-range (cdr regexp-keyword-group-unit))
1073.              (if (< (car regexp-keyword-group-range) (car range))
1074.                  (setq regexp-keyword-group-range
1075.                        (cons (car range) (cdr regexp-keyword-group-range))))
1076.              (if (< (cdr range) (cdr regexp-keyword-group-range))
1077.                  (setq regexp-keyword-group-range
1078.                        (cons (car regexp-keyword-group-range) (cdr range))))
1079.              (if (< (car regexp-keyword-group-range) (cdr regexp-keyword-group-range))
1080.                  (setq text-attribute-units
1081.                        (print-range regexp-keyword-group-range (car tags) (cdr tags)
1082.                                     text-attribute-units)))))
1083.           (:buf2html-line-feed
1084.            (cond
1085.             ((not line-number-p)
1086.              (setq text-attribute-units
1087.                    (print-range range "" "" text-attribute-units)))
1088.             ((= (cdr range) point-max)
1089.              (if *buf2html-number-link*
1090.                  (setq text-attribute-units
1091.                        (print-range range "</A></CODE></LI>" ""
1092.                                     text-attribute-units))
1093.                (setq text-attribute-units
1094.                      (print-range range "</CODE></LI>" ""
1095.                                   text-attribute-units))))
1096.             (t
1097.              (incf line-number)
1098.              (if *buf2html-number-link*
1099.                  (setq text-attribute-units
1100.                        (print-range range "</A></CODE></LI>"
1101.                                     (format nil "<LI><CODE><A name=\"~D\">"
1102.                                             line-number)
1103.                                     text-attribute-units))
1104.                (setq text-attribute-units
1105.                      (print-range range "</CODE></LI>" "<LI><CODE>"
1106.                                   text-attribute-units))))))
1108.           (t
1109.            (setq text-attribute-units
1110.                  (print-range range "" "" text-attribute-units))))))))
1112. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1113. ;; syntax-table 関連
1114. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1115. ; 使用していない
1116. (defun buf2html-syntax-table-check ()
1117.   "buf2html: syntax-table を調べる"
1118.   (let ((percent -1) pre-percent c
1119.         open-tag-characters close-tag-characters
1120.         start-comment-characters end-comment-characters
1121.         start-multi-comment-1-characters start-multi-comment-2-characters
1122.         end-multi-comment-1-characters end-multi-comment-2-characters)
1123.     (dotimes (i *buf2html-char-code-limit*)
1124.       (setq pre-percent percent)
1125.       (setq percent (floor (* 100 (/ i *buf2html-char-code-limit*))))
1126.       (if (/= pre-percent percent) (message "Check syntax table: ~2D%" percent))
1127.       (setq c (code-char i))
1128.       (if (syntax-open-tag-p c) (push c open-tag-characters))
1129.       (if (syntax-close-tag-p c) (push c close-tag-characters))
1130.       (if (syntax-start-comment-p c) (push c start-comment-characters))
1131.       (if (syntax-end-comment-p c) (push c end-comment-characters))
1132.       (if (syntax-start-multi-comment-1-p c) (push c start-multi-comment-1-characters))
1133.       (if (syntax-start-multi-comment-2-p c) (push c start-multi-comment-2-characters))
1134.       (if (syntax-end-multi-comment-1-p c) (push c end-multi-comment-1-characters))
1135.       (if (syntax-end-multi-comment-2-p c) (push c end-multi-comment-2-characters))
1136.       )
1137.     (values open-tag-characters close-tag-characters
1138.             start-comment-characters end-comment-characters
1139.             start-multi-comment-1-characters start-multi-comment-2-characters
1140.             end-multi-comment-1-characters end-multi-comment-2-characters)
1141.     ))
1144. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1145. ;; ini2css-file
1146. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1147. (defun ini2css-file (ini-path)
1148.   "buf2html: xyzzy の設定ファイルからスタイルシートを生成"
1149.   (interactive "fFind ini file: "
1150.     :title0 "Find ini file"
1151.     :default0 (let ((path (concat (si:system-root) "usr/" (user-name) "/"
1152.                                   (case (os-platform)
1153.                                     ('windows-95 "w95")
1154.                                     ('windows-98 "w98")
1155.                                     ('windows-wme "wme")
1156.                                     ('windows-nt "wnt")
1157.                                     ('windows-w2k "w2k"))
1158.                                   "/xyzzy.ini")))
1159.                 (if (file-exist-p path) path "")))
1160.   (if (file-exist-p ini-path)
1161.       (progn
1162.         (save-excursion
1163.           (buf2html-set-buffer *buf2html-buffer-tmp*)
1164.           (with-output-to-buffer (*buf2html-buffer-tmp*)
1165.             (with-open-file (fp ini-path)
1166.               (let ((line nil))
1167.                 (while (setq line (read-line fp nil nil nil))
1168.                   (format t "~A~%" line)))))
1169.           (set-buffer *buf2html-buffer-tmp*)
1170.           (goto-char (point-min))
1171.           (ini2css-buffer)
1172.           (delete-buffer (find-buffer *buf2html-buffer-tmp*)))
1173.         (pop-to-buffer *buf2html-buffer-css*))
1174.     (message "ファイルが存在しません")))
1176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1177. ;; ini2css-buffer
1178. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1179. (defun ini2css-buffer ()
1180.   "buf2html: 現在のバッファからスタイルシートを生成"
1181.   (interactive)
1182.   (let (start-point end-point colors-alist)
1183.     (save-excursion
1184.       (goto-char (point-min))
1185.       (when (scan-buffer "^\\[Colors\\]" :regexp t :case-fold t)
1186.         (setq start-point (point))
1187.         (setq end-point
1188.               (if (scan-buffer "^\\[.+\\]" :regexp t :no-dup t) (point) (point-max)))
1189.         (save-restriction
1190.           (narrow-to-region start-point end-point)
1191.           (goto-char (point-min))
1192.           (while (scan-buffer "^\\([^=]+\\)=#\\([0-9a-f]+\\)"
1193.                               :regexp t :case-fold t :no-dup t)
1194.             (push (cons (match-string 1)
1195.                         (buf2html-bgr2rgb (parse-integer (match-string 2) :radix 16)))
1196.                   colors-alist)))))
1197.     (buf2html-set-buffer *buf2html-buffer-css*)
1198.     (with-output-to-buffer (*buf2html-buffer-css*)
1199.       (flet ((format-selector (colors-alist selector fg-item &optional bg-item single-line)
1200.                (let (fgcolor bgcolor)
1201.                  (if (stringp fg-item)
1202.                      (setq fgcolor (find fg-item colors-alist :key 'car :test 'string-equal)))
1203.                  (if (stringp bg-item)
1204.                      (setq bgcolor (find bg-item colors-alist :key 'car :test 'string-equal)))
1205.                  (when (or fgcolor bgcolor)
1206.                    (format t "~A {" selector)
1207.                    (unless single-line (format t "~%"))
1208.                    (when fgcolor
1209.                      (format t "~A" (if single-line " " "\t"))
1210.                      (format t "~A: #~6,'0x;" "color" (cdr fgcolor))
1211.                      (unless single-line (format t "~%")))
1212.                    (when bgcolor
1213.                      (format t "~A" (if single-line " " "\t"))
1214.                      (format t "~A: #~6,'0x;" "background-color" (cdr bgcolor))
1215.                      (unless single-line (format t "~%")))
1216.                    (if single-line (format t " "))
1217.                    (cond
1218.                     ((and fgcolor bgcolor)
1219.                      (format t "} /* ~A, ~A */~%" fg-item bg-item))
1220.                     (fgcolor
1221.                      (format t "} /* ~A */~%" fg-item))
1222.                     (bgcolor
1223.                      (format t "} /* ~A */~%" bg-item))))
1224.                  )))
1225.         (format-selector colors-alist ".bgcolor" "textColor" "backColor")
1226.         (format-selector colors-alist "SPAN.keyword1" "kwdColor1")
1227.         (format-selector colors-alist "SPAN.keyword2" "kwdColor2")
1228.         (format-selector colors-alist "SPAN.keyword3" "kwdColor3")
1229.         (format-selector colors-alist "SPAN.keyword1inverse" "backColor" "kwdColor1")
1230.         (format-selector colors-alist "SPAN.keyword2inverse" "backColor" "kwdColor2")
1231.         (format-selector colors-alist "SPAN.keyword3inverse" "backColor" "kwdColor3")
1232.         (format-selector colors-alist "SPAN.string" "stringColor")
1233.         (format-selector colors-alist "SPAN.comment" "commentColor")
1234.         (format-selector colors-alist "SPAN.tag" "tagColor")
1235.         (format-selector colors-alist ".fg0" "textColor")
1236.         (format-selector colors-alist ".bg0" nil "backColor")
1237.         (do ((i 1 (1+ i)))
1238.             ((> i 15))
1239.           (format-selector colors-alist (format nil ".fg~D" i) (format nil "fg~D" i) nil t)
1240.           (format-selector colors-alist (format nil ".bg~D" i) nil (format nil "bg~D" i) t))
1241.         )
1242.       ;; bold
1243.       (format t "~A { ~A; }~%" ".bold" "font-weight: bold")
1244.       ;; underline
1245.       (format t "~A { ~A; }~%" ".underline" "text-decoration: underline")
1246.       ;; strike-out
1247.       (format t "~A { ~A; }~%" ".strike-out" "text-decoration: line-through")
1249.       )
1250.     (pop-to-buffer *buf2html-buffer-css*)
1251.     (if (fboundp 'css-mode)
1252.         (css-mode))
1253.     (set-buffer-modified-p nil)
1254.     ))
1256. ;; #ffffff 以上の値はどんなフォーマット？
1257. (defun buf2html-bgr2rgb (bgr)
1258.   "buf2html: bgr の数値を rgb の数値に変換"
1259.   (let ((b (floor (mod bgr #x1000000) #x10000))
1260.         (g (floor (mod bgr #x10000) #x100))
1261.         (r (mod bgr #x100)))
1262.     (+ (* r #x10000) (* g #x100) b)))
1264. (defun buf2html-set-buffer (buffer-name)
1265.   "buf2html: 出力用バッファの準備"
1266.   (save-excursion
1267.     (get-buffer-create buffer-name)
1268.     (erase-buffer buffer-name)
1269.     (set-buffer buffer-name)
1270.     (make-local-variable 'need-not-save)
1271.     (setq need-not-save t)
1272.     (make-local-variable 'need-not-save)
1273.     (setq need-not-save t)))