root/lang/gauche/oldtype/branches/stable/Kahua/oldtype/oldtype/oldtype-mode.el @ 30558

Revision 30558, 26.4 kB (checked in by kiyoka, 4 years ago)
Line 
1;;;-*- mode: lisp-interaction; syntax: elisp -*-;;;
2;;
3;; "oldtype-mode.el" is an WYSIWYG majar mode for OldType format
4;;
5;;   Copyright (C) 2007 Kiyoka Nishiyama
6;;
7;;     $Id: oldtype-mode.el 242 2008-02-02 09:58:22Z kiyoka $
8;;
9;; This file is part of oldtype-mode
10;;
11;; oldtype-mode is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation; either version 2, or (at your option)
14;; any later version.
15;;
16;; oldtype-mode is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19;; GNU General Public License for more details.
20;;
21;; You should have received a copy of the GNU General Public License
22;; along with OldType; see the file COPYING.
23;;
24;;
25;;
26;; How to nstall and How to use:
27;;     http://oldtype.sumibi.org/show-page/oldtype-mode
28;;
29;;
30;; ChangeLog:
31;;   [0.1.1]
32;;     1. Supported URL to ##(nicovideo ID) command conversion feature.  ( C-c C-c key )
33;;
34;;   [0.1.0]
35;;     1. Added oldtype-todays-entry() function.
36;;
37;;   [0.0.9]
38;;     1. Bugfix: 'Converting URL to ##(amazon ASIN) command' feature generates wrong ASIN code.
39;;
40;;   [0.0.8]
41;;     1. Fixed bug: illegal ASINCODE of amazon and VIDEOCODE of youtube use for image file creation.
42;;
43;;   [0.0.7]
44;;     1. Fixed bug: Added The '-' character to ASINCODE of amazon and VIDEOCODE of youtube.
45;;
46;;   [0.0.6]
47;;     1. Improved URL to [URL|TITLE] conversion feature.  ( C-c C-c key )
48;;        oldtype-mode.el fetches remote title page and insert TITLE.
49;;
50;;   [0.0.5]
51;;     1. Fixed bug: [return] key breaks japanese input method UI.
52;;
53;;   [0.0.4]
54;;     1. Added image displaying feature for ##(amazon  asincode)  command.
55;;     2. Added image displaying feature for ##(youtube videocode) command.
56;;
57;;   [0.0.3]
58;;     1. Supported URL to ##(amazon ASIN) command conversion feature.  ( C-c C-c key )
59;;
60;;   [0.0.2]
61;;     1. Added ##(todo),##(undo) command.
62;;     2. Added oldtype-openfile( wikiname ) function.
63;;
64;;   [0.0.1]
65;;     1. first release
66;;
67;;
68(defconst oldtype-version "0.1.1")
69
70(defconst oldtype-wikiname-face 'oldtype-wikiname-face)
71(defface  oldtype-wikiname-face
72  '((((class color) (background light)) (:bold nil :foreground "green4" :underline t))
73    (((class color) (background dark))  (:bold nil :foreground "green2" :underline t))
74    (t                                  (:bold nil :underline t)))
75  "Face used for wikiname."
76  :group 'oldtype)
77(defconst oldtype-wikiname-nofile-face 'oldtype-wikiname-nofile-face)
78(defface  oldtype-wikiname-nofile-face
79  '((((class color) (background light)) (:bold nil :foreground "green4" :underline nil))
80    (((class color) (background dark))  (:bold nil :foreground "green2" :underline nil))
81    (t                                  (:bold nil :underline nil)))
82  "Face used for wikiname (nofile)."
83  :group 'oldtype)
84(defconst oldtype-indent1-face 'oldtype-indent1-face)
85(defface  oldtype-indent1-face
86  '((((class color) (background light)) (:bold nil :background "red" :underline nil))
87    (((class color) (background dark))  (:bold nil :background "red" :underline nil))
88    (t                                  (:bold nil :underline nil)))
89  "Face used for indent pattern."
90  :group 'oldtype)
91(defconst oldtype-indent2-face 'oldtype-indent2-face)
92(defface  oldtype-indent2-face
93  '((((class color) (background light)) (:bold nil :background "light salmon" :underline nil))
94    (((class color) (background dark))  (:bold nil :background "light salmon" :underline nil))
95    (t                                  (:bold nil :underline nil)))
96  "Face used for indent pattern."
97  :group 'oldtype)
98(defconst oldtype-indent3-face 'oldtype-indent3-face)
99(defface  oldtype-indent3-face
100  '((((class color) (background light)) (:bold nil :background "pink" :underline nil))
101    (((class color) (background dark))  (:bold nil :background "pink" :underline nil))
102    (t                                  (:bold nil :underline nil)))
103  "Face used for indent pattern."
104  :group 'oldtype)
105(defconst oldtype-subject-face 'oldtype-subject-face)
106(defface  oldtype-subject-face
107  '((((class color) (background light)) (:bold t :underline nil))
108    (((class color) (background dark))  (:bold t :underline nil))
109    (t                                  (:bold t :underline nil)))
110  "Face used for subject pattern."
111  :group 'oldtype)
112(defconst oldtype-hr-face 'oldtype-hr-face)
113(defface  oldtype-hr-face
114  '((((class color) (background light)) (:bold nil :background "dark slate gray" :underline nil))
115    (((class color) (background dark))  (:bold nil :background "dark slate gray" :underline nil))
116    (t                                  (:bold nil :underline nil)))
117  "Face used for hr pattern."
118  :group 'oldtype)
119(defconst oldtype-pre-face 'oldtype-pre-face)
120(defface  oldtype-pre-face
121  '((((class color) (background light)) (:bold nil :background "deep sky blue" :underline nil))
122    (((class color) (background dark))  (:bold nil :background "deep sky blue" :underline nil))
123    (t                                  (:bold nil :underline nil)))
124  "Face used for pre pattern."
125  :group 'oldtype)
126(defconst oldtype-alink-face     'link)
127(defconst oldtype-code-face      'font-lock-doc-face)
128(defconst oldtype-etc-face       'shadow)
129(defconst oldtype-image-face     'font-lock-comment-face)
130
131(defun oldtype-warning (format &rest args)
132  (apply 'message (concat "OldType Warning: " format) args)
133  (beep)
134  (sleep-for 1))
135
136(defconst oldtype-image-height-s 40)
137(defconst oldtype-image-height-m 80)
138
139(defconst oldtype-image-icon-string
140  "H_")
141
142(defconst oldtype-ext-name
143  ".ot")
144
145(defconst oldtype-allpages-wikiname
146  "#AllPages.ot")
147
148(defconst oldtype-image-prefix-list
149  '("bmp"    "gif"    "jpeg"    "jpg"    "png"    "svg"    "tiff"    "tif"    "xbm"    "xpm"))
150
151(defconst oldtype-imgurl-pattern
152  (concat "\\(.+\\)\\.\\("
153          (mapconcat
154           (lambda (str) str)
155           oldtype-image-prefix-list
156           "\\|")
157          "\\)"))
158
159(defconst oldtype-normal-wikiname-pattern "\\([\[][\[]\\)\\([^\]]+\\)\\([\]][\]]\\)")
160(defconst oldtype-paren-wikiname-pattern "\\([\[(][\[(]\\)\\([^\]]+\\)\\([\]][\]]\\)")
161
162(defcustom oldtype-insert-image-size 100
163  "Image size of oldtype-insert-image command (C-c l)."
164  :type  'integer
165  :group 'oldtype)
166
167(defcustom oldtype-convert-program "/usr/bin/convert"
168  "The full-path of Imagemagick 'convert' program."
169  :type  'string
170  :group 'oldtype)
171
172(defcustom oldtype-curl-program "/usr/bin/curl"
173  "The full-path of 'curl' program."
174  :type  'string
175  :group 'oldtype)
176 
177(defcustom oldtype-work-directory "~/work/edit"
178  "The working directory of OldType's content file (.ot file)."
179  :type  'string
180  :group 'oldtype)
181
182
183;; --- utility ---
184(defun assoc-ref (alist key)
185  (let ((entry (assoc key alist)))
186    (when entry
187      (cdr entry))))
188
189
190;;--- debugging message logger
191(defvar oldtype-debug nil)                       ; debugging enable/disable flag.
192(defun oldtype-debug-print (string)
193  (if oldtype-debug
194      (message string)))
195
196(defun oldtype-insert-image (beg end image &rest args)
197  "Display image on the current buffer.
198Buffer string between BEG and END are replaced with IMAGE."
199  (add-text-properties beg end (list 'display image
200                                     'intangible image
201                                     'invisible nil)))
202
203
204
205;; insert image data to current-buffer.
206;;  e.x.)
207;;     (oldtype-insert-image-data "http://www.sumibi.org/sumibi/sumibi_picture.png")
208(defun oldtype-insert-image-data (url)
209  (cond
210   ((string-match "http://" url)
211    (call-process oldtype-curl-program
212                  nil
213                  '(t nil)
214                  nil
215                  url))
216   (t
217    (insert-file-contents url))))
218
219
220(defun oldtype-create-image (url &optional width height)
221  (let (data pixel-width pixel-height
222             (m (string-match "http://" url)))
223    (when (or (file-readable-p url) m)
224      (when (not m)
225        (setq url (oldtype-expand-full-path url)))
226      (setq pixel-width (or width
227                            ""))
228      (setq pixel-height (or height
229                             ""))
230      (if (not (file-executable-p oldtype-convert-program))
231          (oldtype-warning "'%s' does not executable... Image can't be convert size." oldtype-convert-program)
232        (progn
233          (setq data
234                (with-temp-buffer
235                  (let ((coding-system-for-read 'binary)
236                        (coding-system-for-write 'binary)
237                        (auto-image-file-mode nil))
238                    (set-buffer-multibyte nil)
239                    (oldtype-insert-image-data url)
240                    ;; (message (format "1: min = %s  max = %s " (point-min) (point-max)))
241                    (cond ((or (< 0 (length pixel-width))
242                               (< 0 (length pixel-height)))
243                           (call-process-region (point-min) (point-max)
244                                                oldtype-convert-program
245                                                t
246                                                '(t nil)
247                                                nil
248                                                "-"
249                                                "-resize"
250                                                (format "%sx%s" pixel-width pixel-height)
251                                                "PNG:-"))
252                          (t
253                           (call-process-region (point-min) (point-max)
254                                                oldtype-convert-program
255                                                t
256                                                '(t nil)
257                                                nil
258                                                "-"
259                                                "PNG:-")))
260                    ;; (message (format "2: min = %s  max = %s " (point-min) (point-max)))
261                    (buffer-substring-no-properties (point-min) (point-max)))))
262          (create-image data 'png 'data :ascent 'center))))))
263
264
265(defun oldtype-insert-image-file (beg end attr-alist)
266  "Display image on the current buffer
267Buffer string between BEG and END are replaced with URL."
268
269  (let ((image (assoc-ref oldtype-image-cache attr-alist)))
270    (when (not image)
271      (let (
272            (src    (assoc-ref attr-alist 'src))
273            (width  (assoc-ref attr-alist 'width))
274            (height (assoc-ref attr-alist 'height)))
275       
276        ;; get the image data file
277        (setq image (oldtype-create-image
278                     src
279                     width height))
280        ;; push to cache
281        (push
282         `(,attr-alist
283           .
284           ,image)
285         oldtype-image-cache)
286        ))
287    ;; insert to buffer
288    (oldtype-insert-image beg end image)))
289
290;;
291;; --- test code ---
292;;
293;;(setq  oldtype-image-cache '())
294;;
295;;(oldtype-insert-image-file
296;; (+ (point) 100)
297;; (+ (point) 101)
298;; '(
299;;   (src    . "../doc/img/oldtype_logo.png")
300;;   (width  . "40")
301;;   (height . "40")))
302;;
303;;(insert (pp oldtype-image-cache))
304
305
306(defun oldtype-remove-image (beg end)
307  "Remove an image which is inserted between BEG and END."
308  (remove-text-properties beg end '(display nil intangible nil)))
309
310(defun oldtype-get-image (pos)
311  "Get an image object which is indexed pos."
312  (get-text-property pos 'display))
313
314(defun oldtype-expand-full-path (file)
315  "Expand full path from relative path."
316  (concat default-directory file))
317
318;;
319;; width=10 src="abc\"
320;;   -> (("width" . "10") ("src" . "abc"))
321;;
322;; test pattern:
323;;   (assq 'src (oldtype-parse-attribute "width=10 src=\"abc\""))
324;;
325(defun oldtype-parse-attribute (str)
326  (let ((lst (split-string str "[ ]+"))
327        (oldtype-attribute-pattern "\\([a-zA-Z]+\\)=[\"]?\\([^ \"]+[/]?\\)"))
328    (mapcar
329     (lambda (x)
330       (if (string-match oldtype-attribute-pattern x)
331           (cons
332            (intern (match-string 1 x))
333            (match-string 2 x))
334         nil))
335     lst)))
336
337
338;;
339;; compose region with image file
340;;
341(defun oldtype-compose-region-with-image (beg end icon-str file &optional width height)
342  ;;--- debugging message logger
343  (let* ((alist `(
344                  (src . ,file)))
345         (alist  (if width
346                     (cons `(width . ,width) alist)
347                   alist))
348         (alist  (if height
349                     (cons `(height . ,height) alist)
350                   alist)))
351    (compose-region beg
352                    end
353                    icon-str)
354    (oldtype-remove-image beg
355                          end)
356    (oldtype-insert-image-file beg
357                               end
358                               alist)))
359
360;;
361;; fontification
362;;
363(defun oldtype-install-fontification ()
364  ;;
365  ;; "4873113482"
366  ;;   => "http://images.amazon.com/images/P/4873113482.09.MZZZZZZZ_.jpg"
367  ;;
368  ;; test pattern:
369  ;;   (amazon-asincode-to-url "4873113482")
370  ;;
371  (defun amazon-asincode-to-url (asincode)
372    (if (string-match "^[a-zA-Z0-9-_]+$" asincode)
373        (format "http://images.amazon.com/images/P/%s.09.MZZZZZZZ_.jpg" asincode)
374      nil))
375
376  (defun youtube-video-to-url (videocode)
377    (if (string-match "^[a-zA-Z0-9-_]+$" videocode)
378        (format "http://img.youtube.com/vi/%s/1.jpg" videocode)
379      nil))
380
381  (defun code-linep (pos)
382    (save-excursion
383      (goto-char pos)
384      (eq ?! (char-after (point-at-bol)))))
385
386  (let (
387        (_indent-pattern
388         "^\\([*][*]?[*]?\\|[-][-]?[-]?\\|[#][#]?[#]?\\)[ ].*$")
389        (_subject-pattern
390         "^[*][*]?[*]?[ ]\\(.*\\)$")
391        (_pre-pattern
392         "^\\([ ]+\\)")
393        (_hr-pattern
394         "^---[-]+$")
395        (_imgurl-pattern
396         oldtype-imgurl-pattern)
397        (_url-pattern
398         "http://[^\]\n\"]+")
399        (_code-pattern
400         "^!.*$")
401        (_wikiname-pattern
402         "\\([\[][\[]\\)\\([^\]]+\\)\\([\]][\]]\\)")
403        (_image-pattern
404         "\\(##[(]\\(img[\-]?[sm]?\\)[ ]+\\)\\([^)]+\\)\\([)]\\)")
405        (_various-webservice-pattern
406         "\\(##[(]\\(amazon\\|amazon-s\\|amazon-m\\|youtube\\|youtube-s\\|youtube-m\\)[ ]+\\)\\([^)]+\\)\\([)]\\)")
407        (_simple-command-pattern
408         "\\(##[(]\\(todo\\|done\\)[)]\\)"))
409
410    (set (make-local-variable 'font-lock-defaults)
411         `((
412            ;; http://...
413            (,_url-pattern
414             0
415             oldtype-alink-face)
416
417            ;; path/of/image/file.(jpg|png|bmp ... )
418            (,_imgurl-pattern
419             0
420             oldtype-alink-face)
421
422            ;; ##(img URL)
423            (,_image-pattern
424             2
425             (when (not (code-linep (match-beginning 1)))
426               (let* ((beg       (match-beginning 1))
427                      (image-url (match-string-no-properties 3))
428                      (end       (match-end 4))
429                      (height     
430                       (case (intern (match-string-no-properties 2))
431                         (img-s
432                          (int-to-string oldtype-image-height-s))
433                         (img-m
434                          (int-to-string oldtype-image-height-m)))))
435                 (oldtype-compose-region-with-image beg end oldtype-image-icon-string image-url nil height)))
436             t)
437
438            ;; ##(amazon asincode), ##(youtube asincode),
439            (,_various-webservice-pattern
440             3
441             (let* ((beg       (match-beginning 1))
442                    (command   (match-string-no-properties 2))
443                    (value     (match-string-no-properties 3))
444                    (end       (match-end 4))
445                    (image-url (case (intern command)
446                                 ((amazon amazon-s amazon-m)
447                                  (amazon-asincode-to-url value))
448                                 ((youtube youtube-s youtube-m)
449                                  (youtube-video-to-url value))
450                                 (t
451                                  "")))
452                    (height
453                     (case (intern command)
454                       ((youtube-s amazon-s)
455                        (int-to-string oldtype-image-height-s))
456                       ((youtube-m amazon-m)
457                        (int-to-string oldtype-image-height-m)))))
458               (if image-url
459                   (oldtype-compose-region-with-image beg end oldtype-image-icon-string image-url nil height)))
460             t)
461           
462            ;; ##(todo), ##(done) ...
463            (,_simple-command-pattern
464             2
465             (let ((beg         (match-beginning 1))
466                   (end         (match-end 1))
467                   (image-url
468                    (case (intern (match-string-no-properties 2))
469                      (todo
470                       "../img/icon.todo.png")
471                      (t
472                       "../img/icon.done.png"))))
473               (oldtype-compose-region-with-image beg end oldtype-image-icon-string image-url))
474             t)
475
476            ;; [[WikiName]] or [[URL|Name]]
477            (,_wikiname-pattern
478             2
479             (when (not (code-linep (match-beginning 2)))
480               (let*
481                   ((_elem     (match-string 2))
482                    (_url-pair (save-match-data
483                                 (split-string _elem "|")))
484                    (_url-mode (<= 2 (length _url-pair)))
485                    )
486                 (cond
487                  ;; 1
488                  ((eq 1 (length _elem))
489                   (compose-region (match-beginning 1)
490                                   (match-end 3)
491                                   _elem)
492                   (put-text-property (match-beginning 1)
493                                      (match-end 3)
494                                      'face
495                                      (if (file-exists-p (concat (match-string 2) oldtype-ext-name))
496                                          oldtype-wikiname-face
497                                        oldtype-wikiname-nofile-face)))
498                  ;; over 2
499                  (t
500                   (compose-region (match-beginning 1)
501                                   (+ (match-end 1)
502                                      (if _url-mode
503                                          (+ (length (car _url-pair)) 2)
504                                        1))
505                                   (car (string-to-list
506                                         (if _url-mode
507                                             (cadr _url-pair)
508                                           (match-string 2)))))
509                   (compose-region (- (match-end    2) 1)
510                                   (match-end 3)
511                                   (car
512                                    (reverse
513                                     (string-to-list (match-string 2)))))
514                   (put-text-property (match-beginning 1)
515                                      (match-end 2)
516                                      'face
517                                      (cond
518                                       (_url-mode
519                                        oldtype-alink-face)
520                                       ((file-exists-p (concat (match-string 2) oldtype-ext-name))
521                                        oldtype-wikiname-face)
522                                       (t
523                                        oldtype-wikiname-nofile-face)))))))
524             nil)
525
526            ;; indent pattern like  "*** " "--- " "### "
527            (,_indent-pattern
528             1
529             (let ((str (match-string-no-properties 1)))
530               (cond
531                ((= 1 (length str))
532                 oldtype-indent1-face)
533                ((= 2 (length str))
534                 oldtype-indent2-face)
535                (t
536                 oldtype-indent3-face)))
537             t)
538
539            (,_subject-pattern
540             1
541             (let ((str (match-string-no-properties 1)))
542               oldtype-subject-face)
543             nil)
544
545            (,_pre-pattern
546             0
547             oldtype-pre-face
548             t)
549
550            (,_hr-pattern
551             0
552             oldtype-hr-face
553             t)
554
555            ;; ! ....
556            (,_code-pattern
557             0
558             oldtype-code-face
559             t)
560
561            )))))
562
563
564
565(defun oldtype-mode-hookfunc-stuff ()
566
567  ;; Remove character compositions
568  (eval '(decompose-region (point-min) (point-max)))
569  ;; Install fontification
570  (when (and (boundp 'font-lock-keywords)
571             (symbol-value 'font-lock-keywords)
572             (not (featurep 'noweb-mode)))
573    ;; This warning is not given if the `noweb-mode' package is installed.
574    (oldtype-warning "`font-lock-keywords' already set when hook ran."))
575  (set (make-local-variable 'oldtype-image-cache) '())
576
577  (oldtype-install-fontification))
578
579
580(defun oldtype-search-alink ()
581  "Search alink or wikiname from current line."
582  (let (
583        (_wikiname-pattern oldtype-normal-wikiname-pattern)
584        (match-list '()))
585
586    (save-excursion
587      (goto-char (point-at-bol))
588      (while (re-search-forward _wikiname-pattern (point-at-eol) t)
589        (let* ((start (match-beginning 2))
590               (end   (match-end 2))
591               (url   (match-string-no-properties 2)))
592          (when (string-match "^\\([^|]+\\)|" url)
593            (setq url (match-string 1 url)))
594          (push
595           `(
596             (start . ,start)
597             (end   . ,end)
598             (url   . ,url))
599           match-list))))
600    match-list))
601
602
603
604(defun oldtype-open-allpages ()
605  (defun buffer-exists-p (name)
606    (member
607     name
608     (mapcar
609      (lambda (x)
610        (buffer-name x))
611      (buffer-list))))
612   
613  "Open href source of a tag."
614  (interactive)
615  (when (buffer-exists-p oldtype-allpages-wikiname)
616    (kill-buffer oldtype-allpages-wikiname))
617  (find-file-read-only
618   (concat (getenv "OTHOME")
619           "/edit/"
620           oldtype-allpages-wikiname)))
621
622
623(defun oldtype-open-alink ()
624  "Open href source of a tag."
625  (interactive)
626  (let ((alink-list (oldtype-search-alink))
627        (found nil))
628    (mapcar
629     (lambda (alink-data)
630       (let ((start  (assoc-ref alink-data 'start))
631             (end    (assoc-ref alink-data 'end))
632             (url    (assoc-ref alink-data 'url)))
633         (if (and (<= start (point))
634                  (<= (point) end))
635             (progn
636               (setq found t)
637               (if (string-match "http://" url)
638                   (browse-url url)
639                 (find-file (concat url oldtype-ext-name)))))))
640     alink-list)
641    (if (not found)
642        (newline))))
643
644
645(defun oldtype-todays-entry ()
646  "Open today's blog entry file."
647  (interactive)
648
649  (defun oldtype-today ()
650    (let* ((oldtype-hour-offset 0)
651           (offset-second (* oldtype-hour-offset 60 60))
652           (now (current-time))
653           (high (nth 0 now))
654           (low (+ (nth 1 now) offset-second))
655           (micro (nth 2 now)))
656      (setq high (+ high (/ low 65536))
657            low (% low 65536))
658      (when (< low 0)
659        (setq high (1- high)
660              low (+ low 65536)))
661      (list high low micro)))
662
663  (let ((wikiname
664         (concat (getenv "USER")
665                 "."
666                 (format-time-string "%Y_%m_%d" (oldtype-today)))))
667    (oldtype-openfile wikiname)))
668
669
670;;
671;; [fetch command]
672;;   w3m -no-graph -halfdump -o ext_halfdump=1 -o strict_iso2022=0 -o fix_width_conv=1 URL
673;;       | awk '-F<' '/title_alt/ { print $2; }' | tail -1 | awk '-F"' '{ print $2; }'
674;;
675(defun oldtype-fetch-html-title (url)
676  (cond
677   ((string-match "http://" url)
678    (with-temp-buffer
679      (shell-command
680       (concat
681        "w3m -no-graph -halfdump -o ext_halfdump=1 -o strict_iso2022=0 -o fix_width_conv=1 \'" url "\' |"
682        "awk \'-F\<\' \'/title_alt/ { print $2; }\' |"
683        "tail -1 |"
684        "awk \'-F\"\' \'{ printf(\"%s\", $2); }\'")
685       (current-buffer))
686      (replace-string "[" "<" nil (point-min) (point-max))
687      (replace-string "]" ">" nil (point-min) (point-max))
688      (buffer-substring-no-properties (point-min) (point-max))))
689   (t
690    "No Title")))
691
692
693(defun oldtype-mode-hookfunc ()
694
695  (defun oldtype-fix-wysiwyg-object ()
696    (interactive)
697    (let (
698          (_wikiname-pattern oldtype-paren-wikiname-pattern)
699          (_sexp-pattern
700           "\\(##?[(]\\)\\([a-zA-Z0-9-]+[ ]*[^)]+\\)\\([)]\\)")
701          (_img-pattern oldtype-imgurl-pattern)
702          (_url_file-pattern
703           "\\(http://[^\t \n]+\\|.+html?\\)")
704          (_url_amazon-pattern
705           "\\(http://.*amazon[.]c.*\\)/\\([0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-]\\)[^0-9A-Z-]?\\(.*\\)")
706          (_url_amazon-pattern-part
707           "/dp/\\([0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-][0-9A-Z-]\\)")
708          (_url_youtube-pattern
709           "\\(http://.*youtube[.]com/watch\\?v=\\)\\([0-9A-Za-z_-]+\\)\\(.*\\)")
710          (_url_nicovideo-pattern
711           "\\(http://.*nicovideo[.]jp/watch/\\)\\([0-9A-Za-z_-]+\\)"))
712
713      (let ((cur    (point))
714            (str    (buffer-substring-no-properties (point) (point-at-eol))))
715        (cond
716         ;; [[Wiki Name]]
717         ((string-match      (concat "^" _wikiname-pattern) str)
718          (re-search-forward             _wikiname-pattern  (point-at-eol) t)
719          (let ((start (match-string-no-properties 1))
720                (str   (match-string-no-properties 2))
721                (end   (match-string-no-properties 3)))
722            (delete-region (match-beginning 1) (match-end 3))
723            (let ((pos (point)))
724              (if (string-equal "((" start)
725                  (insert "[[")
726                (insert "(("))
727              (insert str)
728              (insert end)
729              (goto-char pos))))
730         ;; ##(func arg1 arg2 ...)
731         ((string-match      (concat "^" _sexp-pattern) str)
732          (re-search-forward             _sexp-pattern  (point-at-eol) t)
733          (let ((start (match-string-no-properties 1))
734                (str   (match-string-no-properties 2))
735                (end   (match-string-no-properties 3)))
736            (if (oldtype-get-image  (match-beginning 1))
737                (progn
738                  (oldtype-remove-image (match-beginning 1) (match-end 3))
739                  (message "image"))
740              (message"not image"))
741            (delete-region (match-beginning 1) (match-end 3))
742            (let ((pos (point)))
743              (if (string-equal "##(" start)
744                  (insert "#(")
745                (insert "##("))
746              (insert str)
747              (insert end)
748              (goto-char pos))))
749         ((equal ?< (char-after (point)))
750          (if (oldtype-get-image (point))
751              (progn
752                (oldtype-remove-image (point-at-bol)
753                                      (point-at-eol))
754                (message "image"))
755            (message"not image"))
756          (delete-char 1))
757         ;; path/of/image/file.(jpg|png|bmp ... )
758         ((string-match      (concat "^" _img-pattern) str)
759          (re-search-forward             _img-pattern (point-at-eol) t)
760          (goto-char (match-end 2))
761          (insert ")")
762          (goto-char (match-beginning 1))
763          (let ((img-str "##(img "))
764            (insert img-str)
765            (backward-char (string-bytes img-str))))
766         ;; http://amazon/?/ASIN/ASINCODE/... amazon-command
767         ((string-match      (concat "^" _url_amazon-pattern) str)
768          (re-search-forward             _url_amazon-pattern (point-at-eol) t)
769          (let* ((asin  (match-string 2))
770                 (url   (match-string 0))
771                 (s     (match-beginning 1))
772                 (e     (match-end 3))
773                 (title (oldtype-fetch-html-title url)))
774            (when (string-match    _url_amazon-pattern-part  str)
775              (setq asin (match-string 1 str)))
776            (delete-region s e)
777            (goto-char s)
778            (insert (format "##(amazon %s)  %s" asin title))))
779         ;; http://www.youtube.com/watch ...  youtube-command
780         ((string-match      (concat "^" _url_youtube-pattern) str)
781          (re-search-forward             _url_youtube-pattern (point-at-eol) t)
782          (let* ((video (match-string 2))
783                 (url   (match-string 0))
784                 (s     (match-beginning 1))
785                 (e     (match-end 3))
786                 (title (oldtype-fetch-html-title url)))
787            (delete-region s e)
788            (goto-char s)
789            (insert (format "##(youtube %s)  %s" video title))))
790         ;; http://www.nicovideo.jp/watch ...  nicovideo-command
791         ((string-match      (concat "^" _url_nicovideo-pattern) str)
792          (re-search-forward             _url_nicovideo-pattern (point-at-eol) t)
793          (let* ((video (match-string 2))
794                 (url   (match-string 0))
795                 (s     (match-beginning 1))
796                 (e     (match-end 2)))
797            (delete-region s e)
798            (goto-char s)
799            (insert (format "##(nicovideo %s)" video))))
800         ;; http://host/path/of/contents... anchor-keyword
801         ((string-match      (concat "^" _url_file-pattern) str)
802          (re-search-forward             _url_file-pattern (point-at-eol) t)
803          (let* ((url   (match-string 1))
804                 (s     (match-beginning 1))
805                 (e     (match-end 1))
806                 (title (oldtype-fetch-html-title url)))
807            (delete-region s e)
808            (goto-char s)
809            (insert (format "[[%s|%s]]" url title))))
810         (t
811          (message "OldType: Please move cursor to [[URL|Name]]  or [[WikiName]] *.png  or  ##(... )  keywword.' "))))))
812
813  (defun oldtype-insert-images ()
814    "Insert img tags recursivly from current directory."
815    (interactive)
816   
817    (defun search-image-files ()
818      "search image files."
819      (with-temp-buffer
820        (shell-command (mapconcat
821                        (lambda (x)
822                          (format "find ../img -follow -iname '*.%s'; " x))
823                        oldtype-image-prefix-list
824                        "")
825                       (current-buffer))
826        (split-string
827         (buffer-substring-no-properties (point-min) (point-max)))))
828   
829    (defun prefix-check (line)
830      (not
831       (notany
832        (lambda (_prefix)
833          (string-match (concat "\\." _prefix "$") line))
834        oldtype-image-prefix-list)))
835   
836    (mapcar
837     (lambda (x)
838       (when (prefix-check x)
839         (insert
840          (format "##(img %s)" x oldtype-insert-image-size))))
841     (search-image-files)))
842
843
844  (defun oldtype-grep ()
845    "grep keyword from current directory."
846    (interactive)
847   
848    (with-temp-buffer
849      (let ((command
850             (read-from-minibuffer "keyword: ")))
851        (grep (concat "grep -nH -C 3 " command " * ")))))
852 
853
854  (oldtype-mode-hookfunc-stuff)
855 
856  ;; Bind Return/Enter key.
857  (local-set-key "\C-c\C-c" 'oldtype-fix-wysiwyg-object)
858  (local-set-key "\C-c,"    'oldtype-fix-wysiwyg-object)
859  (local-set-key "\C-cl"    'oldtype-insert-images)
860  (local-set-key "\C-m"     'oldtype-open-alink)
861  (local-set-key "\C-ca"    'oldtype-open-allpages)
862  (local-set-key "\C-c/"    'oldtype-grep)
863  (setq mode-name "OldType"))
864
865
866;;;###autoload
867(define-derived-mode oldtype-mode text-mode "OldType"
868  "Major mode for editing OldType documents.
869
870Do \\[describe-variable] oldtype- SPC to see available variables.
871Do \\[describe-key] on the following bindings to discover what they do.
872\\{oldtype-mode-map}"
873
874  (oldtype-mode-hookfunc))
875
876
877;;
878;; When you eval sexp as follows, open oldtype contents file.
879;;
880;; (oldtype-openfile "index")[C-x C-e]
881;;
882(defun oldtype-openfile (wikiname &optional lineno)
883  "open oldtype contents file."
884  (find-file (concat
885              (if (string-match "/$" oldtype-work-directory)
886                  oldtype-work-directory                 
887                (concat oldtype-work-directory "/"))
888              wikiname oldtype-ext-name))
889  (when lineno
890    (goto-line lineno (concat wikiname ".ot"))))
891
892
893(provide 'oldtype)
894;; oldtype-mode.el ends here
Note: See TracBrowser for help on using the browser.