1 ;;; action-lock.el --- invoke magic action by RET key on spell strings
3 ;; Copyright (C) 2002, 2003, 2004, 2005-2018
4 ;; HIRAOKA Kazuyuki <khi@users.osdn.me>
5 ;; $Id: action-lock.el,v 1.72 2011-12-31 15:07:28 hira Exp $
7 ;; This program is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 1, or (at your option)
12 ;; This program is distributed in the hope that it will be useful,
13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;; GNU General Public License for more details.
17 ;; The GNU General Public License is available by anonymouse ftp from
18 ;; prep.ai.mit.edu in pub/gnu/COPYING. Alternately, you can write to
19 ;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
26 ;; rules = (rule rule ...)
27 ;; rule = (regexp action) or (regexp action hilit-pos)
28 ;; action = function with one argument which corresponds to (interactive "P").
33 (require 'cheat-font-lock)
34 (require 'howm-common)
36 (defgroup action-lock nil
37 "Invoke magic action by RET key on spell strings."
40 (defvar action-lock-face 'action-lock-face
41 "*Face for action-lock spells.")
43 (defface action-lock-face
44 (let ((underline (if (and (fboundp 'set-face-underline)
46 '(((class color)) (:underline "dark cyan"))
47 '(((class color)) (:underline t))))
48 (fail-safe '(t (:inverse-video t))))
49 (list underline fail-safe))
50 "*Face for action-lock spells."
54 (defvar action-lock-magic-return-key "\C-m")
55 (put 'action-lock-magic-return-key 'risky-local-variable t)
56 (defvar action-lock-lighter " AL")
57 (defvar action-lock-silent t
58 "Inhibit font-lock-verbose if non-nil.")
60 ;; If you want to change these values,
61 ;; you must set them before loading this file.
62 (defvar action-lock-switch-default '("{ }" "{*}" "{-}")) ;; any number
63 (defvar action-lock-date-default '("{_}" "[%Y-%m-%d %H:%M]")) ;; before after
65 (easy-mmode-define-minor-mode action-lock-mode
66 "With no argument, this command toggles the mode.
67 Non-null prefix argument turns on the mode.
68 Null prefix argument turns off the mode.
70 \\[action-lock-magic-return] Envoke the action on the field
73 action-lock-lighter ;; mode-line
75 (,action-lock-magic-return-key . action-lock-magic-return)
78 ;; emacs20's easy-mmode-define-minor-mode can't have body. sigh...
79 (add-hook 'action-lock-mode-on-hook 'action-lock-initialize-buffer)
80 (add-hook 'action-lock-mode-off-hook 'action-lock-restore-buffer)
82 (defvar action-lock-rules nil)
83 (defvar action-lock-original-font-lock-keywords nil)
84 (defvar action-lock-original-return nil)
85 (put 'action-lock-rules 'risky-local-variable t)
86 (put 'action-lock-original-font-lock-keywords 'risky-local-variable t)
87 (put 'action-lock-original-return 'risky-local-variable t)
89 (make-variable-buffer-local 'action-lock-rules)
90 (make-variable-buffer-local 'action-lock-original-font-lock-keywords)
91 (make-variable-buffer-local 'action-lock-original-return)
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
96 (defun action-lock-switch (label-list)
97 (let ((regexp (mapconcat 'regexp-quote label-list "\\|")))
98 ; (let ((regexp (regexp-opt label-list))) ;; emacs19 lacks regexp-opt
100 `(lambda (&optional dummy)
101 (let* ((b (match-beginning 0))
103 (ring ',(append label-list (list (car label-list))))
104 (s (match-string-no-properties 0))
105 (next (cadr (member s ring))))
110 (defun action-lock-date (regexp time-format)
112 `(lambda (&optional dummy)
113 (delete-region (match-beginning 0) (match-end 0))
114 (insert (format-time-string ,time-format)))))
116 (defun action-lock-open (regexp arg-pos &optional hilit-pos)
117 (action-lock-general #'action-lock-find-file
118 regexp arg-pos hilit-pos t))
119 (defun action-lock-find-file (f u)
121 (find-file-other-window f)
124 ;; (defun action-lock-open (regexp arg-pos &optional hilit-pos)
125 ;; (action-lock-general #'find-file regexp arg-pos hilit-pos))
127 (defvar action-lock-no-browser nil)
128 (defun action-lock-browse-url (url)
129 (setq url (replace-regexp-in-string "^[htp]+\\(s?\\)://" "http\\1://" url))
131 (if action-lock-no-browser
134 (defun action-lock-browse (regexp arg-pos &optional hilit-pos)
135 (action-lock-general #'action-lock-browse-url regexp arg-pos hilit-pos))
137 (defun action-lock-general (func regexp arg-pos &optional hilit-pos arg-p)
138 "Generate an action-lock rule.
139 FUNC is called when action-lock is invoked on a string which matches
140 to REGEXP. ARG-POS specifies a position of subexpression in REGEXP,
141 and matched substring is passed to FUNC.
142 HILIT-POS specifies another position of subexpression in REGEXP,
143 and matched substring is highlighted in buffers.
144 FUNC will receive an additional argument for action, as is described
145 at the beginning of this file, when ARG-P is non-nil."
147 `(lambda (&optional arg)
148 (,func (match-string ,arg-pos)
149 ,@(and arg-p '(arg))))
152 ; (defun action-lock-escape-quote (s)
154 ; (mapcar '(lambda (x) (if (string= x "'") "\\x27" x)) ;; for zsh
155 ; (split-string s ""))))
157 ;; copied and modified from thingatpt.el [2004-01-30]
158 (defvar action-lock-url-path-regexp
159 "\\([-!@#$%^&*()_+|=:~/?a-zA-Z0-9.,;]*[-!@#$%^&*()_+|=:~/?a-zA-Z0-9]+\\)"
160 ;; "\\([^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+\\)"
161 "A regular expression probably matching the host, path or e-mail part of a URL.")
162 ;; (defvar action-lock-url-scheme-regexp
163 ;; "\\<\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)")
164 (defun action-lock-url-regexp (head &optional tail)
166 action-lock-url-path-regexp
169 (defvar action-lock-open-regexp
170 (action-lock-url-regexp "\\<file://\\(localhost\\)?\\(" "\\>/?\\)"))
171 (defvar action-lock-open-regexp-pos 2)
173 ;; emacs20 doesn't support "[htp]\\{3,5\\}"
174 (defvar action-lock-browse-regexp
175 (action-lock-url-regexp "\\<\\([htp][htp][htp][htp]?[htp]?s?\\|ftp\\)://" "\\>/?"))
176 (defvar action-lock-browse-regexp-pos 0)
178 (defvar action-lock-default-rules
179 (list (action-lock-switch action-lock-switch-default)
180 (action-lock-date (regexp-quote (car action-lock-date-default))
181 (cadr action-lock-date-default))
182 (action-lock-open (action-lock-url-regexp "URL:\\(file://\\)?\\(localhost\\)?" ">))")
184 (action-lock-open action-lock-open-regexp
185 action-lock-open-regexp-pos) ;; file://...
186 (action-lock-browse action-lock-browse-regexp
187 action-lock-browse-regexp-pos) ;; http://...
189 (put 'action-lock-default-rules 'risky-local-variable t)
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
194 (defvar action-lock-bury-minor-mode-p t)
195 (defun action-lock-initialize-buffer ()
197 (action-lock-initialize-magic-return)
198 (action-lock-set-rules action-lock-default-rules)
199 (when action-lock-bury-minor-mode-p
200 (action-lock-bury-minor-mode 'action-lock-mode))
203 (defun action-lock-restore-buffer ()
204 (action-lock-restore-font-lock))
206 (defun action-lock-magic-return (&optional arg)
208 (or (action-lock-invoke arg)
210 (let* ((action-lock-mode nil)
211 (f (key-binding action-lock-magic-return-key)))
212 (call-interactively f))
213 ;; Can't happen normally
214 (call-interactively action-lock-original-return))))
216 (defun action-lock-invoke (&optional arg)
218 (let ((action (action-lock-get-action)))
222 ;; (message "%s" action) ;; debug
224 ;; (apply action nil)
227 (defun action-lock-initialize-magic-return ()
228 (when (null action-lock-original-return)
229 (let ((action-lock-mode nil))
230 (setq action-lock-original-return
231 (key-binding action-lock-magic-return-key)))))
233 (defun action-lock-rules ()
235 (defun action-lock-set-rules (rules)
236 (setq action-lock-rules (howm-cl-remove-duplicates* rules))
237 ;; (message "Font lock...")
238 (action-lock-font-lock)
239 ;; (message "...Done.")
241 (defun action-lock-add-rules (rules &optional prepend-p)
242 (action-lock-set-rules (if prepend-p
243 (append rules (action-lock-rules))
244 (append (action-lock-rules) rules))))
246 (defun action-lock-bury-minor-mode (mode)
247 "Bury MODE to the last in minor-mode-map-alist"
248 (let ((pair (assoc mode minor-mode-map-alist)))
250 (setq minor-mode-map-alist
251 ;; Duplications must be removed.
252 `(,@(remove pair minor-mode-map-alist) ,pair)))))
254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257 ;; experimental [2003-10-25]
258 (defvar action-lock-case-fold-search nil)
259 (defvar action-lock-use-case-fold-search t)
261 (defun action-lock-matcher (regexp)
262 (if action-lock-use-case-fold-search
264 (let ((case-fold-search action-lock-case-fold-search))
265 (re-search-forward ,regexp limit t)))
268 (defun action-lock-font-lock ()
269 (cheat-font-lock-mode action-lock-silent)
270 (if (null action-lock-original-font-lock-keywords)
271 (setq action-lock-original-font-lock-keywords font-lock-keywords)
272 (setq font-lock-keywords action-lock-original-font-lock-keywords))
273 (when action-lock-rules
274 (let* ((entries (mapcar (lambda (pair)
275 (let* ((regexp (car pair))
276 (matcher (action-lock-matcher regexp))
277 (pos (or (cl-caddr pair) 0))
278 (hilit (list pos 'action-lock-face
280 (cons matcher hilit)))
282 (cheat-font-lock-append-keywords entries)
283 ;; (cheat-font-lock-prepend-keywords entries)
284 (cheat-font-lock-fontify t)
287 (defun action-lock-restore-font-lock ()
288 (setq font-lock-keywords action-lock-original-font-lock-keywords))
290 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
292 (defun action-lock-get-action ()
293 (car (action-lock-get-action/range)))
295 (defun action-lock-get-range ()
296 (cdr (action-lock-get-action/range)))
298 (defun action-lock-get-action/range ()
299 (let* ((rules action-lock-rules)
302 (while (and rules (not found))
304 (setq current (car rules)
306 (let* ((regexp (car current))
307 (action (cadr current))
308 (pos (cl-caddr current))
309 (range (action-lock-regexp-range regexp pos)))
311 (setq found (cons action range))))))
314 (defun action-lock-regexp-range (regexp &optional pos)
315 (setq pos (or pos 0))
318 (eol (line-end-position))
320 (case-fold-search (if action-lock-use-case-fold-search
321 action-lock-case-fold-search
325 (while (and (<= (point) c)
326 (re-search-forward regexp eol 'no-error)
328 (let ((beg (match-beginning pos))
329 (end (match-end pos)))
330 (when (and (<= beg c) (< c end))
331 (setq range (list beg end)))))
334 (defun action-lock-regexp ()
335 (mapconcat 'car action-lock-rules "\\|"))
337 (defun action-lock-skip-one-link (reverse)
338 (let* ((r (action-lock-get-range))
339 (border (if reverse 0 1)))
341 (goto-char (nth border r)))))
343 (defun action-lock-goto-next-link (&optional reverse)
345 (let* ((move (if reverse #'backward-char #'forward-char)))
346 (action-lock-skip-one-link reverse)
348 (while (not (action-lock-get-action))
351 (action-lock-skip-one-link reverse))))
353 (defun action-lock-goto-previous-link ()
355 (action-lock-goto-next-link t))
359 (provide 'action-lock)
361 ;;; action-lock.el ends here