editors/scel/el/sclang-browser.el

   1 ;; copyright 2003 stefan kersten <steve@k-hornz.de>
   2 ;;
   3 ;; This program is free software; you can redistribute it and/or
   4 ;; modify it under the terms of the GNU General Public License as
   5 ;; published by the Free Software Foundation; either version 2 of the
   6 ;; License, or (at your option) any later version.
   7 ;;
   8 ;; This program is distributed in the hope that it will be useful, but
   9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;; General Public License for more details.
  12 ;;
  13 ;; You should have received a copy of the GNU General Public License
  14 ;; along with this program; if not, write to the Free Software
  15 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
  16 ;; USA
  17
  18 (require 'sclang-util)
  19 (require 'view nil t)
  20
  21 ;; TODO: better factoring
  22 ;; derive from view mode, make mode-map pluggable
  23 ;; define derived mode for completion, definition, help
  24
  25 (defun sclang-browser-fill-keymap (map)
  26   (define-key map "\r" 'sclang-browser-follow-link)
  27   (define-key map [mouse-2] 'sclang-browser-mouse-follow-link)
  28   (define-key map "\t" 'sclang-browser-next-link)
  29   (define-key map [backtab] 'sclang-browser-previous-link)
  30   (define-key map [(shift tab)] 'sclang-browser-previous-link)
  31   (define-key map [?q] 'sclang-browser-quit)
  32   map)
  33
  34 (defvar sclang-browser-mode-map (sclang-browser-fill-keymap (make-sparse-keymap)))
  35 (defvar sclang-browser-mode-hook nil)
  36 (defvar sclang-browser-show-hook nil)
  37 (defvar sclang-browser-link-function nil
  38   "buffer local")
  39 (defvar sclang-browser-return-method nil
  40   "buffer local")
  41
  42 (defun sclang-browser-beginning-of-link ()
  43   (interactive)
  44   (when (get-text-property (point) 'sclang-browser-link)
  45     (while (and (not (bobp))
  46                 (get-text-property (point) 'sclang-browser-link))
  47       (forward-char -1))
  48     (unless (bobp) (forward-char 1))
  49     (point)))
  50
  51 (defun sclang-browser-next-link (&optional n)
  52   (interactive)
  53   (let* ((n (or n 1))
  54          (prop 'sclang-browser-link)
  55          (fwd (>= n 0))
  56          (orig (point))
  57          (beg (if fwd (point-min) (point-max)))
  58          (end (if fwd (point-max) (point-min)))
  59          (inc (if fwd 1 -1))
  60          pos)
  61     (when (get-text-property (point) prop)
  62       (while (and (/= (point) beg)
  63                   (get-text-property (point) prop))
  64         (forward-char inc))
  65       (if (= (point) beg) (goto-char end)))
  66     (while (not (eq pos orig))
  67       (cond ((get-text-property (point) prop)
  68              (sclang-browser-beginning-of-link)
  69              (setq pos orig))
  70             (t
  71              (if (= (point) end) (goto-char beg))
  72              (forward-char inc)
  73              (setq pos (point)))))))
  74
  75 (defun sclang-browser-previous-link ()
  76   (interactive)
  77   (sclang-browser-next-link -1))
  78
  79 (defun sclang-browser-follow-link (&optional pos)
  80   (interactive)
  81   (let* ((pos (or pos (point)))
  82          (data (get-text-property pos 'sclang-browser-link)))
  83     (when (consp data)
  84       (let ((fun (or (car data) sclang-browser-link-function))
  85             (arg (cdr data)))
  86         (when (functionp fun)
  87           (condition-case nil
  88               (funcall fun arg)
  89             (error (sclang-message "Error in link function") nil)))))))
  90
  91 (defun sclang-browser-mouse-follow-link (event)
  92   (interactive "e")
  93   (let* ((start (event-start event))
  94          (window (car start))
  95          (pos (cadr start)))
  96     (with-current-buffer (window-buffer window)
  97       (sclang-browser-follow-link pos))))
  98
  99 (defun sclang-browser-mode ()
 100   "Major mode for viewing hypertext and navigating references in it.
 101 Entry to this mode runs the normal hook `sclang-browser-mode-hook'.
 102 Commands:
 103 \\{sclang-browser-mode-map}"
 104   (interactive)
 105   (kill-all-local-variables)
 106   (use-local-map sclang-browser-mode-map)
 107   (set-keymap-parent sclang-browser-mode-map view-mode-map)
 108   (setq mode-name "Browser")
 109   (setq major-mode 'sclang-browser-mode)
 110   (set (make-local-variable 'sclang-browser-link-function) nil)
 111   (set (make-local-variable 'sclang-browser-return-method) nil)
 112   (set (make-local-variable 'font-lock-defaults) nil)
 113   (view-mode)
 114   (set (make-local-variable 'minor-mode-overriding-map-alist)
 115        (list (cons 'view-mode sclang-browser-mode-map)))
 116     (set (make-local-variable 'view-no-disable-on-exit) t)
 117   (run-hooks 'sclang-browser-mode-hook))
 118
 119 (defun sclang-browser-mode-setup ()
 120   (sclang-browser-mode)
 121   (setq buffer-read-only nil))
 122
 123 (defun sclang-browser-mode-finish ()
 124   (toggle-read-only 1)
 125   (setq view-return-to-alist
 126         (list (cons (selected-window) sclang-browser-return-method)))
 127   (run-hooks 'sclang-browser-show-hook))
 128
 129 (defun sclang-browser-quit ()
 130   (interactive)
 131   (when (eq major-mode 'sclang-browser-mode)
 132     (kill-buffer (current-buffer))))
 133
 134 (defun sclang-browser-make-link (link-text &optional link-data link-function)
 135   (let ((map (make-sparse-keymap)))
 136     (propertize link-text
 137                 'mouse-face 'highlight
 138                 ;;'help-echo "mouse-2: follow link"
 139                 ;;'keymap map
 140                 'sclang-browser-link (cons link-function link-data)
 141                 ;;'sclang-browser-link-data link-data
 142                 ;;'sclang-browser-link-function link-function)))
 143                 )))
 144
 145 (defun sclang-display-browser (buffer-name output-function)
 146   "header: what to insert in the buffer
 147    link-list: list of (link-text link-function link-data)
 148    link-function: function with args (link-text link-data)"
 149   (let ((temp-buffer-setup-hook '(sclang-browser-mode-setup))
 150         (temp-buffer-show-hook '(sclang-browser-mode-finish)))
 151     (with-output-to-temp-buffer buffer-name
 152       (with-current-buffer standard-output
 153         ;; record return method
 154         (setq sclang-browser-return-method
 155               (cond ((special-display-p (buffer-name standard-output))
 156                      ;; If the help output buffer is a special display buffer,
 157                      ;; don't say anything about how to get rid of it.
 158                      ;; First of all, the user will do that with the window
 159                      ;; manager, not with Emacs.
 160                      ;; Secondly, the buffer has not been displayed yet,
 161                      ;; so we don't know whether its frame will be selected.
 162                      (cons (selected-window) t))
 163                     (display-buffer-reuse-frames
 164                      (cons (selected-window) 'quit-window))
 165                     ((not (one-window-p t))
 166                      (cons (selected-window) 'quit-window))
 167                     (pop-up-windows
 168                      (cons (selected-window) t))
 169                     (t
 170                      (list (selected-window) (window-buffer)
 171                            (window-start) (window-point)))))
 172         (funcall output-function)))))
 173
 174 (defmacro with-sclang-browser (buffer-name &rest body)
 175   `(sclang-display-browser ,buffer-name (lambda () ,@body)))
 176
 177 ;; =====================================================================
 178 ;; module setup
 179 ;; =====================================================================
 180
 181 (provide 'sclang-browser)
 182
 183 ;; EOF