summaryrefslogtreecommitdiffstats
path: root/emacs.d/nxhtml/util/mlinks.el
diff options
context:
space:
mode:
Diffstat (limited to 'emacs.d/nxhtml/util/mlinks.el')
-rw-r--r--emacs.d/nxhtml/util/mlinks.el1367
1 files changed, 0 insertions, 1367 deletions
diff --git a/emacs.d/nxhtml/util/mlinks.el b/emacs.d/nxhtml/util/mlinks.el
deleted file mode 100644
index 0f81654..0000000
--- a/emacs.d/nxhtml/util/mlinks.el
+++ /dev/null
@@ -1,1367 +0,0 @@
-;;; 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
generated by cgit v1.2.3-54-g00ecf (git 2.39.0) at 2024-07-10 11:09:24 +0000