1 ;;; action-lock.el --- invoke magic action by RET key on spell strings
3 ;; Copyright (C) 2002, 2003, 2004, 2005-2022
4 ;; HIRAOKA Kazuyuki <khi@users.osdn.me>
6 ;; This program is free software; you can redistribute it and/or modify
7 ;; it under the terms of the GNU General Public License as published by
8 ;; the Free Software Foundation; either version 1, or (at your option)
11 ;; This program is distributed in the hope that it will be useful,
12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;; GNU General Public License for more details.
16 ;; The GNU General Public License is available by anonymouse ftp from
17 ;; prep.ai.mit.edu in pub/gnu/COPYING. Alternately, you can write to
18 ;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
25 ;; rules = (rule rule ...)
26 ;; rule = (regexp action) or (regexp action hilit-pos)
27 ;; action = function with one argument which corresponds to (interactive "P").
32 (require 'cheat-font-lock)
33 (require 'howm-common)
35 (defgroup action-lock nil
36 "Invoke magic action by RET key on spell strings."
39 (defvar action-lock-face 'action-lock-face
40 "*Face for action-lock spells.")
42 (defface action-lock-face
43 (let ((underline (if (and (fboundp 'set-face-underline)
45 '(((class color)) (:underline "dark cyan"))
46 '(((class color)) (:underline t))))
47 (fail-safe '(t (:inverse-video t))))
48 (list underline fail-safe))
49 "*Face for action-lock spells."
53 (defvar action-lock-magic-return-key "\C-m")
54 (put 'action-lock-magic-return-key 'risky-local-variable t)
55 (defvar action-lock-lighter " AL")
56 (defvar action-lock-silent t
57 "Inhibit font-lock-verbose if non-nil.")
59 ;; If you want to change these values,
60 ;; you must set them before loading this file.
61 (defvar action-lock-switch-default '("{ }" "{*}" "{-}")) ;; any number
62 (defvar action-lock-date-default '("{_}" "[%Y-%m-%d %H:%M]")) ;; before after
64 (define-minor-mode action-lock-mode
65 "With no argument, this command toggles the mode.
66 Non-null prefix argument turns on the mode.
67 Null prefix argument turns off the mode.
69 \\[action-lock-magic-return] Envoke the action on the field
71 :init-value nil ;; default = off
72 :lighter action-lock-lighter ;; mode-line
74 (,action-lock-magic-return-key . action-lock-magic-return)
77 (action-lock-initialize-buffer)
78 (action-lock-restore-buffer)))
80 (defvar action-lock-rules nil)
81 (defvar action-lock-original-font-lock-keywords nil)
82 (defvar action-lock-original-return nil)
83 (put 'action-lock-rules 'risky-local-variable t)
84 (put 'action-lock-original-font-lock-keywords 'risky-local-variable t)
85 (put 'action-lock-original-return 'risky-local-variable t)
87 (make-variable-buffer-local 'action-lock-rules)
88 (make-variable-buffer-local 'action-lock-original-font-lock-keywords)
89 (make-variable-buffer-local 'action-lock-original-return)
91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 (defun action-lock-switch (label-list)
95 (let ((regexp (mapconcat 'regexp-quote label-list "\\|")))
96 ; (let ((regexp (regexp-opt label-list))) ;; emacs19 lacks regexp-opt
98 `(lambda (&optional dummy)
99 (let* ((b (match-beginning 0))
101 (ring ',(append label-list (list (car label-list))))
102 (s (match-string-no-properties 0))
103 (next (cadr (member s ring))))
108 (defun action-lock-date (regexp time-format)
110 `(lambda (&optional dummy)
111 (delete-region (match-beginning 0) (match-end 0))
112 (insert (format-time-string ,time-format)))))
114 (defun action-lock-open (regexp arg-pos &optional hilit-pos)
115 (action-lock-general #'action-lock-find-file
116 regexp arg-pos hilit-pos t))
117 (defun action-lock-find-file (f u)
119 (find-file-other-window f)
122 ;; (defun action-lock-open (regexp arg-pos &optional hilit-pos)
123 ;; (action-lock-general #'find-file regexp arg-pos hilit-pos))
125 (defvar action-lock-no-browser nil)
126 (defun action-lock-browse-url (url)
127 (setq url (replace-regexp-in-string "^[htp]+\\(s?\\)://" "http\\1://" url))
129 (if action-lock-no-browser
132 (defun action-lock-browse (regexp arg-pos &optional hilit-pos)
133 (action-lock-general #'action-lock-browse-url regexp arg-pos hilit-pos))
135 (defun action-lock-general (func regexp arg-pos &optional hilit-pos arg-p)
136 "Generate an action-lock rule.
137 FUNC is called when action-lock is invoked on a string which matches
138 to REGEXP. ARG-POS specifies a position of subexpression in REGEXP,
139 and matched substring is passed to FUNC.
140 HILIT-POS specifies another position of subexpression in REGEXP,
141 and matched substring is highlighted in buffers.
142 FUNC will receive an additional argument for action, as is described
143 at the beginning of this file, when ARG-P is non-nil."
145 `(lambda (&optional arg)
146 (,func (match-string ,arg-pos)
147 ,@(and arg-p '(arg))))
150 ; (defun action-lock-escape-quote (s)
152 ; (mapcar '(lambda (x) (if (string= x "'") "\\x27" x)) ;; for zsh
153 ; (split-string s ""))))
155 ;; copied and modified from thingatpt.el [2004-01-30]
156 (defvar action-lock-url-path-regexp
157 "\\([-!@#$%^&*()_+|=:~/?a-zA-Z0-9.,;]*[-!@#$%^&*()_+|=:~/?a-zA-Z0-9]+\\)"
158 ;; "\\([^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+\\)"
159 "A regular expression probably matching the host, path or e-mail part of a URL.")
160 ;; (defvar action-lock-url-scheme-regexp
161 ;; "\\<\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)")
162 (defun action-lock-url-regexp (head &optional tail)
164 action-lock-url-path-regexp
167 (defvar action-lock-open-regexp
168 (action-lock-url-regexp "\\<file://\\(localhost\\)?\\(" "\\>/?\\)"))
169 (defvar action-lock-open-regexp-pos 2)
171 ;; emacs20 doesn't support "[htp]\\{3,5\\}"
172 (defvar action-lock-browse-regexp
173 (action-lock-url-regexp "\\<\\([htp][htp][htp][htp]?[htp]?s?\\|ftp\\)://" "\\>/?"))
174 (defvar action-lock-browse-regexp-pos 0)
176 (defvar action-lock-default-rules
177 (list (action-lock-switch action-lock-switch-default)
178 (action-lock-date (regexp-quote (car action-lock-date-default))
179 (cadr action-lock-date-default))
180 (action-lock-open (action-lock-url-regexp "URL:\\(file://\\)?\\(localhost\\)?" ">))")
182 (action-lock-open action-lock-open-regexp
183 action-lock-open-regexp-pos) ;; file://...
184 (action-lock-browse action-lock-browse-regexp
185 action-lock-browse-regexp-pos) ;; http://...
187 (put 'action-lock-default-rules 'risky-local-variable t)
189 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
192 (defvar action-lock-bury-minor-mode-p t)
193 (defun action-lock-initialize-buffer ()
195 (action-lock-initialize-magic-return)
196 (action-lock-set-rules action-lock-default-rules)
197 (when action-lock-bury-minor-mode-p
198 (action-lock-bury-minor-mode 'action-lock-mode))
201 (defun action-lock-restore-buffer ()
202 (action-lock-restore-font-lock))
204 (defun action-lock-magic-return (&optional arg)
206 (or (action-lock-invoke arg)
208 (let* ((action-lock-mode nil)
209 (f (key-binding action-lock-magic-return-key)))
210 (call-interactively f))
211 ;; Can't happen normally
212 (call-interactively action-lock-original-return))))
214 (defun action-lock-invoke (&optional arg)
216 (let ((action (action-lock-get-action)))
220 ;; (message "%s" action) ;; debug
222 ;; (apply action nil)
225 (defun action-lock-initialize-magic-return ()
226 (when (null action-lock-original-return)
227 (let ((action-lock-mode nil))
228 (setq action-lock-original-return
229 (key-binding action-lock-magic-return-key)))))
231 (defun action-lock-rules ()
233 (defun action-lock-set-rules (rules)
234 (setq action-lock-rules (howm-cl-remove-duplicates* rules))
235 ;; (message "Font lock...")
236 (action-lock-font-lock)
237 ;; (message "...Done.")
239 (defun action-lock-add-rules (rules &optional prepend-p)
240 (action-lock-set-rules (if prepend-p
241 (append rules (action-lock-rules))
242 (append (action-lock-rules) rules))))
244 (defun action-lock-bury-minor-mode (mode)
245 "Bury MODE to the last in minor-mode-map-alist"
246 (let ((pair (assoc mode minor-mode-map-alist)))
248 (setq minor-mode-map-alist
249 ;; Duplications must be removed.
250 `(,@(remove pair minor-mode-map-alist) ,pair)))))
252 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 ;; experimental [2003-10-25]
256 (defvar action-lock-case-fold-search nil)
257 (defvar action-lock-use-case-fold-search t)
259 (defun action-lock-matcher (regexp)
260 (if action-lock-use-case-fold-search
262 (let ((case-fold-search action-lock-case-fold-search))
263 (re-search-forward ,regexp limit t)))
266 (defun action-lock-font-lock ()
267 (cheat-font-lock-mode action-lock-silent)
268 (if (null action-lock-original-font-lock-keywords)
269 (setq action-lock-original-font-lock-keywords font-lock-keywords)
270 (setq font-lock-keywords action-lock-original-font-lock-keywords))
271 (when action-lock-rules
272 (let* ((entries (mapcar (lambda (pair)
273 (let* ((regexp (car pair))
274 (matcher (action-lock-matcher regexp))
275 (pos (or (cl-caddr pair) 0))
276 (hilit (list pos 'action-lock-face
278 (cons matcher hilit)))
280 (cheat-font-lock-append-keywords entries)
281 ;; (cheat-font-lock-prepend-keywords entries)
282 (cheat-font-lock-fontify t)
285 (defun action-lock-restore-font-lock ()
286 (setq font-lock-keywords action-lock-original-font-lock-keywords))
288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290 (defun action-lock-get-action ()
291 (car (action-lock-get-action/range)))
293 (defun action-lock-get-range ()
294 (cdr (action-lock-get-action/range)))
296 (defun action-lock-get-action/range ()
297 (let* ((rules action-lock-rules)
300 (while (and rules (not found))
302 (setq current (car rules)
304 (let* ((regexp (car current))
305 (action (cadr current))
306 (pos (cl-caddr current))
307 (range (action-lock-regexp-range regexp pos)))
309 (setq found (cons action range))))))
312 (defun action-lock-regexp-range (regexp &optional pos)
313 (setq pos (or pos 0))
316 (eol (line-end-position))
318 (case-fold-search (if action-lock-use-case-fold-search
319 action-lock-case-fold-search
323 (while (and (<= (point) c)
324 (re-search-forward regexp eol 'no-error)
326 (let ((beg (match-beginning pos))
327 (end (match-end pos)))
328 (when (and (<= beg c) (< c end))
329 (setq range (list beg end)))))
332 (defun action-lock-regexp ()
333 (mapconcat 'car action-lock-rules "\\|"))
335 (defun action-lock-skip-one-link (reverse)
336 (let* ((r (action-lock-get-range))
337 (border (if reverse 0 1)))
339 (goto-char (nth border r)))))
341 (defun action-lock-goto-next-link (&optional reverse)
343 (let* ((move (if reverse #'backward-char #'forward-char)))
344 (action-lock-skip-one-link reverse)
346 (while (not (action-lock-get-action))
349 (action-lock-skip-one-link reverse))))
351 (defun action-lock-goto-previous-link ()
353 (action-lock-goto-next-link t))
357 (provide 'action-lock)
359 ;;; action-lock.el ends here