cgit.sxemacs.org Git - slh/blob - snap.el

   1 ;;; snap.el --- save/load snapshot of application to/from text
   2
   3 ;; Copyright (c) 2003, 2004, 2005, 2006, 2007
   4 ;;   by HIRAOKA Kazuyuki <khi@users.sourceforge.jp>
   5 ;; $Id: snap.el,v 1.40 2007/05/16 14:44: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 ;; Usage:
  25 ;;
  26 ;; (1) M-x snap-record on application, e.g. Wanderlust.
  27 ;; (2) Yank (C-y) on any buffer, e.g. *scratch* or ~/memo.txt.
  28 ;; (3) M-x snap-play on yanked text ==> snapshot (1) is restored.
  29
  30 ;; Supported applications:
  31 ;;
  32 ;; - BBDB
  33 ;; - BibTeX
  34 ;; - Bookmark
  35 ;; - Dired
  36 ;; - Emacs-wiki
  37 ;; - Gnus
  38 ;; - Help
  39 ;; - howm-search ( C-c , g )
  40 ;; - Info
  41 ;; - Man
  42 ;; - Navi2ch (Article buffer)
  43 ;; - occur (experimental, using fake cgi-extension)
  44 ;; - PCVS
  45 ;; - Shell
  46 ;; - Thumbs
  47 ;; - w3m
  48 ;; - Wanderlust (Summary buffer)
  49 ;; - snap:///  (only message it's version)
  50 ;;
  51 ;; For unsupported buffers,
  52 ;; file name and current position are recorded.
  53
  54 ;; Caution for byte-compilation:
  55 ;;
  56 ;; Byte-compiling this file is not recommended.
  57 ;; Some fucntions will be dropped silently if required features are not
  58 ;; available at compile time.
  59 ;; For example, snap-*:w3m are ignored if the feature w3m is not available.
  60 ;; You may want to recompile this file after you set up these features.
  61
  62 ;; Internal:
  63 ;;
  64 ;; Format of snapshot string is "snap://MAJOR-MODE/SPELL".
  65 ;; Format and meaning of SPELL depend on MAJOR-MODE.
  66 ;; For example,
  67 ;; snap://wl-summary-mode/+ME/hira/<20031101192305.AFA8C43EDC@hoge.fuga.piyo>
  68 ;; is a snapshot string of wl-summary-mode for the spell
  69 ;; +ME/hira/<20031101192305.AFA8C43EDC@hoge.fuga.piyo>,
  70 ;; which indicates
  71 ;; message-id <20031101192305.AFA8C43EDC@hoge.fuga.piyo>
  72 ;; in the folder +ME/hira.
  73 ;;
  74 ;; Please define snap-record:MAJOR-MODE and snap-play:MAJOR-MODE
  75 ;; if you want to support your favorite application.
  76 ;; (snap-record:MAJOR-MODE) returns SPELL string for current snapshot.
  77 ;; (snap-play:MAJOR-MODE SPELL) restores snapshot from SPELL string.
  78
  79 ;; Abbreviation (experimental):
  80 ;;
  81 ;; You can add abbreviation rules of snap strings
  82 ;; to the variable `snap-abbrev'. See its docstring for details.
  83
  84 ;; Fake cgi-extension (experimental):
  85 ;;
  86 ;; When `snap-record-cgi' is not empty, you can use a
  87 ;; fake cgi like "snap://MAJOR-MODE/SPELL??g=110&s=str&q=word&x=",
  88 ;; which calls snap-play::g, snap-play::s, snap-play::q and
  89 ;; snap-play::x.
  90 ;;
  91 ;; At this experimental stage, format of url is not
  92 ;; strict like RFC and not *escaped*. (and I have no idea for doing it
  93 ;; :-) An example of the problem is
  94 ;; "snap://occur-mode/dired-mode/~/??q=drwx??g=2", but it still works
  95 ;; because of longest-match tricks.  See `snap-cgi-decode'
  96 ;;
  97 ;; Supported cgi-functions:
  98 ;; g=110  goto-line
  99 ;; s=str  search string
 100 ;; q=word occur word
 101 ;; x=     dired-x
 102 ;;
 103 ;; For some cases, mode-specific commands may be desired.
 104 ;; See `snap-play-cgi' and `snap-play:help-mode:' for example.
 105
 106 ;; Repair (experimental):
 107 ;;
 108 ;; When you fail snap-play, you can try M-x snap-repair
 109 ;; to repair snapshot text.
 110 ;; This can happen, e.g. when you move mails to other folders.
 111 ;;
 112 ;; You have to write your own 'my-snap-search-mail' function
 113 ;; which receives message-id and returns its file name.
 114 ;; My version requires namazu and howm.
 115 ;; - namazu: full text search engine <http://www.namazu.org/index.html.en>
 116 ;; - howm: note-taking tool <http://howm.sourceforge.jp/>
 117 ;; (defvar my-namazu-mail-dir (expand-file-name "~/PATH/NMZ/Mail"))
 118 ;; (defun my-snap-search-mail (message-id)
 119 ;;   (let* ((query (format "+message-id:%s" message-id))
 120 ;;          (args `("-l" "-n" "1" ,query ,my-namazu-mail-dir)))
 121 ;;     (car (howm-view-call-process "namazu" args))))
 122
 123 ;; Replace environment variables in file name.
 124 ;;
 125 ;; If you like "snap:///${HOME}/hoge" and "snap:///${FOODIR}/bar"
 126 ;; instead of "snap:///~/hoge" and "snap:///usr/local/foo/bar", try this.
 127 ;; I'm not sure whether there is considerable demand for this feature.
 128 ;;
 129 ;; (defvar snap-abbreviate-environment-variables '("FOODIR" "HOME"))
 130 ;; (defadvice snap-abbreviate-file-name (around env-var (raw-path) activate)
 131 ;;   ad-do-it
 132 ;;   (let ((path (expand-file-name raw-path))
 133 ;;         (rules (mapcar (lambda (var)
 134 ;;                          (let ((val (getenv var)))
 135 ;;                            (and val
 136 ;;                                 (cons (concat "^" (regexp-quote val))
 137 ;;                                       (format "${%s}" var)))))
 138 ;;                        snap-abbreviate-environment-variables)))
 139 ;;     (mapc (lambda (r)
 140 ;;             (when (and r (string-match (car r) path))
 141 ;;               (setq ad-return-value
 142 ;;                     (replace-regexp-in-string (car r) (cdr r) path))))
 143 ;;           (reverse rules))))
 144
 145 ;; With bookmark and ffap (experimental):
 146 ;;
 147 ;; ;; Put this code into your .emacs to enable bookmark+snap feature.
 148 ;; (eval-after-load "bookmark"
 149 ;;   (ad-enable-advice 'bookmark-buffer-file-name 'around 'with-snap)
 150 ;;   (ad-enable-advice 'bookmark-jump-noselect 'around 'with-snap))
 151 ;;
 152 ;; ;; Put this code into your .emacs to enable ffap+snap feature.
 153 ;; (setq ffap-url-regexp snap-ffap-url-regexp)
 154 ;; (setq ffap-url-fetcher snap-ffap-url-fetcher)
 155
 156 ;; ChangeLog:
 157 ;;
 158 ;; [2007-08-01] Made most things work for (S)XEmacs (Steve Youngs)
 159 ;; [2007-05-16] use snap-define-op instead of require in defun.
 160 ;; [2007-05-16] PCVS and Thumbs are supported. (thx > Ma)
 161 ;; [2007-05-16] experimental features with bookmark and ffap (thx > Ma)
 162 ;; [2007-02-24] byte-compilation is now OK.
 163 ;;              (thx > Taiki SUGAWARA <buzz.taiki at gmail.com>)
 164 ;; [2006-06-15] snap-record:dired-mode also supports environment variables
 165 ;;              (thx > taku)
 166 ;; [2006-06-07] snap-play:dired-mode also supports environment variables
 167 ;;              (thx > taku)
 168 ;; [2006-05-28] snap-try-decode for atode.el
 169 ;; [2006-04-23] replace environment variables in snap-record: (thx > taku)
 170 ;; [2006-04-11] environment variables in file path are expanded (thx > taku)
 171 ;; [2006-03-25] fix: Obsolete constant name in bibtex. (thx > 20)
 172 ;; [2006-03-21] add document on byte-compilation. (thx > 20)
 173 ;; [2006-01-31] fix: Drive letter problem in windows. (thx > Touhi)
 174 ;; [2005-09-28] cgi for Man-mode. (thx > Ma)
 175 ;; [2005-09-27] mode-specific cgi command. (thx > Ma)
 176 ;; [2005-07-03] Gnus is supported. (thx > Wi)
 177 ;;              Variable snap-mode-functions for extension.
 178 ;; [2005-05-24] snap-record-string never cause error again.
 179 ;;              This is necessary for my another tool, atode.el.
 180 ;;              http://howm.sourceforge.jp/a/atode.el
 181 ;; [2005-05-19] BBDB, BibTeX, Shell ,occur, howm-search are supported.
 182 ;;              fix: `snap-play' and extend fake cgi and `snap-expand-alist'.
 183 ;;              And set `snap-record-default-format'. (thx > Ma)
 184 ;; [2005-03-03] snap-record-string doesn't cause error any more.
 185 ;; [2004-11-16] fix: second -> cadr (thx > Toorisugari)
 186 ;; [2004-09-11] Emacs-wiki, Navi2ch, w3m, Dired are supported. (thx > Ma)
 187 ;; [2004-04-21] fix: Error when action-lock is not available (thx > Nanashi)
 188 ;; [2004-04-18] Goto occurrence when it is unique match.
 189 ;; [2004-04-10] Help, Bookmark, Man, Info are supported. (thx > Ma)
 190 ;; [2004-02-25] action-lock
 191 ;; [2004-02-23] fix: Error on CVS latest Wanderlust (thx > hirose31)
 192 ;; [2004-01-16] Jump to specified position
 193 ;; [2003-11-09] fix: All modes said 'not supported'.
 194 ;; [2003-11-08] First upload
 195 ;; [2003-11-05] First version
 196
 197 ;; Bug/Restriction
 198 ;; - thing-at-point fails to recognize "snap:///file#1: snap:///"
 199
 200 ;;; Code:
 201
 202 (eval-when-compile
 203   (require 'cl))
 204 (require 'thingatpt)
 205
 206 (defvar snap-version "$Id: snap.el,v 1.40 2007/05/16 14:44:28 hira Exp $")
 207 (defvar snap-prt "snap://")
 208 (defvar snap-format (concat snap-prt "%s/%s"))
 209 (defvar snap-regexp (concat (regexp-quote snap-prt) "\\([^/\r\n]*\\)/\\(.*\\)"))
 210 (defvar snap-mode-pos 1)
 211 (defvar snap-spell-pos 2)
 212 (defvar snap-root-dir (expand-file-name "/")) ;; "c:/" etc. for windows
 213 (defvar snap-record-string-no-error t
 214   "For private use by other packages.
 215 It indicates that old bug on `snap-record-string' is already fixed.")
 216 (defvar snap-spell-format "%s??%s"
 217   "Note: You can change this default to \"%s?%s\" like a cgi.  But you
 218 will face to ploblem; how to deal with
 219 \"snap://w3m-mode/http://www.google.com?q=1?q=2\".")
 220 (defvar snap-cgi-format "%s=%s")
 221 (defvar snap-spell-regexp "\\(.*\\)[?][?]\\([a-z][=].*\\)"
 222   "Note: Longest match of first part is important for the case:
 223 \"snap://occur-mode/dired-mode/~/??q=drwx??g=2\"")
 224 (defvar snap-nocgi-pos 1)
 225 (defvar snap-cgi-pos 2)
 226 (defvar snap-cgi-separator "&")
 227 (defvar snap-record-cgi nil
 228   "List of recorded cgi types in `snap-record'")
 229 ;;; for test use:
 230 ;;; (setq snap-record-cgi '("g" "s" "q"))
 231
 232 (defvar snap-abbrev nil
 233   "List of rules on abbreviation for snap string.
 234 Each rule is a list of three strings: ABBREV, MODE, and SPELL-HEAD.
 235 snap://ABBREV/xxx is expanded as snap://MODE/SPELL-HEADxxx.
 236
 237 Example:
 238  ;; snap://l/file ==> snap://dired-mode/usr/local/meadow/1.15/lisp/file
 239  ;; snap://s/dir  ==> snap://shell-mode/~/#dir
 240  (setq snap-abbrev
 241        '((\"l\" \"dired-mode\" \"usr/local/meadow/1.15/lisp/\")
 242          (\"s\" \"shell-mode\" \"~/\#\")))
 243 ")
 244
 245 (defvar snap-mode-functions nil
 246   "List of functions which give the mode string of current buffer
 247 instead of the variable `major-mode'.
 248 Each function must return nil if it cannot determine the mode, so that
 249 decision is passed to the next function.
 250
 251 This variable is prepared for applications which does not use
 252 their own major-mode, e.g. message buffers in Wanderlust.")
 253
 254 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 255 ;;; main
 256
 257 (defun snap-record ()
 258   "Convert snapshot of application to string, and put it to kill-ring."
 259   (interactive)
 260   (let ((snap (snap-record-string)))
 261     (when (null snap)
 262       (error "This buffer is not supported."))
 263     (kill-new snap)
 264     (message "%s" snap)))
 265
 266 (defun snap-play ()
 267   "Restore snapshot of application from string at point."
 268   (interactive)
 269   (let ((snap (thing-at-point 'snap)))
 270     ;; avoid (snap-play-string nil)
 271     (and snap (snap-play-string snap))))
 272
 273 (defun snap-repair ()
 274   (interactive)
 275   (let ((snap (thing-at-point 'snap))
 276         (beg (match-beginning 0))
 277         (end (match-end 0)))
 278     (let ((repaired (snap-repair-string snap)))
 279       (goto-char beg)
 280       (delete-region beg end)
 281       (insert repaired)
 282       (message "Repaired."))))
 283
 284 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 285 ;;; util
 286
 287 (defun snap-record-string ()
 288   (let ((long (snap-record-string-exact)))
 289     (and long (snap-shrink-string long))))
 290 (defun snap-play-string (snap)
 291   (snap-play-string-exact (snap-expand-string snap)))
 292
 293 (defun snap-shrink-string (snap)
 294   "String SNAP is shrinked according to rules in `snap-abbrev'.
 295 When several rules are applicable, the shortest result is returned."
 296   (let ((candidates (mapcar (lambda (rule)
 297                               (snap-shrink-string-by-rule snap rule))
 298                             snap-abbrev)))
 299     (if candidates
 300         (car (sort candidates (lambda (x y) (< (length x) (length y)))))
 301       snap)))
 302
 303 (defun snap-shrink-string-by-rule (snap rule)
 304   (apply (lambda (abbrev mode spell-head)
 305            (apply (lambda (o-mode o-spell)
 306                     (let ((reg (concat "^" (regexp-quote spell-head))))
 307                       (if (and (string= mode o-mode)
 308                                (string-match reg o-spell))
 309                           (snap-encode abbrev (substring o-spell (match-end 0)))
 310                         snap)))
 311                   (snap-decode snap)))
 312          rule))
 313
 314 (defun snap-expand-string (snap)
 315   (apply (lambda (a-mode a-spell)
 316            (let ((rule (assoc a-mode snap-abbrev)))
 317              (if rule
 318                  (apply (lambda (abbrev mode spell-head)
 319                           (snap-encode mode (concat spell-head a-spell)))
 320                         rule)
 321                snap)))
 322          (snap-decode snap)))
 323
 324 (defun snap-record-string-exact ()
 325   "Convert snapshot of application to string.
 326 Nil is returned for unsupported buffer."
 327   (let* ((mode (snap-get-mode snap-mode-functions))
 328          (recorder (or (snap-op 'record mode t)
 329                        (progn (setq mode "") (snap-op 'record mode))))
 330          (spell (funcall recorder)))
 331     (and spell
 332          (snap-encode mode spell
 333                       (delq nil (mapcar #'snap-record-cgi snap-record-cgi))))))
 334
 335 (defun snap-get-mode (functions)
 336   (if (null functions)
 337       major-mode
 338     (or (funcall (car functions))
 339         (snap-get-mode (cdr functions)))))
 340
 341 (defun snap-play-string-exact (snap)
 342   "Restore snapshot of application from string. "
 343   (let* ((x (snap-decode snap snap-record-cgi))
 344          (mode (car x))
 345          (spell (cadr x))
 346          (cgi (cddr x))
 347          (player (snap-op 'play mode)))
 348     (funcall player spell)
 349     (mapcar (lambda (z)
 350               (apply (lambda (op val) (snap-play-cgi op val mode))
 351                      z))
 352             cgi)))
 353
 354 (defun snap-play-cgi (op val &optional mode)
 355   "Find fake cgi command for operation OP and call it with the argument VAL.
 356 If MODE is given, snap-play:MODE:OP or snap-play:MODE: are used preferably
 357 rather than general snap-play::OP.
 358 They are called as
 359   (snap-play:MODE:OP VAL)
 360   (snap-play:MODE: OP VAL)
 361   (snap-play::OP VAL)
 362 respectively."
 363   (let ((player-mo (and mode (snap-op 'play (concat mode ":" op) t)))
 364         (player-m (and mode
 365                        (let ((f (snap-op 'play (concat mode ":"))))
 366                          (and f
 367                               ;; elisp is not scheme. sigh...
 368                               `(lambda (val) (funcall (function ,f)
 369                                                       (quote ,op)
 370                                                       val))))))
 371         (player-o (snap-op 'play (concat ":" op))))
 372     (funcall (or player-mo player-m player-o) val)))
 373
 374 (defun snap-play-cgi-on (buffer op val)
 375   (snap-do-on buffer (lambda () (snap-play-cgi op val))))
 376
 377 (defun snap-do-on (buffer proc)
 378   (save-selected-window
 379     (select-window (get-buffer-window buffer t))
 380     (funcall proc)))
 381
 382 (defun snap-record-cgi (op)
 383   (let ((s (funcall (snap-op 'record (concat ":" op)))))
 384     (if s
 385         (snap-cgi-encode op s)
 386       nil)))
 387
 388 (defun snap-spell-decode (spell)
 389   ;; suppose: spell has no-property
 390   ;; Example:
 391   ;; (snap-spell-decode "body#tag1?g=1&q=2??g=op1&q=?q=&x=#tag2&x")
 392   ;; => ("body#tag1?g=1&q=2" ("g" "op1") ("q" "?q") ("x" "#tag2&x"))
 393   (if (string-match snap-spell-regexp spell)
 394       (cons (match-string snap-nocgi-pos spell)
 395             (snap-cgi-decode (match-string snap-cgi-pos spell)))
 396     (list spell)))
 397
 398 (defun snap-cgi-decode (cgi)
 399   ;; (snap-cgi-decode "a=1&b=c&d&e=&f")
 400   ;; => '(("a" "1") ("b" "c&d") ("e" "&f"))
 401   (let* ((f-regexp (snap-cgi-encode "\\([a-z]\\)" "\\(.*\\)"))
 402          (s-regexp (concat "^\\(.*\\)" snap-cgi-separator f-regexp))
 403          ;; using longest-match of the first part.
 404          (rest cgi)
 405          (olist '()))
 406     (while (string-match s-regexp rest)
 407       (setq olist (cons (list (match-string 2 rest) (match-string 3 rest)) olist))
 408       (setq rest (match-string 1 rest)))
 409     (if (string-match f-regexp rest)
 410         (setq olist (cons (list (match-string 1 rest) (match-string 2 rest)) olist))
 411       (message "unknown error"))
 412     olist))
 413
 414 (defun snap-repair-string (snap)
 415   (let* ((x (snap-decode snap))
 416          (mode (car x))
 417          (spell (cadr x)))
 418     (let ((repairer (snap-op 'repair mode)))
 419       (snap-encode mode (funcall repairer spell)))))
 420
 421 (defun snap-encode (mode spell &optional cgi-list)
 422   (when cgi-list
 423     (setq spell
 424           (format snap-spell-format
 425                   spell
 426                   (mapconcat #'identity cgi-list
 427                              snap-cgi-separator))))
 428   (format snap-format mode spell))
 429
 430 (defun snap-spell-encode (spell cgi)
 431   (format snap-spell-format spell cgi))
 432
 433 (defun snap-cgi-encode (op str)
 434   (format snap-cgi-format op str))
 435
 436 (defun snap-decode (snap &optional cgi-p)
 437   (or (snap-try-decode snap cgi-p)
 438       (error "Wrong snapshot format: %s" snap)))
 439
 440 (defun snap-try-decode (snap &optional cgi-p)
 441   (and (string-match snap-regexp snap)
 442        (let ((mode (match-string-no-properties snap-mode-pos snap))
 443              (spell (match-string-no-properties snap-spell-pos snap)))
 444          (if cgi-p
 445              (cons mode (snap-spell-decode spell))
 446            (list mode spell)))))
 447
 448 (defun snap-op (op mode &optional no-err)
 449   (let ((f (intern-soft (format "snap-%s:%s" op mode))))
 450     (cond ((functionp f) f)
 451           (no-err nil)
 452           (t (error "%s is not supported." mode)))))
 453
 454 ;;; for thing-at-point
 455 (defun forward-snap (arg)
 456   (interactive "p")
 457   (if (natnump arg)
 458       (re-search-forward snap-regexp nil 'move arg)
 459     (progn
 460       (skip-chars-forward "^ \t\r\n")
 461       (while (< arg 0)
 462         (if (re-search-backward snap-regexp nil 'move)
 463             (skip-chars-backward "^ \t\r\n"))
 464         (setq arg (1+ arg))))))
 465
 466 ;;; You need your own 'my-snap-search-mail'
 467 ;;; which receives message-id and returns its file name.
 468 (eval-when-compile
 469   (defalias 'my-snap-search-mail 'ignore))
 470
 471 (defun snap-search-mail (message-id)
 472   (message "Searching...")
 473   (or (my-snap-search-mail message-id)
 474       (error "Not found: %s" message-id)))
 475
 476 (defun snap-line-number ()
 477   (let ((raw (count-lines (point-min) (point))))
 478     ;; see (describe-function 'count-lines)
 479     (if (bolp)
 480         (+ raw 1)
 481       raw)))
 482
 483 ;;; check
 484 (let ((snap-abbrev '(("l" "dired-mode" "usr/meadow/1.15/lisp/")
 485                      ("s" "shell-mode" "~/#")))
 486       (qa '(("snap://l/file" "snap://dired-mode/usr/meadow/1.15/lisp/file")
 487             ("snap://s/dir" "snap://shell-mode/~/#dir"))))
 488   (mapcar (lambda (z)
 489             (apply (lambda (short long)
 490                      (if (and (string= short (snap-shrink-string long))
 491                               (string= (snap-expand-string short) long))
 492                          t
 493                        (error "incorrect snap-abbrev: %s %s" short long)))
 494                    z))
 495           qa))
 496
 497 (defun snap-find-file (path)
 498   (find-file (expand-file-name (substitute-in-file-name path)
 499                                snap-root-dir)))
 500
 501 (put 'snap-with-features 'lisp-indent-function 1)
 502 (put 'snap-define-op 'lisp-indent-function 2)
 503 ;; SXEmacs doesn't have font-lock-add-keywords --SY.
 504 (unless (featurep 'sxemacs)
 505   (font-lock-add-keywords
 506    'emacs-lisp-mode
 507    '(("(\\(snap-with-features\\)\\>" 1 font-lock-keyword-face)
 508      ("(\\(snap-define-op\\)\\>[
 509   \t]+\\(\\sw+\\)"
 510       (1 font-lock-keyword-face)
 511       (2 font-lock-function-name-face)))))
 512
 513 (defmacro snap-with-features (snap-features &rest body)
 514   "Check existence of all SNAP-FEATURES and evaluate BODY if ok.
 515 This macro also attaches requirements of SNAP-FEATURES
 516 inside `eval-when-compile'.
 517
 518 In this environment, a macro `snap-define-op' is available.
 519 This macro is similar to `defun', but requires SNAP-FEATURES."
 520   (unless (memq nil
 521                 (mapcar (lambda (feature)
 522                           (locate-library (symbol-name feature)))
 523                         snap-features))
 524 ;;       `(eval-when-compile
 525 ;;          (message "Ignore some features which require %s." ',snap-features))
 526     `(progn
 527        (eval-when-compile
 528          ,@(mapcar (lambda (feature)
 529                      `(require ',feature))
 530                    snap-features))
 531        (macrolet
 532            ((snap-define-op
 533                 (name arg &rest body)
 534                 (append (list 'defun name arg)
 535                         (mapcar (lambda (feature)
 536                                   (list 'require (list 'quote feature)))
 537                                 ',snap-features)
 538                         body)))
 539          ,@body))))
 540
 541 ;; dummy definition for completion
 542 (defalias 'snap-define-op 'ignore)
 543
 544 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 545 ;;; applications
 546
 547 ;;; <Application>
 548 ;;; <Sample>
 549
 550 ;;; (Default)
 551 ;;; snap:///~/elisp/snap.el#177:(defun snap-record: ()
 552
 553 (defvar snap-record-default-format "%s#%s:%s")
 554                                         ;see also `snap-record:occur-mode'
 555 (defun snap-record: ()
 556   (let ((raw-path (buffer-file-name)))
 557     (if (null raw-path)
 558         nil
 559       (let* ((line (snap-line-number))
 560              (text (save-excursion
 561                      (beginning-of-line)
 562                      (looking-at "^[ \t]*\\(.*\\)")
 563                      (match-string-no-properties 1)))
 564              (path (snap-abbreviate-file-name raw-path)))
 565         (format snap-record-default-format path line text)))))
 566
 567 (defun snap-abbreviate-file-name (raw-path)
 568   (let ((relative-path  ;; not snap:////etc but snap:///etc
 569          (file-relative-name raw-path snap-root-dir))
 570         (abbrev-path  ;; not snap:///home/foo but snap:///~foo
 571          (abbreviate-file-name raw-path)))
 572     ;; use shorter one
 573     (if (< (length relative-path) (length abbrev-path))
 574         relative-path
 575       abbrev-path)))
 576
 577 (defun snap-play: (spell)
 578   (cond
 579    ((or (null spell) (string= spell ""))
 580     (message "snap-version %s" snap-version))
 581    ((string-match "\\([^#\r\n]+\\)\\(#\\([0-9]+\\):\\(.*\\)\\)?" spell)
 582     (let ((path (match-string-no-properties 1 spell))
 583           (positionp (match-string-no-properties 2 spell))
 584           (line (match-string-no-properties 3 spell))
 585           (text (match-string-no-properties 4 spell)))
 586       (snap-find-file path)
 587       (when positionp
 588         (snap-play-search: (concat "^[ \t]*" (regexp-quote text) "$")
 589                            (string-to-number line)))))
 590    (t
 591     (error "not supported: %s" spell))))
 592
 593 (defun snap-play-search: (regexp line-number)
 594   (goto-line line-number)
 595   (cond ((looking-at regexp) t)
 596         ((snap-occur-p regexp) (snap-occur regexp line-number))
 597         (t (message "No match."))))
 598
 599 (defun snap-occur-p (regexp)
 600   (save-excursion
 601     (goto-char (point-min))
 602     (re-search-forward regexp nil t)))
 603
 604 (defun snap-occur (regexp line-number)
 605   (occur regexp 0)
 606   (switch-to-buffer "*Occur*") ;; why needed??
 607   (let ((hits (snap-looking-at-number)))
 608     (forward-line)
 609     (if (= hits 1)
 610         (snap-occur-goto-occurence)
 611       (snap-occur-goto-line line-number))))
 612
 613 (defun snap-occur-goto-occurence ()
 614   (message "Line number is obsolete.")
 615   (occur-mode-goto-occurrence)
 616   ;; I prefer bol.
 617   (beginning-of-line))
 618
 619 (defun snap-occur-goto-line (line-number)
 620   (while (let* ((n (snap-looking-at-number))
 621                 (stop (and n (>= n line-number))))
 622            (and (not stop)
 623                 (= (forward-line) 0)))
 624     ;; nothing to do
 625     nil)
 626   (if (not (snap-looking-at-number))
 627       (forward-line -1)))
 628
 629 (defun snap-looking-at-number ()
 630   (and (looking-at "[ \t]*\\([0-9]+\\)")
 631        (string-to-number (match-string-no-properties 1))))
 632
 633 ;;; Wanderlust
 634 ;;; snap://wl-summary-mode/+ME/hira/<20031101192305.AFA8C43EDC@hoge.fuga.piyo>
 635
 636 (snap-with-features (wl)
 637   (snap-define-op snap-record:wl-summary-mode ()
 638     (let ((n (wl-summary-message-number)))
 639       (and (numberp n)
 640            (let* ((folder wl-summary-buffer-elmo-folder)
 641                   (fld-name (elmo-folder-name-internal folder))
 642                   (id (elmo-message-field folder n 'message-id)))
 643              (snap-encode:wl-summary-mode fld-name id)))))
 644
 645   (snap-define-op snap-play:wl-summary-mode (spell)
 646     (let ((prefix-arg 4))
 647       (wl prefix-arg)) ;; skip folder checking
 648     (let* ((state (snap-decode:wl-summary-mode spell))
 649            (fld-name (car state))
 650            (id (cadr state))
 651            (summary-buf (wl-summary-get-buffer-create fld-name)))
 652       (wl-summary-goto-folder-subr fld-name
 653                                    (wl-summary-get-sync-range
 654                                     (wl-folder-get-elmo-folder fld-name))
 655                                    nil nil t)
 656       (wl-summary-jump-to-msg-by-message-id id)
 657       (wl-summary-redisplay)))
 658
 659   (snap-define-op snap-repair:wl-summary-mode (spell)
 660     (let* ((state (snap-decode:wl-summary-mode spell))
 661            (id (cadr state))
 662            (found-file (snap-search-mail id))
 663            (folder (snap:wl-file-folder found-file)))
 664       (when (null folder)
 665         (error "No folder for %s" found-file))
 666       (snap-encode:wl-summary-mode folder id)))
 667
 668   (defun snap-encode:wl-summary-mode (folder-name message-id)
 669     (concat folder-name "/" message-id))
 670
 671   (defun snap-decode:wl-summary-mode (spell)
 672     (and (string-match "\\(.*\\)/\\([^/]*\\)" spell)
 673          (let ((fld-name (match-string-no-properties 1 spell))
 674                (id (match-string-no-properties 2 spell)))
 675            (list fld-name id))))
 676
 677   (defun snap:wl-file-folder (file)
 678     (setq file (file-truename file))
 679     (let ((buf (current-buffer)))
 680       (wl 4)
 681       (goto-char (point-min))
 682       (wl-folder-open-all)
 683       (prog1
 684           (catch 'found
 685             (while (not (eobp))
 686               (let* ((name (wl-folder-get-entity-from-buffer))
 687                      (folder (wl-folder-search-entity-by-name
 688                               name
 689                               wl-folder-entity 'folder))
 690                      (ef (and folder (wl-folder-get-elmo-folder folder)))
 691                      (dir (and ef
 692                                (eq (elmo-folder-type-internal ef) 'localdir)
 693                                (elmo-localdir-folder-directory-internal ef))))
 694                 (when (and dir
 695                            (string-match (format "^%s"
 696                                                  (regexp-quote
 697                                                   (file-truename dir)))
 698                                          file))
 699                   (throw 'found name))
 700                 (forward-line)))
 701             nil)
 702         (switch-to-buffer buf))))
 703   )
 704
 705 ;;; Help
 706 ;;; snap://help-mode/f/find-file
 707 ;;; snap://help-mode/m/lambda
 708 ;;; snap://help-mode/v/buffer-file-name
 709
 710 ;; Recording the `m' (macro) variant of the spell is only available
 711 ;; on (S)XEmacs because I didn't know how to do it for GNU/Emacs.
 712 ;; snap-play should work fine for all emacsen though. --SY.
 713 (eval-and-compile
 714   (when (featurep 'xemacs)
 715     (provide 'help)))
 716
 717 (snap-with-features (help)
 718     (snap-define-op snap-record:help-mode ()
 719       (if (featurep 'xemacs)
 720           (progn
 721             (let ((name (save-excursion
 722                           (goto-char (point-min))
 723                           (re-search-forward "^`\\(.*\\)'" (eolp) t)
 724                           (intern-soft (match-string 1)))))
 725               (if (fboundp name)
 726                   (if (eq 'macro (car-safe (symbol-function name)))
 727                       (format "m/%s" name)
 728                     (format "f/%s" name))
 729                 (format "v/%s" name))))
 730         (let ((function (car help-xref-stack-item))
 731               (variable (car (cdr help-xref-stack-item))))
 732           (cond
 733            ((equal function 'describe-function) (format "f/%s" variable))
 734            ((equal function 'describe-variable) (format "v/%s" variable))
 735            (help-xref-stack-item help-xref-stack-item)
 736            (t "")))))
 737
 738   (snap-define-op snap-play:help-mode (spell)
 739     (if (string-match "\\([^/\n \t]+\\)/\\(.+\\)" spell)
 740         (let ((function (match-string 1 spell))
 741               (variable (match-string 2 spell)))
 742           (cond
 743            ((or (string-match "^f.*" function)
 744                 (string-match "^m.*" function)
 745                 (string-match "describe-function" function))
 746             (describe-function (intern variable)))
 747            ((or (string-match "^v.*" function)
 748                 (string-match "describe-variable" function))
 749             (describe-variable (intern variable)))
 750            (t
 751             (message "Not support this method %s" spell))))
 752       (message "I can't all %s" spell)))
 753
 754 ;; for fake cgi
 755   (defun snap-play:help-mode: (op val)
 756     (snap-play-cgi-on "*Help*" op val))
 757   )
 758
 759 ;;; Bookmark
 760 ;;; snap://bookmark-bmenu-mode/kuzu
 761
 762 (snap-with-features (bookmark)
 763   (snap-define-op snap-record:bookmark-bmenu-mode ()
 764     (bookmark-bmenu-bookmark))
 765
 766   (snap-define-op snap-play:bookmark-bmenu-mode (spell)
 767     (if (equal spell "")
 768         (progn
 769           (bookmark-bmenu-list)
 770           (switch-to-buffer "*Bookmark List*"))
 771       (bookmark-jump spell)))
 772   )
 773
 774 ;;; Man
 775 ;;; snap://Man-mode/printf/3
 776
 777 ;;; (S)XEmacs records to these spells, but can play both formats. --SY.
 778 ;;; snap://Manual-mode/ls
 779 ;;; snap://Manual-mode/printf/3
 780
 781 (snap-with-features (man)
 782   (defvar snap-man-spacer "/")
 783
 784   (defvar *snap-man-mode-cgi* nil "for internal use")
 785   (defvar *snap-man-mode-buffer* nil "for internal use")
 786
 787   (if (featurep 'xemacs)
 788       ;; (S)XEmacs
 789       (progn
 790         (snap-define-op snap-record:Manual-mode ()
 791           (let ((buf (buffer-name)))
 792             (cond
 793              ((string-match "^Man: \\(.*\\)(\\([1-8]+\\))$" buf)
 794               (concat (match-string 1 buf) snap-man-spacer (match-string 2 buf)))
 795              ((string-match "^Man: \\(.*$\\)" buf)
 796               (concat (match-string 1 buf)))
 797              (t
 798               (error "not support buffer-name of man-mode: %s" buf)))))
 799
 800         (snap-define-op snap-play:Manual-mode (spell)
 801           (let* ((strs (split-string spell (regexp-quote snap-man-spacer)))
 802                  (str-com (car strs))
 803                  (str-sec (mapconcat 'concat (cdr strs) snap-man-spacer))
 804                  (topic (if (equal str-sec "")
 805                             (concat str-com)
 806                           (concat  str-com "(" str-sec ")"))))
 807             ;; `snap-play:Man-mode:' needs this information.
 808             (setq *snap-man-mode-buffer* (snap-man-mode-buffer topic))
 809             (manual-entry topic)))
 810
 811         (snap-define-op snap-play:Man-mode (spell)
 812           (let* ((strs (split-string spell (regexp-quote snap-man-spacer)))
 813                  (str-com (car strs))
 814                  (str-sec (mapconcat 'concat (cdr strs) snap-man-spacer))
 815                  (topic (if (equal str-sec "")
 816                             (concat str-com)
 817                           (concat  str-com "(" str-sec ")"))))
 818             ;; `snap-play:Man-mode:' needs this information.
 819             (setq *snap-man-mode-buffer* (snap-man-mode-buffer topic))
 820             (manual-entry topic))))
 821     ;; GNU/Emacs
 822     (snap-define-op snap-record:Man-mode ()
 823       (let ((buf (buffer-name)))
 824         (cond
 825          ((string-match "^[*]Man[ \t]+\\([^ \t]+\\)[ \t]+\\([^ \t]+\\)[*]" buf)
 826           (concat (match-string 2 buf) snap-man-spacer (match-string 1 buf)))
 827          ((string-match "^[*]Man[ \t]+\\([^ \t]+\\)[*]" buf)
 828           (concat (match-string 1 buf)))
 829          (t
 830           (error "not support buffer-name of man-mode: %s" buf)))))
 831
 832     (snap-define-op snap-play:Man-mode (spell)
 833       (let* ((strs (split-string spell (regexp-quote snap-man-spacer)))
 834              (str-com (car strs))
 835              (str-sec (mapconcat 'concat (cdr strs) snap-man-spacer))
 836              (topic (if (equal str-sec "")
 837                         (concat str-com)
 838                       (concat  str-com "(" str-sec ")"))))
 839         ;; `snap-play:Man-mode:' needs this information.
 840         (setq *snap-man-mode-buffer* (snap-man-mode-buffer topic))
 841         (man topic))))
 842
 843
 844   ;; For fake cgi, we need to adjourn operations
 845   ;; because man process is run asynchronously.
 846
 847   (defun snap-play:Man-mode: (op val)
 848     (if *snap-man-mode-buffer*
 849         ;; When corresponding man-buffer already exists, `man' just notifies it.
 850         ;; Man-mode-hook is not run in this case.
 851         ;; So, we will do our job immediately.
 852         (snap-play-cgi-on *snap-man-mode-buffer* op val)
 853       (snap-man-mode-adjourn-cgi op val)))
 854
 855   (defadvice Man-bgproc-sentinel (around snap-cgi (process msg) activate)
 856     ad-do-it
 857     (snap-do-on (snap-man-mode-process-buffer process)
 858                 #'snap-man-mode-play-cgi))
 859
 860   (defun snap-man-mode-adjourn-cgi (op val)
 861     (add-to-list '*snap-man-mode-cgi* (cons op val)))
 862
 863   (defun snap-man-mode-play-cgi (&optional buf)
 864     (unwind-protect
 865         (mapcar (lambda (pair)
 866                   (snap-play-cgi (car pair) (cdr pair)))
 867                 *snap-man-mode-cgi*)
 868       (setq *snap-man-mode-cgi* nil)))
 869
 870   ;; copied from man.el
 871
 872   (defun snap-man-mode-buffer (topic)
 873     ;; from `Man-getpage-in-background'
 874     (let* ((man-args topic)
 875            (bufname (concat "*Man " man-args "*"))
 876            (buffer  (get-buffer bufname)))
 877       buffer))
 878
 879   (defun snap-man-mode-process-buffer (process)
 880     ;; from `Man-bgproc-sentinel'
 881     (if (stringp process)
 882         (get-buffer process)
 883       (process-buffer process)))
 884
 885   ;; ;; I used `Man-mode-hook' instead of defadvice at first.
 886   ;; ;; But, "q" operation failed because Man-mode-hook is run
 887   ;; ;; inside save-excursion in `Man-bgproc-sentinel'.
 888   ;; (add-hook 'Man-mode-hook #'snap-man-mode-play-cgi)
 889   )
 890
 891 ;;; Info
 892 ;;; snap://Info-mode/cvs#Tracking sources
 893
 894 (snap-with-features (info)
 895   (defvar snap-info-spacer "#")
 896
 897   (snap-define-op snap-record:Info-mode ()
 898     (let ((str-file (if Info-current-file
 899                         (file-name-nondirectory Info-current-file)
 900                       ""))
 901           (str-node (or Info-current-node "")))
 902       (concat str-file snap-info-spacer str-node)))
 903
 904   (snap-define-op snap-play:Info-mode (spell)
 905     (let* ((strs (split-string spell (regexp-quote snap-info-spacer)))
 906            (str-file (or (car strs) "dir"))
 907            (str-node (mapconcat 'concat (cdr strs) snap-info-spacer)))
 908       (Info-goto-node (concat "(" str-file ")" str-node))))
 909   )
 910
 911 ;;; Emacs-wiki
 912 ;;; snap://emacs-wiki-mode/WelcomePage#title
 913
 914 (snap-with-features (emacs-wiki)
 915   (snap-define-op snap-record:emacs-wiki-mode ()
 916     (let ((raw-path (buffer-file-name)))
 917       (if (null raw-path)
 918           nil
 919         (format "%s" (file-name-nondirectory raw-path)))))
 920
 921   (snap-define-op snap-play:emacs-wiki-mode (spell)
 922     (emacs-wiki-visit-link spell))
 923   )
 924
 925 ;;; Navi2ch
 926 ;;; snap://navi2ch-article-mode/pc5.2ch.net/test/read.cgi/tech/1068351911/100-200
 927 ;;; snap://navi2ch-article-mode/http://pc5.2ch.net/test/read.cgi/tech/1068351911/150
 928
 929 (snap-with-features (navi2ch)
 930   (defvar snap-navi2ch-set-offline t)
 931
 932   (snap-define-op snap-record:navi2ch-article-mode ()
 933     (save-match-data
 934       (let* ((n (navi2ch-article-get-current-number))
 935              (s (navi2ch-article-to-url navi2ch-article-current-board
 936                                         navi2ch-article-current-article
 937                                         n n t)))
 938         (when (string-match "^http://" s)
 939           (setq s (substring s (match-end 0))))
 940         s)))
 941
 942   (snap-define-op snap-play:navi2ch-article-mode (spell)
 943     (when snap-navi2ch-set-offline
 944       (setq navi2ch-offline t))
 945     (navi2ch-goto-url (if (string-match "^http://" spell)
 946                           spell
 947                         (concat "http://" spell))))
 948   )
 949
 950 ;;; w3m
 951 ;;; snap://w3m-mode/http://www
 952
 953 ;; (snap-with-features (w3m)
 954 ;;   (snap-define-op snap-record:w3m-mode ()
 955 ;;     w3m-current-url)
 956
 957 ;;   (snap-define-op snap-play:w3m-mode (spell)
 958 ;;     (w3m spell))
 959 ;;   )
 960
 961 ;;; Dired
 962 ;;; snap://dired-mode/~/
 963
 964 (snap-with-features (dired)
 965   (snap-define-op snap-record:dired-mode ()
 966     (snap-abbreviate-file-name dired-directory))
 967
 968   (snap-define-op snap-play:dired-mode (spell)
 969     (snap-find-file spell))
 970   )
 971
 972 ;;; BBDB
 973 ;;; snap://bbdb-mode/name
 974
 975 (snap-with-features (bbdb)
 976   (snap-define-op snap-play:bbdb-mode (spell)
 977     (bbdb spell nil))
 978
 979   (snap-define-op snap-record:bbdb-mode ()
 980     (let ((bbdb-record (bbdb-current-record)))
 981       (car (bbdb-record-net bbdb-record))))
 982
 983   (defun snap-play:bbdb-mode: (op val)
 984     ;; disable fake cgi
 985     )
 986   )
 987
 988 ;;; Bibtex
 989 ;;; snap://bibtex-mode/file#bibtex-key
 990
 991 (snap-with-features (bibtex)
 992   (defvar snap-bibtex-spacer "#")
 993   (snap-define-op snap-play:bibtex-mode (spell)
 994     (if (string-match "^\\(.*\\)#\\(.*\\)$" spell)
 995         (let ((k (match-string 2 spell)))
 996           (find-file (match-string 1 spell))
 997           (and k
 998                (not (snap-bibtex-search k))
 999                (message "No such bibtex-key \"%s\"" k)))
1000       (find-file spell)))
1001   (defun snap-bibtex-search (k)
1002     (let ((regexp (concat "^@.*" k)))
1003       (goto-char (point-max))
1004       (while (and (re-search-backward regexp nil t)
1005                   (not (string= k (snap-bibtex-key)))))
1006       (string= k (snap-bibtex-key))))
1007   (defun snap-bibtex-key ()
1008     (save-excursion                     ;c.f. `bibtex-clean-entry'
1009       (let ((case-fold-search t)
1010             (eob (bibtex-end-of-entry))
1011             (head (cond ((boundp 'bibtex-entry-head) ; new
1012                          bibtex-entry-head)
1013                         ((boundp 'bibtex-reference-head) ; old
1014                          bibtex-reference-head)
1015                         (t
1016                          (error "Neither bibtex-entry-head nor bibtex-reference-head is defined.")))))
1017         (bibtex-beginning-of-entry)
1018         (if (re-search-forward head eob t)
1019             (buffer-substring-no-properties
1020              (match-beginning bibtex-key-in-head)
1021              (match-end bibtex-key-in-head))))))
1022   (snap-define-op snap-record:bibtex-mode ()
1023     (let ((f (buffer-file-name))
1024           (k (snap-bibtex-key)))
1025       (if k
1026           (concat f snap-bibtex-spacer k)
1027         f)))
1028   )
1029
1030 ;;; Shell
1031 ;;; snap://shell-mode/~/#pwd
1032
1033 ;;; ToDo directory with # is not allowed!
1034
1035 (snap-with-features (shell)
1036   (defvar snap-shell-spacer "#")
1037   (defvar snap-shell-buffer-name "*shell*snap*")
1038
1039   (snap-define-op snap-record:shell-mode ()
1040     "record now directory and a command now inputed"
1041     (let ((pm (process-mark (get-buffer-process (current-buffer))))
1042           (p (point)))
1043       ;; c.f. comint-kill-input
1044       (concat default-directory
1045               (if (> p (marker-position pm))
1046                   (concat snap-shell-spacer (buffer-substring-no-properties pm p))))))
1047   (snap-define-op snap-play:shell-mode (spell)
1048     "1. start shell-mode for snap 2.  insert a command (without
1049 execution)"
1050     (string-match "\\([^#\r\n]+\\)#?\\(.*\\)" spell)
1051     (let ((default-directory (match-string-no-properties 1 spell))
1052           (c (or (match-string-no-properties 2 spell) ""))
1053           nn no)
1054       (if (not (comint-check-proc "*shell*"))
1055           (shell)
1056         ;;duplicate shell
1057         (set-buffer "*shell*")
1058         (setq no (rename-buffer "*shell*" t))
1059         (shell)
1060         (setq nn (rename-buffer snap-shell-buffer-name t))
1061         (set-buffer no)
1062         (rename-buffer "*shell*" t)
1063         (set-buffer nn)
1064         )
1065       (insert c)))
1066   )
1067
1068 ;;; Occur
1069 ;;; snap://occur-mode/dired-mode/~/??q=drwx??g=2
1070 ;;; by using "snap://MAJOR-MODE/SPELL??q=word"
1071
1072 (snap-with-features ()
1073   (defvar snap-occur-cgi-string "q")
1074   (snap-define-op snap-record:occur-mode ()
1075     (let* ((b occur-buffer)
1076            (s (car occur-command-arguments))
1077            (snap-record-cgi nil)
1078            (snap-record-default-format "%s")
1079            (x (snap-decode (save-excursion (set-buffer b) (snap-record-string))))
1080            (mode (car x))
1081            (spell (cadr x))
1082            (snap (snap-encode mode (snap-spell-encode spell (snap-cgi-encode snap-occur-cgi-string s)))))
1083       (if (string-match (concat "^" snap-prt) snap)
1084           (substring snap (match-end 0))
1085         snap)))
1086
1087   (snap-define-op snap-play:occur-mode (spell)
1088     (save-window-excursion
1089       (snap-play-string (concat snap-prt spell)))
1090     (if (get-buffer "*Occur*")
1091         (switch-to-buffer "*Occur*")
1092       (message "maybe failed to match")))
1093   )
1094
1095 ;;; Howm
1096 ;;; snap://howm-view-summary-mode/word
1097 ;;; snap://howm-view-contents-mode/word
1098                                         ; checked on howm-test-050518
1099
1100 (snap-with-features (howm)
1101   (snap-define-op snap-record:howm-view-summary-mode ()
1102     (howm-view-name))
1103   (snap-define-op snap-record:howm-view-contents-mode ()
1104     (howm-view-name))
1105   (snap-define-op snap-play:howm-view-summary-mode (spell)
1106     ;; completion-p is always nil in my case.
1107     (message "howm searching %s ..." spell)
1108     ;; message is needed because howm-search needs long time.
1109     (howm-search spell nil))
1110   (snap-define-op snap-play:howm-view-contents-mode (spell)
1111     (message "howm searching %s ..." spell)
1112     (howm-search spell nil))
1113   )
1114
1115 ;;; Gnus
1116 ;;; snap://gnus-summary-mode/group/article-number:<20031101.ACDC@hoge.fuga.piyo>
1117
1118 (snap-with-features (gnus gnus-sum)
1119   (snap-define-op snap-record:gnus-summary-mode ()
1120     (snap-encode:gnus-summary-mode
1121      gnus-newsgroup-name
1122      (gnus-summary-article-number)
1123      (mail-header-message-id (gnus-summary-article-header))))
1124
1125   (snap-define-op snap-play:gnus-summary-mode (spell)
1126     (unless (and (fboundp 'gnus-alive-p) (gnus-alive-p)) (gnus))
1127     (require 'gnus-score)
1128     (let* ((state (snap-decode:gnus-summary-mode spell))
1129            (group (car state))
1130            (article (cadr state))
1131            (id (car (cddr state)))
1132            backend
1133            ;; cf. gnus-group-quick-select-group
1134            ;; gnus-visual
1135            gnus-score-find-score-files-function
1136            gnus-home-score-file
1137            gnus-apply-kill-hook
1138            gnus-summary-expunge-below)
1139       (setq backend
1140             (if (string-match "\\([^+]+\\).*:.+" group)
1141                 (match-string 1 group)
1142               (symbol-name (car gnus-select-method))))
1143       ;; disable getting new message
1144       (eval `(let ((,(intern (concat backend "-get-new-mail")) nil))
1145                (gnus-group-read-group 0 t group)))
1146       (unless (and
1147                (gnus-summary-goto-article article nil t)
1148                (string= id (mail-header-message-id (gnus-summary-article-header))))
1149         (gnus-summary-goto-article id nil t))))
1150
1151   (defun snap-encode:gnus-summary-mode (group article id)
1152     (format "%s/%s:%s" group article id))
1153
1154   (defun snap-decode:gnus-summary-mode (spell)
1155     (when (string-match "\\(.*\\)/\\([0-9]+\\):\\([^/]*\\)" spell)
1156       (list (match-string-no-properties 1 spell)
1157             (match-string-no-properties 2 spell)
1158             (match-string-no-properties 3 spell))))
1159   )
1160
1161 ;;; PCVS
1162 ;;; snap://cvs-mode/~/hoge/
1163
1164 (snap-with-features (pcl-cvs)
1165   (snap-define-op snap-play:cvs-mode (spell)
1166     (cvs-examine spell t))
1167   (snap-define-op snap-record:cvs-mode ()
1168     (abbreviate-file-name default-directory))
1169   )
1170
1171 ;;; Thumb
1172 ;;; snap://thumbs-mode/~/hoge/
1173 ;;; snap://thumbs-view-image-mode/~/tmp.jpg
1174
1175 (snap-with-features (thumbs)
1176   (snap-define-op snap-record:thumbs-mode ()
1177     ;; only for `thumbs-show-all-from-dir' not `thumbs-dired-show-marked'.
1178     (abbreviate-file-name thumbs-current-dir))
1179   (snap-define-op snap-play:thumbs-mode (spell)
1180     (thumbs-show-all-from-dir spell nil t))
1181   (snap-define-op snap-record:thumbs-view-image-mode ()
1182     (abbreviate-file-name thumbs-current-image-filename))
1183   (snap-define-op snap-play:thumbs-view-image-mode (spell)
1184     (if (file-exists-p spell)
1185         (thumbs-find-image spell)
1186       (message "No such file:%s" spell)))
1187   )
1188
1189 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1190 ;;; cgi extension
1191 ;;;
1192 ;;; Examples:
1193 ;;;|goto-line       |snap:///file??g=110
1194 ;;;|search&move str |snap:///file??s=str
1195 ;;;|occur str       |snap:///file??q=str
1196 ;;;|dired-x (file)  |snap:///??x=file
1197 ;;;|dired-x (buffer)|snap:///??x=
1198 ;;;|open & dired-x  |snap:///file??x=
1199 ;;;|open &dired-x   |snap:///dir??x=file
1200 ;;;|find & dired-x  |snap:///dir??s=str&x=
1201 ;;;|move & dired-x  |snap:///dir??g=10&x=
1202 ;;;
1203 ;;; ToDo: find and compilation
1204
1205 (defun snap-play-dired-x (file)
1206   ""
1207   (let ((dir (or (file-name-directory file) default-directory))
1208         (filename (file-name-nondirectory file))
1209         (font-lock-global-modes nil))
1210     (save-excursion
1211       (find-file dir)
1212       (goto-char (point-min))
1213       (search-forward-regexp (concat "[ ]" (regexp-quote filename) "$") nil)
1214       (call-interactively 'dired-do-shell-command)
1215       (bury-buffer))))
1216
1217 (defun snap-play::x (spell)
1218   "snap-record cgi extension for execute"
1219   (if (or (null spell) (string= "" spell))
1220       (cond
1221        (buffer-file-name
1222         (snap-play-dired-x buffer-file-name))
1223        ((eq major-mode 'dired-mode)
1224         (call-interactively 'dired-do-shell-command))
1225        (t
1226         (message "error")))
1227     (cond
1228      ((or (file-exists-p spell) (eq major-mode 'dired-mode))
1229       (snap-play-dired-x spell))
1230      (buffer-file-name
1231       (snap-play-dired-x buffer-file-name))
1232      (t
1233       (message "error")))))
1234 (defun snap-record::g ()
1235   "snap-record cgi extension for goto-line"
1236   (number-to-string (snap-line-number)))
1237 (defun snap-play::g (spell)
1238   "snap-record cgi extension for goto-line"
1239   (goto-line (string-to-number spell)))
1240 (defun snap-record:: ()
1241   "snap-record cgi extension for default tag"
1242   (number-to-string (snap-line-number)))
1243 (defun snap-play:: (spell)
1244   "snap-record cgi extension for default tag"
1245   (goto-line (string-to-number spell)))
1246 (defun snap-record::s ()
1247   "snap-record cgi extension for search return the string of
1248 kill-ring. (not work. help) "
1249   (cond
1250    ;;  ((eq last-command 'kill-ring-save)
1251    ;;    (remove-text-properties (current-kill 0))
1252    ;;    )
1253    (t
1254     (save-excursion
1255       (beginning-of-line)
1256       (looking-at "^[ \t]*\\(.*\\)")
1257       (match-string-no-properties 1)))))
1258 (defun snap-play::s (spell)
1259   "snap-play cgi extension for search around point"
1260   (or (search-forward spell nil t)
1261       (progn (goto-char (point-max))
1262              (search-backward spell nil t))
1263       (message "Failed search")))
1264 (defun snap-record::q ()
1265   "snap-record cgi extension for search
1266
1267 return 1. the string of kill-ring.  (not yet)
1268
1269 2. the word at cursor."
1270   (cond
1271    ;;   ((eq last-command 'kill-ring-save)
1272    ;;    (remove-text-properties (current-kill 0))
1273    ;;    )
1274    ((provide 'thingatpt)
1275     (or (thing-at-point 'word) (thing-at-point 'symbol)))
1276    (t
1277     nil)))
1278
1279 (defun snap-play::q (spell)
1280   "snap-play cgi extension for occur"
1281   (occur spell))
1282
1283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1284 ;;; with other tools
1285
1286 ;;; with action-lock.el
1287 ;;; (in howm: <http://howm.sourceforge.jp/>)
1288
1289 (snap-with-features (action-lock)
1290   (defun snap-action-lock (regexp arg-pos &optional hilit-pos)
1291     (action-lock-general #'(lambda (f u)
1292                              (call-interactively 'snap-play))
1293                          regexp arg-pos hilit-pos t))
1294   )
1295
1296 (eval-after-load "action-lock"
1297   '(let ((snap-action-lock-rules (list (snap-action-lock snap-regexp 0))))
1298      (setq action-lock-default-rules
1299            (append snap-action-lock-rules action-lock-default-rules))))
1300
1301 ;;; with bookmark
1302
1303 (snap-with-features (bookmark)
1304   (defadvice bookmark-buffer-file-name
1305     (around with-snap first () disable)
1306     "Extend it's function for snap protocol"
1307     ad-do-it
1308     (unless ad-return-value
1309       (setq ad-return-value (snap-record-string))))
1310   (defadvice bookmark-jump-noselect (around with-snap first (str) disable)
1311     "Extend it's function for snap protocol with the help of
1312 `snap-bookmark-jump-noselect'.
1313
1314 Suppose `bookmark-jump-noselect' has (str) as inputs and
1315 returns (BUFFER . POINT)
1316 "
1317     (bookmark-maybe-load-default-file)
1318     (let* ((str (ad-get-arg 0))
1319            (url (bookmark-get-filename str)))
1320       (cond
1321        ((string-match snap-regexp url)
1322         (setq ad-return-value (snap-bookmark-jump-noselect str)))
1323        (t ad-do-it))))
1324   (defun snap-bookmark-jump-noselect (str)
1325     (let* ((url (bookmark-get-filename str))
1326            (snap-p (string-match snap-regexp url))
1327 ;;            (file (if snap-p url (expand-file-name url)))
1328            (forward-str (bookmark-get-front-context-string str))
1329            (behind-str (bookmark-get-rear-context-string str))
1330 ;;            (place (bookmark-get-position str))
1331 ;;            (info-node (bookmark-get-info-node str))
1332 ;;            (orig-file file)
1333            )
1334       (if snap-p
1335           (save-excursion
1336             (save-window-excursion
1337               (snap-play-string url)
1338               (when (and forward-str
1339                          (search-forward forward-str (point-max) t))
1340                 (goto-char (match-beginning 0)))
1341               (when (and behind-str
1342                          (search-backward behind-str (point-min) t))
1343                 (goto-char (match-end 0)))
1344               (setq bookmark-current-bookmark str)
1345               (cons (current-buffer) (point))))
1346         (ding))))
1347   )
1348
1349 ;;; with ffap
1350
1351 (snap-with-features (ffap)
1352   (defvar snap-ffap-url-regexp
1353     (concat
1354      "\\`\\("
1355      "news\\(post\\)?:\\|mailto:\\|file:" ; no host ok
1356      "\\|"
1357      "\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\|snap\\)://" ; needs host
1358      "\\)."                             ; require one more character
1359      ))
1360   (defvar snap-ffap-url-fetcher 'snap-ffap-browse-url)
1361   (defun snap-ffap-browse-url (url &rest args)
1362     "Deal with a snap protocol in addition to the function `browse-url'"
1363     (if (string-match snap-regexp url)
1364         (snap-play-string url)
1365       (browse-url url args)))
1366   )
1367
1368 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1369 ;;; provide
1370
1371 (provide 'snap)
1372
1373 ;;; snap.el ends here.