2011年5月31日火曜日

Hunchentoot で2chブラウザ その3


このエントリーをはてなブックマークに追加


相変わらず試行錯誤しています。いくつか機能追加してみました。

・スレッド編集(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>|まちBBS|ツール類|チャット|-->)" 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 件のコメント:

コメントを投稿