1367 lines
51 KiB
EmacsLisp
1367 lines
51 KiB
EmacsLisp
;;; mlinks.el --- Minor mode making major mode dependent links
|
|
;;
|
|
;; Author: Lennar Borgman
|
|
;; Created: Tue Jan 16 2007
|
|
(defconst mlinks:version "0.28") ;;Version:
|
|
;; Last-Updated: 2010-01-05 Tue
|
|
;; Keywords:
|
|
;; Compatibility:
|
|
;;
|
|
;; Fxeatures that might be required by this library:
|
|
;;
|
|
;; `appmenu', `cl', `mail-prsvr', `mm-util', `ourcomments-util',
|
|
;; `url-expand', `url-methods', `url-parse', `url-util',
|
|
;; `url-vars'.
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;;; Commentary:
|
|
;;
|
|
;; This file implements the minor mode `mlinks-mode' that create
|
|
;; hyperlinks for different major modes. Such links can be visible or
|
|
;; invisible. The meanings of the links are defined per mode.
|
|
;;
|
|
;; Examples:
|
|
;;
|
|
;; - In in html style modes the links are visible they can mean either
|
|
;; open a file for editing, go to an achnor or view the link in a
|
|
;; web browser etc.
|
|
;;
|
|
;; - In emacs lisp mode the links are invisible, but maybe highlighed
|
|
;; when point or mouse is on them. (Having them highlighted when
|
|
;; point is on them can be a quick way to check that you have
|
|
;; spelled a symbol correct.) The meanings of the links in emacs
|
|
;; lisp mode are go to definition.
|
|
;;
|
|
;; Common to links that open a buffer in Emacs is that you can the
|
|
;; buffer opened in the same window, the other window or in a new
|
|
;; frame. The same key binding is used in all major modes for this.
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;;; Change log:
|
|
;;
|
|
;; FIX-ME: url-hexify-string etc
|
|
;;
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
;; Boston, MA 02111-1307, USA.
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;;; Code:
|
|
|
|
(eval-when-compile (require 'cl))
|
|
(eval-when-compile (require 'appmenu nil t))
|
|
(eval-when-compile (require 'mumamo nil t))
|
|
(eval-when-compile (require 'ourcomments-util nil t))
|
|
|
|
(require 'rx)
|
|
(require 'url-parse)
|
|
(require 'url-expand)
|
|
|
|
(defvar mlinks-point-hilighter-overlay nil)
|
|
(make-variable-buffer-local 'mlinks-point-hilighter-overlay)
|
|
(put 'mlinks-point-hilighter-overlay 'permanent-local t)
|
|
|
|
;;;###autoload
|
|
(defgroup mlinks nil
|
|
"Customization group for `mlinks-mode'."
|
|
:group 'nxhtml
|
|
:group 'hypermedia)
|
|
|
|
(defvar mlinks-link-face 'mlinks-link-face)
|
|
(defface mlinks-link-face
|
|
'((t (:inherit highlight)))
|
|
"Face normally active links have on them."
|
|
:group 'mlinks)
|
|
|
|
(defvar mlinks-hyperactive-link-face 'mlinks-hyperactive-link-face)
|
|
(defface mlinks-hyperactive-link-face
|
|
'((t (:inherit isearch)))
|
|
"Face hyper active links have on them."
|
|
:group 'mlinks)
|
|
|
|
(defvar mlinks-font-lock-face 'mlinks-font-lock-face)
|
|
(defface mlinks-font-lock-face
|
|
'((t :inherit link))
|
|
"Default face for MLinks' links."
|
|
:group 'mlinks)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Mode function bindings
|
|
|
|
;;(customize-option mlinks-mode-functions)
|
|
(defcustom mlinks-mode-functions
|
|
'(
|
|
;; For message buffer etc.
|
|
(fundamental-mode
|
|
((goto mlinks-elisp-goto)
|
|
(hili mlinks-elisp-hili)
|
|
(hion t)
|
|
)
|
|
)
|
|
(emacs-lisp-mode
|
|
((goto mlinks-elisp-goto)
|
|
(hili mlinks-elisp-hili)
|
|
(hion t)
|
|
)
|
|
)
|
|
;; *scractch*
|
|
(lisp-interaction-mode
|
|
((goto mlinks-elisp-goto)
|
|
(hili mlinks-elisp-hili)
|
|
(hion t)
|
|
)
|
|
)
|
|
(help-mode
|
|
((goto mlinks-elisp-goto)
|
|
(hili mlinks-elisp-hili)
|
|
(hion t)
|
|
)
|
|
)
|
|
(Info-mode
|
|
((goto mlinks-elisp-goto)
|
|
(hili mlinks-elisp-hili)
|
|
(hion t)
|
|
)
|
|
)
|
|
(Custom-mode
|
|
((goto mlinks-elisp-custom-goto)
|
|
(hili mlinks-elisp-hili)
|
|
(hion t)
|
|
(fontify mlinks-custom-fontify)
|
|
)
|
|
)
|
|
(text-mode
|
|
((goto mlinks-goto-plain-url)
|
|
(hion t)
|
|
(fontify mlinks-plain-urls-fontify)
|
|
)
|
|
)
|
|
(nxhtml-mode
|
|
((hion t)
|
|
(fontify mlinks-html-fontify)
|
|
(goto mlinks-html-style-goto)
|
|
)
|
|
)
|
|
(nxml-mode
|
|
((hion t)
|
|
(fontify mlinks-html-fontify)
|
|
(goto mlinks-html-style-goto)
|
|
)
|
|
)
|
|
(sgml-mode
|
|
((hion t)
|
|
(fontify mlinks-html-fontify)
|
|
(goto mlinks-html-style-goto)
|
|
)
|
|
)
|
|
(html-mode
|
|
((hion t)
|
|
(fontify mlinks-html-fontify)
|
|
(goto mlinks-html-style-goto)
|
|
)
|
|
)
|
|
)
|
|
"Defines MLinks hyperlinks for major modes.
|
|
"
|
|
;; Each element in the list is a list with two elements
|
|
|
|
;; \(MAJOR-MODE SETTINGS)
|
|
|
|
;; where MAJOR-MODE is the major mode for which the settings SETTINGS should be used.
|
|
;; SETTINGS is an association list which can have the following element types
|
|
|
|
;; \(hili HILIGHT-FUN) ;; Mandatory
|
|
;; \(goto GOTO-FUN) ;; Mandatory
|
|
;; \(hion HION-BOOL) ;; Optional
|
|
;; \(next NEXT-FUN) ;; Optional
|
|
;; \(prev PREV-FUN) ;; Optional
|
|
|
|
;; Where
|
|
;; - HILIGHT-FUN is the function to hilight a link when point is
|
|
;; inside the link. This is done when Emacs is idle.
|
|
;; - GOTO-FUN is the function to follow the link at point.
|
|
;; - HION-BOOL is t or nil depending on if hilighting should be on
|
|
;; by default.
|
|
;; - NEXT-FUN is the function to go to the next link.
|
|
;; - PREV-FUN is the function to go to the previous link."
|
|
;; ;;:type '(repeat (alist :key-type symbol :value-type (alist :key-type symbol :value symbol)))
|
|
:type '(alist :key-type major-mode-function
|
|
:value-type (list
|
|
(set
|
|
(const :tag "Enable MLinks in this major mode" hion)
|
|
(const :tag "Mark All Links" mark)
|
|
(list :tag "Enable" (const :tag "Hilighting" hili) function)
|
|
(list :tag "Enable" (const :tag "Follow Link" goto) function)
|
|
(list :tag "Enable" (const :tag "Goto Next Link" next) function)
|
|
(list :tag "Enable" (const :tag "Goto Previous Link" prev) function)
|
|
)))
|
|
:group 'mlinks)
|
|
|
|
|
|
(defun mlinks-get-mode-value (which)
|
|
(let* ((major major-mode)
|
|
(mode-rec (assoc major mlinks-mode-functions)))
|
|
(catch 'mode-rec
|
|
(while (and major
|
|
(not mode-rec))
|
|
(setq major (get major 'derived-mode-parent))
|
|
(setq mode-rec (assoc major mlinks-mode-functions))
|
|
(when mode-rec (throw 'mode-rec nil))))
|
|
(when mode-rec
|
|
(let* ((mode (car mode-rec))
|
|
(funs-alist (cadr mode-rec))
|
|
(funs (assoc which funs-alist)))
|
|
(cdr funs)))))
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Minor modes
|
|
|
|
;; (appmenu-dump-keymap mlinks-mode-map)
|
|
(defvar mlinks-mode-map
|
|
(let ((m (make-sparse-keymap "mlinks")))
|
|
(define-key m [(control ?c) ?\r ?\r] 'mlinks-goto)
|
|
(define-key m [(control ?c) ?\r ?w] 'mlinks-goto-other-window)
|
|
(define-key m [(control ?c) ?\r ?f] 'mlinks-goto-other-frame)
|
|
(define-key m [(control ?c) ?\r ?n] 'mlinks-next-saved-position)
|
|
(define-key m [(control ?c) ?\r ?p] 'mlinks-prev-saved-position)
|
|
(define-key m [(control ?c) ?\r S-tab] 'mlinks-backward-link)
|
|
(define-key m [(control ?c) ?\r tab] 'mlinks-forward-link)
|
|
(define-key m [(control ?c) ?\r ?h] 'mlinks-toggle-hilight)
|
|
(define-key m [(control ?c) ?\r ?c] 'mlinks-copy-link-text)
|
|
m))
|
|
|
|
;;;###autoload
|
|
(define-minor-mode mlinks-mode
|
|
"Recognizes certain parts of a buffer as hyperlinks.
|
|
The hyperlinks are created in different ways for different major
|
|
modes with the help of the functions in the list
|
|
`mlinks-mode-functions'.
|
|
|
|
The hyperlinks can be hilighted when point is over them. Use
|
|
`mlinks-toggle-hilight' to toggle this feature for the current
|
|
buffer.
|
|
|
|
All keybindings in this mode are by default done under the prefi§x
|
|
key
|
|
|
|
C-c RET
|
|
|
|
which is supposed to be a kind of mnemonic for link (alluding to
|
|
the RET key commonly used in web browser to follow a link).
|
|
\(Unfortunately this breaks the rules in info node `Key Binding
|
|
Conventions'.) Below are the key bindings defined by this mode:
|
|
|
|
\\{mlinks-mode-map}
|
|
|
|
For some major modes `mlinks-backward-link' and
|
|
`mlinks-forward-link' will take you to the previous/next link.
|
|
By default the link moved to will be active, see
|
|
`mlinks-active-links'.
|
|
|
|
"
|
|
nil
|
|
" L"
|
|
nil
|
|
:keymap mlinks-mode-map
|
|
:group 'mlinks
|
|
(if mlinks-mode
|
|
(progn
|
|
(mlinks-add-appmenu)
|
|
(mlinks-start-point-hilighter)
|
|
(mlinks-add-font-lock))
|
|
(mlinks-stop-point-hilighter)
|
|
(when mlinks-point-hilighter-overlay
|
|
(when (overlayp mlinks-point-hilighter-overlay)
|
|
(delete-overlay mlinks-point-hilighter-overlay))
|
|
(setq mlinks-point-hilighter-overlay nil))
|
|
(mlinks-remove-font-lock)))
|
|
(put 'mlinks-mode 'permanent-local t)
|
|
|
|
(defun mlinks-turn-on-in-buffer ()
|
|
(let ((hion (unless (and (boundp 'mumamo-set-major-running)
|
|
mumamo-set-major-running)
|
|
(mlinks-get-mode-value 'hion))))
|
|
(when hion (mlinks-mode 1))))
|
|
|
|
;;;###autoload
|
|
(define-globalized-minor-mode mlinks-global-mode mlinks-mode
|
|
mlinks-turn-on-in-buffer
|
|
"Turn on `mlink-mode' in all buffer where it is specified.
|
|
This is specified in `mlinks-mode-functions'."
|
|
:group 'mlinks)
|
|
|
|
;; The problem with global minor modes:
|
|
(when (and mlinks-global-mode
|
|
(not (boundp 'define-global-minor-mode-bug)))
|
|
(mlinks-global-mode 1))
|
|
|
|
;;(define-toggle mlinks-active-links t
|
|
(define-minor-mode mlinks-active-links
|
|
"Use quick movement keys on active links if non-nil.
|
|
When moving to an mlink with `mlinks-forward-link' or
|
|
`mlinks-backward-link' the link moved to will be in an active
|
|
state. This is marked with a new color \(the face `isearch').
|
|
When the new color is shown the following keys are active
|
|
|
|
\\{mlinks-hyperactive-point-hilighter-keymap}
|
|
Any command cancels this state."
|
|
:global t
|
|
:init-value t
|
|
:group 'mlinks)
|
|
|
|
|
|
|
|
(defun mlinks-link-text-prop-range (pos)
|
|
(let* ((link-here (get-text-property pos 'mlinks-link))
|
|
(beg (when link-here (previous-single-char-property-change (+ pos 1) 'mlinks-link)))
|
|
(end (when link-here (next-single-char-property-change (- pos 0) 'mlinks-link))))
|
|
(when (and beg end)
|
|
(cons beg end))))
|
|
|
|
(defun mlinks-link-range (pos)
|
|
(or (mlinks-link-text-prop-range pos)
|
|
(let ((funs-- (mlinks-get-mode-value 'hili)))
|
|
(when funs--
|
|
(save-match-data
|
|
(run-hook-with-args-until-success 'funs--))))))
|
|
|
|
(defun mlinks-link-at-point ()
|
|
"Get link at point."
|
|
(mlinks-point-hilighter-1)
|
|
(when (and mlinks-point-hilighter-overlay
|
|
(overlay-buffer mlinks-point-hilighter-overlay))
|
|
(let* ((ovl mlinks-point-hilighter-overlay)
|
|
(beg (overlay-start ovl))
|
|
(end (overlay-end ovl)))
|
|
(buffer-substring-no-properties beg end))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; At point highligher
|
|
|
|
(defvar mlinks-point-hilighter-timer nil)
|
|
|
|
(defun mlinks-stop-point-hilighter ()
|
|
(when (timerp mlinks-point-hilighter-timer)
|
|
(cancel-timer mlinks-point-hilighter-timer)
|
|
(setq mlinks-point-hilighter-timer nil)))
|
|
|
|
(defun mlinks-start-point-hilighter ()
|
|
(mlinks-stop-point-hilighter)
|
|
(setq mlinks-point-hilighter-timer
|
|
(run-with-idle-timer 0.1 t 'mlinks-point-hilighter)))
|
|
|
|
(defvar mlinks-link-overlay-priority 100)
|
|
|
|
(defun mlinks-make-point-hilighter-overlay (bounds)
|
|
(unless mlinks-point-hilighter-overlay
|
|
(setq mlinks-point-hilighter-overlay
|
|
(make-overlay (car bounds) (cdr bounds)))
|
|
(overlay-put mlinks-point-hilighter-overlay 'priority mlinks-link-overlay-priority)
|
|
(overlay-put mlinks-point-hilighter-overlay 'mouse-face 'highlight)
|
|
(mlinks-set-normal-point-hilight)
|
|
))
|
|
|
|
(defun mlinks-point-hilighter ()
|
|
"Mark link at point if any.
|
|
This moves the hilight point overlay to point or deletes it."
|
|
;; This runs in a timer, protect it.
|
|
(condition-case err
|
|
(let ((inhibit-point-motion-hooks t))
|
|
(mlinks-point-hilighter-1))
|
|
(error "mlinks-point-hilighter error: %s" (error-message-string err))))
|
|
|
|
(defun mlinks-point-hilighter-1 ()
|
|
(when mlinks-mode
|
|
(let ((bounds-- (mlinks-link-range (point))))
|
|
(if bounds--
|
|
(if mlinks-point-hilighter-overlay
|
|
(move-overlay mlinks-point-hilighter-overlay (car bounds--) (cdr bounds--))
|
|
(mlinks-make-point-hilighter-overlay bounds--))
|
|
(when mlinks-point-hilighter-overlay
|
|
(delete-overlay mlinks-point-hilighter-overlay))))))
|
|
|
|
(defvar mlinks-hyperactive-point-hilighter-keymap
|
|
(let ((m (make-sparse-keymap "mlinks")))
|
|
(define-key m [S-tab] 'mlinks-backward-link)
|
|
(define-key m [tab] 'mlinks-forward-link)
|
|
(define-key m "\t" 'mlinks-forward-link)
|
|
(define-key m [?\r] 'mlinks-goto)
|
|
(define-key m [?w] 'mlinks-goto-other-window)
|
|
(define-key m [?f] 'mlinks-goto-other-frame)
|
|
(define-key m [mouse-1] 'mlinks-goto)
|
|
(set-keymap-parent m mlinks-mode-map)
|
|
m))
|
|
|
|
(defvar mlinks-point-hilighter-keymap
|
|
(let ((m (make-sparse-keymap "mlinks")))
|
|
(define-key m [mouse-1] 'mlinks-goto)
|
|
(set-keymap-parent m mlinks-mode-map)
|
|
m))
|
|
|
|
(defun mlinks-point-hilighter-pre-command ()
|
|
(condition-case err
|
|
(unless (let ((map (overlay-get mlinks-point-hilighter-overlay 'keymap)))
|
|
(where-is-internal this-command
|
|
(list
|
|
map)))
|
|
(mlinks-set-normal-point-hilight)
|
|
(unless mlinks-point-hilighter-timer
|
|
(delete-overlay mlinks-point-hilighter-overlay)))
|
|
(error (message "mlinks-point-hilighter-pre-command: %s" err))))
|
|
(put 'mlinks-point-hilighter-pre-command 'permanent-local t)
|
|
|
|
(defun mlinks-set-hyperactive-point-hilight ()
|
|
"Make link hyper active, ie add some special key binding.
|
|
Used after jumping specifically to a link. The idea is that the
|
|
user may want to easily jump between links in this state."
|
|
(add-hook 'pre-command-hook 'mlinks-point-hilighter-pre-command nil t)
|
|
(mlinks-point-hilighter)
|
|
(overlay-put mlinks-point-hilighter-overlay 'face mlinks-hyperactive-link-face)
|
|
(overlay-put mlinks-point-hilighter-overlay 'keymap mlinks-hyperactive-point-hilighter-keymap))
|
|
|
|
(defun mlinks-set-normal-point-hilight ()
|
|
"Make link normally active as if you happened to be on it."
|
|
(remove-hook 'pre-command-hook 'mlinks-point-hilighter-pre-command t)
|
|
(mlinks-point-hilighter)
|
|
(overlay-put mlinks-point-hilighter-overlay 'face mlinks-link-face)
|
|
(overlay-put mlinks-point-hilighter-overlay 'keymap mlinks-point-hilighter-keymap))
|
|
|
|
(defun mlinks-set-point-hilight-after-jump-to ()
|
|
"Set hilight style after jump to link."
|
|
(if mlinks-active-links
|
|
(mlinks-set-hyperactive-point-hilight)
|
|
(mlinks-set-normal-point-hilight)))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Jumping around
|
|
|
|
(defvar mlinks-places nil)
|
|
(make-variable-buffer-local 'mlinks-placesn)
|
|
(put 'mlinks-places 'permanent-local t)
|
|
|
|
(defvar mlinks-places-n 0)
|
|
(make-variable-buffer-local 'mlinks-places-n)
|
|
(put 'mlinks-places-n 'permanent-local t)
|
|
|
|
(defun mlinks-has-links ()
|
|
(or (mlinks-get-mode-value 'fontify)
|
|
(when (and (boundp 'mumamo-multi-major-mode) mumamo-multi-major-mode)
|
|
;; Fix-me: just assume multi major has it... Need a list of
|
|
;; major modes. There is no way to get such a list for the
|
|
;; multi major mode (since you can't know what the chunk
|
|
;; functions will return. However you can get a list of
|
|
;; current chunks major mode.
|
|
t
|
|
)))
|
|
|
|
(defun mlinks-backward-link ()
|
|
"Go to previous `mlinks-mode' link in buffer."
|
|
(interactive)
|
|
(if (not (mlinks-has-links))
|
|
(message "There is no way to go to previous link for this major mode")
|
|
(let ((res (mlinks-prev-link)))
|
|
(if res
|
|
(progn
|
|
(goto-char res)
|
|
(mlinks-set-point-hilight-after-jump-to))
|
|
(message "No previous link found")))))
|
|
|
|
(defun mlinks-forward-link ()
|
|
"Go to next `mlinks-mode' link in buffer."
|
|
(interactive)
|
|
(if (not (mlinks-has-links))
|
|
(message "There is no way to go to next link for this major mode")
|
|
(let ((res (mlinks-next-link)))
|
|
(if res
|
|
(progn
|
|
(goto-char res)
|
|
(mlinks-set-point-hilight-after-jump-to))
|
|
(message "No next link found")))))
|
|
|
|
|
|
(defun mlinks-goto ()
|
|
"Follow `mlinks-mode' link at current point.
|
|
Save the current position so that they can be move to again by
|
|
`mlinks-prev-saved-position' and `mlinks-next-saved-position'.
|
|
|
|
Return non-nil if link was followed, otherewise nil."
|
|
(interactive)
|
|
(mlinks-goto-1 nil))
|
|
|
|
(defun mlinks-goto-other-window ()
|
|
"Like `mlinks-goto' but opens in other window.
|
|
Uses `switch-to-buffer-other-window'."
|
|
(interactive)
|
|
(mlinks-goto-1 'other-window))
|
|
|
|
(defun mlinks-goto-other-frame ()
|
|
"Like `mlinks-goto' but opens in other frame.
|
|
Uses `switch-to-buffer-other-frame'."
|
|
(interactive)
|
|
(mlinks-goto-1 'other-frame))
|
|
|
|
(defun mlinks-goto-1(where)
|
|
(push-mark)
|
|
(let* ((funs (mlinks-get-mode-value 'goto))
|
|
(old (point-marker))
|
|
(mlinks-temp-buffer-where where)
|
|
(res (run-hook-with-args-until-success 'funs)))
|
|
(if (not res)
|
|
(progn
|
|
(message "Don't know how to follow this MLink link")
|
|
nil)
|
|
(unless (= old (point-marker))
|
|
(let* ((prev (car mlinks-places)))
|
|
(when (or (not prev)
|
|
;;(not (markerp prev))
|
|
(not (marker-buffer prev))
|
|
(/= old prev))
|
|
(setq mlinks-places (cons old mlinks-places))
|
|
(setq mlinks-places-n (length mlinks-places))))))))
|
|
|
|
|
|
(defun mlinks-prev-saved-position ()
|
|
"Go to previous position saved by `mlinks-goto'."
|
|
(interactive)
|
|
(unless (mlinks-goto-n (1- mlinks-places-n))
|
|
(message "No previous MLink position")))
|
|
|
|
(defun mlinks-next-saved-position ()
|
|
"Go to next position saved by `mlinks-goto'."
|
|
(interactive)
|
|
(unless (mlinks-goto-n (1+ mlinks-places-n))
|
|
(message "No next MLink position")))
|
|
|
|
(defun mlinks-goto-n (to)
|
|
(if (not mlinks-places)
|
|
(message "No saved MLinks positions")
|
|
(let ((minp 1)
|
|
(maxp (length mlinks-places)))
|
|
(if (<= to minp)
|
|
(progn
|
|
(setq to minp)
|
|
(message "Going to first MLinks position"))
|
|
(if (>= to maxp)
|
|
(progn
|
|
(setq to maxp)
|
|
(message "Going to last MLinks position"))))
|
|
(setq mlinks-places-n to)
|
|
(let ((n (- maxp to))
|
|
(places mlinks-places)
|
|
place
|
|
buffer
|
|
point)
|
|
(while (> n 0)
|
|
(setq places (cdr places))
|
|
(setq n (1- n)))
|
|
(setq place (car places))
|
|
(mlinks-switch-to-buffer (marker-buffer place))
|
|
(goto-char place)))))
|
|
|
|
(defvar mlinks-temp-buffer-where nil)
|
|
(defun mlinks-switch-to-buffer (buffer)
|
|
(mlinks-switch-to-buffer-1 buffer mlinks-temp-buffer-where))
|
|
|
|
(defun mlinks-switch-to-buffer-1(buffer where)
|
|
(cond
|
|
((null where)
|
|
(switch-to-buffer buffer))
|
|
((eq where 'other-window)
|
|
(switch-to-buffer-other-window buffer))
|
|
((eq where 'other-frame)
|
|
(switch-to-buffer-other-frame buffer))
|
|
(t
|
|
(error "Invalid argument, where=%s" where))))
|
|
|
|
;; FIXME: face, var
|
|
(defun mlinks-custom (var)
|
|
(customize-option var)
|
|
)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; AppMenu support
|
|
|
|
(defun mlinks-appmenu ()
|
|
(when mlinks-mode
|
|
;; Fix-me: reverse the list
|
|
(let ((link-val (mlinks-link-at-point))
|
|
(map (make-sparse-keymap "mlinks"))
|
|
(num 2))
|
|
(when (mlinks-get-mode-value 'prev)
|
|
(define-key map [mlinks-next-link]
|
|
(list 'menu-item "Next Link" 'mlinks-forward-link)))
|
|
(when (mlinks-get-mode-value 'next)
|
|
(define-key map [mlinks-prev-link]
|
|
(list 'menu-item "Previous Link" 'mlinks-backward-link)))
|
|
(when link-val
|
|
(let* ((possible (when (member major-mode '(html-mode nxhtml-mode nxml-mode sqml-mode text-mode))
|
|
(mlinks-html-possible-href-actions link-val)))
|
|
(mailto (assoc 'mailto possible))
|
|
(view-web (assoc 'view-web possible))
|
|
(view-web-base (assoc 'view-web-base possible))
|
|
(edit (assoc 'edit possible))
|
|
(file (nth 1 edit))
|
|
(anchor (nth 2 edit))
|
|
(choices)
|
|
(answer)
|
|
)
|
|
(when (> (length map) num)
|
|
(define-key map [mlinks-href-sep] (list 'menu-item "--")))
|
|
(setq num (length map))
|
|
(when view-web
|
|
(define-key map [mlinks-href-view-web]
|
|
(list 'menu-item "Browse Link Web Url"
|
|
`(lambda () (interactive)
|
|
(browse-url ,link-val)))))
|
|
(when view-web-base
|
|
(define-key map [mlinks-href-view-web-based]
|
|
(list 'menu-item "Browse Link Web Url (base URL found)"
|
|
`(lambda () (interactive)
|
|
(browse-url (cdr ,view-web-base))))))
|
|
(when mailto
|
|
(define-key map [mlinks-href-mail]
|
|
(list 'menu-item (concat "&Mail to " (substring link-val 7))
|
|
`(lambda () (interactive)
|
|
(mlinks-html-mail-to ,link-val)))))
|
|
(when edit
|
|
(when (and (file-exists-p file)
|
|
(not anchor)
|
|
(assoc 'upload possible))
|
|
(let ((abs-file (expand-file-name file)))
|
|
(define-key map [mlinks-href-upload]
|
|
(list 'menu-item "Upload Linked File"
|
|
`(lambda () (interactive)
|
|
(html-upl-upload-file ,abs-file))))))
|
|
(when (and (file-exists-p file)
|
|
(not anchor)
|
|
(assoc 'edit-gimp possible))
|
|
(let ((abs-file (expand-file-name file)))
|
|
(define-key map [mlinks-href-edit-gimp]
|
|
(list 'menu-item "Edit Linked File with GIMP"
|
|
`(lambda () (interactive)
|
|
(gimpedit-edit-file ,abs-file))))))
|
|
(when (and (file-exists-p file)
|
|
(assoc 'view-local possible))
|
|
(let ((url (concat "file:///" (expand-file-name file))))
|
|
(when anchor
|
|
(let ((url-anchor (concat url "#" anchor)))
|
|
(define-key map [mlinks-href-view-file-at]
|
|
(list 'menu-item (concat "Browse Linked File URL at #" anchor)
|
|
`(lambda () (interactive)
|
|
(browse-url ,url-anchor))))))
|
|
(define-key map [mlinks-href-view-file]
|
|
(list 'menu-item "&Browse Linked File URL"
|
|
`(lambda () (interactive)
|
|
(browse-url ,url))))))
|
|
(when (> (length map) num)
|
|
(define-key map [mlinks-href-sep-2] (list 'menu-item "--")))
|
|
(setq num (length map))
|
|
(unless (equal file (buffer-file-name))
|
|
(define-key map [mlinks-href-edit]
|
|
(list 'menu-item "&Open Linked File"
|
|
`(lambda () (interactive) (mlinks-goto))))
|
|
(define-key map [mlinks-href-edit-window]
|
|
(list 'menu-item "&Open Linked File in Other Window"
|
|
`(lambda () (interactive) (mlinks-goto-other-window))))
|
|
(define-key map [mlinks-href-edit-frame]
|
|
(list 'menu-item "&Open Linked File in New Frame"
|
|
`(lambda () (interactive) (mlinks-goto-other-frame))))
|
|
)
|
|
(when (and (file-exists-p file) anchor)
|
|
(define-key map [mlinks-href-edit-at]
|
|
(list 'menu-item (concat "Open Linked File &at #" anchor)
|
|
`(lambda () (interactive)
|
|
(mlinks-goto)))))
|
|
)
|
|
(when (> (length map) num)
|
|
(define-key map [mlinks-href-sep-1] (list 'menu-item "--")))
|
|
(setq num (length map))
|
|
(when link-val
|
|
(define-key map [mlinks-href-copy-link]
|
|
(list 'menu-item "&Copy Link Text"
|
|
'mlinks-copy-link-text)))))
|
|
(when (> (length map) 2)
|
|
map))))
|
|
|
|
(defun mlinks-add-appmenu ()
|
|
"Add entries for MLinks to AppMenu."
|
|
(when (featurep 'appmenu)
|
|
(appmenu-add 'mlinks 100 'mlinks-mode "Current MLink" 'mlinks-appmenu)))
|
|
|
|
(defun mlinks-copy-link-text ()
|
|
"Copy text of `mlinks-mode' link at point to clipboard."
|
|
(interactive)
|
|
(mlinks-point-hilighter)
|
|
(let ((ovl mlinks-point-hilighter-overlay))
|
|
(if (and ovl
|
|
(overlayp ovl)
|
|
(overlay-buffer ovl)
|
|
(eq (current-buffer)
|
|
(overlay-buffer ovl))
|
|
(<= (overlay-start ovl)
|
|
(point))
|
|
(>= (overlay-end ovl)
|
|
(point)))
|
|
(let* ((beg (overlay-start ovl))
|
|
(end (overlay-end ovl))
|
|
(str (buffer-substring beg end)))
|
|
(copy-region-as-kill beg end)
|
|
(message "Copied %d chars to clipboard" (length str)))
|
|
(message "No link here to copy"))))
|
|
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;; text-mode etc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defvar mlinks-plain-urls-regexp
|
|
(rx-to-string `(or (submatch (optional "mailto:")
|
|
(regexp ,(concat
|
|
;;"[a-z0-9$%(*-=?[_][^<>\")!;:,{}]*"
|
|
"[a-z0-9$%(*=?[_-][^<>\")!;:,{}]*"
|
|
"\@"
|
|
"\\(?:[a-z0-9\-]+\.\\)+[a-z0-9]\\{2,4\\}")))
|
|
(submatch (or (regexp "https?://")
|
|
"www.")
|
|
(1+ (any ,url-get-url-filename-chars))
|
|
)
|
|
)))
|
|
|
|
(defun mlinks-plain-urls-fontify (bound)
|
|
(mlinks-fontify bound mlinks-plain-urls-regexp 0))
|
|
|
|
(defun mlinks-goto-plain-url ()
|
|
(let* ((range (mlinks-link-range (point)))
|
|
(link (when range (buffer-substring-no-properties (car range) (cdr range)))))
|
|
;;(mlinks-html-href-act-on link)
|
|
(when (= 0 (string-match mlinks-plain-urls-regexp link))
|
|
(let ((which (if (match-end 1) 1 2)))
|
|
(cond
|
|
((= 1 which)
|
|
(mlinks-html-mail-to link)
|
|
t)
|
|
((= 2 which)
|
|
(browse-url link)
|
|
t)
|
|
(t nil))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;; nxhtml-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun mlinks-html-style-goto ()
|
|
(mlinks-html-style-mode-fun t))
|
|
|
|
(defvar mlinks-html-link-regexp
|
|
;; This value takes care of nxhtml-strval-mode (and is therefore a little bit incorrect ...)
|
|
;;"\\(?:^\\|[[:space:]]\\)\\(?:href\\|src\\)[[:space:]]*=[[:space:]]*\"\\([^<«\"]*\\)\""
|
|
(rx (or "^" space)
|
|
(or "href" "src")
|
|
(0+ space)
|
|
"="
|
|
(0+ space)
|
|
(submatch
|
|
(or
|
|
(seq "\""
|
|
(and
|
|
(0+ (not (any "\""))))
|
|
"\"")
|
|
(seq "'"
|
|
(and
|
|
(0+ (not (any "\'"))))
|
|
"'")))))
|
|
|
|
(defun mlinks-html-style-mode-fun (goto)
|
|
(let (start
|
|
end
|
|
bounds)
|
|
(save-excursion
|
|
(forward-char)
|
|
(when (< 0 (skip-chars-forward "^\"'" (line-end-position)))
|
|
(forward-char)
|
|
(save-match-data
|
|
(when (looking-back
|
|
mlinks-html-link-regexp
|
|
(line-beginning-position -1))
|
|
(let ((which (if (match-beginning 1) 1 2)))
|
|
(setq start (1+ (match-beginning which)))
|
|
(setq end (1- (match-end which))))
|
|
(setq bounds (cons start end))))))
|
|
(when start
|
|
(if (not goto)
|
|
bounds
|
|
(let ((href-val (buffer-substring-no-properties start end)))
|
|
(mlinks-html-href-act-on href-val))
|
|
t))))
|
|
|
|
(defun mlink-check-file-to-edit (file)
|
|
(assert (file-name-absolute-p file))
|
|
(let ((file-dir (file-name-directory file)))
|
|
(unless (file-directory-p file-dir)
|
|
(if (file-directory-p (file-name-directory file))
|
|
(if (yes-or-no-p (format "Directory %s does not exist. Create it? " file-dir))
|
|
(make-directory file-dir)
|
|
(setq file nil))
|
|
(if (yes-or-no-p (format "Directory %s and its parent does not exist. Create them? " file-dir))
|
|
(make-directory file-dir t)
|
|
(setq file nil))))
|
|
file))
|
|
|
|
(defun mlinks-html-edit-at (file &optional anchor)
|
|
(let ((abs-file (if (file-name-absolute-p file)
|
|
file
|
|
(expand-file-name file))))
|
|
(if (or (file-directory-p abs-file)
|
|
(string= abs-file
|
|
(file-name-as-directory abs-file)))
|
|
(if (file-directory-p abs-file)
|
|
(when (y-or-n-p (format "Do you want to edit the directory %s? : " abs-file))
|
|
(dired abs-file))
|
|
(message "Can't find directory %s" abs-file))
|
|
(when (mlink-check-file-to-edit abs-file)
|
|
(let ((b (find-file-noselect abs-file)))
|
|
(mlinks-switch-to-buffer b))
|
|
(when anchor
|
|
(let ((here (point))
|
|
(anchor-regexp (concat "\\(?:id\\|name\\)[[:space:]]*=[[:space:]]*\"" anchor "\"")))
|
|
(goto-char (point-min))
|
|
(if (search-forward-regexp anchor-regexp nil t)
|
|
(backward-char 2)
|
|
(message "Anchor \"%s\" not found" anchor)
|
|
(goto-char here))))))))
|
|
|
|
(defun mlinks-html-mail-to (addr)
|
|
(browse-url addr))
|
|
|
|
(defun mlinks-html-href-act-on (href-val)
|
|
(if href-val
|
|
(let* ((possible (mlinks-html-possible-href-actions href-val))
|
|
(edit (assoc 'edit possible))
|
|
(file (nth 1 edit))
|
|
(anchor (nth 2 edit))
|
|
)
|
|
(cond (edit
|
|
(mlinks-html-edit-at file anchor)
|
|
t)
|
|
((assoc 'mailto possible)
|
|
(when (y-or-n-p "This is a mail address. Do you want to send a message to this mail address? ")
|
|
(mlinks-html-mail-to href-val)))
|
|
((assoc 'view-web possible)
|
|
(when (y-or-n-p "Can't edit this URL, it is on the web. View the URL in your web browser? ")
|
|
(browse-url href-val)))
|
|
((assoc 'view-web-base possible)
|
|
(when (y-or-n-p "Can't edit, based URL is to the web. View resulting URL in your web browser? ")
|
|
(browse-url (cdr (assoc 'view-web-base possible)))))
|
|
(t
|
|
(message "Do not know how to handle this URL"))
|
|
))
|
|
(message "No value for href attribute")))
|
|
|
|
(defun mlinks-html-possible-href-actions (link)
|
|
(let ((urlobj (url-generic-parse-url link))
|
|
(edit nil)
|
|
(possible nil))
|
|
(cond ((member (url-type urlobj) '("http" "https"))
|
|
(add-to-list 'possible (cons 'view-web link)))
|
|
((member (url-type urlobj) '("mailto"))
|
|
(add-to-list 'possible (cons 'mailto link)))
|
|
((url-host urlobj)
|
|
(message "Do not know how to handle this URL"))
|
|
(t (setq edit t)))
|
|
(when edit
|
|
(let ((base-href (mlinks-html-find-base-href)))
|
|
(when base-href
|
|
(let ((baseobj (url-generic-parse-url base-href)))
|
|
(setq edit nil)
|
|
(cond ((member (url-type baseobj) '("http" "https"))
|
|
(add-to-list 'possible (cons 'view-web-base (url-expand-file-name link base-href))))
|
|
((url-host urlobj)
|
|
(message "Do not know how to handle this URL"))
|
|
(t (setq edit t)))))
|
|
(when edit
|
|
(let* ((full (split-string (url-filename urlobj) "#"))
|
|
(file (nth 0 full))
|
|
(anchor (nth 1 full))
|
|
)
|
|
(when (equal file "")
|
|
(setq file (buffer-file-name)))
|
|
(when base-href
|
|
;; We know at this point it is not a http url
|
|
(setq file (expand-file-name file base-href)))
|
|
(let ((ext (downcase (file-name-extension file))))
|
|
(when (member ext '("htm" "html"))
|
|
(add-to-list 'possible (cons 'view-local (list file anchor))))
|
|
(when (and (featurep 'gimpedit)
|
|
(member ext '("gif" "png" "jpg" "jpeg")))
|
|
(add-to-list 'possible (cons 'edit-gimp (list file anchor)))))
|
|
(when (featurep 'html-upl)
|
|
(add-to-list 'possible (cons 'upload (list file anchor))))
|
|
(add-to-list 'possible (cons 'edit (list file anchor)))))))
|
|
possible))
|
|
|
|
(defun mlinks-html-find-base-href ()
|
|
"Return base href found in the current file."
|
|
(let ((base-href))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(while (and (not base-href)
|
|
(search-forward-regexp "<!--[^!]*-->\\|<base[[:space:]]" nil t))
|
|
(when (equal " " (char-to-string (char-before)))
|
|
(backward-char 6)
|
|
(when (looking-at "<base [^>]*href *= *\"\\(.*?\\)\"")
|
|
(setq base-href (match-string-no-properties 1))))))
|
|
base-href))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;; Custom-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defun mlinks-elisp-custom-goto ()
|
|
(mlinks-elisp-mode-fun 'custom))
|
|
|
|
(defvar mlinks-custom-link-regexp
|
|
(rx "`"
|
|
(group
|
|
(1+ (not (any "'"))))
|
|
"'"))
|
|
|
|
(defun mlinks-custom-fontify (bound)
|
|
(mlinks-fontify bound mlinks-custom-link-regexp 0))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;; emacs-lisp-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defun mlinks-elisp-goto ()
|
|
(mlinks-elisp-mode-fun 'source))
|
|
|
|
(defun mlinks-elisp-hili ()
|
|
(mlinks-elisp-mode-fun nil))
|
|
|
|
(defun mlinks-elisp-mode-fun (goto)
|
|
(let ((symbol-name (thing-at-point 'symbol)))
|
|
(when symbol-name
|
|
(let ((bounds-- (bounds-of-thing-at-point 'symbol))
|
|
ret--)
|
|
(if (save-excursion
|
|
(goto-char (cdr bounds--))
|
|
(looking-back (concat "(\\(?:require\\|featurep\\)\s+'" symbol-name)
|
|
(line-beginning-position)))
|
|
(progn
|
|
(setq ret-- bounds--)
|
|
(when goto
|
|
(mlinks-elisp-mode-require symbol-name)))
|
|
(when (mlinks-elisp-mode-symbol symbol-name goto)
|
|
(setq ret-- bounds--)))
|
|
ret--))))
|
|
|
|
(defun mlinks-elisp-function (symbol)
|
|
"Go to an elisp function."
|
|
(interactive "aElisp function: ")
|
|
(mlinks-elisp-mode-symbol (symbol-name symbol) 'source))
|
|
|
|
(defun mlinks-elisp-mode-symbol (symbol-name-- goto--)
|
|
;; Fix-me: use uninterned variables (see mail from Miles)
|
|
;; Make these names a bit strange because they are boundp at the time of checking:
|
|
(let ((symbol-- (intern-soft symbol-name--))
|
|
defs--)
|
|
(when (and symbol-- (boundp symbol--))
|
|
(add-to-list 'defs-- 'variable))
|
|
(when (fboundp symbol--)
|
|
(add-to-list 'defs-- 'function))
|
|
(when (facep symbol--)
|
|
(add-to-list 'defs-- 'face))
|
|
;; Avoid some fails hits
|
|
(when (memq symbol--
|
|
'(goto t
|
|
bounds-- funs-- ret--
|
|
symbol-- defs-- symbol-name-- goto--))
|
|
(setq defs-- nil))
|
|
(let (defs-places
|
|
def)
|
|
(if (not goto--)
|
|
(progn
|
|
defs--)
|
|
(if (not defs--)
|
|
(progn
|
|
(message "Could not find definition of '%s" symbol-name--)
|
|
nil)
|
|
(dolist (type (cond
|
|
((eq goto-- 'source)
|
|
'(nil defvar defface))
|
|
((eq goto-- 'custom)
|
|
'(defvar defface))
|
|
(t
|
|
(error "Bad goto-- value: %s" goto--))))
|
|
(condition-case err
|
|
(add-to-list 'defs-places
|
|
(cons
|
|
type
|
|
(save-excursion
|
|
(let* ((bp (find-definition-noselect symbol-- type))
|
|
(b (car bp))
|
|
(p (cdr bp)))
|
|
(unless p
|
|
(with-current-buffer b
|
|
(save-restriction
|
|
(widen)
|
|
(setq bp (find-definition-noselect symbol-- type)))))
|
|
bp))))
|
|
(error
|
|
;;(lwarn '(mlinks) :error "%s" (error-message-string err))
|
|
(when t
|
|
(cond
|
|
((eq (car err) 'search-failed))
|
|
((and (eq (car err) 'error)
|
|
(string= (error-message-string err)
|
|
(format "Don't know where `%s' is defined" symbol--))))
|
|
(t
|
|
(message "%s: %s" (car err) (error-message-string err))))))))
|
|
(if (= 1 (length defs-places))
|
|
(setq def (car defs-places))
|
|
(let ((many nil)
|
|
lnk)
|
|
(dolist (d defs-places)
|
|
(if (not lnk)
|
|
(setq lnk (cdr d))
|
|
(unless (equal lnk (cdr d))
|
|
(setq many t))))
|
|
(if (not many)
|
|
(setq def (car defs-places))
|
|
(let* ((alts (mapcar (lambda (elt)
|
|
(let ((type (car elt))
|
|
str)
|
|
(setq str
|
|
(cond
|
|
((not type)
|
|
"Function")
|
|
((eq type 'defvar)
|
|
"Variable")
|
|
((eq type 'defface)
|
|
"Face")))
|
|
(cons str elt)))
|
|
defs-places))
|
|
(stralts (mapcar (lambda (elt)
|
|
(car elt))
|
|
alts))
|
|
(completion-ignore-case t)
|
|
(stralt (completing-read "Type: " stralts nil t))
|
|
(alt (assoc stralt alts)))
|
|
(setq def (cdr alt))))))
|
|
(when def
|
|
(cond
|
|
((eq goto-- 'source)
|
|
;; Be sure to go to the real sources from CVS:
|
|
(let* ((buf (car (cdr def)))
|
|
;; Avoid going to source
|
|
;;(file (find-source-lisp-file (with-current-buffer buf buffer-file-name)) )
|
|
(file (with-current-buffer buf buffer-file-name))
|
|
(orig-buf (find-file-noselect file)))
|
|
(mlinks-switch-to-buffer orig-buf)
|
|
(let ((p (cdr (cdr def))))
|
|
;; Fix-me: Move this test to a more general place.
|
|
(if (or (< p (point-min))
|
|
(> p (point-max)))
|
|
;; Check for cloned indirect buffers.
|
|
(progn
|
|
(setq orig-buf
|
|
(catch 'view-in-buf
|
|
(dolist (indirect-buf (buffer-list))
|
|
;;(message "base-buffer=%s, orig-buf=%s, eq => %s" (buffer-base-buffer indirect-buf) orig-buf (eq (buffer-base-buffer indirect-buf) orig-buf))
|
|
(when (eq (buffer-base-buffer indirect-buf) orig-buf)
|
|
(with-current-buffer indirect-buf
|
|
;;(message "indirect-buf=%s" indirect-buf)
|
|
(unless (or (< p (point-min))
|
|
(> p (point-max)))
|
|
;;(message "switching")
|
|
;;(mlinks-switch-to-buffer indirect-buf)
|
|
(message "mlinks: Switching to indirect buffer because of narrowing")
|
|
(throw 'view-in-buf indirect-buf)
|
|
))
|
|
))))
|
|
(when orig-buf
|
|
(mlinks-switch-to-buffer orig-buf))
|
|
;;(message "cb=%s" (current-buffer))
|
|
(if (or (< p (point-min))
|
|
(> p (point-max)))
|
|
(when (y-or-n-p (format "%s is invisible because of narrowing. Widen? " symbol--))
|
|
(widen)
|
|
(goto-char p))
|
|
(goto-char p)))
|
|
(goto-char p)))))
|
|
((eq goto-- 'custom)
|
|
(mlinks-custom symbol--))
|
|
(t
|
|
(error "Back goto-- value again: %s" goto--)))))))))
|
|
|
|
(defun mlinks-elisp-mode-require (module)
|
|
(let ((where mlinks-temp-buffer-where))
|
|
(cond
|
|
((null where)
|
|
(find-library module))
|
|
((eq where 'other-window)
|
|
(other-window 1)
|
|
(find-library module))
|
|
((eq where 'other-frame)
|
|
(make-frame-command)
|
|
(find-library module))
|
|
(t
|
|
(error "Invalid argument, where=%s" where)))))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;; Helpers when adopting for modes ;;;;;;;;;;;;;;;;;
|
|
|
|
;;; Save this, do not delete this comment:
|
|
|
|
;; (defun mlinks-hit-test ()
|
|
;; "Just a helper function for adding support for new modes."
|
|
;; (let* (
|
|
;; (s0 (if (match-string 0) (match-string 0) ""))
|
|
;; (s1 (if (match-string 1) (match-string 1) ""))
|
|
;; (s2 (if (match-string 2) (match-string 2) ""))
|
|
;; (s3 (if (match-string 3) (match-string 3) ""))
|
|
;; )
|
|
;; (message "match0=%s, match1=%s, match2=%s, match3=%s" s0 s1 s2 s3)))
|
|
|
|
;; (defun mlinks-handle-reg-fun-list (reg-fun-list)
|
|
;; "Just a helper function."
|
|
;; (let (done
|
|
;; regexp
|
|
;; hitfun
|
|
;; m
|
|
;; p
|
|
;; b
|
|
;; )
|
|
;; (dolist (rh reg-fun-list)
|
|
;; (message "rh=%s" rh);(sit-for 2)
|
|
;; (unless done
|
|
;; (setq regexp (car rh))
|
|
;; (setq hitfun (cadr rh))
|
|
;; (message "regexp=%s, hitfun=%s" regexp hitfun);(sit-for 1)
|
|
;; (when (and (save-match-data
|
|
;; (setq m (re-search-backward regexp (line-beginning-position) t))
|
|
;; (> p (match-beginning 0))))
|
|
;; (setq done t)
|
|
;; (setq b (match-beginning 0))
|
|
;; (setq e (match-end 0))
|
|
;; )
|
|
;; (if (not (and b e
|
|
;; (< b p)
|
|
;; (< p e)))
|
|
;; (message "MLinks Mode did not find any link here")
|
|
;; (goto-char b)
|
|
;; (if (not (looking-at regexp))
|
|
;; (error "Internal error, regexp %s, no match looking-at" regexp)
|
|
;; (let ((last (car mlinks-places))
|
|
;; (m (make-marker)))
|
|
;; (set-marker m (line-beginning-position))
|
|
;; (when (or (not last)
|
|
;; (/= m last))
|
|
;; (setq mlinks-places (cons m mlinks-places))))
|
|
;; (funcall hitfun))
|
|
;; )))))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Font Lock use
|
|
|
|
(defvar mlinks-link-update-pos-max nil)
|
|
(make-variable-buffer-local 'mlinks-link-update-pos-max)
|
|
(put 'mlinks-link-update-pos-max 'permanent-local t)
|
|
|
|
(defun mlinks-remove-font-lock ()
|
|
"Remove info from font-lock."
|
|
(when (mlinks-want-font-locking)
|
|
(mlink-font-lock nil)))
|
|
|
|
(defun mlinks-add-font-lock ()
|
|
"Add info to font-lock."
|
|
(when (mlinks-want-font-locking)
|
|
(mlink-font-lock t)))
|
|
|
|
(defun mlinks-want-font-locking ()
|
|
(or (mlinks-get-mode-value 'fontify)
|
|
(mlinks-get-mode-value 'next-mark)))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Font Lock integration
|
|
|
|
(defun mlink-font-lock (on)
|
|
(let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
|
|
(fontify-fun (car (mlinks-get-mode-value 'fontify)))
|
|
(args (list nil `(( ,fontify-fun ( 0 mlinks-font-lock-face t ))))))
|
|
(when fontify-fun
|
|
;; Note: Had a lot of trouble with this which I modelled first
|
|
;; after dlink. Using hi-lock as a model made it work with
|
|
;; mumamo too.
|
|
;;
|
|
;; Next arg, HOW, is needed to get it to work with mumamo. This
|
|
;; adds it last, like hi-lock.
|
|
(when on (setq args (append args (list t))))
|
|
(apply add-or-remove args)
|
|
(font-lock-mode -1)
|
|
(font-lock-mode 1))))
|
|
|
|
(defun mlinks-html-fontify (bound)
|
|
(mlinks-fontify bound mlinks-html-link-regexp 1))
|
|
|
|
(defun mlinks-fontify (bound regexp border)
|
|
(let ((start (point))
|
|
end-start
|
|
stop next-stop
|
|
(more t)
|
|
old-beg old-end
|
|
(wn 1)
|
|
ret)
|
|
;; Note: we shouldnot use save-match-data here. Instead
|
|
;; set-match-data is called below!
|
|
(if (not (re-search-forward regexp bound t))
|
|
(setq end-start bound)
|
|
(setq ret t)
|
|
(setq end-start (- (point) 2))
|
|
(let* ((which (if (match-beginning 1) 1 2))
|
|
(beg (+ (match-beginning which) border))
|
|
(end (- (match-end which) border)))
|
|
(put-text-property beg end 'mlinks-link t)
|
|
(set-match-data (list (copy-marker end) (copy-marker beg)))))
|
|
(setq stop start)
|
|
(setq next-stop -1)
|
|
(while (and (> 100 (setq wn (1+ wn)))
|
|
(setq next-stop (next-single-char-property-change stop 'mlinks-link nil end-start))
|
|
(/= next-stop stop))
|
|
(setq stop next-stop)
|
|
(if (get-text-property stop 'mlinks-link)
|
|
(setq old-beg stop)
|
|
(when old-beg
|
|
(remove-list-of-text-properties old-beg stop '(mlinks-link 'mouse-face)))))
|
|
ret))
|
|
|
|
(defun mlinks-next-link ()
|
|
"Find next link, fontify as necessary."
|
|
(let* ((here (point))
|
|
(prev-pos (point))
|
|
(fontified-here (get-text-property (max (point-min) (1- prev-pos)) 'fontified))
|
|
(fontified-to (next-single-char-property-change prev-pos 'fontified))
|
|
(pos (next-single-char-property-change prev-pos 'mlinks-link nil
|
|
(or fontified-to (point-max))))
|
|
(fontified-all (and fontified-here (not fontified-to)))
|
|
ready
|
|
next-fontified-to)
|
|
(while (not (or ready
|
|
(and fontified-all
|
|
(not pos))))
|
|
(if pos
|
|
(progn
|
|
(unless (get-text-property pos 'mlinks-link)
|
|
;; Get to next link
|
|
(setq prev-pos pos)
|
|
(setq pos (next-single-char-property-change prev-pos 'mlinks-link nil
|
|
(or fontified-to (point-max)))))
|
|
(when pos
|
|
(setq ready (get-text-property pos 'mlinks-link))
|
|
(setq prev-pos pos)
|
|
(unless ready (setq pos nil))))
|
|
(unless (or fontified-all fontified-to)
|
|
(if (get-text-property prev-pos 'fontified)
|
|
(setq fontified-all
|
|
(not (setq fontified-to
|
|
(next-single-char-property-change prev-pos 'fontified))))
|
|
(setq fontified-to ( or (previous-single-char-property-change prev-pos 'fontified)
|
|
1))))
|
|
(setq next-fontified-to (min (+ fontified-to 5000)
|
|
(point-max)))
|
|
(mumamo-with-buffer-prepared-for-jit-lock
|
|
(progn
|
|
(put-text-property fontified-to next-fontified-to 'fontified t)
|
|
(font-lock-fontify-region fontified-to next-fontified-to)))
|
|
(setq fontified-to (next-single-char-property-change (1- next-fontified-to)
|
|
'fontified))
|
|
(setq fontified-all (not fontified-to))
|
|
(setq pos (next-single-char-property-change prev-pos 'mlinks-link nil
|
|
(or fontified-to (point-max))))))
|
|
(when ready prev-pos)))
|
|
|
|
(defun mlinks-prev-link ()
|
|
"Find previous link, fontify as necessary."
|
|
(let* ((prev-pos (point))
|
|
(fontified-from (previous-single-char-property-change prev-pos 'fontified))
|
|
(fontified-here (get-text-property (max (point-min) (1- prev-pos)) 'fontified))
|
|
(fontified-all (and fontified-here (not fontified-from)))
|
|
(pos (when fontified-here
|
|
(previous-single-char-property-change prev-pos 'mlinks-link nil
|
|
(or fontified-from 1))))
|
|
ready
|
|
next-fontified-from)
|
|
(while (not (or ready
|
|
(and fontified-all
|
|
(not pos))))
|
|
(assert (numberp prev-pos) t)
|
|
(if pos
|
|
(progn
|
|
(when (and (> (1- pos) (point-min))
|
|
(get-text-property (1- pos) 'mlinks-link))
|
|
;; Get out of current link
|
|
(setq prev-pos pos)
|
|
(setq pos (previous-single-char-property-change prev-pos 'mlinks-link nil
|
|
(or fontified-from 1))))
|
|
(when pos
|
|
(setq prev-pos pos)
|
|
(setq ready (and (get-text-property pos 'fontified)
|
|
(or (= 1 pos)
|
|
(not (get-text-property (1- pos) 'mlinks-link)))
|
|
(get-text-property pos 'mlinks-link)))
|
|
(unless ready (setq pos nil))))
|
|
(setq next-fontified-from (max (- fontified-from 5000)
|
|
(point-min)))
|
|
(mumamo-with-buffer-prepared-for-jit-lock
|
|
(progn
|
|
(put-text-property next-fontified-from fontified-from 'fontified t)
|
|
(font-lock-fontify-region next-fontified-from fontified-from)))
|
|
(setq fontified-from (previous-single-char-property-change
|
|
(1+ next-fontified-from) 'fontified))
|
|
(setq fontified-all (not fontified-from))
|
|
(setq pos (previous-single-char-property-change prev-pos 'mlinks-link nil
|
|
(or fontified-from 1)))))
|
|
(when ready pos)))
|
|
|
|
|
|
;;; This is for the problem reported by some Asian users:
|
|
;;;
|
|
;;; Lisp error: (invalid-read-syntax "] in a list")
|
|
;;;
|
|
;; Local Variables:
|
|
;; coding: utf-8
|
|
;; End:
|
|
|
|
(provide 'mlinks)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; mlinks.el ends here
|