LISPUSER

スクリプトファイル本体．ライブラリはイメージに取り込んであります． clisp 専用なのは，cron で呼び出すスクリプティング用途がメインなのでフッ トプリントの軽い clisp のみとしてあるだけで，深い意図はありません．

#!/usr/bin/env clisp

#+clisp
(eval-when (:execute :load-toplevel) (setf *load-compiling* t))
#-clisp
(error "sorry. this script need clisp 2.35 or later.")

(defpackage :mkindex (:use :cl :indexer))
(in-package :mkindex)

(define-root (merge-pathnames "doc" (user-homedir-pathname)))

(define-category "Lisp Resources"
    :link '(("Common Lisp Hyper Spec" "./HyperSpec/Front/index.htm")
          ("Common Lisp The Language 2nd Edition" "./cltl/cltl2.html")
          ("Practical Common Lisp" "./web/www.gigamonkeys.com/book/index.html")
          ("Paul Graham" "./web/www.paulgraham.com/index.html")
          ("Dream Songs" "./web/www.dreamsongs.com/index.html")
          ("Pascal Contanza" "./web/p-cos.net/index.html")
          ("Structure and Interpretation of Computer Programms" "./web/www-mitpress.mit.edu/sicp/index.html")
          ("SICM" "web/swiss.csail.mit.edu/~gjs/6946/sicm-html/index.html")
          ))

(define-category "Other Documents"
  :link '(("PostgreSQL 8.1 (ja)" "./postgres/index.html")
        ("Statistics with R" "./web/zoonek2.free.fr/UNIX/48_R/all.html")
        ("Perl and Shift_JIS" "http://homepage1.nifty.com/nomenclator/perl/index.htm")
        ("Perl Hints" "http://www.geocities.co.jp/SiliconValley-Oakland/4080/")
        ("Perl and Unicode" "http://www.lr.pi.titech.ac.jp/~abekawa/perl/index.html")
        ))

(define-category "Maxima Documents"
    :pred (filter :directory "lisp" :filetype "pdf"))

(define-category "PDF Documents"
    :pred (filter :directory "ebook" :filetype "pdf"))

(define-category "CHM Documents"
    :pred (filter :directory "ebook" :filetype "chm"))

(generate-index)

ドキュメント数が増えてきたので JavaScript でソート機能をつけました．

#!/usr/bin/env clisp

#+clisp
(eval-when (:execute :load-toplevel) (setf *load-compiling* t))
#-clisp
(error "sorry. this script need clisp 2.35 or later.")

