occur.l

001: (require 'occur)
002: 
003: (setq *occur-regexp* "^¥¥(¥¥*[¥¥*]* ¥¥|; ¥¥* ¥¥)")
004: (setq *my-occur-regexp* "^¥¥(¥¥*[¥¥*]* ¥¥|; ¥¥* ¥¥|(defun ¥¥)")
005: (setq *my-occur-string* nil)
006: 
007: (global-set-key '(#¥C-5 #¥5); 見出し行のリストをポップアップ
008:                 'list-headlines)
009: 
010: (global-set-key '(#¥C-5 #¥l); 見出し行のリストをポップアップ
011:                 'list-headlines)
012: 
013: (global-set-key '(#¥C-5 #¥6); 検索語を含む見出行をpopアップ
014:                 'search-word-in-headlines)
015: 
016: (global-set-key '(#¥C-5 #¥7); occur 検索語を含む行をpopアップ
017:                 'search-string-in-lines)
018: ; 見出し行にかぎらず、検索します。
019: 
020: (global-set-key '(#¥C-5 #¥8); 前回実行した occur 操作の繰り返し
021:                 'repeat-last-occur-work)
022: 
023: ; ひとつ下のレベルの見出し行のリストをポップアップ
024: (global-set-key '(#¥C-5 #¥d); 一つ下位レベルの見出し行をpopup
025:                 'user::occur-directlyunder-heading)
026: 
027: ; 星一つの見出し行だけ
028: (global-set-key '(#¥C-5 #¥o); 星一つの見出し行をpopup
029:                 'user::onestar)
030: 
031: ; 星一つまたは星二つの見出し行だけ
032: ; (File "sitelisp.lnk" "occur.l")
033: (global-set-key '(#¥C-5 #¥t); 星2つまでの見出し行をpopup
034:                 'user::twostar)
035: 
036: ; * occur-suball-heading
037: ; その見出し行より下位のレベルの見出し行のリストをポップアップw
038: ; (File "sitelisp.lnk" "occur.l")
039: ; 
040: (global-set-key '(#¥C-5 #¥a); 下位レベルの見出し行を popup
041:                 'user::occur-suball-heading)
042: 
043: ; * occur-samelevel-heading
044: ; その見出し行と同じレベルの見出し行のリストをポップアップ
045: ; (File "sitelisp.lnk" "occur.l")
046: (global-set-key '(#¥C-5 #¥s); 同位の見出し行をpopup
047:                 'user::occur-samelevel-heading)
048: 
049: ; * previous-samelevel-heading-line
050: ; * following-samelevel-heading-line
051: (global-set-key '(#¥C-5 #¥p) 'previous-samelevel-heading-line)
052: (global-set-key '(#¥C-5 #¥f) 'following-samelevel-heading-line)
053: (global-set-key '(#¥C-5 #¥n) 'following-samelevel-heading-line)
054: 
055: (global-set-key '(#¥C-5 #¥4 #¥5); 見出し行をポップアップ
056:    #'(lambda () (interactive) 
057:        (message "見出し行をポップアップします。")
058:        (setq *lastpos* (point))
059:        (setq *my-occur-regexp* *occur-regexp*)
060:        (setq *my-occur-string* nil)
061:        (my-occur-dialog-box *my-occur-regexp*)))
062: 
063: (global-set-key '(#¥C-5 #¥4 #¥6); 検索語を含む見出行をpopアップ
064:    #'(lambda (str) 
065:      (interactive "sSearch string in headings: ")
066:        (message "検索語を含む見出行をポップアップします。")
067:        (setq *lastpos* (point))
068:        (setq *my-occur-regexp* *occur-regexp*)
069:        (setq *my-occur-string* str)
070:        (my-occur-dialog-box (concat *my-occur-regexp* ".*" str))))
071: 
072: (global-set-key '(#¥C-5 #¥4 #¥7); 検索語を含む行をpopアップ
073:    #'(lambda (str) 
074:      (interactive "sSearch string: ")
075:        (message "検索語を含む行をポップアップします。")
076:        (setq *lastpos* (point))
077:        (setq *my-occur-regexp* nil)
078:        (setq *my-occur-string* str)
079:        (my-occur-dialog-box str)))
080: 
081: (global-set-key '(#¥C-5 #¥4 #¥8); ひとつ前の occur 操作の繰り返し
082:    #'(lambda () (interactive) 
083:        (setq *lastpos* (point))
084:        (cond ((and *my-occur-regexp* *my-occur-string*)
085:               (my-occur-dialog-box (concat *my-occur-regexp* ".*" *my-occur-string*)))
086:              ((not *my-occur-regexp*)
087:               (my-occur-dialog-box *my-occur-string*))
088:              ((not *my-occur-string*)
089:               (my-occur-dialog-box *my-occur-regexp*)))
090:        ))

002: ; occur-dialog-box
003: ; my-occur-dialog-box
004: ; *occur-regexp*
005: ; を export しています。
006: (export '(occur-dialog-box my-occur-dialog-box *occur-regexp*))
007: 
008: (defvar *occur-regexp* "^¥¥(■¥¥|●¥¥|;;;¥¥|;;¥¥|(def¥¥)")
009: (defvar *my-occur-regexp* 
010:       "^¥¥(¥¥*[¥¥*]* ¥¥|; ¥¥* ¥¥|(defun ¥¥)")
011: (defvar *my-occur-string* nil)
012: 
013: (setq *list-box-up-char* #¥p)
014: (setq *list-box-down-char* #¥n)
015: (setq *list-box-def-char* #¥f)
016: (defvar *referred-to-buffer* nil)

017: (defun occur-get-line ()
018:   (save-excursion
019:     (buffer-substring (progn
020:                         (goto-bol)
021:                         (point))
022:                       (progn
023:                         (goto-eol)
024:                         (point)))))

025: (defun occur-make-list (str)
026:   (let (result)
027:     (save-excursion
028:       (goto-char (point-max))
029:       (while
030:           (scan-buffer str :regexp t :reverse t :no-dup t :tail nil)
031:         (let ((midashi (occur-get-line))
032:               (point (point)))
033:           (push (list midashi point) result)
034:           ); end of let loop
035:         ); end of while loop
036:       result)
037:   ))

038: (defvar *occur-dialog-template*
039:   '(dialog 0 0 232 416
040:     (:caption "おかー")
041:     (:font 10 "ＭＳ Ｐゴシック")
042:     (:control
043:      (:listbox list nil #x50a10011 2 2 230 398)
044:      (:button go "go 跳(&G)" #x50030001 2 400 30 12)))
045:   ; ------------------------------------------------------------
046:   ; '(dialog 0 0 232 336
047:   ;  (:caption "おかー")
048:   ;  (:font 10 "ＭＳ Ｐゴシック")
049:   ;  (:control
050:   ;   (:listbox list nil #x50a10011 2 2 230 318)
051:   ;   (:button go "跳(&G)" #x50030001 2 320 30 12)))
052:   ; ------------------------------------------------------------
053:   ; (dialog 0 0 W+2 H+18
054:   ;  (:caption "おかー")
055:   ;  (:font 10 "ＭＳ Ｐゴシック")
056:   ;  (:control
057:   ;   (:listbox list nil #x50a10011 2 2 W H)
058:   ;   (:button go "跳(&G)" #x50030001 2 H+2 30 12)))
059:   ; ------------------------------------------------------------
060:   )

061: (defun occur-dialog-box (str)
062:   (interactive "s正規表現: " :default0 *occur-regexp*)
063:   (setq *referred-to-buffer* (selected-buffer))
064:   (let ((strings (occur-make-list str))
065:         choice)
066:     (multiple-value-bind (result data)
067:         (dialog-box *occur-dialog-template*
068:                     (list (cons 'list strings))
069:                     '((list :column (80 0 -6 228) :must-match t :enable (go))))
070:       (cond ((eq result 'go)
071:              (setq choice (caddr (assoc 'list data)))
072:              (setq *my-occur-lchoice* choice)    
073:              (occur-goto choice))
074:             (t nil)))))

075: (defun occur-goto (point)
076:   (interactive)
077:   (set-buffer *referred-to-buffer*)
078:   (goto-char point))
079: 
080: ; (global-set-key #¥C-F4 'occur-dialog-box)

081: (defun my-occur-dialog-box (str)
082:   (interactive "s正規表現: " :default0 *occur-regexp*)
083:   (setq *referred-to-buffer* (selected-buffer))
084:   (let ((strings (my-occur-make-list str (point-min) (point-max)))
085:         choice line)
086:     (multiple-value-bind (result data)
087:         (dialog-box *occur-dialog-template*
088:                     (list (cons 'list strings))
089:                     '((list :column (80 0 -6 228) :must-match t :enable (go))))
090:       (cond ((eq result 'go)
091:              (setq choice (caddr (assoc 'list data)))
092:              (setq line (cadr (assoc 'list data)))
093:              (setq *my-occur-lchoice* choice)    
094:              (occur-goto choice)
095:              (message line)
096:              )
097:             (t nil)))))

098: (defun list-headlines ()
099:   (interactive)
100:   (setq *lastpos* (point))
101:   (setq *my-occur-regexp* *occur-regexp*)
102:   (setq *my-occur-string* nil)
103:   (my-occur-dialog-box *my-occur-regexp*))

104: (defun my-occur-region-dialog-box (str pmin pmax)
105:   (interactive "s正規表現: " :default0 *occur-regexp*)
106:   (setq *referred-to-buffer* (selected-buffer))
107:   (let ((strings (my-occur-make-list str pmin pmax))
108:         choice line)
109:     (multiple-value-bind (result data)
110:         (dialog-box *occur-dialog-template*
111:                     (list (cons 'list strings))
112:                     '((list :column (80 0 -6 228) 
113:                             :must-match t :enable (go))))
114:       (cond ((eq result 'go)
115:              (setq choice (caddr (assoc 'list data)))
116:              (setq line (cadr (assoc 'list data)))
117:              (setq *my-occur-lchoice* choice)    
118:              (occur-goto choice)
119:              (message line)
120:              )
121:             (t nil)))))

122: (defun my-occur-make-list (str pmin pmax)
123:   (let (result)
124:     (save-excursion
125:       ; (goto-char (point-max))
126:       (goto-char pmax)
127:       (while
128:           (scan-buffer str :regexp t :reverse t :no-dup t :tail nil :limit pmin)
129:         (let ((midashi (my-occur-get-line))
130:               (point (point)))
131:           (push (list midashi point) result)
132:           ); end of let loop
133:         ); end of while loop
134:       result)
135:   ))

136: (defun my-occur-get-line ()
137:   (save-excursion
138:     (let (midashi cpos)
139:       (setq midashi
140:             (buffer-substring 
141:              (progn (goto-bol) (point))
142:              (progn (goto-eol) (point))))
143:       (if (string-match "^[*]+ " midashi)
144:           (progn
145:             (goto-bol)
146:             (setq midashi (user::headingline)))
147:         (setq midashi (concat " " midashi))
148:         )
149:       midashi)
150:     ))

151: (defun same-level-headline-position ()
152:   (interactive)
153:   (let (tmpstr nstar mstar bool cpos tpos)
154:     (setq cpos (point))
155:     (goto-bol)
156:     (re-search-backward "^¥¥*[¥¥*]* [^ ]")
157:     ;
158:     ; 現在の見出し行の行頭から行末までの文字列を tmpstr に格納す
159:     ; る
160:     (setq tmpstr (buffer-substring (progn (goto-bol) (point))
161:                                    (progn (goto-eol) (point))))
162:     (goto-bol)
163:     ;
164:     ; つぎの２行で、行頭の * の個数を数えて、nstar に格納する
165:     (string-match "^¥¥([¥*][¥*]*¥¥) .*" tmpstr)
166:     (setq nstar (length (string-replace-match tmpstr "¥¥1")))
167:     ;
168:     (forward-line 1)
169:     (loop
170:       (setq bool (re-search-forward "^[¥*][¥*]* [^ ]" t))
171:       (if (not bool)
172:           (progn
173:             (message-box "見出し行が見つかりません。")
174:             (call-process (concat (si:system-root) "xyzzycli.exe"))
175:             (goto-char cpos)
176:             (return-from same-level-headline-position cpos)))
177:       ;
178:       ; つぎの５行で、行頭の * の個数を数えて、mstar に格納する
179:       (setq tmpstr (buffer-substring (progn (goto-bol) (point))
180:                                      (progn (goto-eol) (point))))
181:       (goto-bol)
182:       (string-match "^¥¥([¥*][¥*]*¥¥) .*" tmpstr)
183:       (setq mstar (length (string-replace-match tmpstr "¥¥1")))
184:       ;
185:       (if (= mstar nstar)
186:         (progn
187:           (setq tpos (point))
188:           (goto-char cpos)
189:           (return-from same-level-headline-position tpos))
190:       )
191:       (if (< mstar nstar)
192:         (progn
193:           (setq tpos (point))
194:           (goto-char cpos)
195:           (return-from same-level-headline-position tpos))
196:       )
197:       (forward-line 1)
198:       )      
199:     ))

200: (defun user::occur-suball-heading (num)
201:   (interactive "P")
202:   (let (pmin pmax cpos)
203:     (setq user::*lastjumptype* "up-headline")
204:     (setq cpos (point))
205:     (if num (user::upstar))
206:     (goto-bol)
207:     (re-search-backward "^¥¥*[¥¥*]* [^ ]")
208:     (setq pmin (point))
209:     (setq pmax (same-level-headline-position))
210:     (if num (goto-char cpos))
211:     (user::my-occur-region-dialog-box 
212:        "^¥¥*[¥¥*]* [^ ]" pmin pmax)
213:   ))

214: (defun user::occur-directlyunder-heading (num)
215:   (interactive "P")
216:   (let (pmin pmax cpos nstar)
217:     (setq cpos (point))
218:     (goto-eol)
219:     (re-search-backward "^¥¥*[¥¥*]* [^ ]")
220:     (if num (user::upstar))
221: ;    (goto-eol)
222: ;    (re-search-backward "^¥¥*[¥¥*]* [^ ]")
223:     (let (tmpstr)
224:       (setq tmpstr (buffer-substring (progn (goto-bol) (point))
225:                                    (progn (goto-eol) (point))))
226:       (goto-bol)
227:       ;
228:       ; つぎの２行で、行頭の * の個数を数えて、nstar に格納する
229:       (string-match "^¥¥([¥*][¥*]*¥¥) .*" tmpstr)
230:       (setq nstar (length (string-replace-match tmpstr "¥¥1")))
231:     )
232:     (setq pmin (point))
233:     (setq pmax (same-level-headline-position))
234:     (if num (goto-char cpos))
235:     (cond 
236:       ((= nstar 1)
237:           (user::my-occur-region-dialog-box 
238:            "^¥¥(¥¥*¥¥*¥¥|¥¥*¥¥) [^ ]" pmin pmax))
239:       ((= nstar 2)
240:        (user::my-occur-region-dialog-box 
241:          "^¥¥(¥¥*¥¥*¥¥*¥¥|¥¥*¥¥*¥¥) [^ ]" pmin pmax))
242:       ((= nstar 3)
243:        (user::my-occur-region-dialog-box 
244:          "^¥¥(¥¥*¥¥*¥¥*¥¥*¥¥|¥¥*¥¥*¥¥*¥¥) [^ ]" pmin pmax))
245:       ((= nstar 4)
246:        (user::my-occur-region-dialog-box 
247:          "^¥¥(¥¥*¥¥*¥¥*¥¥*¥¥*¥¥|¥¥*¥¥*¥¥*¥¥*¥¥) [^ ]" pmin pmax))
248:       ((> nstar 5)
249:        (user::my-occur-region-dialog-box 
250:          "^¥¥(¥¥*¥¥*¥¥*¥¥*¥¥*[¥¥*]*) [^ ]" pmin pmax))
251:          )
252:     )
253:   )

254: (defun user::occur-samelevel-heading ()
255:   (interactive)
256:   (let (cpos nstar)
257:     (setq cpos (point))
258:     (goto-eol)
259:     (re-search-backward "^¥¥*[¥¥*]* [^ ]")
260:     (let (tmpstr)
261:       (setq tmpstr (buffer-substring (progn (goto-bol) (point))
262:                                    (progn (goto-eol) (point))))
263:       (goto-bol)
264:       ;
265:       ; つぎの２行で、行頭の * の個数を数えて、nstar に格納する
266:       (string-match "^¥¥([¥*][¥*]*¥¥) .*" tmpstr)
267:       (setq nstar (length (string-replace-match tmpstr "¥¥1")))
268:     )
269:     (goto-char cpos)
270:     (if (= nstar 1)
271:         (user::onestar)
272:       (user::occur-directlyunder-heading 1)
273:       )
274:     )
275:   )

276: (defun user::upstar ()
277:   (interactive)
278:   (let (cpos tmpstr nstar mstar)
279:     (setq user::*lastpos* (point))
280:     ; (setq user::*lastjumptype* "up-headline")
281:     (setq *lastfunc* 'upstar)
282:     (setq cpos (point))
283:     (goto-bol)
284:     (re-search-backward "^¥¥*[¥¥*]* [^ ]")
285:     ;
286:     ; 現在の見出し行の行頭から行末までの文字列を tmpstr に格納す
287:     ; る
288:     (setq tmpstr (buffer-substring (progn (goto-bol) (point))
289:                                    (progn (goto-eol) (point))))
290:     (goto-bol)
291:     ;
292:     ; つぎの２行で、行頭の * の個数を数えて、nstar に格納する
293:     (string-match "^¥¥([¥*][¥*]*¥¥) .*" tmpstr)
294:     (setq nstar (length (string-replace-match tmpstr "¥¥1")))
295:     (if (= nstar 1)
296:         (progn
297:           (message "これより上のレベルの見出しはありません。")
298:           (return-from user::upstar))
299:       )
300:     (forward-line -1)
301:     (loop
302:       (re-search-backward "^[¥*][¥*]* [^ ]" t)
303:       ; つぎの５行で、行頭の * の個数を数えて、mstar に格納する
304:       (setq tmpstr (buffer-substring (progn (goto-bol) (point))
305:                                      (progn (goto-eol) (point))))
306:       (goto-bol)
307:       (string-match "^¥¥([¥*][¥*]*¥¥) .*" tmpstr)
308:       (setq mstar (length (string-replace-match tmpstr "¥¥1")))
309:       (if (< mstar nstar)
310:           ; move-to-sixth-line は kh-base.l で定義されています。
311:           ; (File *my-sitelisp* "kh-base.l")
312:           (progn
313:             (refresh-screen)
314:             (user::move-to-sixth-line)
315:             (return-from user::upstar))
316:         )
317:       (forward-line -1)
318:       )
319:     )
320:   )

321: (defun user::onestar ()
322:    (interactive)
323:    (setq user::*lastpos* (point))
324:    (setq *my-occur-regexp* *occur-regexp*)
325:    (setq *my-occur-string* nil)
326:    (my-occur-dialog-box "^¥¥* "))

327: (defun user::twostar ()
328:    (interactive) 
329:    (setq user::*lastpos* (point))
330:    (setq *my-occur-regexp* *occur-regexp*)
331:    (setq *my-occur-string* nil)
332:   (my-occur-dialog-box "^¥¥(¥¥* ¥¥|¥¥*¥¥* ¥¥)"))

333: (defun user::popup-suball-heading ()
334:   (interactive)
335:   (goto-previous-heading-line)
336:   (call-interactively 'occur-suball-heading)
337:   )

338: (defun search-word-in-headlines (str)
339:   (interactive "sSearch string in headings: ")
340:   (setq *lastpos* (point))
341:   (setq *my-occur-regexp* *occur-regexp*)
342:   (setq *my-occur-string* str)
343:   (my-occur-dialog-box (concat *my-occur-regexp* ".*" str))
344:   (setq *lastfunc* 'repeat-last-occur-work)
345:   )

346: (defun search-string-in-lines (str)
347:      (interactive "sSearch string: ")
348:        (setq *lastfunc* 'repeat-last-occur-work)
349:        (setq *lastpos* (point))
350:        (setq *my-occur-regexp* nil)
351:        (setq *my-occur-string* str)
352:        (my-occur-dialog-box str))

353: (defun repeat-last-occur-work ()
354:   (interactive)
355:   (setq *lastfunc* 'repeat-last-occur-work)
356:   (setq *lastpos* (point))
357:   (cond ((and *my-occur-regexp* *my-occur-string*)
358:          (occur-dialog-box (concat *my-occur-regexp* ".*" *my-occur-string*)))
359:         ((not *my-occur-regexp*)
360:          (my-occur-dialog-box *my-occur-string*))
361:         ((not *my-occur-string*)
362:          (my-occur-dialog-box *my-occur-regexp*)))
363:   )

364: (provide "occur")