窓使いの憂鬱 Linux 対応版 を使っているのだけど、少々 Stumpwm と合相が悪い。電源ボタン等を押すと Stumpwm が落ちたりする。
いろいろといい機会なので SBCL で窓使いの憂鬱みたいなのを作ってみることにした。
sb-alien と cffi の両方を使ってしまっているけど、どちらかに統一したい。むしろ IOLib を使うこと検討すべきかも。なるべくライブラリを使わない方向がいいようにも思う。
root 権限が必要なため sudo sbcl したものに M-x slime-connect して開発している。 root 権限の sbcl に接続するのは、Stumpwm を走らせている sbcl に接続する以上に、落ち着かない。 sudo しなくてすむ方法がないものだろうか。
キーのリマップと SandS は実装した。あとは config.lisp に自分用の Dvorak 改の設定を書けば、何とか使えそうだ。
Climacs の find-file で次の対応。
C-i は 2 回連続で押さないと補完してくれない。なぜだろう？
そろそろ Emacs を卒業して、Common Lisp の世界で生活したい。
;;; -*- mode: lisp; indent-tabs: nil -*-
;;; (require :info.read-eval-print.climacs.ext)
(in-package :info.read-eval-print.climacs.ext)
(defun test ()
(format t "Hello World from new project info.read-eval-print.climacs.ext~%"))
(in-package :clim-internals)
(defun ext%normalize-so-far (so-far)
(reduce (lambda (acc x)
(ppcre:regex-replace (car x) acc (cadr x)))
`((".*//" "/") (".*/~/" ,(namestring (user-homedir-pathname))))
:initial-value so-far))
(assert (string= (ext%normalize-so-far "/tmp//a") "/a"))
(assert (string= (ext%normalize-so-far "/tmp/~/a") (q:str (namestring (user-homedir-pathname)) "a")))
(defun filename-completer (so-far mode)
(let* ((so-far (ext%normalize-so-far so-far))
(directory-prefix
(if (eq :absolute (car (pathname-directory (pathname so-far))))
""
(namestring #+sbcl *default-pathname-defaults*
#+cmu (ext:default-directory)
#-(or sbcl cmu) *default-pathname-defaults*)))
(full-so-far (concatenate 'string directory-prefix so-far))
(pathnames
(loop with length = (length full-so-far)
and wildcard = (format nil "~A*.*"
(loop for start = 0 ; Replace * -> \*
for occurence = (position #\* so-far :start start)
until (= start (length so-far))
until (null occurence)
do (replace so-far "\\*" :start1 occurence)
(setf start (+ occurence 2))
finally (return so-far)))
for path in
#+(or sbcl cmu lispworks) (directory wildcard)
#+openmcl (directory wildcard :directories t)
#+allegro (directory wildcard :directories-are-files nil)
#+cormanlisp (nconc (directory wildcard)
(cl::directory-subdirs dirname))
#-(or sbcl cmu lispworks openmcl allegro cormanlisp)
(directory wildcard)
when (let ((mismatch (mismatch (namestring path) full-so-far)))
(q:p path full-so-far mismatch)
(or (null mismatch) (= mismatch length)))
collect path))
(strings (mapcar #'namestring pathnames))
(first-string (car strings))
(length-common-prefix nil)
(completed-string nil)
(full-completed-string nil)
(input-is-directory-p (when (plusp (length so-far))
(char= (aref so-far (1- (length so-far))) #\/))))
(unless (null pathnames)
(setf length-common-prefix
(loop with length = (length first-string)
for string in (cdr strings)
do (setf length (min length (or (mismatch string first-string) length)))
finally (return length))))
(unless (null pathnames)
(setf completed-string
(subseq first-string (length directory-prefix)
(if (null (cdr pathnames)) nil length-common-prefix)))
(setf full-completed-string
(concatenate 'string directory-prefix completed-string)))
(case mode
((:complete-limited :complete-maximal)
(cond ((null pathnames)
(values so-far nil nil 0 nil))
((null (cdr pathnames))
(values completed-string (plusp (length so-far)) (car pathnames) 1 nil))
(input-is-directory-p
(values completed-string t (parse-namestring so-far) (length pathnames) nil))
(t
(values completed-string nil nil (length pathnames) nil))))
(:complete
;; This is reached when input is activated, if we did
;; completion, that would mean that an input of "foo" would
;; be expanded to "foobar" if "foobar" exists, even if the
;; user actually *wants* the "foo" pathname (to create the
;; file, for example).
(values so-far t so-far 1 nil))
(:possibilities
(values nil nil nil (length pathnames)
(loop with length = (length directory-prefix)
for name in pathnames
collect (list (subseq (namestring name) length nil)
name)))))))
(in-package :info.read-eval-print.climacs.ext)
;; C-i でも補完
(progn
(clim:define-gesture-name :complete :keyboard (:tab))
(clim:define-gesture-name :complete :keyboard (#\i :control) :unique nil))
Quicklisp を使う。
まだベータ http://www.quicklisp.org/beta/
http://beta.quicklisp.org/quicklisp.lisp からダウンロードする。
ダウンロードした quicklisp.lisp を Emacs で開く。
C-c C-l で quicklisp.lisp をロードする。
To continue, evaluate: (quicklisp-quickstart:install)
と repl に表示されるので、そのとおり実行する。
続いて (ql:add-to-init-file) を実行すると、~/.sbclrc に次のコードが追加される。
;;; The following lines added by ql:add-to-init-file:
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
これで Quicklisp にインストールと設定は完了。
次の SLIME 関係。
(ql:quickload "quicklisp-slime-helper") を実行するの次のように表示されるので、追加しておく。
To use, add this to your ~/.emacs:
(load (expand-file-name "~/quicklisp/slime-helper.el"))
以上、全て完了。
アップデートは次のとおり。
;; インストールしたものをアップデートする。
(ql:update-all-dists)
;; Quicklisp のアップデートする。
(ql:update-client)
自前のライブラリは Quicklisp 的にどうするのがいいんでしょう。とりあえず、いままでどおり ~/.sbclrc で asdf:*central-registry* に pushnew することにした。
Quicklisp 導入後の ~/.sbclrc はこんなのになった。
;;;;; -*-lisp-*-
;;デバッグ用セッティング
(declaim (optimize (debug 3) (safety 3) (compilation-speed 3)))
;;(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0) (compilation-speed 0)))
;;; The following lines added by ql:add-to-init-file:
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(require :asdf)
;; fasl のバージョンが古い場合リコンパイルする
(defmethod asdf:perform :around ((o asdf:load-op) (c asdf:cl-source-file))
(handler-case (call-next-method o c)
(#+sbcl sb-ext:invalid-fasl
#+allegro excl::file-incompatible-fasl-error
#+lispworks conditions:fasl-error
#+cmu ext:invalid-fasl
#-(or sbcl allegro lispworks cmu) error ()
(asdf:perform (make-instance 'asdf:compile-op) c)
(call-next-method))))
;; ;; clbuild
;; (pushnew (translate-logical-pathname "home:clbuild;systems;")
;; asdf:*central-registry*)
;; ~/letter/lib 以下の asd を登録する。
(flet ((f (path)
(loop for path in (directory path)
do (let ((pd (pathname-directory path)))
(unless (member "_darcs" pd :test #'equal)
(pushnew (make-pathname :directory pd)
asdf:*central-registry*
:test #'equal))))))
(f "~/letter/lisp/lib/**/*.asd")
(f "~/letter/lisp/craft/**/*.asd"))
;; iko-yo
(pushnew "~/job/actindi/ikoyo/iko-yo-tool/" asdf:*central-registry*)
(defun climacs ()
"Climacs を起動する。"
(load (merge-pathnames ".climacs.lisp" (user-homedir-pathname))))
(defun maxima ()
"Maxima を起動する。"
(let ((*default-pathname-defaults*
(translate-logical-pathname "home:clbuild;source;maxima;src;")))
(load "maxima-build.lisp")
(maxima-load)
(cl-user::run)))
(require :swank)
(ql:quickload "series")
(series::install :implicit-map t)
(require :info.read-eval-print.repl-tw)
#+http\://informatimago.com/develop/lisp/index.html
(progn
(defparameter *informatimago-base* "~/letter/lisp/lib/com/informatimago/")
(mapc (lambda (p) (pushnew (make-pathname :name nil :type nil :version nil :defaults p)
asdf:*central-registry* :test #'equal))
(directory (merge-pathnames "**/*.asd" *informatimago-base* nil)))
(asdf:oos 'asdf:load-op :com.informatimago.common-lisp))
ついでに ~/.emacs の SLIM 関係はこう。
;;;;; quicklisp-slime-helper
(load (expand-file-name "~/quicklisp/slime-helper.el"))
;;;;;SLIME
(setq common-lisp-hyperspec-root "file:/usr/share/doc/hyperspec/")
;;(setq slime-communication-style :fd-handler)
;;(setq slime-communication-style :spawn)
;;(setq slime-communication-style :sigio)
(setq slime-net-coding-system 'utf-8-unix)
(setq slime-lisp-implementations
`((sbcl ("sbcl") :coding-system utf-8-unix)
(ccl ("/home/ancient/local/opt/ccl/lx86cl64")
:coding-system utf-8-unix)
;; (ccl ("/home/ancient/letter/lisp/clbuild/clbuild"
;; "--implementation" "ccl" "lisp")
;; :coding-system utf-8-unix)
(deb-sbcl ("/usr/bin/sbcl") :coding-system utf-8-unix)
(clisp ("/home/ancient/letter/lisp/clbuild/clbuild"
"--implementation" "clisp" "lisp")
:coding-system utf-8-unix)
(abcl ("my-abcl")
:coding-system utf-8-unix)
(acl ("/home/ancient/local/opt/acl82express/alisp")
:coding-system utf-8-unix)
(cmucl ("lisp"))))
;;(add-hook 'lisp-mode-hook
;; (lambda ()
;; (cond ((not (featurep 'slime))
;; (require 'slime)
;; (normal-mode)))))
(setq slime-truncate-lines nil)
(setq slime-enable-evaluate-in-emacs t)
(defun my-slime-complete-form ()
(interactive)
(condition-case nil
(slime-complete-form)
(error
(save-excursion
(insert
(multiple-value-bind (ops arg-indices points)
(slime-enclosing-form-specs)
(run-hook-with-args 'slime-autodoc-hook ops arg-indices points)
(multiple-value-bind (cache-key retrieve-form)
(slime-compute-autodoc-rpc-form ops arg-indices points)
(slime-eval retrieve-form))))))))
(add-to-list 'auto-mode-alist '("\\.asd$" . common-lisp-mode))
;;(add-path "~/letter/lisp/clbuild/source/slime")
;;(add-path "~/letter/lisp/clbuild/source/slime/contrib")
(eval-after-load "slime"
'(progn
(slime-setup '(slime-repl
slime-asdf
slime-fancy
slime-indentation
slime-references
slime-tramp
slime-banner))
(setq slime-complete-symbol*-fancy t)
(setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)
(setq slime-autodoc-use-multiline-p t)
(global-set-key [(control ?\;)] 'slime-selector)
(loop for (key command) in
'(([(control ?c) ?\;] slime-insert-balanced-comments)
([(control ?u) (control ?c) ?\;] slime-remove-balanced-comments)
([(control ?c) ?\;] slime-insert-balanced-comments)
("\C-j" slime-que-print-last-expression)
("\C-m" newline-and-indent)
("\C-u" universal-argument)
("\C-i" slime-indent-and-complete-symbol))
do (define-key slime-mode-map key command))
(setq lisp-indent-function 'cl-indent:function)
;; Series のためのインデント
(define-cl-indent '(mapping ((&whole 4 &rest (&whole 1 1 2)) &body)))
(define-cl-indent '(iterate ((&whole 4 &rest (&whole 1 1 2)) &body)))
(define-cl-indent '(producing ((&whole 4 &rest (&whole 1 1 2)) &body)))
;; defpackage も調整
(define-cl-indent '(defpackage (4 2)))
;; tramp
;;(push (slime-create-filename-translator :machine-instance "li31-15"
;; :remote-host "li31-15.members.linode.com"
;; :username "ancient")
;; slime-filename-translations)
(progn
(defun slime-que-print-last-expression (string)
"Evaluate sexp before point; print value into the current buffer"
(interactive (list (slime-last-expression)))
(slime-eval-async `(swank:eval-and-grab-output ,string)
(lambda (result)
(destructuring-bind (output value) result
(push-mark)
(or (bolp) (insert "\n"))
(let ((output-p (if (string= "" output) "" ";;-> ")))
(insert (concat output-p
(if (<= 5 (length output))
(substring (replace-regexp-in-string "^" ";; " output) 5)
output)))
(and output-p (or (bolp) (insert "\n")))
(insert (concat ";;=> " (if (<= 5 (length value))
(substring (replace-regexp-in-string "^" ";; " value) 5)
value))
"\n")))))))
;; g000001 さん作
(progn
(defun gcode-lookup ()
"カーソル位置のシンボルを Google Code で検索 (lisp 決め打ち)"
(interactive)
(browse-url
(format "http://www.google.com/codesearch?q=%s+lang:%s+file:\\.%s$&hl=ja&num=20"
(thing-at-point 'symbol) "lisp" "lisp")))
(define-key slime-mode-map
[(control ?c) (control ?d) ?g] 'gcode-lookup))))
(require 'slime-autoloads)
Quicklisp すごいな。登録されているプロジェクト数がもう 430 を越えてる。全部 REPL から操作できるのもすばらしい。
ありがとうございます。
~/.tc
;;; -*-emacs-lisp-*- This file is automatically created
(setq tcode-data-directory (expand-file-name "~/.tcode/"))
(setq tcode-site-data-directory tcode-data-directory)
(setq tcode-default-input-method "japanese-T-Code")
;; 前置型交ぜ書き
;; (setq tcode-use-prefix-mazegaki t)
;; ○句読点等の切り替え
;; 標準よりも組み合わせを増やし、かつ「(」や「)」も切り替えるようにする。
(defvar tcode-left-paren "（" "* 開き括弧")
(make-variable-buffer-local 'tcode-left-paren)
(defvar tcode-right-paren "）" "* 閉じ括弧")
(make-variable-buffer-local 'tcode-right-paren)
(setq tcode-switch-table-list
'(;; 全角系 デフォールト
((tcode-touten . "、")
(tcode-kuten . "。")
(tcode-left-paren . "（")
(tcode-right-paren . "）"))
;; 半角系
((tcode-touten . ", ")
(tcode-kuten . ". ")
(tcode-left-paren . "(")
(tcode-right-paren . ")"))
;; 2バイト系
((tcode-touten . "，")
(tcode-kuten . "．")
(tcode-left-paren . "（")
(tcode-right-paren . "）"))))
;;; ○句読点の自動切り替え
;; 切り替えの規準(正規表現)の指定
(setq tcode-kutouten-regexp-alist
(list '("[、。]" . 1)
(if (tcode-nemacs-p)
'("\\z[,.]" . 2)
'("\\cj[,.]" . 2))
'("[，．]" . 3)))
;; 切り替える主モードを指定(text-mode latex-mode)
(setq tcode-auto-identify-kutouten-mode-list
'(text-mode latex-mode hnf-mode))
;; バッファで最初に Tコードモードに入ったときに、
;; 句読点を自動的に切り替える。
(add-hook 'tcode-mode-hook 'tcode-auto-switch-kutouten)
;; EELLL でイメージを使わない。
(setq eelll-use-image nil)
;; ヘルプ用のウィンドウの大きさを自動的に調整する。
(setq tcode-adjust-window-for-help t)
;; isearch-printing-char: Symbol's function definition is void: isearch-last-command-char 対策
;; tc-sysdep.el の L231
(if (string-match "^\\(19\\|2[0123]\\)" emacs-version)
(progn
(defun tcode-redo-command (ch)
"キー CH を現在のキーマップで再実行する"
(setq unread-command-events
(cons (character-to-event ch) unread-command-events)))
(or (fboundp 'character-to-event)
(defun character-to-event (ch)
ch))
;; XEmacs
(or (fboundp 'isearch-last-command-char)
(defun isearch-last-command-char ()
last-command-char))
(or (boundp 'search-upper-case)
(setq search-upper-case 'not-yanks)))
;; NEmacs
(defun tcode-redo-command (ch)
"キー CH を現在のキーマップで再実行する"
(setq unread-command-char ch)))
;; キーボードのカスタマイズ
(setq tcode-key-layout-list
'(("quek" . (?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0
?' ?( ?) ?p ?y ?f ?g ?c ?r ?l
?a ?o ?e ?u ?i ?d ?h ?t ?n ?s
?\; ?q ?j ?k ?x ?b ?m ?w ?v ?z
?! ?\@ ?# ?$ ?% ?^ ?& ?* ?< ?>
?\" ?, ?. ?P ?Y ?F ?G ?C ?R ?L
?A ?O ?E ?U ?I ?D ?H ?T ?N ?S
?L ?Q ?J ?K ?X ?B ?M ?W ?V ?Z
))))
(add-hook
'tcode-ready-hook
(lambda ()
(set-tcode-mode-key
"/" 'tcode-insert-ya-outset) ; 記号入力
(set-tcode-mode-key ; 片仮名変換
"$" 'tcode-katakana-preceding-chars)
;; モード切り替え時にヘルプ用のバッファを消す。
(setq tcode-auto-remove-help-count 1)
(add-hook 'tcode-toggle-hook
'tcode-auto-remove-help)
;; カーソルに色をつける
(and window-system
(tcode-enable-cursor-to-change-color)
(setq tcode-mode-on-cursor-color "Violet"))
;; org-mode 対応
(push 'org-self-insert-command tcode-input-command-list)
;; 独自キーマップ
(tcode-set-key-layout "quek")
;; 補完機能
(require 'tc-complete)
;; "\" を補完・確定に使う。
;;(tcode-set-key "\" 'tcode-mazegaki-complete-and-convert)
;; 1文字から補完する。
(setq tcode-complete-min-context-length 1)
;; ;; コントロールキーを伴わないモード切り替え
;; (global-set-key " " 'tcode-electric-space)
;; (global-set-key ")" 'tcode-electric-comma)
;; (tcode-set-key " " 'tcode-electric-space)
;; zap-to-char の拡張
(global-set-key "\M-z" 'tcode-zap-to-char)
))
;;; ●文字表を読んだ後に行う設定
;;; ○2ストローク以上のストロークのキー割り当て
(add-hook 'tcode-after-load-table-hook
(lambda ()
(when (eq tcode-input-method 'tcode)
;; Tコード用の設定
;; 表を一部変更する。
;; 0 1 2 3 4 5 6 7 8 9
;; 10 11 12 13 14 15 16 17 18 19
;; 20 21 22 23 24 25 26 27 28 29
;; 30 31 32 33 34 35 36 37 38 39
(tcode-set-action-to-table '(5 5) "です。")
(tcode-set-action-to-table '(5 6) "ます。")
(tcode-set-action-to-table '(5 7) "削")
;; QWERTY での「ke」に変数 tcode-left-paren を割り当てる。
(tcode-set-action-to-table '(27 12)
'tcode-left-paren)
;; QWERTY での「id」に変数 tcode-right-paren を割り当てる。
(tcode-set-action-to-table '(17 22)
'tcode-right-paren))))
(progn ;; フィルターによる拡張入力。
(defun my-t-code-filter (x)
(or (cdr (assoc x '((?で . "です。")
(?ま . "ます。")
(?し . "した。")
(?事 . "こと")
(?〜 . "から")
(?消 . "削")
(?願 . "お願いします。")
(?以 . "以上、")
(?メ . "read.eval.print@gmail.com")
(?住 . "横浜市泉区岡津町110-3 グレーシアパーク山手台 EAST 壱番館 412")
)))
x))
(setq tcode-input-filter-functions
'((tcode-katakana-mode . japanese-katakana)
((and (boundp 'tcode-bushu-prefix-list)
tcode-bushu-prefix-list)
. tcode-bushu-prefix-convert)
(tcode-alnum-2-byte . tcode-1-to-2)
(tcode-shift-state . my-t-code-filter)))
)
(defun quek-dupm-tcode-key-table ()
"(quek-dupm-tcode-key-table)"
(load "tc-tbl")
(remove-if
(lambda (x)
(or (string= " " (caadr x))
(string= "■" (caadr x))
(atom (caar x))))
(mapcar (lambda (x)
(list (list (mapcar (lambda (key)
(char-to-string (tcode-key-to-char key)))
(tcode-encode x)))
(list (char-to-string x))))
(apply 'concat (mapcar 'identity tcode-tbl)))))
この記事は 漢直 Advent Calendar : ATND の中のある 1 日です。
Eamcs での T-Code 入力 tc2 をちょっ便利にしてみます。
AZIK の特殊拡張では「ます」を「ms」、「こと」を「kt」、「から」を「kr」で打てます。これらを T-Code 打つと一文字 2 ストロークですから、それぞれ 4 ストロークで、 AZIK の倍の打鍵が必要になります。
tc2 でも AZIK と同様に 2 ストロークで入力できるようにしたいと思います。
tc2 には入力フィルタという仕組みがあり、打鍵の結果をいじることができます。
;; "-shift" 付のレイアウトを指定します。
(tcode-set-key-layout "qwerty-jis-shift")
(progn ;; フィルターによる拡張入力。
(defun my-t-code-filter (x)
(or (cdr (assoc x '((?で . "です。")
(?ま . "ます。")
(?し . "した。")
(?事 . "こと")
(?〜 . "から")
(?消 . "削")
(?願 . "お願いします。")
(?以 . "以上、")
(?メ . "foo.bar.baz@gmail.com")
(?住 . "横浜市中区上野町123-42")
)))
x))
(setq tcode-input-filter-functions
'((tcode-katakana-mode . japanese-katakana)
((and (boundp 'tcode-bushu-prefix-list)
tcode-bushu-prefix-list)
. tcode-bushu-prefix-convert)
(tcode-alnum-2-byte . tcode-1-to-2)
(tcode-shift-state . my-t-code-filter)))
)
これで、「ます。」は「Shift+ま」（「Md」）、「こと」は「Shift+事」（「Uf」）、「から」は「Shift+〜」（「<m」）で入力できるようになります。シフトキーは必要でするが 2 ストロークになりました。
また、「Shift+メ」でメールアドレスを入力したり、「Shift+住」で住所を入力したりするのもいいですね。
あまり興味を持ってもらえない Climacs の Dired ではあるが、ないと不便だと思うので実装した。まだ、一覧表示してファイルを開くことしかできない。
と、分からないところが多い。
ソースは github にあるけど、ここにも貼り付けておく。
;;; -*- mode: lisp; indent-tabs: nil -*-
(in-package :info.read-eval-print.climacs.dired)
(define-syntax-command-table dired-table :errorp nil
:inherit-from '(drei:movement-table climacs-gui:window-table))
;;;;;; presentation
;;(define-presentation-type dired ()
;; :inherit-from 't)
;;
;;(define-presentation-method presentation-typep (object (type dired))
;; (pathnamep object))
;;
;;(define-presentation-method present (object (type dired) stream
;; (view textual-view)
;; &key)
;; (let ((stat (sb-posix:stat (namestring object)))
;; (name (if (directory-pathname-p object)
;; (car (last (pathname-directory object)))
;; (file-namestring object))))
;; (format stream
;; " ~o ~a ~a ~6,d ~a ~a"
;; (sb-posix:stat-mode stat)
;; (file-author object)
;; (sb-posix:group-name (sb-posix:getgrgid (sb-posix:stat-gid stat)))
;; (sb-posix:stat-size stat)
;; (dt:|yyyy-mm-dd hh:mm| (dt:from-posix-time (sb-posix:stat-mtime stat)))
;; name)))
;;;; dired-syntax
(define-syntax dired-syntax (fundamental-syntax)
()
(:name "Dired")
(:command-table dired-table))
(defmethod name-for-info-pane ((syntax dired-syntax) &key pane)
(declare (ignore pane))
(format nil "Dired"))
(defmethod display-syntax-name ((syntax dired-syntax)
(stream extended-output-stream) &key pane)
(declare (ignore pane))
(princ "Dired" stream))
;;;; dired-mode
(define-syntax-mode dired-mode ()
((path :initarg :path))
(:documentation "A mode for Directory editing.")
(:applicable-syntaxes fundamental-syntax))
(defmethod syntax-command-tables append ((syntax dired-mode))
'(dired-table))
(defun ensure-pathname-for-dired (path)
(make-pathname :directory (namestring path)
:name :wild))
;;(defun make-buffer-contents (path)
;; (loop for x in (directory (ensure-pathname-for-dired path))
;; do (defmethod presentation-type-of ((object (eql x)))
;; 'dired)
;; nconc (list x #\Newline)))
(defun make-buffer-contents (path)
(str (namestring path) #\Newline
(trivial-shell:shell-command #"""ls -al #,(namestring path)""")))
(defun make-dired-buffer (path)
(let ((buffer (make-new-buffer)))
(insert-buffer-sequence buffer 0 (make-buffer-contents path))
(clear-undo-history buffer)
buffer))
(defun find-directory (path)
(cond ((null path)
(display-message "No file name given.")
(beep))
((not (directory-pathname-p path))
(display-message "~A is a not directory name." path)
(beep))
((not (probe-file path))
(display-message "~A is a not found." path)
(beep))
(t
(let* ((buffer (make-dired-buffer path))
(view (climacs-core::make-new-view-for-climacs
*esa-instance* 'textual-drei-syntax-view
:name (namestring path)
:buffer buffer)))
(unless (climacs-core::buffer-pane-p (current-window))
(climacs-core::other-window (or (find-if (^ typep _window 'climacs-core::climacs-pane)
(windows *esa-instance*))
(climacs-core::split-window t))))
(setf (offset (point buffer)) (offset (point view))
(syntax view) (make-syntax-for-view view 'dired-syntax)
(file-write-time buffer) nil
(needs-saving buffer) nil
(name buffer) (namestring path))
(enable-mode view 'dired-mode :path path)
(setf (current-view (current-window)) view)
(evaluate-attribute-line view)
(setf (filepath buffer) (pathname path)
(read-only-p buffer) t)
(beginning-of-buffer (point view))
buffer))))
(define-command (com-dired :name t :command-table esa-io-table)
((path 'pathname
:prompt "Dired (directory): "
:prompt-mode :raw
:default (esa-io::directory-of-current-buffer)
:default-type 'pathname
:insert-default t))
"Prompt for a directory name then edit that directory."
(handler-case (find-directory path)
(file-error (e)
(display-message "~a" e))))
(defun dired-find-file (path)
(unless path
(let* ((dir (slot-value (syntax (current-view)) 'path))
(mark (point))
(line (region-to-string (beginning-of-line (clone-mark mark))
(end-of-line (clone-mark mark)))))
(ppcre:register-groups-bind (d file)
("(.)(?:[^ ]+ +){7}(.*\)" line)
(setf path (merge-pathnames (str file (when (string= "d" d) "/")) dir)))))
(when path
(if (directory-pathname-p path)
(find-directory path)
(find-file path))))
(define-command (com-dired-find-file :name t :command-table dired-table)
((path 'pathname
:prompt "File: "
:prompt-mode :raw
:default-type 'pathname))
"Find file."
(dired-find-file path))
(set-key 'com-dired-find-file 'dired-table '((#\Newline)))
(set-key `(drei-commands::com-forward-line ,*numeric-argument-marker*) 'dired-table
'((#\n)))
(set-key `(drei-commands::com-backward-line ,*numeric-argument-marker*) 'dired-table
'((#\p)))
(set-key `(climacs-commands::com-kill-view (current-view)) 'dired-table
'((#\q)))