(defpackage :indexer (:use :cl :cl-who :fad :json)
  (:export #:define-root #:define-category #:generate-index #:filter))
(in-package :indexer)

(defclass <node> ()
  ((name :accessor name-of :initarg :name :initform nil)
   (path :accessor path-of :initarg :path)))

(defclass <file-node> (<node>) ())
(defclass <uri-node> (<node>) ())

(defclass <category> ()
  ((name  :accessor name-of  :initarg :name  :initform nil)
   (nodes :accessor nodes-of :initarg :nodes :initform nil)
   (pred  :accessor pred-of  :initarg :pred  :initform nil)))

(defparameter *categories* nil)
(defparameter *nodes* nil)
(defparameter *root* nil)

(defmethod make-instance :around ((class (eql '<node>)) &rest initargs &key name path &allow-other-keys)
  "指定されたパスが URI スキーマか，ファイルパスかで実際に生成するクラスの型を替える"
  (declare (ignorable initargs))
  (cond ((and (stringp path) (search "://" path))
       (make-instance '<uri-node> :name name :path path))
      (t
       (make-instance '<file-node> :name name :path (merge-pathnames path *root*)))))

(defmethod href-of ((self <file-node>))
  "ハイパーリンク用の文字列を構築する"
  (format nil "./~A" 
        (cl-who:escape-string-minimal-plus-quotes
         (subseq (format nil "~A" (path-of self)) (length (format nil "~A" *root*))))))

(defmethod href-of ((self <node>))
  "ハイパーリンク用の文字列を構築する"
  (format nil "~A" 
        (cl-who:escape-string-minimal-plus-quotes
         (subseq (format nil "~A" (path-of self)) (length (format nil "~A" *root*))))))

(defmethod title-of ((self <node>))
  (or (name-of self) (pathname-name (path-of self))))

(defmethod mtime-of ((self <file-node>))
  "ファイルノードは mtime を表示する"
  ;; (format *error-output* "path: ~A~%" (path-of self))
  (multiple-value-bind (sec min hour day month year _ _ _)
      (decode-universal-time (ext:file-stat-mtime (ext:file-stat (path-of self))))
    (declare (ignorable _))
    (format nil "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day hour min sec)))

(defmethod mtime-of ((self <node>))
  "ファイル以外のノードは時間を持たない"
  "none")

(defmethod render-nodes (name lst stream)
  "ノードを表示する"
  (format stream "contents[~S] = " name)
  (json:encode-json
   (mapcar #'(lambda (self)
             (let ((h (make-hash-table)))
               (setf (gethash "title" h) (title-of self)
                     (gethash "link" h) (href-of self)
                     (gethash "time" h) (mtime-of self))
               h))
         lst)
   stream)
  (write-line ";" stream))

(defmethod render ((self <category>) stream)
  "カテゴリを表示する"
  (cl-who:with-html-output (s stream :indent t)
    (:div
     (:script (render-nodes (name-of self) (nodes-of self) s))
     (:h2 (str (name-of self)))
     (:table :id (name-of self) :width "100%" :align "center"
       (:tr
      (:th :width "80%" :onclick "by_name(this)" "Title") (:th :onclick "by_date(this)" "Date"))))))

(defmethod sort-nodes ((self <category>))
  (let ((nodes (sort (nodes-of self)
                   #'string-lessp
                   :key #'(lambda (node)
                            (pathname-name (path-of node))))))
    (setf (nodes-of self) nodes)))

(defun define-root (root)
  "ルート項目のパスを設定する"
  (setf *root* (fad:pathname-as-directory root)))

(defun define-category (name &key link pred)
  ;; (assert (or link pred) "must be specified :link or :pred")
  (flet ((link->node (link)
         (loop for l in link
                 collect (make-instance '<node>
                                      :name (first l)
                                      :path (second l)))))
    (let ((category
         (cond (pred  (make-instance '<category> :name name :pred pred))
               (link  (make-instance '<category> :name name :nodes (link->node link))))))
      (pushnew category *categories*))))

(defun register-node (path)
  (let ((node (make-instance '<node> :path path)))
    (push node *nodes*)
    (dolist (category *categories*)
      (when (and (pred-of category) (funcall (pred-of category) path))
      (pushnew node (nodes-of category))))))

(defun generate-index ()
  (fad:walk-directory *root* #'register-node)
  (loop for category in (reverse *categories*) do (sort-nodes category))
  (with-open-file (css (merge-pathnames "pdms.css" *root*) :direction :output :if-exists :supersede)
    (write-line "h1 { border: gray 3px solid; background: #D0D0D0; padding: 5px; text-align: center; }" css)
    (write-line "h2 { border-bottom: black 1px solid }" css)
    (write-line "div#footer { border-top: black 1px solid; border-bottom: black 1px solid; }" css)
    (write-line "div#footer p { text-align: right; }" css))
  (with-open-file (index (merge-pathnames "index.html" *root*) :direction :output :if-exists :supersede)
    (cl-who:with-html-output (s index :prologue t :indent t)
      (:html
       (:head
      (:title "PDMS - Personal Documents Management System")
      (:link :rel "stylesheet" :href "pdms.css" :type "text/css")
      (:script :language "JavaScript" "
    var contents = Object();
    function build (name) {
        var data   = contents[name];
        var table  = document.all(name);
        var tbody  = table.firstChild;
        var header = table.rows[0];

        for (var i = 0; i < data.length; i++) {
            var d = data[i];
            row = tbody.insertRow();
            for (var j=0; j < header.cells.length; j++) {
                var txt  = header.cells[j].innerText
                var cell = row.insertCell();
                if (/^Title/.test(txt)) {
                    cell.innerHTML = '<a href=\"'+d['link']+'\">'+d['title']+'</a>';
                } else {
                    cell.innerText = d['time'];
                }
            }
        }
    }
    function by_name (obj) {
        var check = function (table) {
            var compare;
            if (table.sort_by_name) {
               table.sort_by_name = false;
               compare = function (a, b) { return (a.title == b.title) ? 0 : (a.title > b.title) ? 1 : -1; }
            } else {
               table.sort_by_name = true;
               compare = function (a, b) { return (a.title == b.title) ? 0 : (a.title < b.title) ? 1 : -1; }
            }
            return compare;
        }
        sort_table(obj, check);
    }
    function by_date (obj) {
        var check = function (table) {
            var compare;
            if (table.sort_by_date) {
               table.sort_by_date = false;
               compare = function (a, b) { return (a.time == b.time) ? 0 : (a.time > b.time) ? 1 : -1; }
            } else {
               table.sort_by_date = true;
               compare = function (a, b) { return (a.time == b.time) ? 0 : (a.time < b.time) ? 1 : -1; }
            }
            return compare;
        }
        sort_table(obj, check);
    }
    function sort_table (obj, check) {
        var table  = obj;
        for (; table.tagName != 'TABLE'; table = table.parentNode)
               ;
        var tbody  = table.firstChild;
        var header = table.rows[0];
        var data   = contents[table.id];
        var comp   = check(table);
        data = data.sort(comp);

        for (var i = 1; i < table.rows.length; i++) {
            var d   = data[i-1];
            var row = table.rows[i].cell;
            for (var j=0; j < header.cells.length; j++) {
                var txt  = header.cells[j].innerText;
                var cell = table.rows[i].cells[j];
                if (/^Title/.test(txt)) {
                    cell.innerHTML = '<a href=\"'+d['link']+'\">'+i+'. '+d['title']+'</a>';
                } else {
                    cell.innerText = d['time'];
                }
            }
        }     
    }
    function init () { for (name in contents) { build(name); }}
"))
       (:body :onLoad "init();"
      (:div :id "header"
            (:h1 "PDMS - Personal Documents Management System"))
      (:div :id "contents"
            (loop for category in (reverse *categories*) do (render category s)))
      (:div :id "footer"
            (:p "Powered by LISP")))))))

(defun filter (&key directory filetype (test #'string-equal))
  (lambda (p)
    (and (find directory (pathname-directory p) :test test)
       (funcall test filetype (pathname-type p)))))

#!/usr/bin/env clisp

#+clisp
(eval-when (:execute :load-toplevel) (setf *load-compiling* t))
#-clisp
(error "sorry. this script need clisp 2.35 or later.")

(defpackage :indexer (:use :cl :cl-who :fad)
  (:export #:define-root #:define-category #:generate-index #:filter))
(in-package :indexer)

(defclass <node> ()
  ((name :accessor name-of :initarg :name :initform nil)
   (path :accessor path-of :initarg :path)))

(defclass <file-node> (<node>) ())
(defclass <uri-node> (<node>) ())

(defclass <category> ()
  ((name  :accessor name-of  :initarg :name  :initform nil)
   (nodes :accessor nodes-of :initarg :nodes :initform nil)
   (pred  :accessor pred-of  :initarg :pred  :initform nil)))

(defparameter *categories* nil)
(defparameter *nodes* nil)
(defparameter *root* nil)

(defmethod make-instance :around ((class (eql '<node>)) &rest initargs &key name path &allow-other-keys)
  "指定されたパスが URI スキーマか，ファイルパスかで実際に生成するクラスの型を替える"
  (declare (ignorable initargs))
  (cond ((and (stringp path) (search "://" path))
       (make-instance '<uri-node> :name name :path path))
      (t
       (make-instance '<file-node> :name name :path (merge-pathnames path *root*)))))

(defmethod href-of ((self <file-node>))
  "ハイパーリンク用の文字列を構築する"
  (format nil "./~A" 
        (cl-who:escape-string-minimal-plus-quotes
         (subseq (format nil "~A" (path-of self)) (length (format nil "~A" *root*))))))

(defmethod href-of ((self <node>))
  "ハイパーリンク用の文字列を構築する"
  (format nil "~A" 
        (cl-who:escape-string-minimal-plus-quotes
         (subseq (format nil "~A" (path-of self)) (length (format nil "~A" *root*))))))

(defmethod title-of ((self <node>))
  (or (name-of self) (pathname-name (path-of self))))

(defmethod mtime-of ((self <file-node>))
  "ファイルノードは mtime を表示する"
  ;; (format *error-output* "path: ~A~%" (path-of self))
  (multiple-value-bind (sec min hour day month year _ _ _)
      (decode-universal-time (ext:file-stat-mtime (ext:file-stat (path-of self))))
    (declare (ignorable _))
    (format nil " - ~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D" year month day hour min sec)))

(defmethod mtime-of ((self <node>))
  "ファイル以外のノードは時間を持たない"
  " - now")

(defmethod render ((self <node>) stream)
  "ノードを表示する"
  (cl-who:with-html-output (s stream :indent t)
    (:li
     (:a :href (href-of self) (str (title-of self)))
     (:small (str (mtime-of self))))))

(defmethod render ((self <category>) stream)
  "カテゴリを表示する"
  (cl-who:with-html-output (s stream :indent t)
    (:div :id (name-of self)
      (:h2 :name (name-of self) :id (name-of self) (str (name-of self)))
      (:ol
       (loop for node in (nodes-of self) do (render node s))))))

(defmethod sort-nodes ((self <category>))
  (let ((nodes (sort (nodes-of self)
                   #'string-lessp
                   :key #'(lambda (node)
                            (pathname-name (path-of node))))))
    (setf (nodes-of self) nodes)))

(defun define-root (root)
  "ルート項目のパスを設定する"
  (setf *root* (fad:pathname-as-directory root)))

(defun define-category (name &key link pred)
  ;; (assert (or link pred) "must be specified :link or :pred")
  (flet ((link->node (link)
         (loop for l in link
                 collect (make-instance '<node>
                                      :name (first l)
                                      :path (second l)))))
    (let ((category
         (cond (pred  (make-instance '<category> :name name :pred pred))
               (link  (make-instance '<category> :name name :nodes (link->node link))))))
      (pushnew category *categories*))))

(defun register-node (path)
  (let ((node (make-instance '<node> :path path)))
    (push node *nodes*)
    (dolist (category *categories*)
      (when (and (pred-of category) (funcall (pred-of category) path))
      (pushnew node (nodes-of category))))))

(defun generate-index ()
  (fad:walk-directory *root* #'register-node)
  (loop for category in (reverse *categories*) do (sort-nodes category))
  (with-open-file (css (merge-pathnames "pdms.css" *root*) :direction :output :if-exists :supersede)
    (write-line "h1 { border: gray 3px solid; background: #D0D0D0; padding: 5px; text-align: center; }" css)
    (write-line "h2 { border-bottom: black 1px solid }" css)
    (write-line "div#footer { border-top: black 1px solid; border-bottom: black 1px solid; }" css)
    (write-line "div#footer p { text-align: right; }" css))
  (with-open-file (index (merge-pathnames "index.html" *root*) :direction :output :if-exists :supersede)
    (cl-who:with-html-output (s index :prologue t :indent t)
      (:html
       (:head
      (:title "PDMS - Personal Documents Management System")
      (:link :rel "stylesheet" :href "pdms.css" :type "text/css"))
       (:body
      (:div :id "header"
            (:h1 "PDMS - Personal Documents Management System"))
      (:div :id "contents"
            (loop for category in (reverse *categories*) do (render category s)))
      (:div :id "footer"
            (:p "Copyright (&copy;) Masayuki Onjo")))))))

(defun filter (&key directory filetype (test #'string-equal))
  (lambda (p)
    (and (find directory (pathname-directory p) :test test)
       (funcall test filetype (pathname-type p)))))

$Last Update: 2006/08/20 3:16:22 $