・スレッド編集（2chまとめサイト作るノリのものです。ここを参考にしました）
強調ボタン、AAボタンはおいてあるだけ。これから作る予定・・・？
・アンカーリンクの削除（ホントはアンカーに基づいてスレ順を組み替えたい）
・自動リンク
・YouTubeリンクの展開
・画像リンクの展開
・ちゃんとセッションを使うようにしました（2chで教えて貰いました。ありがとうございます）
・編集したスレ＆レスを記録して一覧で編集済みのマークが出るようにしました。
・相変わらずIEでトップページが動きません・・・
・正規表現がバックスラッシュ大杉で訳わからなくなってます。
・Win7 + CCL + Chrome で動作確認しています。
・一部の板で動きません。どうもURLの形式が通常と違う板があるようです（自分が見る板は問題ないので放置予定）
・:jpライブラリはこちらのものに、clozure対応パッチを当てたものを使っています。
2ch-web.lisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :hunchentoot)
(require :cl-who)
(require :drakma)
(require :jp)
(require :cl-ppcre)
(require :parenscript))
(defpackage :2ch-editor
(:use :cl :hunchentoot :cl-who :drakma :jp :cl-ppcre :parenscript)
(:shadow :COOKIE-VALUE
:*HEADER-STREAM*
:PARAMETER-ERROR
:COOKIE-NAME
:COOKIE-DOMAIN
:COOKIE-PATH
:COOKIE-EXPIRES)
(:export #:main #:start-2ch-server #:stop-2ch-server))
;; 参考
;; Common Lisp で Web アプリを作るためのブランクプロジェクト
;; http://read-eval-print.blogspot.com/2011/02/common-lisp-web.html
(in-package :2ch-editor)
;; TODO?
;; アンカーに基づいたレス順入れ替え
;; AA強調ボタン
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 環境設定
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *default-directory*
(pathname "c:/export/home/clisp/2ch-web/")
"このファイルがあるディレクトリを指定")
(defparameter *js-path* (merge-pathnames "js/" *default-directory*)
"JavaScript 用ディレクトリ")
(defparameter *css-path* (merge-pathnames "css/" *default-directory*)
"スタイルシート用ディレクトリ")
;; 文字コードを設定
(setf
;; for utf-8
hunchentoot:*hunchentoot-default-external-format* (flexi-streams:make-external-format :utf-8)
hunchentoot:*default-content-type* "text/html; charset=utf-8"
;; for debug
hunchentoot:*catch-errors-p* nil)
;; スタイルシートと、javascriptディレクトリをアクセス可能にする。
(setf hunchentoot:*dispatch-table*
(list
'hunchentoot:dispatch-easy-handlers
(hunchentoot:create-folder-dispatcher-and-handler "/css/" *css-path*)
(hunchentoot:create-folder-dispatcher-and-handler "/js/" *js-path*)))
;;わかったのでやめ
;;(defvar *global-session* nil "Hunchentootのセッションがよくわからないので自前変数")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 汎用関数
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *port8080-acceptor* (make-instance 'hunchentoot:acceptor :port 8080)
"hunchentootの起動ポートを指定する")
(defun start-2ch-server ()
"Web サーバ起動"
(start *port8080-acceptor*))
(defun stop-2ch-server ()
"Web サーバ停止"
(stop *port8080-acceptor*))
(defmacro with-default-template ((&key (title "題名")
(charset "UTF-8")) &body body)
"ページのテンプレート"
`(with-html-output-to-string (out nil :indent t :prologue t)
(htm (:html :lang "ja"
(:head
(:meta :charset ,charset :http-equiv "Content-Type" :content="text/html")
(:title ,title)
(:link :rel "stylesheet" :href "css/main.css" :media "all")
(:script :type "text/javascript" :scr "js/prototype.js")
(:script :type "text/javascript" :src "js/main.js"))
(:body :bgcolor "#efefef" ,@body)))))
;; 各スレッドの情報を格納する
(defclass res ()
((num :initarg :num)
(name :initarg :name)
(mail :initarg :mail)
(date :initarg :date)
(text :initarg :text)
(ancr :initarg :ancr)
(flag :initarg :flag)))
(defun http-request-jp (url)
"ページをバイナリで取得しデコードして表示する。たまに変な文字コードが混ざるので消しておく"
(delete #\Return (jp:decode (http-request url :force-binary t) :guess)))
(defun delete-html-tag (text)
"タグを除去する"
(cl-ppcre:regex-replace-all "<[/a-zA-Z]+>" text ""))
(defvar *thread-db* nil
"編集済みのスレッド情報を格納する変数")
(defvar *thread-db-path* "thread.db"
"スレッドDBのパス")
(defun load-thread-db ()
"スレッドDBをロードする。"
(with-open-file (in *thread-db-path*)
(with-standard-io-syntax
(setf *thread-db* (read in)))))
(defun save-thread-db ()
"スレッドDBをセーブする。"
(with-open-file (out *thread-db-path*
:direction :output
:if-exists :supersede)
(with-standard-io-syntax
(print *thread-db* out))))
(defun check-exist-record-in-thread-db (url)
"DBにレコードが存在するかチェック"
(if (remove-if-not #'(lambda (x) (when (string= (first x) url) x)) *thread-db*)
t
nil))
(defun add-record-to-thread-db (url num-list)
"スレッドDBへ新規データを格納する"
(if (check-exist-record-in-thread-db url)
(setf *thread-db*
(mapcar #'(lambda (x) (if (string= (first x) url)
(list (first x) (sort (delete-duplicates (nconc (second x) num-list)) #'<))
x)) *thread-db*))
(setf *thread-db* (push (list url num-list) *thread-db*)))
(save-thread-db))
(defun delete-anchor-link (res-class-list)
"アンカーリンクを削除して、アンカー先をクラスのプロパティに格納する"
(loop for i in res-class-list
collect
(let ((temp (slot-value i 'text)))
(cl-ppcre:do-register-groups ($1 $2) ("(<a href=[a-zA-Z0-9\\.\\-\\/\\_\\=\" ]+>\\>\\;\\>\\;([0-9]+)<\\/a>)" temp)
(setf (slot-value i 'text) (cl-ppcre:regex-replace (cl-ppcre:quote-meta-chars $1) temp
(concatenate 'string ">>" $2)))
(push $2 (slot-value i 'ancr)))
i)))
(defun link-edit-all (text)
"すべてのリンク文字列を編集する"
(let ((temp text))
(cl-ppcre:do-register-groups ($1 $2 $3) ("((http|ttp|https|ttps|ftp)\\:\\/\\/([a-zA-Z0-9\\.\\-\\_\\/\\?\\=\\;\\&]+))" text)
(setf temp (cl-ppcre:regex-replace (cl-ppcre:quote-meta-chars $1) temp
(concatenate 'string
"<a href=\""
(cond
((string= $2 "http") "http")
((string= $2 "ttp") "http")
((string= $2 "https") "https")
((string= $2 "ttps") "https")
((string= $2 "ftp") "ftp")
(t $1))
"://" $3 "\" target=\"_blank\">"
$1 "</a>"))))
temp))
;; 前にPHPで組んだ時に使ったヤツ
;; // $pattern = '/((?:https?|ftp):\/\/[-_.!~*\'()a-zA-Z0-9;\/?:@&=+$,%#]+)/';
;; $pattern = '/((?:h?ttps?|ftp):\/\/([-_.!~*\'()a-zA-Z0-9;\/?:@&=+$,%#]+))/';
;; // 置換後の文字列
;; $replacement = '<a href="http://\2" target="_blank">\1</a>';
(defun link-edit-youtube (text)
"youtubeリンクを展開する"
(let ((temp text)
(regex "(<a[^>]+href=\"http\\:\\/\\/[a-zA-Z0-9]+\\.youtube\\.com/watch\\?v\\=([a-zA-Z0-9\\_\\-]+)[&]*[^(<>)]*\" target=\"\\_blank\">h?ttp\\:[^<]+[\\-\\_\\.!~*\\'a-zA-Z0-9;\\/?:\\@&=+\\$,%#]+<\\/a>)"))
;; (cl-ppcre:all-matches regex text)))
(cl-ppcre:do-register-groups ($1 $2) (regex text)
(setf temp (cl-ppcre:regex-replace (cl-ppcre:quote-meta-chars $1) temp
(concatenate 'string
$1 "<br />"
"<iframe width=\"480\" height=\"390\" src=\"http://www.youtube.com/embed/"
$2
"\" frameborder=\"0\" allowfullscreen></iframe><br />"))))
temp))
;; 前にPHPで組んだ時に使ったヤツ
;; $youtube_patterns = '/<a[^>]+href=\"(http\:\/\/[0-9a-zA-Z]+\.youtube\.com\/watch\?v=([0-9a-zA-Z_-]+)[^(<>)]*)\" target=\"_blank\">h?ttp:[^<]+[-_.!~*\'a-zA-Z0-9;\/?:\@&=+\$,%#]+\?v=[0-9a-zA-Z\.\/\_-]+<\/a>/i';
;; $youtube_replacements = '\0<br /><iframe width="480" height="390" src="http://www.youtube.com/embed/\2" frameborder="0" allowfullscreen></iframe><br />';
(defun link-edit-image (text)
"画像リンクを展開する"
(let ((temp text)
(regex "(<a[^>]+href=\"(http://[\\-\\_\\.!~\\*\\'a-zA-Z0-9\\;\\/\\?\\:\\@&\\=+\\$,%#]+\\.(jpg|jpeg|png|gif))\" target=\"_blank\">h?ttp[^>]+[\\-\\_\\.!~*\\'a-zA-Z0-9;\\/\\?:\\@&=+\\$,%#]+\.(jpg|jpeg|png|gif)<\/a>)"))
;; (cl-ppcre:all-matches regex text)))
(cl-ppcre:do-register-groups ($1 $2) (regex text)
(setf temp (cl-ppcre:regex-replace (cl-ppcre:quote-meta-chars $1) temp
(concatenate 'string
$1 "<br />"
"<img src=\"" $2 "\" height=200><br />"))))
temp))
;; 前にPHPで組んだ時に使ったヤツ
;; $img_patterns = "/<a[^>]+href=\"(http:\/\/[-_.!~*'a-zA-Z0-9;\/?:\@&=+\$,%#]+\.(jpg|jpeg|png|gif))\" target=\"_blank\">h?ttp[^>]+[-_.!~*'a-zA-Z0-9;\/?:\@&=+\$,%#]+\.(jpg|jpeg|png|gif)<\/a>/ims";
;; $img_replacements = '\0<br /><img src="\1" height=200><br />';
(defun link-edit (text)
"アンカー以外のリンク処理を全て行う"
(link-edit-image (link-edit-youtube (link-edit-all text))))
(defun main ()
"メイン処理を開始する"
(load-thread-db)
(start-2ch-server))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; トップページ /
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-bbslist-from-bbmenu ()
"bbsmenuから余分なHTMLを削除したリストのリストを得る。この時点ではアンカータグは残っている"
(mapcar #'(lambda (x) (cl-ppcre:split #\Linefeed x))
(remove-if #'(lambda (x) (cl-ppcre:scan "(<HTML>|</HTML>|まちＢＢＳ|ツール類|チャット|-->)" x))
(cl-ppcre:split "<BR><BR>" (http-request-jp "http://menu.2ch.net/bbsmenu.html")))))
(defun edit-bbssublist (bbslist)
"カテゴリ別のリストを受け取り、タグを削除する"
(loop for i in bbslist
collect (mapcar #'(lambda (x) (delete-tag-from-a-bbsmenu x)) i)))
(defun delete-tag-from-a-bbsmenu (text)
"BBSMENUのタグを削除する"
(cond
((cl-ppcre:scan "(<B>|</B>)" text)
(cl-ppcre:register-groups-bind (first) ("<B>(.+)</B>" text)
first))
((cl-ppcre:scan "<A HREF=http://.+\\.2ch\\.net/.+/>" text)
(cl-ppcre:register-groups-bind (url bkey name) ("<A HREF=(http://.+\\.2ch\\.net/)(.+)/>(.+)</A>" text)
(list name url bkey)))
((cl-ppcre:scan "<A HREF=http://.+\\.bbspink\\.com/.+>" text)
(cl-ppcre:register-groups-bind (url bkey name) ("<A HREF=(http://.+\\.bbspink\\.com/)(.+)/>(.+)</A>" text)
(list name url bkey)))
(t nil)))
(defun root-html ()
"トップページを生成"
(with-default-template (:title "板一覧")
(loop for category in (edit-bbssublist (get-bbslist-from-bbmenu))
for counter from 1 to 1000
do (progn
(htm
(:table :border 0 ;; :style "float:left;"
(loop for i in category
for j from 1 to 1000
do (if i
(if (not (listp i))
(htm (:tr (:td (:div :onclick (concatenate 'string
"javascript:menushow(" (princ-to-string counter) ");")
(:b (:font :color "gray" (str "■") (str i)))))))
(htm (:tr :style "display:none;"
:name (concatenate 'string "counter" (princ-to-string counter))
:id (concatenate 'string "counter_" (princ-to-string counter) "_" (princ-to-string j))
(:td (:a :href (concatenate 'string
"index?url="
(url-encode (second i))
"&bkey="
(url-encode (third i))
"&title="
(url-encode (first i)))
(str (first i)))))))))))
))))
;; トップページを作成
(define-easy-handler (top :uri "/") ()
(setf (hunchentoot:content-type*) "text/html; charset=utf-8")
(root-html))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; スレッド一覧 /index
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-thread-subject (url bkey)
"スレッド一覧を取得する"
(let ((burl (concatenate 'string url bkey "/subject.txt")))
(http-request-jp burl)))
(defun make-thread-list (text)
"取得したスレッドをリストに分解する"
(let ((var (mapcar #'(lambda (x) (cl-ppcre:split "<>" x))
(cl-ppcre:split #\LineFeed text))))
(loop for i in var
collect (cl-ppcre:register-groups-bind (title num)
("\(\^.+\)\\(\([0-9]+\)\\)$" (second i))
(list (first i) title num)))))
(defun check-already-edited (url bkey dat)
"編集済みのスレッドには■を、未編集には－をつける"
(let ((target (concatenate 'string url "test/read.cgi/" bkey "/" (cl-ppcre:regex-replace "\\.dat$" dat ""))))
(let ((result (remove-if-not #'(lambda (x) (when (string= (first x) target) x)) *thread-db*)))
(if result
"■"
"－"))))
(defun make-thread-html (list url bkey title)
"スレッド一覧を表示するHTMLを構築"
(with-default-template (:title "スレッド一覧")
(htm (:font :color "red" (str title)) :br)
(htm (:table :border 0
(loop for (dat title num) in list
do (htm (:tr
:onmouseover "this.style.background=\"#FFFACD\""
:onmouseout "this.style.background=\"#efefef\""
(htm (:td :align "right" (str num)))
(htm (:td (:a :href (concatenate 'string "edit?"
"dat=" (url-encode dat)
"&url=" (url-encode url)
"&bkey=" (url-encode bkey))
:target "_blank" (:font :size "-1" (str "編集")))))
(htm (:td (:font :color "gray" (str (check-already-edited url bkey dat)))))
(htm (:td (:font :size "-1" :color "gray" (:a :href (concatenate 'string url "test/read.cgi/" bkey "/" (cl-ppcre:regex-replace "\\.dat$" dat ""))
:target "_blank" (str "[元]")))))
(htm (:td))
(htm (:td (:a :href (concatenate 'string "view?"
"dat=" (url-encode dat)
"&url=" (url-encode url)
"&bkey=" (url-encode bkey))
:target "_blank" (str title)))))))
))))
(defun index-html (url bkey title)
"スレッド一覧を表示する。"
(make-thread-html (make-thread-list (get-thread-subject url bkey)) url bkey title))
(define-easy-handler (index :uri "/index") (url bkey title)
(setf (hunchentoot:content-type*) "text/html; charset=utf-8")
(index-html url bkey title))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; スレッドビュー /view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-thread-dat (url bkey dat)
"スレッドDATを取得する。"
(let ((burl (concatenate 'string
(url-decode url)
(url-decode bkey) "/dat/"
(url-decode dat))))
(http-request-jp burl)))
(defun make-thread-res-list (text)
"DATを分解して配列に格納する。"
(let ((i 1)
(result nil))
(loop for res in (cl-ppcre:split #\LineFeed text)
do (let ((temp (cl-ppcre:split "<>" res)))
(when (= i 1)
(push (make-instance 'res
:num 0
:ancr nil
:text (car (last temp))) result)
(push (make-instance 'res
:num i
:name (delete-html-tag (first temp))
:mail (second temp)
:date (third temp)
:text (fourth temp)
:ancr 0
:flag nil) result))
(when (not (= i 1))
(push (make-instance 'res
:num i
:name (delete-html-tag (first temp))
:mail (second temp)
:date (third temp)
:text (fourth temp)
:ancr nil
:flag nil) result))
(incf i)))
(setf result (delete-anchor-link (reverse result)))
(setf result (loop for i in result
collect (progn
(setf (slot-value i 'text) (link-edit (slot-value i 'text)))
i)))
result)
)
(defun thread-html (url bkey dat)
"スレッドを展開してHTML化"
(let ((res (make-thread-res-list (get-thread-dat url bkey dat))))
(with-default-template (:title "スレビュー")
(htm
(loop for i in res
do (cond
((= 0 (slot-value i 'num))
(htm (:a :href
(concatenate 'string url "test/read.cgi/" bkey "/" (cl-ppcre:regex-replace "\\.dat$" dat ""))
:target "_blank"
(:font :color "red" (:b (str (slot-value i 'text)))) :br :br)))
(t (progn
(htm (:hr)
(:div :id (concatenate 'string "thread" (princ-to-string (slot-value i 'num)))
:onmouseover "this.style.background=\"#FFFACD\""
:onmouseout "this.style.background=\"#efefef\""
(:dl (:dt
(htm (str (slot-value i 'num))
(:b :style "color:forestgreen;" (str (slot-value i 'name)))
(str (concatenate 'string "[" (slot-value i 'mail) "] "))
(str (slot-value i 'date)) :br))
(htm (:dd (str (slot-value i 'text))) :br :br))))))))))))
(define-easy-handler (view :uri "/view") (url bkey dat)
(setf (hunchentoot:content-type*) "text/html; charset=utf-8")
(thread-html url bkey dat))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; エディットモード /edit
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check-already-used-res (num url)
"すでに使われたレスか調べる"
(let ((result (first (remove-if-not #'(lambda (x) (when (string= (first x) url) x)) *thread-db*))))
(if result
(let ((result-num (remove-if-not #'(lambda (y) (when (= y num) y)) (second result))))
(if result-num
"<font color=\"gray\">■■ 済 ■■</font>"))
"")))
(defun edit-thread-html (url bkey dat)
"スレッドを展開してHTML化"
(start-session)
(let ((res (make-thread-res-list (get-thread-dat url bkey dat))))
(setf (slot-value (first res) 'mail) (concatenate 'string url "test/read.cgi/" bkey "/" (cl-ppcre:regex-replace "\\.dat$" dat "")))
(setf (session-value :threaddata) res)
(with-default-template (:title "スレエディット")
(htm
(:form :method "post" :action "result" :onsubmit "javascript:collectCheckbox()"
(:input :type "hidden" :id "hdnSelect" :name "hdnSelect" :value "")
(:input :type "hidden" :id "hdnStrong" :name "hdnStrong" :value "")
(:input :type "hidden" :id "hdnAA" :name "hdnAA" :value "")
(loop for i in res
do (cond
((= 0 (slot-value i 'num))
(htm (:a :href (concatenate 'string url "test/read.cgi/" bkey "/" (cl-ppcre:regex-replace "\\.dat$" dat ""))
:target "_blank"
(htm (:font :color "red" (:b (str (slot-value i 'text))))))))
(t (progn
(htm (:hr))
(htm
(htm (:a :href "javascript:void(0);"
:onclick (concatenate
'string "javascript:resDispSwitch(" (princ-to-string (slot-value i 'num)) ");")
(str "■")))
(:input :type "checkbox" :id (concatenate 'string "selectRes" (princ-to-string (slot-value i 'num)))
:name "chkA"
:value (slot-value i 'num))
(str "選択 ")
(:input :type "checkbox" :id (concatenate 'string "storongRes" (princ-to-string (slot-value i 'num)))
:name "chkB"
:value (slot-value i 'num))
(str "強調 ")
(:input :type "checkbox" :id (concatenate 'string "aaRes" (princ-to-string (slot-value i 'num)))
:name "chkC"
:value (slot-value i 'num))
(str "AA ")
(str
(check-already-used-res (slot-value i 'num)
(concatenate 'string url "test/read.cgi/" bkey "/" (cl-ppcre:regex-replace "\\.dat$" dat ""))))
(:div :style "float:right;" (:input :type "submit" :value "完了"))
(:div :id (concatenate 'string "selectdiv" (princ-to-string (slot-value i 'num)))
:onclick (concatenate
'string "javascript:selectRes(" (princ-to-string (slot-value i 'num)) ");")
(:dl :onmouseover "this.style.background=\"#FFFACD\""
:onmouseout "this.style.background=\"#efefef\""
(:dt
(htm (str (slot-value i 'num))
(:b :style "color:forestgreen;" (str (slot-value i 'name)))
(str (concatenate 'string "[" (slot-value i 'mail) "] "))
(str (slot-value i 'date)) :br))
(:div :id (concatenate 'string "thread" (princ-to-string (slot-value i 'num)))
(htm (:dd (str (slot-value i 'text)) :br :br))))))))))
)))))
(define-easy-handler (edit :uri "/edit") (url bkey dat)
(setf (hunchentoot:content-type*) "text/html; charset=utf-8")
(edit-thread-html url bkey dat))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 編集結果表示 /result
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-easy-handler (result :uri "/result") ()
(setf (hunchentoot:content-type*) "text/html; charset=utf-8")
(let ((res (session-value :threaddata))
(edited nil)
(view (cl-ppcre:split "," (post-parameter "hdnSelect")))
(strong (cl-ppcre:split "," (post-parameter "hdnStrong")))
(aa (cl-ppcre:split "," (post-parameter "hdnAA"))))
(when view
(setf edited
(loop for i in view
collect (first (subseq res (parse-integer i) (+ (parse-integer i) 1))))))
(with-default-template (:title "編集結果")
(htm
(htm (:form
(:input :type "button"
:value "選択"
:onclick "javascript:selectTextArea()")
(:input :type "button"
:value "DB書込み"
:onclick (concatenate 'string
"requestFile(\"\" , \"GET\", \"recordadd?"
"url=" (url-encode (slot-value (first res) 'mail))
"&num-list=" (url-encode (post-parameter "hdnSelect"))
"\", true )")
)
(:span :id "writeresult"))
:br)
;; ここはかなりいけてない・・・
(htm (:form :name "resultform"
(:textarea :rows "10" :cols "100" :name "resultbox"
(htm (:a :href (slot-value (first res) 'mail) :target "_blank"
(:font :color "gray" (:b (str (slot-value (first res) 'text)))) :br))
(loop for i in edited
do (htm
(:dl (:dt
(htm (str (slot-value i 'num))
(:b :style "color:forestgreen;" (str (slot-value i 'name)))
(str (concatenate 'string "[" (slot-value i 'mail) "] "))
(str (slot-value i 'date)) :br))
(htm (:dd (str (slot-value i 'text)) :br :br)))))
)) :br :br)
(htm (:a :href (slot-value (first res) 'mail) :target "_blank"
(:font :color "gray" (:b (str (slot-value (first res) 'text)))) :br))
(loop for i in edited
do (htm
(:dl (:dt
(htm (str (slot-value i 'num))
(:b :style "color:forestgreen;" (str (slot-value i 'name)))
(str (concatenate 'string "[" (slot-value i 'mail) "] "))
(str (slot-value i 'date)) :br))
(htm (:dd (str (slot-value i 'text)) :br :br)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DB書き込み /recordadd (XMLhttpRequestから呼び出している)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-easy-handler (recordadd :uri "/recordadd") ()
(setf (hunchentoot:content-type*) "text/html; charset=utf-8")
(let ((result (add-record-to-thread-db (get-parameter "url")
(mapcar #'(lambda (x) (parse-integer x)) (cl-ppcre:split "," (get-parameter "num-list"))))))
(format nil "~a" (if result
t
nil))))
js/main.js
////////////////////////////////////////
// レスを折りたたみ
//
function resDispSwitch(num)
{
var foo = document.getElementById('thread' + num);
foo.style.display =
(foo.style.display == 'none')
? 'block' : 'none';
}
////////////////////////////////////////
// 編集モードで本文をクリックしたら選択チェック
//
function selectRes(num)
{
var foo = document.getElementById('selectRes' + num);
foo.checked =
(foo.checked == true)
? false : true;
}
////////////////////////////////////////
// 板リストのメニュー折りたたみ
//
function menushow(num)
{
var elements = document.getElementsByName('counter' + num);
for (var i = 0; i < elements.length; i ++) {
elements[i].style.display =
(elements[i].style.display == 'none' )
? 'block' : 'none';
}
}
////////////////////////////////////////
// 編集モードでチェックボックスの集計を行う
//
function collectCheckbox()
{
var elementsA = document.getElementsByName('chkA');
var elementsB = document.getElementsByName('chkB');
var elementsC = document.getElementsByName('chkC');
var hdnSelect = document.getElementById('hdnSelect');
var hdnStrong = document.getElementById('hdnStrong');
var hdnAA = document.getElementById('hdnAA');
hdnSelect.value = "";
hdnStrong.value = "";
hdnAA.value = "";
for (var i = 0; i < elementsA.length; i ++) {
if (elementsA[i].checked)
hdnSelect.value = hdnSelect.value + (i+1) + ",";
if (elementsB[i].checked)
hdnStrong.value = hdnStrong.value + (i+1) + ",";
if (elementsC[i].checked)
hdnAA.value = hdnAA.value + (i+1) + ",";
}
}
////////////////////////////////////////
// 編集結果を全選択する
//
function selectTextArea()
{
document.resultform.resultbox.focus(); //テキストエリアをフォーカスする
document.resultform.resultbox.select(); //テキストエリアを全選択する
}
////////////////////////////////////////
// 編集したスレッドをajaxで記録する
// 参考：http://allabout.co.jp/gm/gc/24097/
function createHttpRequest(){
//Win ie用
if(window.ActiveXObject){
try {
//MSXML2以降用
return new ActiveXObject("Msxml2.XMLHTTP") //[1]'
} catch (e) {
try {
//旧MSXML用
return new ActiveXObject("Microsoft.XMLHTTP") //[1]'
} catch (e2) {
return null
}
}
} else if(window.XMLHttpRequest){
//Win ie以外のXMLHttpRequestオブジェクト実装ブラウザ用
return new XMLHttpRequest() //[1]'
} else {
return null
}
}
//コールバック関数 ( 受信時に実行されます )
function on_loaded(oj)
{
//レスポンスを取得
res = oj.responseText //[6]
//ダイアログで表示
element = document.getElementById("writeresult");
element.innerHTML = res;
}
function requestFile( data , method , fileName , async )
{
//XMLHttpRequestオブジェクト生成
var httpoj = createHttpRequest() //[1]
//open メソッド
httpoj.open( method , fileName , async ) //[2]
//受信時に起動するイベント
httpoj.onreadystatechange = function() //[4]
{
//readyState値は4で受信完了
if (httpoj.readyState==4) //[5]
{
//コールバック
on_loaded(httpoj)
}
}
//send メソッド
httpoj.send( data ) //[3]
}
0 件のコメント:
コメントを投稿