outline-tree2 の設定ファイルをさらしてみる。
;; -*- Mode: lisp; Package: OUTLINE-TREE2; outline-tree: user-regexp-lisp-dots; -*- ;;; Code: (require "outline-tree/outline-tree") (in-package "outline-tree2") ;;; extended-key-translate-table 設定 ;(set-extended-key-translate-table exkey-C-tab #\F23) ;(set-extended-key-translate-table exkey-C-return #\F20) ; ;;; Editor <-> TreeView ;; Editor -> TreeView ;(global-set-key #\F23 'treeview::treeview-focus-treeview) ;; TreeView (outline-tree) -> Editor ;(define-key outline-tree2::*outline-tree-map* #\F23 'treeview::treeview-focus-editor) ;;; outline 更新 ;(global-set-key #\F20 'outline-tree2::outline-tree-create-outline-and-select-node) ;(define-key outline-tree2::*outline-tree-map* ; #\F20 'outline-tree2::outline-tree-create-outline-and-select-node) ;; ノード対応テキストハイライト (setq *outline-tree-text-highlight-attribute* '(:background 3 :prefix #\T :extend t)) ;;; sample.config.l ends here ;; バッファ更新時にバッファが削除済みの場合、更新処理を行わないように修正 ;; 上書き (defun outline-tree-update-modified-buffer-node-name-view () (unless *outline-tree-update-modified-buffer-node-name-view-p* (return-from outline-tree-update-modified-buffer-node-name-view nil)) (treeview::with-app (*outline-tree-app-id*) (let (buffer-node-name-view) (maphash #'(lambda (buffer buffer-node) (unless (deleted-buffer-p buffer) ;; この条件を追加 (setq buffer-node-name-view (if (buffer-modified-p buffer) (concat "* " (outline-tree-data-get-node-name buffer-node)) (outline-tree-data-get-node-name buffer-node))) (unless (string-equal buffer-node-name-view (treeview::treeview-get-item-text buffer-node)) (treeview::treeview-set-item-text buffer-node buffer-node-name-view)))) outline-tree2::*outline-tree-buffer-hash*)))) ;;----------------------------------------------------------- ;;. outline-treeを表示･非表示 (defun outline-tree-toggle-open () "outline-tree: アウトラインツリーのトグル" (interactive) (let ((whndl (get-window-handle)) (center (winapi:make-RECT)) width) (winapi::GetWindowRect whndl center) (setq width (- (winapi::RECT-right center) (winapi::RECT-left center))) (setq treeview::*treeview-window-size-default* (cond ((> width 1900) 400) ((> width 1600) 300) (t 200)))) (if (outline-tree-exist-p) (if (outline-tree-open-p) (outline-tree-close) (outline-tree-open)) (progn (outline-tree-create) (outline-tree-open)))) (defun set-toggle-olc-keybind () (if (fboundp 'user::toggle-buffer-bar) (global-set-key '(#\C-c #\C-o) (x-key-macro 16 'outline-tree-toggle-open 'user::toggle-buffer-bar)) (global-set-key '(#\C-c #\C-o) 'outline-tree-toggle-open))) (if (modulep "allconfigs/allconfigs") (set-toggle-olc-keybind) (add-hook 'user::*post-allconfigs-hook* 'set-toggle-olc-keybind)) ;;. カーソル追従の深さを無制限に ;;----------------------------------------------------------- (setq *outline-tree-expand-on-chase-cursor* t) ;;----------------------------------------------------------- ;;. outline-treeの現在ノード以下を展開・非展開 (defun toggle-outline-tree-node-expand () "outline-treeの現在ノード以下を展開・非展開" (interactive) (treeview::with-app (outline-tree2::*outline-tree-app-id*) (let ((node (outline-tree-get-selected-node))) (if (treeview::treeview-expand-p node) (outline-tree-expand-collapse-subtree node) (outline-tree-expand-expand-subtree-show-heading-node node) )))) (global-set-key #\C-M-\: 'toggle-outline-tree-node-expand) ;;----------------------------------------------------------- ;;. outline-treeの現在ノードの親以下を展開 (defun outline-tree-node-expand-parent () "outline-treeの現在ノードの親以下を展開" (interactive) (treeview::with-app (outline-tree2::*outline-tree-app-id*) (let ((node (outline-tree-get-selected-node)) parent) (setq parent (treeview::treeview-get-parent-item node)) (outline-tree-expand-expand-subtree-show-heading-node parent) ))) (global-set-key #\C-M-\; 'outline-tree-node-expand-parent) ;;----------------------------------------------------------- ;;. outline-tree を左端から arg 分だけスクロールした場所に移動する (defvar *outline-tree-hscroll-arg* nil) (setq *outline-tree-hscroll-arg* 8) (defvar *outline-tree-hscroll-arg* nil) (defvar *outline-tree-hscroll-delay* nil) ;(setq *outline-tree-hscroll-delay* 0.1) (defun outline-tree-hscroll (arg) "outline-tree を左端から arg 分だけスクロールした場所に移動する" (interactive "p") (if arg (if *outline-tree-hscroll-delay* (start-timer *outline-tree-hscroll-delay* #'(lambda () (treeview::with-app (outline-tree2::*outline-tree-app-id*) (do-events) (treeview::treeview-hscroll-window-left) (treeview::treeview-hscroll-window arg))) t) (treeview::with-app (outline-tree2::*outline-tree-app-id*) (do-events) (treeview::treeview-hscroll-window-left) (treeview::treeview-hscroll-window arg)) ))) ;;----------------------------------------------------------- ;;. 削除されたウィンドウの場合のバグを修正 (defun outline-tree-funcall-buffer-by-window (func window) (unless window (setq window (outline-tree-get-target-window))) (let ((gcolumn (goal-column))) (prog1 (save-window-excursion (handler-case (set-window window) (error (c) (setq window (selected-window)))) (funcall func (selected-buffer))) (set-goal-column gcolumn)))) ;;----------------------------------------------------------- ;;. recenter (C-l) で outline-treeも更新 (defun olt-updates () (when (and (outline-tree-exist-p) (outline-tree-open-p)) ;(outline-tree-create-outline) (outline-tree-hscroll *outline-tree-hscroll-arg*))) (require "recenter/recenter-with-hook") (add-hook 'ed::*after-recenter-hook* 'olt-updates t) (defvar *olt-updates-expand-depth* 4) (setq *olt-updates-expand-depth* 5) ;;----------------------------------------------------------- ;;. recenter (C-l) ×2 で outline-treeを展開更新 (defun olt-updates-with-expand () (and (outline-tree-exist-p) (outline-tree-open-p) (let ((*outline-tree-expand-depth-on-create-outline* (if (boundp 'outline-tree-expand-depth-on-create-outline-local) outline-tree-expand-depth-on-create-outline-local *outline-tree-expand-depth-on-create-outline*))) (outline-tree-create-outline) (outline-tree-expand-expand-subtree *olt-updates-expand-depth*) (outline-tree-hscroll *outline-tree-hscroll-arg*) ))) (add-hook 'ed::*after-continued-recenter-hook* 'olt-updates-with-expand t) ;(global-set-key #\Delete 'outline-tree-delete-outline-by-node) ;(global-set-key #\M-\C-p 'outline-tree-select-up-key-node) ;(global-set-key #\M-\C-n 'outline-tree-select-down-key-node) ;(global-set-key #\M-\C-b 'outline-tree-select-left-key-node) ;(global-set-key #\M-\C-f 'outline-tree-select-right-key-node) ;(define-key *outline-tree-map* #\RET 'outline-tree-node-action) (defun outline-tree-select-up-key-node-if-exists () (interactive) (if (and (outline-tree-exist-p) (outline-tree-open-p)) (outline-tree-select-up-key-node))) (defun outline-tree-select-down-key-node-if-exists () (interactive) (if (and (outline-tree-exist-p) (outline-tree-open-p)) (outline-tree-select-down-key-node))) (defun outline-tree-select-left-key-node-if-exists () (interactive) (if (and (outline-tree-exist-p) (outline-tree-open-p)) (outline-tree-select-left-key-node))) (defun outline-tree-select-right-key-node-if-exists () (interactive) (if (and (outline-tree-exist-p) (outline-tree-open-p)) (outline-tree-select-right-key-node))) (global-set-key #\M-\C-0 'outline-tree-select-up-key-node-if-exists) (global-set-key #\M-\C-Up 'outline-tree-select-up-key-node-if-exists) (global-set-key #\M-\C-Down 'outline-tree-select-down-key-node-if-exists) (global-set-key #\M-\C-Left 'outline-tree-select-left-key-node-if-exists) (global-set-key #\M-\C-Right 'outline-tree-select-right-key-node-if-exists) (global-set-key #\M-\C-h (x-key-macro #x12 'backward-kill-word 'outline-tree-select-left-key-node-if-exists)) (global-set-key #\M-\C-j 'outline-tree-select-down-key-node-if-exists) (global-set-key #\M-\C-k 'outline-tree-select-up-key-node-if-exists) (global-set-key '(#\C-x #\O) 'treeview::treeview-focus-treeview) (define-key treeview::*treeview-map* '(#\C-x #\O) 'treeview::treeview-other-window) ;(global-set-key #\M-\C-l 'outline-tree-select-right-key-node-if-exists) ;(global-set-key #\M-\C-z 'outline-tree-select-pageup-key-node) ;(global-set-key #\M-\C-v 'outline-tree-select-pagedown-key-node) ;(global-set-key #\M-\C-a 'outline-tree-select-ancestor-node) ;(global-set-key #\M-\C-e 'outline-tree-select-eldest-descendants-node) ;(global-set-key #\M-\C-s (treeview::treeview-make-tv-command outline-tree-isearch-forward)) ;(global-set-key #\M-\C-r (treeview::treeview-make-tv-command outline-tree-isearch-backward)) ;(global-set-key #\M-\P 'outline-tree-swap-region-by-prev-range-node) ;(global-set-key #\M-\N 'outline-tree-swap-region-by-next-range-node) ;(global-set-key #\M-\D 'outline-tree-delete-region-by-range-node)) ;;. icon を指定できるように ;:layer-regexp-list を以下のリストに拡張: ; 正規表現、または正規表現とアイコンID のリスト (defun outline-tree-insert-range-node (range-name parent-node &key (insertafter winapi:TVI_LAST) title-range whole-range sub-type implicit-func explicit-func heading-icon) (let (icon group-count) (cond ((eq sub-type :header-node) (setq icon *outline-tree-icon-id-header*)) ((and *outline-tree-range-node-group-p* (plusp (setq group-count (outline-tree-data-get-group-count parent-node)))) (cond ((eq sub-type :heading-node) (cond ((= (mod group-count 2) 1) (setq icon *outline-tree-icon-id-heading1*)) ((= (mod group-count 2) 0) (setq icon *outline-tree-icon-id-heading2*)))) (t (cond ((= (mod group-count 2) 1) (setq icon *outline-tree-icon-id-range1*)) ((= (mod group-count 2) 0) (setq icon *outline-tree-icon-id-range2*)))))) (t (cond ((eq sub-type :heading-node) (setq icon (or heading-icon *outline-tree-icon-id-heading*))) (t (setq icon *outline-tree-icon-id-range*))))) (treeview::with-app (*outline-tree-app-id*) (outline-tree-register-range-node range-name (treeview::treeview-insert-item range-name parent-node :insertafter insertafter :icon icon :sicon icon) :title-range title-range :whole-range whole-range :sub-type sub-type :implicit-func implicit-func :explicit-func explicit-func)))) (defun outline-tree-create-outline-regexp-internal (&key root-node layer-regexp-list layer-regexp-list-case-fold (layer-regexp-list-order :non-miss) create-sub-outline-func title-converter sub-type line-oriented) "正規表現アウトライン作成内部 function ROOT-NODE LAYER-REGEXP-LIST LAYER-REGEXP-LIST-CASE-FOLD LAYER-REGEXP-LIST-ORDER: :top-miss, :any-miss, :non-miss, :disorder" (labels (;; ************************************************************ ;; 階層検索 ;; ************************************************************ (outline-tree-create-outline-regexp-order (&key root-node layer-regexp-list layer-regexp-list-order create-sub-outline-func line-oriented) (let ((current-regexp (car layer-regexp-list)) (layer-regexp-list (cdr layer-regexp-list)) header-node range-node value-list from next-from title-from title-to whole-range title-range contents-from regnum title heading-icon icon match) (when (consp current-regexp) (setq heading-icon (cadr current-regexp) current-regexp (car current-regexp)) (if (symbolp heading-icon) (setq heading-icon (symbol-value heading-icon)))) (save-excursion (goto-char (point-min)) ;; **************************************** ;; サブアウトライン作成 ;; **************************************** (unless current-regexp (when create-sub-outline-func (funcall create-sub-outline-func root-node)) (return-from outline-tree-create-outline-regexp-order)) ;; **************************************** ;; 現在の正規表現でのマッチ情報を取得 ;; **************************************** (when current-regexp (while (scan-buffer current-regexp :regexp t) (setq from next-from next-from (point)) (setq whole-range (cons from next-from) title-range (cons title-from title-to)) (if (functionp heading-icon) (progn (setq match (match-data)) (setq icon (funcall heading-icon)) (store-match-data match)) (setq icon heading-icon)) ;; from が nil のものもとりあえず push (push (list whole-range title-range contents-from icon) value-list) (setq contents-from (match-end 0)) (when line-oriented (goto-char contents-from) (unless (bolp) (goto-eol) (forward-char) (setq contents-from (point)))) (if (setq regnum (dotimes (i 9) (if (match-string (- 9 i)) (return (- 9 i))))) ;; 正規表現からタイトル取得 (setq title-from (match-beginning regnum) title-to (match-end regnum)) ;; 先頭行からタイトル取得 (save-excursion (goto-char (match-beginning 0)) (setq title-from (point) title-to (progn (goto-eol) (point))))) (goto-char contents-from)) ;; 最後の一回分を push (when next-from (setq whole-range (cons next-from (if (= (point-max) (buffer-size)) nil (point-max))) title-range (cons title-from title-to)) (if (functionp heading-icon) (save-excursion (goto-char next-from) (setq icon (funcall heading-icon))) (setq icon heading-icon)) (push (list whole-range title-range contents-from icon) value-list)) ;; 順番を逆にした上で、from が nil のものを取り除く (setq value-list (cdr (nreverse value-list)))) ;; ****************************** ;; 正規表現マッチ情報に従い処理実施 ;; ****************************** (cond ;; 現在の正規表現にマッチする部分が見つかった場合 (value-list ;; layer-regexp-list-order を更新 (when (eq layer-regexp-list-order :top-miss) (setq layer-regexp-list-order :non-miss)) ;; 現在の正規表現にマッチ開始するまでの範囲を処理 (if line-oriented (setq whole-range (cons (save-excursion (goto-char (point-min)) (if (bolp) (point) (progn (goto-eol) (forward-char) (point)))) (car (first (car value-list))))) (setq whole-range (cons (point-min) (car (first (car value-list)))))) (when (< (outline-tree-get-range-from whole-range) (outline-tree-get-range-to whole-range)) (save-excursion (save-restriction ;; サブアウトライン作成 (narrow-to-region (outline-tree-get-range-from whole-range) (outline-tree-get-range-to whole-range)) (setq header-node (outline-tree-insert-range-node *outline-tree-header-node-name* root-node :whole-range whole-range :sub-type :header-node :heading-icon (fourth (car value-list)))) (outline-tree-create-outline-regexp-order :root-node header-node :create-sub-outline-func create-sub-outline-func) (when (and (not (outline-tree-node-has-children-p header-node)) (not (and (eq sub-type :heading-node) (outline-tree-buffer-node-p root-node)))) (outline-tree-remove-range-node header-node))))) ;; 現在の正規表現にマッチした箇所から開始するそれぞれの範囲を処理 ;; (階層定義正規表現リスト) (dolist (value value-list) (setq whole-range (first value) title-range (second value) contents-from (third value)) (setq title (buffer-substring (outline-tree-get-range-from title-range) (outline-tree-get-range-to title-range))) (when title-converter (setq title (funcall title-converter title))) (setq range-node (outline-tree-insert-range-node title root-node :title-range title-range :whole-range whole-range :sub-type sub-type :heading-icon (fourth value))) (when (< contents-from (outline-tree-get-range-to whole-range)) (save-restriction (narrow-to-region contents-from (outline-tree-get-range-to whole-range)) (outline-tree-create-outline-regexp-order :root-node range-node :layer-regexp-list layer-regexp-list :layer-regexp-list-order layer-regexp-list-order :create-sub-outline-func create-sub-outline-func :line-oriented line-oriented)))) (caaar value-list)) ;; 正規表現にマッチする部分が見つからず、それが許容される場合 ((member layer-regexp-list-order '(:top-miss :any-miss)) (outline-tree-create-outline-regexp-order :root-node root-node :layer-regexp-list layer-regexp-list :layer-regexp-list-order layer-regexp-list-order :create-sub-outline-func create-sub-outline-func :line-oriented line-oriented)) (t (outline-tree-create-outline-regexp-order :root-node root-node :create-sub-outline-func create-sub-outline-func)))))) ;; ************************************************************ ;; 階層解析 ;; ************************************************************ (outline-tree-create-outline-regexp-disorder (&key root-node layer-regexp-list create-sub-outline-func line-oriented) (let (current-regexp match-alist regexp-position regnum header-node title heading-icon) (save-excursion ;; **************************************** ;; 今回の階層をどの正規表現で作成するか解析 ;; **************************************** ;; 各正規表現がマッチする最初のポイントを取得 (dolist (regexp layer-regexp-list) (when (consp regexp) (setq heading-icon (cadr regexp) regexp (car regexp)) (if (symbolp heading-icon) (setq heading-icon (symbol-value heading-icon)))) (goto-char (point-min)) (when (and regexp (scan-buffer regexp :regexp t)) (push (cons regexp (point)) match-alist))) ;; どの正規表現に始めにマッチしたか確認 (when match-alist (setq current-regexp (caar (stable-sort match-alist #'< :key #'cdr))) ;(setq regexp-position ; (position current-regexp layer-regexp-list :test 'equal)) (setq regexp-position (position current-regexp layer-regexp-list :test #'(lambda (x y) (or (equal x y) (equal x (safe-car y)))))) (setq layer-regexp-list (append (subseq layer-regexp-list 0 regexp-position) (subseq layer-regexp-list (1+ regexp-position))))) (goto-char (point-min)) ;; **************************************** ;; サブアウトライン作成 ;; **************************************** (unless current-regexp (when create-sub-outline-func (funcall create-sub-outline-func root-node)) (return-from outline-tree-create-outline-regexp-disorder)) ;; **************************************** ;; 現在の正規表現でのマッチ情報を取得 ;; **************************************** (when current-regexp (let ((heading-icon-function-p (functionp heading-icon)) range-node value-list from next-from title-from title-to whole-range title-range contents-from icon) (while (scan-buffer current-regexp :regexp t) (setq from next-from next-from (point)) (setq whole-range (cons from next-from) title-range (cons title-from title-to)) (if heading-icon-function-p (let ((match (match-data))) (setq icon (funcall heading-icon)) (store-match-data match)) (setq icon heading-icon)) ;; from が nil のものもとりあえず push (push (list whole-range title-range contents-from icon) value-list) (setq contents-from (match-end 0)) (when line-oriented (goto-char contents-from) (unless (bolp) (goto-eol) (forward-char) (setq contents-from (point)))) (if (setq regnum (dotimes (i 9) (if (match-string (- 9 i)) (return (- 9 i))))) ;; 正規表現からタイトル取得 (setq title-from (match-beginning regnum) title-to (match-end regnum)) ;; 先頭行からタイトル取得 (save-excursion (goto-char (match-beginning 0)) (setq title-from (point) title-to (progn (goto-eol) (point))))) (goto-char contents-from)) ;; 最後の一回分を push (when next-from (setq whole-range (cons next-from (if (= (point-max) (buffer-size)) nil (point-max))) title-range (cons title-from title-to)) (push (list whole-range title-range contents-from) value-list)) ;; 順番を逆にした上で、from が nil のものを取り除く (setq value-list (cdr (nreverse value-list))) (cond (value-list ;; 現在の正規表現にマッチ開始するまでの範囲を処理 (if line-oriented (setq whole-range (cons (save-excursion (goto-char (point-min)) (if (bolp) (point) (progn (goto-eol) (forward-char) (point)))) (car (first (car value-list))))) (setq whole-range (cons (point-min) (car (first (car value-list)))))) (when (< (outline-tree-get-range-from whole-range) (outline-tree-get-range-to whole-range)) (save-excursion (save-restriction ;; サブアウトライン作成 (narrow-to-region (outline-tree-get-range-from whole-range) (outline-tree-get-range-to whole-range)) (setq header-node (outline-tree-insert-range-node *outline-tree-header-node-name* root-node :whole-range whole-range :sub-type :header-node :heading-icon (fourth (car value-list)))) (outline-tree-create-outline-regexp-disorder :root-node header-node :create-sub-outline-func create-sub-outline-func) (when (and (not (outline-tree-node-has-children-p header-node)) (not (and (eq sub-type :heading-node) (outline-tree-buffer-node-p root-node)))) (outline-tree-remove-range-node header-node))))) ;; 現在の正規表現にマッチした箇所から開始するそれぞれの範囲を処理 ;; (階層定義正規表現リスト) (dolist (value value-list) (setq whole-range (first value) title-range (second value) contents-from (third value)) (setq title (buffer-substring (outline-tree-get-range-from title-range) (outline-tree-get-range-to title-range))) (when title-converter (setq title (funcall title-converter title))) (setq range-node (outline-tree-insert-range-node title root-node :title-range title-range :whole-range whole-range :sub-type sub-type :heading-icon (fourth value))) (when (< contents-from (outline-tree-get-range-to whole-range)) (save-restriction (narrow-to-region contents-from (outline-tree-get-range-to whole-range)) (outline-tree-create-outline-regexp-disorder :root-node range-node :layer-regexp-list layer-regexp-list :create-sub-outline-func create-sub-outline-func :line-oriented line-oriented)))) (caaar value-list)) ;; 正規表現にマッチする部分が見つからず、検索終了の場合 (t (outline-tree-create-outline-regexp-disorder :root-node root-node :create-sub-outline-func create-sub-outline-func))))))))) ;; 処理開始部 ;; layer-regexp-list の各要素を compiled-regexp 形式に (when (symbolp layer-regexp-list) (setq layer-regexp-list (symbol-value layer-regexp-list))) (setq layer-regexp-list (mapcar #'(lambda (regexp) (if (stringp regexp) (compile-regexp regexp layer-regexp-list-case-fold) (if (and (consp regexp) (stringp (car regexp))) (cons (compile-regexp (car regexp)) (cdr regexp)) regexp))) layer-regexp-list)) (cond ;; 階層解析 ((member layer-regexp-list-order '(:disorder)) (outline-tree-create-outline-regexp-disorder :root-node root-node :layer-regexp-list layer-regexp-list :create-sub-outline-func create-sub-outline-func :line-oriented line-oriented)) ;; 階層検索 (t (unless (member layer-regexp-list-order '(:top-miss :any-miss :non-miss)) (setq layer-regexp-list-order :non-miss)) (outline-tree-create-outline-regexp-order :root-node root-node :layer-regexp-list layer-regexp-list :layer-regexp-list-order layer-regexp-list-order :create-sub-outline-func create-sub-outline-func :line-oriented line-oriented))) (outline-tree-node-has-children-p root-node))) #| icon を指定する example: .outline-tree/autoload/cr-user-regexp-lisp-dots.l >>> (require "outline-tree/outline-tree") (require "outline-tree/cr-regexp-internal") (in-package "outline-tree2") ;; definition (defun outline-tree-create-outline-user-regexp-lisp-dots (root-node) (outline-tree-create-outline-regexp-internal :root-node root-node :layer-regexp-list-order :non-miss :layer-regexp-list '(("^;;;?\\.[ \t]*\\([^.\n][^;\n]*\\)[ \t;]*$" *outline-tree-icon-id-info*) ;"^;;\\.[ \t]+\\([^.\n].*\\)" ("^;;;?\\.\\{2\\}[ \t]*\\([^.\n].*\\)") "^;;;?\\.\\{3\\}[ \t]*\\([^.\n].*\\)" "^;;;?\\.\\{4\\}[ \t]*\\([^.\n].*\\)" "^;;;?\\.\\{5\\}[ \t]*\\([^.\n].*\\)" "^;;;?\\.\\{6\\}[ \t]*\\([^.\n].*\\)" "^;;;?\\.\\{7\\}[ \t]*\\([^.\n].*\\)" "^;;;?\\.\\{8\\}[ \t]*\\([^.\n].*\\)" "^;;;?\\.\\{9\\}[ \t]*\\([^.\n].*\\)" ) :layer-regexp-list-case-fold nil :sub-type :heading-node :line-oriented nil :title-converter nil)) ;; register (outline-tree-add-create-outline-function 'outline-tree-create-outline-user-regexp-lisp-dots "* user : Lisp 階層付きテキスト" '(:user :sequential) "Lisp コメントを考慮した階層付きテキストを階層表示します。") <<< |# ;;. autoload の設定 ;; Note: buf2htmlは、autoload でロードできるように本体側を修正済み (autoload 'ed::buf2html-get-ini2css-string "buf2html") (autoload 'ed::buf2html-get-region-string "buf2html")
KaMailV3 で、スレッドの表示順を変える
オリジナルのスレッド表示順は、スレッドの最初のメールで順番付けされるが、それをスレッド中のメールすべてを見て決定するようにできるようにしてみた。
(defvar *kamail3-thread-order-all-mails* t "スレッド内すべてのメールを見てスレッド順を決めるときは t, オリジナルの動作にするときは nil") (defun kamail3-thread-order (key prep response-list) (let ((nval key) (rep (assoc key response-list))) (dolist (i (if (consp rep) (mapcar #'(lambda (y) (kamail3-thread-order y prep response-list)) (cdr rep)))) (if (funcall prep i nval) (setq nval i))) nval)) (defun summary-thread-parse (messages) (let (id-alist rp-alist response-list parent-list) (dolist (x messages) (let* ((num (car x)) (h (cdr x)) (message-id (junk::mail-get-header-value "message-id" h)) (in-reply-to (junk::mail-get-header-value "in-reply-to" h)) (references (junk::mail-get-header-value "references" h)) tmp ) (if (and (stringp in-reply-to) (string-match "\\(<[^>]+>\\)" in-reply-to)) (setq in-reply-to (match-string 1)) (if (stringp references) (progn (while (string-match "<[^>]+>" references) (setq tmp (match-string 0)) (setq references (substring references (match-end 0) (length references)))) (if tmp (setq in-reply-to tmp) (setq in-reply-to nil))))) (push (cons message-id num) id-alist) (push (cons num in-reply-to) rp-alist))) (dolist (x (reverse rp-alist)) (let ((num (car x)) (in-reply-to (cdr x)) parent ) (if (and in-reply-to (setq parent (cdr (assoc in-reply-to id-alist :test #'equal)))) (let ((num-childs (assoc parent response-list))) (if num-childs (push num (cdr num-childs)) (push (cons parent (list num)) response-list))) (push num parent-list)))) (if (and *kamail3-thread-order-all-mails* (query-order *query-last-query*)) (let ((prep (if (string-match "\\<NUMA\\>" (query-order *query-last-query*)) #'> #'<))) ;; スレッドの表示順を変更 (setq parent-list (stable-sort (nreverse parent-list) #'< :key #'(lambda (x) (or (kamail3-thread-order x prep response-list) x) ))) (values parent-list (nreverse response-list))) (values (nreverse parent-list) (nreverse response-list)) )))
う〜、一年ぶりの更新。一応、生きてます。。。
KaMailV3 で summaryからの返信操作は、キャンセル時にsummaryの画面状態へ戻す。
summary で返信 (r) を押して、キャンセルせる (q) すると、draftバッファが表示されて変な感じがするので、上書き修正してみた。
;;.. summaryからの返信操作は、キャンセル時にsummaryの画面状態へ戻す。 ;;... draft-winconf が設定されていないときだけ保存する。 ;;上書き (defun draft-winconf-save () (unless *draft-winconf* (setq *draft-winconf* (current-window-configuration)))) ;;... summary-view-mailをする前に draft-winconf を保存する ;; 上書き (defun summary-message-reply (&optional all) (interactive "p") (let ((old-conf *draft-winconf*)) (draft-winconf-save) (if (summary-view-mail) (message-reply all) (setq *draft-winconf* old-conf))))
KaMailV3 で draftバッファを閉じるとき尋ねる & 返信のキャンセルは、未編集なら尋ねない。
Hieさんのところにあった気もするけど。。。
;;.. draftバッファを閉じるとき尋ねる & 返信のキャンセルは、未編集なら尋ねない。 (defun draft-close-query () (interactive) (if (and (buffer-modified-p) (yes-no-or-cancel-p "Do you save the draft?")) (draft-save)) (draft-close)) (define-key *draft-map* #\q 'draft-close-query) ;;... 新規・返信メッセージ作成時は、非修正状態 ;; *draft-create-post-hook* に登録された他の関数によって修正状態になる ;; 可能性があるので戻す。 (defun set-draft-buffer-modified-nil () (set-buffer-modified-p nil)) (add-hook '*draft-create-post-hook* 'set-draft-buffer-modified-nil t)
KaMailV3 で特定のアドレスは除外してbccに自分のアドレスを追加
自分が登録されているメーリングリストへはbccを追加したくなかったので、デフォルトで用意されている方法ではなく、自分で作ってみた。
(defvar *add-bcc-ignore-reciever-list* nil "bccを追加しないアドレスの正規表現のリスト") (defvar *my-address* nil "bccに自動的に追加するアドレス") (defun add-my-address-to-bcc () (let* ((header (draft-header *draft-current*)) (bcc (cdr (assoc "bcc" header :test 'equal))) (cc (cdr (assoc "cc" header :test 'equal))) (to (cdr (assoc "to" header :test 'equal)))) (or (find *my-address* cc :test 'equal) (find *my-address* bcc :test 'equal) (progn (or (listp bcc) (setq bcc (list bcc))) (or (listp cc) (setq cc (list cc))) (or (listp to) (setq to (list to))) (dolist (addr *add-bcc-ignore-reciever-list*) (flet ((match-ignore-receiver (receiver) (string-match addr receiver))) (if (or (some #'match-ignore-receiver to) (some #'match-ignore-receiver cc) (some #'match-ignore-receiver bcc)) (return t))))) (progn (draft-add-header-addr "bcc" *my-address*) (set-buffer-modified-p nil))))) (add-hook '*draft-create-post-hook* 'add-my-address-to-bcc)
KaMailV3 で送信してはいけない文字があった時は、送るかどうか尋ねる。
自分ではこうした文字を積極的に使うことは無いが、返信するときに元の文章に含まれているときぐらいは、そのまま送りたく変更した。
以下を .kamail3/config.l に書いてください。
(defun edit-save-query () (interactive) ; from den8view.l (when (re-search-forward "[\xa0-\xdf\X8540-\X889e\Xeb40-\Xffff]+" t) (ed::show-match) (or (no-or-yes-p "送信してはまずい文字を発見しました。\nそれでも送信しますか？\n") (kamail3-error "送信しちゃまずい文字発見"))) (setf (draft-body *draft-current*) (buffer-substring (point-min) (point-max))) (edit-close) (draft-refresh)) (define-key *edit-map* '(#\C-x #\C-s) 'edit-save-query)
KaMailV3 で、添付ファイルがメールなら、summaryで表示
以前のではエンコーディング等の関係でうまくいかないことがあったみたい。
KaMail3 をよく見たら、summary内にインライン表示する機能が既にあったので
それを利用するにように。
以前のは全て消して、以下を .kamail3/config.l に書いてください。
(in-package "junk") (defun mail-inline-p (headers) (let* ((content-type (mail-get-header-content "content-type" headers)) (mime-type (mail-get-content-mime-type content-type)) (content-disposition (mail-get-header-content "content-disposition" headers)) (content-transfer-encoding (mail-get-header-content "content-transfer-encoding" headers))) (or (not mime-type) (and (or (equalp "text/plain" mime-type) (equalp "message/rfc822" mime-type)) (not (equalp "attachment" (car content-disposition))))) )) (in-package "kamail3")
