OSDN Git Service

update docs for 1.4.6
[howm/howm.git] / action-lock.el
1 ;;; action-lock.el --- invoke magic action by RET key on spell strings
2
3 ;; Copyright (C) 2002, 2003, 2004, 2005-2019
4 ;;   HIRAOKA Kazuyuki <khi@users.osdn.me>
5 ;;
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)
9 ;; any later version.
10 ;;
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.
15 ;;
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,
19 ;; USA.
20
21 ;;; Commentary:
22
23 ;;; Code:
24
25 ;; rules = (rule rule ...)
26 ;; rule = (regexp action) or (regexp action hilit-pos)
27 ;; action = function with one argument which corresponds to (interactive "P").
28
29 (require 'cl-lib)
30 (require 'easy-mmode)
31 (require 'font-lock)
32 (require 'cheat-font-lock)
33 (require 'howm-common)
34
35 (defgroup action-lock nil
36   "Invoke magic action by RET key on spell strings."
37   :group 'convenience)
38
39 (defvar action-lock-face 'action-lock-face
40   "*Face for action-lock spells.")
41
42 (defface action-lock-face
43   (let ((underline (if (and (fboundp 'set-face-underline)
44                             window-system)
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."
50   :group 'action-lock
51   :group 'howm-faces)
52
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.")
58
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
63
64 (easy-mmode-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.
68
69 \\[action-lock-magic-return]  Envoke the action on the field
70 "
71   nil ;; default = off
72   action-lock-lighter ;; mode-line
73   `(
74     (,action-lock-magic-return-key . action-lock-magic-return)
75     ))
76
77 ;; emacs20's easy-mmode-define-minor-mode can't have body. sigh...
78 (add-hook 'action-lock-mode-on-hook 'action-lock-initialize-buffer)
79 (add-hook 'action-lock-mode-off-hook 'action-lock-restore-buffer)
80
81 (defvar action-lock-rules nil)
82 (defvar action-lock-original-font-lock-keywords nil)
83 (defvar action-lock-original-return nil)
84 (put 'action-lock-rules 'risky-local-variable t)
85 (put 'action-lock-original-font-lock-keywords 'risky-local-variable t)
86 (put 'action-lock-original-return 'risky-local-variable t)
87
88 (make-variable-buffer-local 'action-lock-rules)
89 (make-variable-buffer-local 'action-lock-original-font-lock-keywords)
90 (make-variable-buffer-local 'action-lock-original-return)
91
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ;; sample
94
95 (defun action-lock-switch (label-list)
96   (let ((regexp (mapconcat 'regexp-quote label-list "\\|")))
97 ;   (let ((regexp (regexp-opt label-list))) ;; emacs19 lacks regexp-opt
98     (list regexp
99           `(lambda (&optional dummy)
100              (let* ((b (match-beginning 0))
101                     (e (match-end 0))
102                     (ring ',(append label-list (list (car label-list))))
103                     (s (match-string-no-properties 0))
104                     (next (cadr (member s ring))))
105                (delete-region b e)
106                (insert next)
107                (goto-char b))))))
108
109 (defun action-lock-date (regexp time-format)
110   (list regexp
111         `(lambda (&optional dummy)
112            (delete-region (match-beginning 0) (match-end 0))
113            (insert (format-time-string ,time-format)))))
114
115 (defun action-lock-open (regexp arg-pos &optional hilit-pos)
116   (action-lock-general #'action-lock-find-file
117                        regexp arg-pos hilit-pos t))
118 (defun action-lock-find-file (f u)
119   (if u
120       (find-file-other-window f)
121     (find-file f)))
122
123 ;; (defun action-lock-open (regexp arg-pos &optional hilit-pos)
124 ;;   (action-lock-general #'find-file regexp arg-pos hilit-pos))
125
126 (defvar action-lock-no-browser nil)
127 (defun action-lock-browse-url (url)
128   (setq url (replace-regexp-in-string "^[htp]+\\(s?\\)://" "http\\1://" url))
129   (message "%s" url)
130   (if action-lock-no-browser
131       (kill-new url)
132     (browse-url url)))
133 (defun action-lock-browse (regexp arg-pos &optional hilit-pos)
134   (action-lock-general #'action-lock-browse-url regexp arg-pos hilit-pos))
135
136 (defun action-lock-general (func regexp arg-pos &optional hilit-pos arg-p)
137   "Generate an action-lock rule.
138 FUNC is called when action-lock is invoked on a string which matches
139 to REGEXP. ARG-POS specifies a position of subexpression in REGEXP,
140 and matched substring is passed to FUNC.
141 HILIT-POS specifies another position of subexpression in REGEXP,
142 and matched substring is highlighted in buffers.
143 FUNC will receive an additional argument for action, as is described
144 at the beginning of this file, when ARG-P is non-nil."
145   (list regexp
146         `(lambda (&optional arg)
147            (,func (match-string ,arg-pos)
148                   ,@(and arg-p '(arg))))
149         hilit-pos))
150
151 ; (defun action-lock-escape-quote (s)
152 ;   (apply 'concat
153 ;        (mapcar '(lambda (x) (if (string= x "'") "\\x27" x)) ;; for zsh
154 ;                (split-string s ""))))
155
156 ;; copied and modified from thingatpt.el [2004-01-30]
157 (defvar action-lock-url-path-regexp
158   "\\([-!@#$%^&*()_+|=:~/?a-zA-Z0-9.,;]*[-!@#$%^&*()_+|=:~/?a-zA-Z0-9]+\\)"
159 ;;   "\\([^]\t\n \"'()<>[^`{}]*[^]\t\n \"'()<>[^`{}.,;]+\\)"
160   "A regular expression probably matching the host, path or e-mail part of a URL.")
161 ;; (defvar action-lock-url-scheme-regexp
162 ;;   "\\<\\(https?://\\|ftp://\\|gopher://\\|telnet://\\|wais://\\|file:/\\|s?news:\\|mailto:\\)")
163 (defun action-lock-url-regexp (head &optional tail)
164   (concat head
165           action-lock-url-path-regexp
166           (or tail "")))
167
168 (defvar action-lock-open-regexp
169   (action-lock-url-regexp "\\<file://\\(localhost\\)?\\(" "\\>/?\\)"))
170 (defvar action-lock-open-regexp-pos 2)
171
172 ;; emacs20 doesn't support "[htp]\\{3,5\\}"
173 (defvar action-lock-browse-regexp
174   (action-lock-url-regexp "\\<\\([htp][htp][htp][htp]?[htp]?s?\\|ftp\\)://" "\\>/?"))
175 (defvar action-lock-browse-regexp-pos 0)
176
177 (defvar action-lock-default-rules
178   (list (action-lock-switch action-lock-switch-default)
179         (action-lock-date (regexp-quote (car action-lock-date-default))
180                           (cadr action-lock-date-default))
181         (action-lock-open (action-lock-url-regexp "URL:\\(file://\\)?\\(localhost\\)?" ">))")
182                           3) ;; ((<URL:...>))
183         (action-lock-open action-lock-open-regexp
184                           action-lock-open-regexp-pos) ;; file://...
185         (action-lock-browse action-lock-browse-regexp
186                             action-lock-browse-regexp-pos) ;; http://...
187         ))
188 (put 'action-lock-default-rules 'risky-local-variable t)
189
190 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
191 ;; main
192
193 (defvar action-lock-bury-minor-mode-p t)
194 (defun action-lock-initialize-buffer ()
195   (interactive)
196   (action-lock-initialize-magic-return)
197   (action-lock-set-rules action-lock-default-rules)
198   (when action-lock-bury-minor-mode-p
199     (action-lock-bury-minor-mode 'action-lock-mode))
200 )
201
202 (defun action-lock-restore-buffer ()
203   (action-lock-restore-font-lock))
204
205 (defun action-lock-magic-return (&optional arg)
206   (interactive "P")
207   (or (action-lock-invoke arg)
208       (if action-lock-mode
209           (let* ((action-lock-mode nil)
210                  (f (key-binding action-lock-magic-return-key)))
211             (call-interactively f))
212         ;; Can't happen normally
213         (call-interactively action-lock-original-return))))
214
215 (defun action-lock-invoke (&optional arg)
216 ;;   (interactive)
217   (let ((action (action-lock-get-action)))
218     (if (null action)
219         nil
220       (progn
221 ;;         (message "%s" action) ;; debug
222         (funcall action arg)
223 ;;         (apply action nil)
224         t))))
225
226 (defun action-lock-initialize-magic-return ()
227   (when (null action-lock-original-return)
228     (let ((action-lock-mode nil))
229       (setq action-lock-original-return
230             (key-binding action-lock-magic-return-key)))))
231
232 (defun action-lock-rules ()
233   action-lock-rules)
234 (defun action-lock-set-rules (rules)
235   (setq action-lock-rules (howm-cl-remove-duplicates* rules))
236 ;;   (message "Font lock...")
237   (action-lock-font-lock)
238 ;;   (message "...Done.")
239   )
240 (defun action-lock-add-rules (rules &optional prepend-p)
241   (action-lock-set-rules (if prepend-p
242                              (append rules (action-lock-rules))
243                            (append (action-lock-rules) rules))))
244
245 (defun action-lock-bury-minor-mode (mode)
246   "Bury MODE to the last in minor-mode-map-alist"
247   (let ((pair (assoc mode minor-mode-map-alist)))
248     (when pair
249       (setq minor-mode-map-alist
250             ;; Duplications must be removed.
251             `(,@(remove pair minor-mode-map-alist) ,pair)))))
252
253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254 ;; Font lock
255
256 ;; experimental [2003-10-25]
257 (defvar action-lock-case-fold-search nil)
258 (defvar action-lock-use-case-fold-search t)
259
260 (defun action-lock-matcher (regexp)
261   (if action-lock-use-case-fold-search
262       `(lambda (limit)
263          (let ((case-fold-search action-lock-case-fold-search))
264            (re-search-forward ,regexp limit t)))
265     regexp))
266
267 (defun action-lock-font-lock ()
268   (cheat-font-lock-mode action-lock-silent)
269   (if (null action-lock-original-font-lock-keywords)
270       (setq action-lock-original-font-lock-keywords font-lock-keywords)
271     (setq font-lock-keywords action-lock-original-font-lock-keywords))
272   (when action-lock-rules
273     (let* ((entries (mapcar (lambda (pair)
274                               (let* ((regexp (car pair))
275                                      (matcher (action-lock-matcher regexp))
276                                      (pos (or (cl-caddr pair) 0))
277                                      (hilit (list pos 'action-lock-face
278                                                   'prepend)))
279                                 (cons matcher hilit)))
280                             action-lock-rules)))
281       (cheat-font-lock-append-keywords entries)
282 ;;       (cheat-font-lock-prepend-keywords entries)
283       (cheat-font-lock-fontify t)
284       )))
285
286 (defun action-lock-restore-font-lock ()
287   (setq font-lock-keywords action-lock-original-font-lock-keywords))
288
289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290
291 (defun action-lock-get-action ()
292   (car (action-lock-get-action/range)))
293
294 (defun action-lock-get-range ()
295   (cdr (action-lock-get-action/range)))
296
297 (defun action-lock-get-action/range ()
298   (let* ((rules action-lock-rules)
299          (current nil)
300          (found nil))
301     (while (and rules (not found))
302       (save-excursion
303         (setq current (car rules)
304               rules (cdr rules))
305         (let* ((regexp (car current))
306                (action (cadr current))
307                (pos (cl-caddr current))
308                (range (action-lock-regexp-range regexp pos)))
309           (if range
310               (setq found (cons action range))))))
311     found))
312
313 (defun action-lock-regexp-range (regexp &optional pos)
314   (setq pos (or pos 0))
315   (save-excursion
316     (let ((c (point))
317           (eol (line-end-position))
318           (range nil)
319           (case-fold-search (if action-lock-use-case-fold-search
320                                 action-lock-case-fold-search
321                               case-fold-search))
322           )
323       (beginning-of-line)
324       (while (and (<= (point) c)
325                   (re-search-forward regexp eol 'no-error)
326                   (not range))
327         (let ((beg (match-beginning pos))
328               (end (match-end pos)))
329           (when (and (<= beg c) (< c end))
330             (setq range (list beg end)))))
331       range)))
332
333 (defun action-lock-regexp ()
334   (mapconcat 'car action-lock-rules "\\|"))
335
336 (defun action-lock-skip-one-link (reverse)
337   (let* ((r (action-lock-get-range))
338          (border (if reverse 0 1)))
339     (when r
340       (goto-char (nth border r)))))
341
342 (defun action-lock-goto-next-link (&optional reverse)
343   (interactive)
344   (let* ((move (if reverse #'backward-char #'forward-char)))
345     (action-lock-skip-one-link reverse)
346     (funcall move)
347     (while (not (action-lock-get-action))
348       (funcall move))
349     (when reverse
350       (action-lock-skip-one-link reverse))))
351
352 (defun action-lock-goto-previous-link ()
353   (interactive)
354   (action-lock-goto-next-link t))
355
356 ;;;;;;;;;;;;;
357
358 (provide 'action-lock)
359
360 ;;; action-lock.el ends here