;;; 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 "\\|]*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