名前つきパイプ経由でメッセージを送れるように↓。
% echo テスト | nkf -w > /home/foo/pipe
(use gauche.net)
(use gauche.logger)
(use gauche.threads)
(use gauche.charconv)
(use file.util)
(use srfi-19)
;; ===============================================
;; setting
(define debug #f)
(define irc-server "127.0.0.1")
(define irc-server-port 6667)
(define irc-channel "#sys")
(define bot-nick "gircbot")
(define irc-client-address "127.0.0.1")
(define pipe-file "/home/foo/pipe")
(define log-dir "/home/foo/gircbot-log") ;; 事前に作っておく
(define log-encoding "utf-8")
(define pipe-encoding "utf-8")
(define irc-in-encoding "ISO2022JP")
(define irc-out-encoding "ISO2022JP")
;; ===============================================
;; util
(define (guard-read-line port)
(guard (exc
((<read-error> exc) "read error.")
(else "error."))
(read-line port))
)
;; ===============================================
;; logging
(define (make-log-path)
(build-path log-dir (date->string (current-date) "~Y-~m-~d.log"))
)
(define log-drain (make <log-drain> :path (make-log-path) :prefix "~T: "))
(define (write-log . msg)
(let1 msg1 (apply string-append msg)
(display msg1)
(newline)
(let1 path (make-log-path)
;; log rotate
(unless
(string=? path (slot-ref log-drain 'path))
(set! log-drain (make <log-drain> :path path :prefix "~T: "))
))
(log-format log-drain "~a" (ces-convert msg1 "*JP" log-encoding))))
(define (write-debug-log . msg)
(when debug
(let1 msg1 (apply string-append msg)
(write-log "[DEBUG] " msg1))))
;; ===============================================
;; irc
(define irc-socket
(make-client-socket 'inet irc-server irc-server-port))
(define irc-socket-input-port
(open-input-conversion-port
(socket-input-port irc-socket :buffering #f)
irc-in-encoding))
(define irc-socket-output-port
(open-output-conversion-port
(socket-output-port irc-socket :buffering #f)
irc-out-encoding))
(define (irc-send-body . msg)
(let1 msg1 (apply string-append msg)
(display (string-append msg1 "\r\n") irc-socket-output-port)
(flush irc-socket-output-port)))
(define (irc-send-internal . msg)
(let1 msg1 (apply string-append msg)
(write-debug-log "[SEND] " msg1)
(irc-send-body msg1)))
(define (irc-send . msg)
(let1 msg1 (apply string-append msg)
(write-log "[SEND] " msg1)
(irc-send-body msg1)))
(irc-send "NICK " bot-nick)
(irc-send "USER " bot-nick " " irc-server " " irc-client-address " " bot-nick)
(irc-send "JOIN " irc-channel)
(define (irc-reader)
(let loop ((str (string-incomplete->complete (guard-read-line irc-socket-input-port))))
(if (eof-object? str)
(begin (socket-close irc-socket))
(begin
(let ((str-list (string-split str " ")))
(cond ((string=? "PING" (list-ref str-list 0))
(write-debug-log "[PING RECEIVED]" str)
(irc-send-internal "PONG " (list-ref str-list 1)))
((and (string=? "PRIVMSG" (list-ref str-list 1))
(string=? bot-nick (list-ref str-list 2)))
(write-log (string-append "msg got from " ((#/^[^!]*!/ (list-ref str-list 0)))))
)
(else (write-log "[RECEIVED] " str)))
)
(loop (string-incomplete->complete (guard-read-line irc-socket-input-port))))
))
)
(define irc-thread (make-thread irc-reader))
;; kick
(thread-start! irc-thread)
;; ===============================================
;; named pipe
(unless (file-exists? pipe-file)
(sys-mkfifo pipe-file (+ (* 64 (+ (* 1 0) (* 2 0) (* 4 1)))
(* 8 (+ (* 1 0) (* 2 0) (* 4 1)))
(* 1 (+ (* 1 0) (* 2 1) (* 4 1))))))
(define (socket-reader)
(let loop1 ((port (open-input-file pipe-file :buffering #f :encoding pipe-encoding)))
(let loop2 ((line (guard-read-line port)))
(if (eof-object? line)
(begin
(close-input-port port)
(loop1 (open-input-file pipe-file :buffering #f :encoding pipe-encoding))
)
(begin
(irc-send "PRIVMSG " irc-channel " :" line)
(loop2 (guard-read-line port))))
))
)
;; kick
(socket-reader)面白そうなので、いろいろ試行錯誤、暗中模索。
まずは簡単そうなプラグインから。[2005-05-04 11:49:18]
プラグイン：
;; 誤 (1-1) (define-module A (export <klass-A> slt-of) (define-class <klass-A> () ((slt :accessor slt-of)))) (define-module B (use A) (export <klass-B>) (define-class <klass-B> (<klass-A>) ())) (use A) (use B) (slot-ref (setter slt-of) 'methods)
としますと、<klass-B>と<klass-A>の両方のsetter of slt-ofが得られます。ところが、ひとつめのモジュールの名前Aをアルファベット順でBより後のCにしてみますと、
;; 誤 (1-2) (define-module C (export <klass-A> slt-of) (define-class <klass-A> () ((slt :accessor slt-of)))) (define-module B (use C) (export <klass-B>) (define-class <klass-B> (<klass-A>) ())) (use C) (use B) (slot-ref (setter slt-of) 'methods)
Gauche 0.8.3では<klass-C>のsetter of slt-ofしか得られません。かなり悩みましたが、
;; 正 (1) (define-module C (export <klass-A> slt-of |setter of slt-of|) (define-class <klass-A> () ((slt :accessor slt-of)))) (define-module B (use C) (export <klass-B>) (define-class <klass-B> (<klass-A>) ())) (use C) (use B) (slot-ref (setter slt-of) 'methods)
単に|setter of slt-of|をexportしていなかっただけというオソマツな話しでした。
extendでモジュールをまとめる際にもsetterの迷子は起きるので注意しましょう > 将来の自分。
;; 誤 (2) (define-module A (export <klass-A> slt-of) (define-class <klass-A> () ((slt :accessor slt-of)))) (define-module B (extend A)) (define-module C (use B) (export <klass-C>) (define-class <klass-C> (<klass-A>) ())) (use A) (use C) (slot-ref (setter slt-of) 'methods)
|setter of slt-of|をexportすれば、期待通りに動いてくれます。[2005-04-02 21:28:39]
;; 正 (2) (define-module A (export <klass-A> slt-of |setter of slt-of|) (define-class <klass-A> () ((slt :accessor slt-of)))) (define-module B (extend A)) (define-module C (use B) (export <klass-C>) (define-class <klass-C> (<klass-A>) ())) (use A) (use C) (slot-ref (setter slt-of) 'methods)
Emacs の scheme-mode から Gauche の info にアクセスするための設定。M-x info-complete-symbol で補完、M-x info-lookup-symbol で info の検索が行なえる。適当なキーに割り当てておけば便利。scheme-mode のところを変えれば、他のモードにも対応できる。[2004-12-04 06:47:54]
ssax:xml->sxmlのように':'が入るとうまく動かないような気がします。
Open Source WEBにもっと詳しく書いたものがありました。[2005-02-09 16:00:29]
(auto-compression-mode t)
(eval-after-load
"info-look"
'(info-lookup-add-help
:topic 'symbol
:mode 'scheme-mode
:regexp "[^()'\" \n]+"
:ignore-case nil
:doc-spec '(("(gauche-refj.info)Index - 手続きと構文索引" nil
"^[ ]+-- [^:]+:[ ]*" nil)
("(gauche-refj.info)Index - モジュール索引" nil
"^[ ]+-- [^:]+:[ ]*" nil)
("(gauche-refj.info)Index - クラス索引" nil
"^[ ]+-- [^:]+:[ ]*" nil)
("(gauche-refj.info)Index - 変数索引" nil
"^[ ]+-- [^:]+:[ ]*" nil))
:parse-rule nil
:other-modes nil))Emacs をフロントエンドとして使うためのパーツ。
草稿。[2004-12-04 01:39:17]
(defvar gosh-server nil)
(defvar gosh-temp-buffer " Gosh Temp")
(defun gosh-server-live-p ()
(and gosh-server
(eq 'run (process-status gosh-server))))
(defmacro when-gosh-server-live (&rest body)
`(if (gosh-server-live-p)
(progn ,@body)
(message "Gosh: Server is dead.")))
;; gosh との通信は、非同期プロセスで pipe を用いて行なう。
;; Emacs は gosh の出力を一度にすべて受けとるとはかぎらないので、
;; いったんバッファ(gosh-temp-buffer)にためておく。
;; gosh が次の入力待ちになるタイミングを知るためにプロンプトを利用する。
;; プロンプトを出すために gosh は引数 -i で立ち上げる。
;; プロンプト "gosh> " をみつけたときに、それまでためた内容をはきだす。
;; プロンプトをみつけるために、出力はフィルタ(gosh-server-filter)を通す。
(defun gosh-server-start ()
(unless (gosh-server-live-p)
(let* ((process-connection-type nil)
(proc (start-process "gosh-server" nil "gosh" "-iq")))
(setq gosh-server proc)
(unless (buffer-live-p gosh-temp-buffer)
(get-buffer-create gosh-temp-buffer))
(catch 'gosh-done ;; dummy
(set-process-filter proc 'gosh-server-filter)
(while (gosh-server-live-p) (accept-process-output gosh-server)))
(process-kill-without-query proc nil)
(set-process-coding-system proc 'euc-jp 'euc-jp)
(set-process-buffer proc nil)
(gosh-server-setup)
(message "Gosh: Server starts."))))
(defun gosh-server-restart ()
(when (gosh-server-live-p)
(gosh-server-send '(exit)))
(gosh-server-start))
(defun gosh-server-setup ()
(gosh-server-send '(load "gauche-init"))
)
;; gosh へ S 式をおくる。この場合、#/regexp/ のような # を用いた記法が使えない。
;; このようなものが必要ならば、文字列を引数に取るようにし、その文字列を gosh に
;; おくるように改造すればよい。
;; また、返り値に #<hoge> のようなものが入っていると、Emacs 側の表現に直せない。
;; そのような場合にはエラーを出さずに、文字列として出力するようにしてある。
(defun gosh-server-send (sexp)
(save-excursion
(when-gosh-server-live
(when sexp
(process-send-string gosh-server
(concat (prin1-to-string sexp) "\n"))
(let ((value (catch 'gosh-done
(while (gosh-server-live-p)
(accept-process-output gosh-server)))))
(when (stringp value)
(cond ((string-equal value "#t") t)
((or (string-equal value "#f")
(string-equal value "#<undef>")) nil)
(t (condition-case ()
(car (read-from-string value))
(error value))))))))))
;; プロンプトとエラーを監視している。
(defun gosh-server-filter (proc out)
(set-buffer gosh-temp-buffer)
(goto-char (point-max))
(insert out)
(let ((last-line (buffer-substring (line-beginning-position)
(line-end-position)))
(last-line-point (max (- (line-beginning-position) 1)
(point-min))))
(when (string= last-line "gosh> ")
(let ((output (buffer-substring (point-min) last-line-point)))
(erase-buffer)
(save-match-data
(if (string-match "^\*\*\* ERROR: " output)
(progn
(gosh-server-error output)
(throw 'gosh-done nil))
(throw 'gosh-done output)))))))
;; エラーが出たときに、エラーメッセージを入れたバッファを表示する。
(defun gosh-server-error (error-string)
(let ((err-buf (get-buffer-create " Gosh: Server Error Log")))
(set-buffer err-buf)
(erase-buffer)
(insert error-string)
(unless (get-buffer-window err-buf)
(display-buffer err-buf))))(gosh-server-start) "Gosh: Server starts." (gosh-server-send '(+ 1 2 3 4)) 10 (gosh-server-send '(use srfi-1)) "(#<module srfi-1>)" (gosh-server-send '(iota 10)) (0 1 2 3 4 5 6 7 8 9) (gosh-server-send '(exit)) nil
dir を基準として、path までの相対パスが欲しい。[2004-11-17 16:21:08]
(use file.util)
(define (relative-path path dir)
(define (split-path path)
(let lp ((dir path)
(dirs '()))
(if (string=? dir (sys-dirname dir))
(cons dir dirs)
(lp (sys-dirname dir) (cons (sys-basename dir) dirs)))))
(let lp ((p (split-path path))
(b (split-path dir)))
(if (and (not (null? p))
(not (null? b))
(string=? (car p) (car b)))
(lp (cdr p) (cdr b))
(apply build-path
(append
(if (null? b)
'("")
(make-list (length b) ".."))
p)))))(relative-path "/home/guest/test/hoge" "/home/guest/") => "test/hoge" (relative-path "/home/guest/test/hoge" "/home/guest/hoge/foo/bar/") => "../../../test/hoge"