Sponsored Link
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: 半角スペースを必ず &nbsp; に変換")
  227. (defvar *buf2html-number-link* t
  228.   "buf2html: 行番号出力時、行番号の <A> タグを付加")
  230. (defvar *buf2html-string-encode-alist*
  231.   '(("&" . "&amp;")
  232.     ("<" . "&lt;")
  233.     (">" . "&gt;")
  234.     ( "\"" . "&quot;")
  235. ;   " " は状況に応じて変換
  236. ;   (" " . "&nbsp;")
  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