Common Lisp – 小物プログラム

はじめに

はじめに

日常的に使っている小物 Lisp プログラムを紹介します．

CVS や Subversion や darcs の更新

まぁ，shell でかけば一瞬ですが．

for i in `find . -name "_darcs"; do (cd $i/..; darcs pull); done

とかと同等なんですがね…．最近は Subversion リポジトリで公開されているものは svk でローカルにミラーしていじってます．

#!/usr/bin/env clisp

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

(defpackage :script.vc-auto-update (:use :cl :fad))
(in-package :script.vc-auto-update)

(defparameter *dirs* '(#p"~/lisp" #p"~/local/darcs" #p"~/local/site-lisp"))
(defparameter *hold* '(;; obsolete
                       "odcl" "imho" "uncommonsql" "uncommonxml"
                       "osicat"
                       ;; hold
                       "maxima" "lispuser" "blog"))

(defun check (path)
  (let ((name (car (last (pathname-directory path)))))
    (loop for e in *hold*
          never (string= e name))))

(defun guess-vc-type (path)
  (cond ((fad:directory-exists-p (merge-pathnames "CVS/" path))
         :cvs)
        ((fad:directory-exists-p (merge-pathnames ".svn/" path))
         :svn)
        ((fad:directory-exists-p (merge-pathnames "_darcs/" path))
         :darcs)))

(defun auto-update-p (path)
  (guess-vc-type path))
  
(defun auto-update (path &key (dry-run nil))
  (format *standard-output* "update: ~A~%" path)
  (let ((type (guess-vc-type path)))
    (ext:cd path)
    (multiple-value-bind (cmd args)
        (case type
          (:cvs
            (values "cvs" '("-z9" "update" "-dP")))
          (:svn
            (values "svn" '("update")))
          (:darcs
            (values "darcs" '("pull"))))
      (format *standard-output* " => ~A: ~A, ~A~%" type cmd args)
      (unless dry-run
        (ext:run-program cmd :arguments args)))))

(defun walk-vc-directory (path fn &key test)
  (cond ((funcall test path)
         (when (check path) (funcall fn path)))
        (t
         (dolist (e (fad:list-directory path))
           (when (fad:directory-pathname-p e)
             (walk-vc-directory e fn :test test))))))

(defun main (*args*)
  (let ((fn (cond ((find "print" *args* :test #'string=)
                   (lambda (path) (auto-update path :dry-run t)))
                  (t
                   (lambda (path) (auto-update path))))))
    (dolist (d *dirs*)
      (walk-vc-directory d fn :test #'auto-update-p))))
  
(main ext:*args*)

PDF へ書き込み

CL-PDF には PDF 生成機能のほかに pdf-parser がついており，PDF ファイルに書き込みができます．

;; 最小の例
(pdf:with-existing-document (#P"/tmp/original.pdf")
  (pdf:with-existing-page (0) ;; 最初のページ
    (let ((font (pdf:get-font "Helvetica")))
      (pdf:insert-original-page-content)
      (pdf:set-font font 16.0) ;; サイズ指定
      (pdf:move-text 100 100)  ;; 位置指定
      (pdf:draw-text "Comment Text")))
  (pdf:write-document #P"/tmp/modified.pdf"))

これは，たとえばコメント文字列をあとで PDF に反映したり，オーダーフォームに書き込んだりと時々役に立ちます．↓の URL にページ番号を振る例があります．

http://foldr.org/~michaelw/log/programming/lisp/add-pdf-page-numbers

ドキュメント目録 HTML 作成

ローカルに置いてあるドキュメントのインデックス HTML 作成用．

mkindex.lisp

スクリプトファイル本体．ライブラリはイメージに取り込んであります． 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)

indexer.lisp

ドキュメント数が増えてきたので 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)))))

indexer.lisp (旧バージョン)

#!/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 $

LISPUSER

Table of Contents