cgit.sxemacs.org Git - packages/blob - mule-packages/lookup/lisp/lookup-content.el

   1 ;;; lookup-content.el --- lookup-content-mode
   2 ;; Copyright (C) 1999 Lookup Development Team <lookup@ring.gr.jp>
   3
   4 ;; Author: Keisuke Nishida <kei@psn.net>
   5 ;; Version: $Id: lookup-content.el,v 1.3 1999/05/23 17:27:20 knishida Exp $
   6
   7 ;; This file is part of Lookup.
   8
   9 ;; Lookup is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; Lookup is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with Lookup; if not, write to the Free Software Foundation,
  21 ;; Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  22
  23 ;;; Code:
  24
  25 (require 'lookup)
  26 (require 'lookup-vse)
  27
  28 ;;;
  29 ;:: Internal variables
  30 ;;;
  31
  32 ;; \e$B%P%C%U%!$,I=<($7$F$$$k%(%s%H%j$rJ];}$9$k!#\e(B
  33 (defvar lookup-content-current-entry nil)
  34
  35 ;; \e$B%b!<%I%i%$%s9T$KI=<($9$k>pJs!#\e(B
  36 (defvar lookup-content-line-heading nil)
  37
  38 (make-variable-buffer-local 'lookup-content-current-entry)
  39 (make-variable-buffer-local 'lookup-content-line-heading)
  40
  41 ;;;;;;;;;;;;;;;;;;;;
  42 ;: Construct Buffer
  43 ;;;;;;;;;;;;;;;;;;;;
  44
  45 ;; Content \e$B%P%C%U%!$K$O%(%s%H%j$NFbMF$,=PNO$5$l$k!#\e(B
  46 ;; \e$B4X?t\e(B `lookup-content-display' \e$B$K$h$j!"$3$l$r9T$J$&!#\e(B
  47
  48 (defun lookup-content-display (entry)
  49   ;; Content \e$B%P%C%U%!$r@8@.$7!"\e(BENTRY \e$B$NFbMF$rI=<($9$k!#\e(B
  50   ;; \e$B<B:]$NA^F~=hM}$r9T$J$&$N$O\e(B `lookup-vse-insert-content'\e$B!#\e(B
  51   (with-current-buffer (lookup-open-buffer (lookup-content-buffer))
  52     (let ((inhibit-read-only t))
  53       (erase-buffer)
  54       (if (lookup-reference-p entry)
  55           (insert "(no contents)")
  56         (lookup-vse-insert-content entry)))
  57     (lookup-content-mode)
  58     (setq lookup-content-current-entry entry)
  59     (setq lookup-content-line-heading (lookup-entry-heading entry))
  60     (lookup-display-buffer (current-buffer))))
  61
  62 \f
  63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  64 ;:  Lookup Content mode
  65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66
  67 (defvar lookup-content-mode-map nil
  68   "*Keymap for Lookup Content mode.")
  69
  70 (unless lookup-content-mode-map
  71   (setq lookup-content-mode-map (make-sparse-keymap))
  72   (define-key lookup-content-mode-map " " 'scroll-up)
  73   (define-key lookup-content-mode-map "\C-?" 'scroll-down)
  74   (define-key lookup-content-mode-map [delete] 'scroll-down)
  75   (define-key lookup-content-mode-map "<" 'beginning-of-buffer)
  76   (define-key lookup-content-mode-map ">" 'end-of-buffer)
  77   (define-key lookup-content-mode-map "\C-i" 'lookup-content-next-link)
  78   (define-key lookup-content-mode-map "\C-m" 'lookup-content-follow-link)
  79   (define-key lookup-content-mode-map "t" 'lookup-content-toggle-format)
  80   (define-key lookup-content-mode-map "w" 'lookup-content-cite-region)
  81   (define-key lookup-content-mode-map "h" 'lookup-content-entry-window)
  82   (define-key lookup-content-mode-map "f" 'lookup-entry-search-pattern)
  83   (define-key lookup-content-mode-map "g" 'lookup-content-update)
  84   (define-key lookup-content-mode-map "q" 'lookup-content-leave)
  85   (define-key lookup-content-mode-map "?" 'lookup-content-help)
  86   (if (featurep 'xemacs)
  87       (define-key lookup-content-mode-map 'button2 'lookup-content-mouse-follow)
  88     (define-key lookup-content-mode-map [mouse-2] 'lookup-content-mouse-follow))
  89   )
  90
  91 (defconst lookup-content-mode-help
  92   "Lookup Content \e$B%b!<%I\e(B:
  93
  94 `SPC' - \e$B%Z!<%8$r?J$a$k\e(B          `<'   - \e$B%P%C%U%!$N:G=i$X\e(B
  95 `DEL' - \e$B%Z!<%8$rLa$k\e(B            `>'   - \e$B%P%C%U%!$N:G8e$X\e(B
  96
  97 `TAB' - \e$B<!$N%j%s%/$X\e(B            `RET' - \e$B%j%s%/$rC)$k\e(B
  98
  99 `t'   - \e$B@07A=hM}$r%H%0%k$9$k\e(B    `w'   - \e$B%j!<%8%g%s$r0zMQ\e(B
 100 `h'   - Entry \e$B%P%C%U%!$K0\F0\e(B    `g'   - \e$B%P%C%U%!$r99?7$9$k\e(B
 101 `q'   - \e$B%P%C%U%!$rH4$1$k\e(B        `?'   - \e$B%X%k%W$rI=<(\e(B")
 102
 103 (defvar lookup-content-mode-hook nil)
 104
 105 (defun lookup-content-mode ()
 106   "Lookup Content \e$B%b!<%I!#\e(B
 107
 108 \\{lookup-content-mode-map}
 109 \e$B%b!<%I$KF~$k$H$-$K\e(B `lookup-content-mode-hook' \e$B$,8F$P$l$k!#\e(B"
 110   (interactive)
 111   (kill-all-local-variables)
 112   (buffer-disable-undo)
 113   (setq major-mode 'lookup-content-mode)
 114   (setq mode-name "Content")
 115   (setq mode-line-buffer-identification
 116         '("Lookup:%b {" lookup-content-line-heading "}"))
 117   (setq buffer-read-only t)
 118   (use-local-map lookup-content-mode-map)
 119   (run-hooks 'lookup-content-mode-hook))
 120
 121 ;;;
 122 ;:: Interactive commands
 123 ;;;
 124
 125 (defun lookup-content-next-link ()
 126   "\e$B<!$N%j%s%/$K0\F0$9$k!#\e(B"
 127   (interactive)
 128   (if (lookup-goto-next-link)
 129       (message (lookup-entry-id (lookup-get-link (point))))
 130     (if (lookup-get-link (point))
 131         (error "No more link in this buffer")
 132       (goto-char (point-min))
 133       (if (lookup-goto-next-link)
 134           (message (lookup-entry-id (lookup-get-link (point))))
 135         (error "No link in this buffer")))))
 136
 137 (defun lookup-content-follow-link ()
 138   "\e$B%]%$%s%H0LCV$N%j%s%/$r;2>H$9$k!#\e(B"
 139   (interactive)
 140   (let ((entry (lookup-get-link (point))))
 141     (if entry
 142         (let* ((module (lookup-session-module lookup-current-session))
 143                (heading (lookup-entry-heading lookup-content-current-entry))
 144                (query (lookup-make-query 'reference heading))
 145                (entries (if (not (lookup-reference-p entry))
 146                             (list entry)
 147                           (lookup-reference-refer entry)
 148                           (lookup-reference-entries entry))))
 149           (if entries
 150               (lookup-display-entries module query entries)
 151             (error "This link is torn off")))
 152       (error "No link here"))))
 153
 154 (defun lookup-content-mouse-follow (event)
 155   "\e$B%^%&%9$G%/%j%C%/$7$?%j%s%/$r;2>H$9$k!#\e(B"
 156   (interactive "e")
 157   (mouse-set-point event)
 158   (lookup-content-follow-link))
 159
 160 (defun lookup-content-toggle-format ()
 161   "\e$BK\J8$N@07A=hM}$r%H%0%k$9$k!#\e(B"
 162   (interactive)
 163   (setq lookup-enable-format (not lookup-enable-format))
 164   (lookup-content-display lookup-content-current-entry))
 165
 166 (defun lookup-content-cite-region (start end)
 167   "\e$B%j!<%8%g%s$NFbMF$r%-%k%j%s%0$KJ]B8$9$k!#\e(B
 168 \e$B$=$N:]!"JQ?t\e(B `lookup-cite-header' \e$B$^$?$O<-=q%*%W%7%g%s\e(B `cite-header'
 169 \e$B$K$h$j0zMQ;~$N%X%C%@$r!"JQ?t\e(B `lookup-cite-prefix' \e$B$^$?$O<-=q%*%W%7%g%s\e(B
 170 `cite-prefix' \e$B$K$h$j0zMQ;~$N%W%l%U%#%/%9$r;XDj$9$k$3$H$,=PMh$k!#\e(B"
 171   (interactive "r")
 172   (let* ((dictionary (lookup-entry-dictionary lookup-content-current-entry))
 173          (header (or (lookup-dictionary-option dictionary ':cite-header t)
 174                      lookup-cite-header))
 175          (prefix (or (lookup-dictionary-option dictionary ':cite-prefix t)
 176                      lookup-cite-prefix))
 177          (contents (buffer-substring-no-properties start end)))
 178     (when prefix
 179       (with-temp-buffer
 180         (insert contents)
 181         (goto-char (point-min))
 182         (while (not (eobp))
 183           (insert prefix)
 184           (forward-line))
 185         (setq contents (buffer-string))))
 186     (when header
 187       (let ((title (lookup-dictionary-title dictionary)))
 188         (while (string-match "%T" header)
 189           (setq header (replace-match title t t header))))
 190       (setq contents (concat header contents)))
 191     (kill-new contents)
 192     (if transient-mark-mode (setq deactivate-mark t))
 193     (when (interactive-p)
 194       (if (pos-visible-in-window-p (mark) (selected-window))
 195           (let ((inhibit-quit t))
 196             (save-excursion (goto-char (mark)) (sit-for 1)))
 197         (let ((len (min (abs (- end start)) 40)))
 198           (if (= (point) start)
 199               (message "Saved text until \"%s\""
 200                        (buffer-substring (- end len) end))
 201             (message "Saved text from \"%s\""
 202                      (buffer-substring start (+ start len)))))))))
 203
 204 (defun lookup-content-entry-window ()
 205   "Entry \e$B%P%C%U%!$K0\F0$9$k!#\e(B"
 206   (interactive)
 207   (select-window (get-buffer-window (lookup-entry-buffer))))
 208
 209 (defun lookup-content-update ()
 210   "\e$B%-%c%C%7%e$rMQ$$$:$KK\J8$rFI$_D>$9!#\e(B"
 211   (interactive)
 212   (let ((lookup-force-update t))
 213     (lookup-content-display lookup-content-current-entry)))
 214
 215 (defun lookup-content-leave ()
 216   "Content \e$B%P%C%U%!$rH4$1$k!#\e(B"
 217   (interactive)
 218   (lookup-hide-buffer (current-buffer))
 219   (lookup-entry-display-content))
 220
 221 (defun lookup-content-help ()
 222   "Content \e$B%b!<%I$N4J0W%X%k%W$rI=<($9$k!#\e(B"
 223   (interactive)
 224   (with-current-buffer (lookup-open-buffer (lookup-help-buffer))
 225     (help-mode)
 226     (let ((inhibit-read-only t))
 227       (erase-buffer)
 228       (insert lookup-content-mode-help))
 229     (lookup-display-help (current-buffer))))
 230
 231 ;;;
 232 ;:: Useful functions
 233 ;;;
 234
 235 (defun lookup-content-collect-references ()
 236   ;; Content \e$B%P%C%U%!$N%j%U%!%l%s%9$rA4$F=8$a$F%j%9%H$K$7$FJV$9!#\e(B
 237   (with-current-buffer (lookup-content-buffer)
 238     (let (entries)
 239       (lookup-map-over-property
 240        (point-min) (point-max) 'lookup-reference
 241        (lambda (start end entry)
 242          (setq entries
 243                (if (and (lookup-reference-p entry)
 244                         (not (lookup-reference-dynamic-p entry)))
 245                    (nconc (reverse (lookup-reference-entries entry)) entries)
 246                  (cons entry entries)))))
 247       (nreverse entries))))
 248
 249 (provide 'lookup-content)
 250
 251 ;;; lookup-content.el ends here