OSDN Git Service

set version as 1.4.4-snapshot
[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, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2015, 2016
4 ;;   HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
5 ;; $Id: action-lock.el,v 1.72 2011-12-31 15:07:28 hira Exp $
6 ;;
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)
10 ;; any later version.
11 ;;
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.
16 ;;
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,
20 ;; USA.
21
22 ;;; Commentary:
23
24 ;;; Code:
25
26 ;; rules = (rule rule ...)
27 ;; rule = (regexp action) or (regexp action hilit-pos)
28 ;; action = function with one argument which corresponds to (interactive "P").
29
30 (require 'cl-lib)
31 (require 'easy-mmode)
32 (require 'font-lock)
33 (require 'cheat-font-lock)
34 (require 'howm-common)
35
36 (defgroup action-lock nil
37   "Invoke magic action by RET key on spell strings."
38   :group 'convenience)
39
40 (defvar action-lock-face 'action-lock-face
41   "*Face for action-lock spells.")
42
43 (defface action-lock-face
44   (let ((underline (if (and (fboundp 'set-face-underline)
45                             window-system)
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."
51   :group 'action-lock
52   :group 'howm-faces)
53
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.")
59
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
64
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.
69
70 \\[action-lock-magic-return]  Envoke the action on the field
71 "
72   nil ;; default = off
73   action-lock-lighter ;; mode-line
74   `(
75     (,action-lock-magic-return-key . action-lock-magic-return)
76     ))
77
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)
81
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)
88
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)
92
93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
94 ;; sample
95
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
99     (list regexp
100           `(lambda (&optional dummy)
101              (let* ((b (match-beginning 0))
102                     (e (match-end 0))
103                     (ring ',(append label-list (list (car label-list))))
104                     (s (match-string-no-properties 0))
105                     (next (cadr (member s ring))))
106                (delete-region b e)
107                (insert next)
108                (goto-char b))))))
109
110 (defun action-lock-date (regexp time-format)
111   (list regexp
112         `(lambda (&optional dummy)
113            (delete-region (match-beginning 0) (match-end 0))
114            (insert (format-time-string ,time-format)))))
115
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)
120   (if u
121       (find-file-other-window f)
122     (find-file f)))
123
124 ;; (defun action-lock-open (regexp arg-pos &optional hilit-pos)
125 ;;   (action-lock-general #'find-file regexp arg-pos hilit-pos))
126
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))
130   (message "%s" url)
131   (if action-lock-no-browser
132       (kill-new url)
133     (browse-url url)))
134 (defun action-lock-browse (regexp arg-pos &optional hilit-pos)
135   (action-lock-general #'action-lock-browse-url regexp arg-pos hilit-pos))
136
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."
146   (list regexp
147         `(lambda (&optional arg)
148            (,func (match-string ,arg-pos)
149                   ,@(and arg-p '(arg))))
150         hilit-pos))
151
152 ; (defun action-lock-escape-quote (s)
153 ;   (apply 'concat
154 ;        (mapcar '(lambda (x) (if (string= x "'") "\\x27" x)) ;; for zsh
155 ;                (split-string s ""))))
156
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)
165   (concat head
166           action-lock-url-path-regexp
167           (or tail "")))
168
169 (defvar action-lock-open-regexp
170   (action-lock-url-regexp "\\<file://\\(localhost\\)?\\(" "\\>/?\\)"))
171 (defvar action-lock-open-regexp-pos 2)
172
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)
177
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\\)?" ">))")
183                           3) ;; ((<URL:...>))
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://...
188         ))
189 (put 'action-lock-default-rules 'risky-local-variable t)
190
191 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
192 ;; main
193
194 (defvar action-lock-bury-minor-mode-p t)
195 (defun action-lock-initialize-buffer ()
196   (interactive)
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))
201 )
202
203 (defun action-lock-restore-buffer ()
204   (action-lock-restore-font-lock))
205
206 (defun action-lock-magic-return (&optional arg)
207   (interactive "P")
208   (or (action-lock-invoke arg)
209       (if action-lock-mode
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))))
215
216 (defun action-lock-invoke (&optional arg)
217 ;;   (interactive)
218   (let ((action (action-lock-get-action)))
219     (if (null action)
220         nil
221       (progn
222 ;;         (message "%s" action) ;; debug
223         (funcall action arg)
224 ;;         (apply action nil)
225         t))))
226
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)))))
232
233 (defun action-lock-rules ()
234   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.")
240   )
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))))
245
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)))
249     (when pair
250       (setq minor-mode-map-alist
251             ;; Duplications must be removed.
252             `(,@(remove pair minor-mode-map-alist) ,pair)))))
253
254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
255 ;; Font lock
256
257 ;; experimental [2003-10-25]
258 (defvar action-lock-case-fold-search nil)
259 (defvar action-lock-use-case-fold-search t)
260
261 (defun action-lock-matcher (regexp)
262   (if action-lock-use-case-fold-search
263       `(lambda (limit)
264          (let ((case-fold-search action-lock-case-fold-search))
265            (re-search-forward ,regexp limit t)))
266     regexp))
267
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
279                                                   'prepend)))
280                                 (cons matcher hilit)))
281                             action-lock-rules)))
282       (cheat-font-lock-append-keywords entries)
283 ;;       (cheat-font-lock-prepend-keywords entries)
284       (cheat-font-lock-fontify t)
285       )))
286
287 (defun action-lock-restore-font-lock ()
288   (setq font-lock-keywords action-lock-original-font-lock-keywords))
289
290 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
291
292 (defun action-lock-get-action ()
293   (car (action-lock-get-action/range)))
294
295 (defun action-lock-get-range ()
296   (cdr (action-lock-get-action/range)))
297
298 (defun action-lock-get-action/range ()
299   (let* ((rules action-lock-rules)
300          (current nil)
301          (found nil))
302     (while (and rules (not found))
303       (save-excursion
304         (setq current (car rules)
305               rules (cdr rules))
306         (let* ((regexp (car current))
307                (action (cadr current))
308                (pos (cl-caddr current))
309                (range (action-lock-regexp-range regexp pos)))
310           (if range
311               (setq found (cons action range))))))
312     found))
313
314 (defun action-lock-regexp-range (regexp &optional pos)
315   (setq pos (or pos 0))
316   (save-excursion
317     (let ((c (point))
318           (eol (line-end-position))
319           (range nil)
320           (case-fold-search (if action-lock-use-case-fold-search
321                                 action-lock-case-fold-search
322                               case-fold-search))
323           )
324       (beginning-of-line)
325       (while (and (<= (point) c)
326                   (re-search-forward regexp eol 'no-error)
327                   (not range))
328         (let ((beg (match-beginning pos))
329               (end (match-end pos)))
330           (when (and (<= beg c) (< c end))
331             (setq range (list beg end)))))
332       range)))
333
334 (defun action-lock-regexp ()
335   (mapconcat 'car action-lock-rules "\\|"))
336
337 (defun action-lock-skip-one-link (reverse)
338   (let* ((r (action-lock-get-range))
339          (border (if reverse 0 1)))
340     (when r
341       (goto-char (nth border r)))))
342
343 (defun action-lock-goto-next-link (&optional reverse)
344   (interactive)
345   (let* ((move (if reverse #'backward-char #'forward-char)))
346     (action-lock-skip-one-link reverse)
347     (funcall move)
348     (while (not (action-lock-get-action))
349       (funcall move))
350     (when reverse
351       (action-lock-skip-one-link reverse))))
352
353 (defun action-lock-goto-previous-link ()
354   (interactive)
355   (action-lock-goto-next-link t))
356
357 ;;;;;;;;;;;;;
358
359 (provide 'action-lock)
360
361 ;;; action-lock.el ends here