emacs/nxhtml/util/mlinks.el

   1 ;;; mlinks.el --- Minor mode making major mode dependent links
   2 ;;
   3 ;; Author: Lennar Borgman
   4 ;; Created: Tue Jan 16 2007
   5 (defconst mlinks:version "0.28") ;;Version:
   6 ;; Last-Updated: 2010-01-05 Tue
   7 ;; Keywords:
   8 ;; Compatibility:
   9 ;;
  10 ;; Fxeatures that might be required by this library:
  11 ;;
  12 ;;   `appmenu', `cl', `mail-prsvr', `mm-util', `ourcomments-util',
  13 ;;   `url-expand', `url-methods', `url-parse', `url-util',
  14 ;;   `url-vars'.
  15 ;;
  16 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17 ;;
  18 ;;; Commentary:
  19 ;;
  20 ;; This file implements the minor mode `mlinks-mode' that create
  21 ;; hyperlinks for different major modes.  Such links can be visible or
  22 ;; invisible.  The meanings of the links are defined per mode.
  23 ;;
  24 ;; Examples:
  25 ;;
  26 ;; - In in html style modes the links are visible they can mean either
  27 ;;   open a file for editing, go to an achnor or view the link in a
  28 ;;   web browser etc.
  29 ;;
  30 ;; - In emacs lisp mode the links are invisible, but maybe highlighed
  31 ;;   when point or mouse is on them.  (Having them highlighted when
  32 ;;   point is on them can be a quick way to check that you have
  33 ;;   spelled a symbol correct.)  The meanings of the links in emacs
  34 ;;   lisp mode are go to definition.
  35 ;;
  36 ;; Common to links that open a buffer in Emacs is that you can the
  37 ;; buffer opened in the same window, the other window or in a new
  38 ;; frame.  The same key binding is used in all major modes for this.
  39 ;;
  40 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41 ;;
  42 ;;; Change log:
  43 ;;
  44 ;; FIX-ME: url-hexify-string etc
  45 ;;
  46 ;;
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48 ;;
  49 ;; This program is free software; you can redistribute it and/or modify
  50 ;; it under the terms of the GNU General Public License as published by
  51 ;; the Free Software Foundation; either version 2, or (at your option)
  52 ;; any later version.
  53 ;;
  54 ;; This program is distributed in the hope that it will be useful,
  55 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  56 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  57 ;; GNU General Public License for more details.
  58 ;;
  59 ;; You should have received a copy of the GNU General Public License
  60 ;; along with this program; see the file COPYING.  If not, write to the
  61 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  62 ;; Boston, MA 02111-1307, USA.
  63 ;;
  64 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65 ;;
  66 ;;; Code:
  67
  68 (eval-when-compile (require 'cl))
  69 (eval-when-compile (require 'appmenu nil t))
  70 (eval-when-compile (require 'mumamo nil t))
  71 (eval-when-compile (require 'ourcomments-util nil t))
  72
  73 (require 'rx)
  74 (require 'url-parse)
  75 (require 'url-expand)
  76
  77 (defvar mlinks-point-hilighter-overlay nil)
  78 (make-variable-buffer-local 'mlinks-point-hilighter-overlay)
  79 (put 'mlinks-point-hilighter-overlay 'permanent-local t)
  80
  81 ;;;###autoload
  82 (defgroup mlinks nil
  83   "Customization group for `mlinks-mode'."
  84   :group 'nxhtml
  85   :group 'hypermedia)
  86
  87 (defvar mlinks-link-face 'mlinks-link-face)
  88 (defface mlinks-link-face
  89   '((t (:inherit highlight)))
  90   "Face normally active links have on them."
  91   :group 'mlinks)
  92
  93 (defvar mlinks-hyperactive-link-face 'mlinks-hyperactive-link-face)
  94 (defface mlinks-hyperactive-link-face
  95   '((t (:inherit isearch)))
  96   "Face hyper active links have on them."
  97   :group 'mlinks)
  98
  99 (defvar mlinks-font-lock-face 'mlinks-font-lock-face)
 100 (defface mlinks-font-lock-face
 101   '((t :inherit link))
 102   "Default face for MLinks' links."
 103   :group 'mlinks)
 104
 105
 106
 107 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 108 ;;; Mode function bindings
 109
 110 ;;(customize-option mlinks-mode-functions)
 111 (defcustom mlinks-mode-functions
 112   '(
 113     ;; For message buffer etc.
 114     (fundamental-mode
 115      ((goto mlinks-elisp-goto)
 116       (hili mlinks-elisp-hili)
 117       (hion t)
 118       )
 119      )
 120     (emacs-lisp-mode
 121      ((goto mlinks-elisp-goto)
 122       (hili mlinks-elisp-hili)
 123       (hion t)
 124       )
 125      )
 126     ;; *scractch*
 127     (lisp-interaction-mode
 128      ((goto mlinks-elisp-goto)
 129       (hili mlinks-elisp-hili)
 130       (hion t)
 131       )
 132      )
 133     (help-mode
 134      ((goto mlinks-elisp-goto)
 135       (hili mlinks-elisp-hili)
 136       (hion t)
 137       )
 138      )
 139     (Info-mode
 140      ((goto mlinks-elisp-goto)
 141       (hili mlinks-elisp-hili)
 142       (hion t)
 143       )
 144      )
 145     (Custom-mode
 146      ((goto mlinks-elisp-custom-goto)
 147       (hili mlinks-elisp-hili)
 148       (hion t)
 149       (fontify mlinks-custom-fontify)
 150       )
 151      )
 152     (text-mode
 153      ((goto mlinks-goto-plain-url)
 154       (hion t)
 155       (fontify mlinks-plain-urls-fontify)
 156       )
 157      )
 158     (nxhtml-mode
 159      ((hion t)
 160       (fontify mlinks-html-fontify)
 161       (goto mlinks-html-style-goto)
 162       )
 163      )
 164     (nxml-mode
 165      ((hion t)
 166       (fontify mlinks-html-fontify)
 167       (goto mlinks-html-style-goto)
 168       )
 169      )
 170     (sgml-mode
 171      ((hion t)
 172       (fontify mlinks-html-fontify)
 173       (goto mlinks-html-style-goto)
 174       )
 175      )
 176     (html-mode
 177      ((hion t)
 178       (fontify mlinks-html-fontify)
 179       (goto mlinks-html-style-goto)
 180       )
 181      )
 182     )
 183   "Defines MLinks hyperlinks for major modes.
 184 "
 185   ;; Each element in the list is a list with two elements
 186
 187   ;;   \(MAJOR-MODE SETTINGS)
 188
 189   ;; where MAJOR-MODE is the major mode for which the settings SETTINGS should be used.
 190   ;; SETTINGS is an association list which can have the following element types
 191
 192   ;;   \(hili HILIGHT-FUN)  ;; Mandatory
 193   ;;   \(goto GOTO-FUN)     ;; Mandatory
 194   ;;   \(hion HION-BOOL)    ;; Optional
 195   ;;   \(next NEXT-FUN)     ;; Optional
 196   ;;   \(prev PREV-FUN)     ;; Optional
 197
 198   ;; Where
 199   ;; - HILIGHT-FUN is the function to hilight a link when point is
 200   ;;   inside the link. This is done when Emacs is idle.
 201   ;; - GOTO-FUN is the function to follow the link at point.
 202   ;; - HION-BOOL is t or nil depending on if hilighting should be on
 203   ;;   by default.
 204   ;; - NEXT-FUN is the function to go to the next link.
 205   ;; - PREV-FUN is the function to go to the previous link."
 206   ;;   ;;:type '(repeat (alist :key-type symbol :value-type (alist :key-type symbol :value symbol)))
 207   :type '(alist :key-type major-mode-function
 208                 :value-type (list
 209                              (set
 210                               (const :tag "Enable MLinks in this major mode" hion)
 211                               (const :tag "Mark All Links" mark)
 212                               (list :tag "Enable" (const :tag "Hilighting" hili) function)
 213                               (list :tag "Enable" (const :tag "Follow Link" goto) function)
 214                               (list :tag "Enable" (const :tag "Goto Next Link" next) function)
 215                               (list :tag "Enable" (const :tag "Goto Previous Link" prev) function)
 216                               )))
 217   :group 'mlinks)
 218
 219
 220 (defun mlinks-get-mode-value (which)
 221   (let* ((major major-mode)
 222          (mode-rec (assoc major mlinks-mode-functions)))
 223     (catch 'mode-rec
 224       (while (and major
 225                   (not mode-rec))
 226         (setq major (get major 'derived-mode-parent))
 227         (setq mode-rec (assoc major mlinks-mode-functions))
 228         (when mode-rec (throw 'mode-rec nil))))
 229     (when mode-rec
 230       (let* ((mode (car mode-rec))
 231              (funs-alist (cadr mode-rec))
 232              (funs (assoc which funs-alist)))
 233         (cdr funs)))))
 234
 235
 236
 237
 238 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 239 ;;; Minor modes
 240
 241 ;; (appmenu-dump-keymap mlinks-mode-map)
 242 (defvar mlinks-mode-map
 243   (let ((m (make-sparse-keymap "mlinks")))
 244     (define-key m [(control ?c) ?\r ?\r]   'mlinks-goto)
 245     (define-key m [(control ?c) ?\r ?w]    'mlinks-goto-other-window)
 246     (define-key m [(control ?c) ?\r ?f]    'mlinks-goto-other-frame)
 247     (define-key m [(control ?c) ?\r ?n]    'mlinks-next-saved-position)
 248     (define-key m [(control ?c) ?\r ?p]    'mlinks-prev-saved-position)
 249     (define-key m [(control ?c) ?\r S-tab] 'mlinks-backward-link)
 250     (define-key m [(control ?c) ?\r tab]   'mlinks-forward-link)
 251     (define-key m [(control ?c) ?\r ?h]    'mlinks-toggle-hilight)
 252     (define-key m [(control ?c) ?\r ?c]    'mlinks-copy-link-text)
 253     m))
 254
 255 ;;;###autoload
 256 (define-minor-mode mlinks-mode
 257   "Recognizes certain parts of a buffer as hyperlinks.
 258 The hyperlinks are created in different ways for different major
 259 modes with the help of the functions in the list
 260 `mlinks-mode-functions'.
 261
 262 The hyperlinks can be hilighted when point is over them.  Use
 263 `mlinks-toggle-hilight' to toggle this feature for the current
 264 buffer.
 265
 266 All keybindings in this mode are by default done under the prefi§x
 267 key
 268
 269   C-c RET
 270
 271 which is supposed to be a kind of mnemonic for link (alluding to
 272 the RET key commonly used in web browser to follow a link).
 273 \(Unfortunately this breaks the rules in info node `Key Binding
 274 Conventions'.) Below are the key bindings defined by this mode:
 275
 276 \\{mlinks-mode-map}
 277
 278 For some major modes `mlinks-backward-link' and
 279 `mlinks-forward-link' will take you to the previous/next link.
 280 By default the link moved to will be active, see
 281 `mlinks-active-links'.
 282
 283 "
 284   nil
 285   " L"
 286   nil
 287   :keymap mlinks-mode-map
 288   :group 'mlinks
 289   (if mlinks-mode
 290       (progn
 291         (mlinks-add-appmenu)
 292         (mlinks-start-point-hilighter)
 293         (mlinks-add-font-lock))
 294     (mlinks-stop-point-hilighter)
 295     (when mlinks-point-hilighter-overlay
 296       (when (overlayp mlinks-point-hilighter-overlay)
 297         (delete-overlay mlinks-point-hilighter-overlay))
 298       (setq mlinks-point-hilighter-overlay nil))
 299     (mlinks-remove-font-lock)))
 300 (put 'mlinks-mode 'permanent-local t)
 301
 302 (defun mlinks-turn-on-in-buffer ()
 303   (let ((hion (unless (and (boundp 'mumamo-set-major-running)
 304                            mumamo-set-major-running)
 305                 (mlinks-get-mode-value 'hion))))
 306     (when hion (mlinks-mode 1))))
 307
 308 ;;;###autoload
 309 (define-globalized-minor-mode mlinks-global-mode mlinks-mode
 310   mlinks-turn-on-in-buffer
 311   "Turn on `mlink-mode' in all buffer where it is specified.
 312 This is specified in `mlinks-mode-functions'."
 313   :group 'mlinks)
 314
 315 ;; The problem with global minor modes:
 316 (when (and mlinks-global-mode
 317            (not (boundp 'define-global-minor-mode-bug)))
 318   (mlinks-global-mode 1))
 319
 320 ;;(define-toggle mlinks-active-links t
 321 (define-minor-mode mlinks-active-links
 322   "Use quick movement keys on active links if non-nil.
 323 When moving to an mlink with `mlinks-forward-link' or
 324 `mlinks-backward-link' the link moved to will be in an active
 325 state.  This is marked with a new color \(the face `isearch').
 326 When the new color is shown the following keys are active
 327
 328 \\{mlinks-hyperactive-point-hilighter-keymap}
 329 Any command cancels this state."
 330   :global t
 331   :init-value t
 332   :group 'mlinks)
 333
 334
 335
 336 (defun mlinks-link-text-prop-range (pos)
 337   (let* ((link-here (get-text-property pos 'mlinks-link))
 338          (beg (when link-here (previous-single-char-property-change (+ pos 1) 'mlinks-link)))
 339          (end (when link-here (next-single-char-property-change (- pos 0) 'mlinks-link))))
 340     (when (and beg end)
 341       (cons beg end))))
 342
 343 (defun mlinks-link-range (pos)
 344   (or (mlinks-link-text-prop-range pos)
 345       (let ((funs-- (mlinks-get-mode-value 'hili)))
 346         (when funs--
 347           (save-match-data
 348             (run-hook-with-args-until-success 'funs--))))))
 349
 350 (defun mlinks-link-at-point ()
 351   "Get link at point."
 352   (mlinks-point-hilighter-1)
 353   (when (and mlinks-point-hilighter-overlay
 354              (overlay-buffer mlinks-point-hilighter-overlay))
 355     (let* ((ovl mlinks-point-hilighter-overlay)
 356            (beg (overlay-start ovl))
 357            (end (overlay-end ovl)))
 358       (buffer-substring-no-properties beg end))))
 359
 360
 361 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 362 ;;; At point highligher
 363
 364 (defvar mlinks-point-hilighter-timer nil)
 365
 366 (defun mlinks-stop-point-hilighter ()
 367   (when (timerp mlinks-point-hilighter-timer)
 368     (cancel-timer mlinks-point-hilighter-timer)
 369     (setq mlinks-point-hilighter-timer nil)))
 370
 371 (defun mlinks-start-point-hilighter ()
 372   (mlinks-stop-point-hilighter)
 373   (setq mlinks-point-hilighter-timer
 374         (run-with-idle-timer 0.1 t 'mlinks-point-hilighter)))
 375
 376 (defvar mlinks-link-overlay-priority 100)
 377
 378 (defun mlinks-make-point-hilighter-overlay (bounds)
 379   (unless mlinks-point-hilighter-overlay
 380     (setq mlinks-point-hilighter-overlay
 381           (make-overlay (car bounds) (cdr bounds)))
 382     (overlay-put mlinks-point-hilighter-overlay 'priority mlinks-link-overlay-priority)
 383     (overlay-put mlinks-point-hilighter-overlay 'mouse-face 'highlight)
 384     (mlinks-set-normal-point-hilight)
 385     ))
 386
 387 (defun mlinks-point-hilighter ()
 388   "Mark link at point if any.
 389 This moves the hilight point overlay to point or deletes it."
 390   ;; This runs in a timer, protect it.
 391   (condition-case err
 392       (let ((inhibit-point-motion-hooks t))
 393         (mlinks-point-hilighter-1))
 394     (error "mlinks-point-hilighter error: %s" (error-message-string err))))
 395
 396 (defun mlinks-point-hilighter-1 ()
 397   (when mlinks-mode
 398     (let ((bounds-- (mlinks-link-range (point))))
 399       (if bounds--
 400           (if mlinks-point-hilighter-overlay
 401               (move-overlay mlinks-point-hilighter-overlay (car bounds--) (cdr bounds--))
 402             (mlinks-make-point-hilighter-overlay bounds--))
 403         (when mlinks-point-hilighter-overlay
 404           (delete-overlay mlinks-point-hilighter-overlay))))))
 405
 406 (defvar mlinks-hyperactive-point-hilighter-keymap
 407   (let ((m (make-sparse-keymap "mlinks")))
 408     (define-key m [S-tab]   'mlinks-backward-link)
 409     (define-key m [tab]     'mlinks-forward-link)
 410     (define-key m "\t"      'mlinks-forward-link)
 411     (define-key m [?\r]     'mlinks-goto)
 412     (define-key m [?w]      'mlinks-goto-other-window)
 413     (define-key m [?f]      'mlinks-goto-other-frame)
 414     (define-key m [mouse-1] 'mlinks-goto)
 415     (set-keymap-parent m mlinks-mode-map)
 416     m))
 417
 418 (defvar mlinks-point-hilighter-keymap
 419   (let ((m (make-sparse-keymap "mlinks")))
 420     (define-key m [mouse-1] 'mlinks-goto)
 421     (set-keymap-parent m mlinks-mode-map)
 422     m))
 423
 424 (defun mlinks-point-hilighter-pre-command ()
 425   (condition-case err
 426       (unless (let ((map (overlay-get mlinks-point-hilighter-overlay 'keymap)))
 427                 (where-is-internal this-command
 428                                    (list
 429                                     map)))
 430         (mlinks-set-normal-point-hilight)
 431         (unless mlinks-point-hilighter-timer
 432           (delete-overlay mlinks-point-hilighter-overlay)))
 433     (error (message "mlinks-point-hilighter-pre-command: %s" err))))
 434 (put 'mlinks-point-hilighter-pre-command 'permanent-local t)
 435
 436 (defun mlinks-set-hyperactive-point-hilight ()
 437   "Make link hyper active, ie add some special key binding.
 438 Used after jumping specifically to a link. The idea is that the
 439 user may want to easily jump between links in this state."
 440   (add-hook 'pre-command-hook 'mlinks-point-hilighter-pre-command nil t)
 441   (mlinks-point-hilighter)
 442   (overlay-put mlinks-point-hilighter-overlay 'face mlinks-hyperactive-link-face)
 443   (overlay-put mlinks-point-hilighter-overlay 'keymap mlinks-hyperactive-point-hilighter-keymap))
 444
 445 (defun mlinks-set-normal-point-hilight ()
 446   "Make link normally active as if you happened to be on it."
 447   (remove-hook 'pre-command-hook 'mlinks-point-hilighter-pre-command t)
 448   (mlinks-point-hilighter)
 449   (overlay-put mlinks-point-hilighter-overlay 'face mlinks-link-face)
 450   (overlay-put mlinks-point-hilighter-overlay 'keymap mlinks-point-hilighter-keymap))
 451
 452 (defun mlinks-set-point-hilight-after-jump-to ()
 453   "Set hilight style after jump to link."
 454   (if mlinks-active-links
 455       (mlinks-set-hyperactive-point-hilight)
 456     (mlinks-set-normal-point-hilight)))
 457
 458
 459
 460 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 461 ;;; Jumping around
 462
 463 (defvar mlinks-places nil)
 464 (make-variable-buffer-local 'mlinks-placesn)
 465 (put 'mlinks-places 'permanent-local t)
 466
 467 (defvar mlinks-places-n 0)
 468 (make-variable-buffer-local 'mlinks-places-n)
 469 (put 'mlinks-places-n 'permanent-local t)
 470
 471 (defun mlinks-has-links ()
 472   (or (mlinks-get-mode-value 'fontify)
 473       (when (and (boundp 'mumamo-multi-major-mode) mumamo-multi-major-mode)
 474         ;; Fix-me: just assume multi major has it... Need a list of
 475         ;; major modes. There is no way to get such a list for the
 476         ;; multi major mode (since you can't know what the chunk
 477         ;; functions will return.  However you can get a list of
 478         ;; current chunks major mode.
 479         t
 480         )))
 481
 482 (defun mlinks-backward-link ()
 483   "Go to previous `mlinks-mode' link in buffer."
 484   (interactive)
 485   (if (not (mlinks-has-links))
 486       (message "There is no way to go to previous link for this major mode")
 487     (let ((res (mlinks-prev-link)))
 488       (if res
 489           (progn
 490             (goto-char res)
 491             (mlinks-set-point-hilight-after-jump-to))
 492         (message "No previous link found")))))
 493
 494 (defun mlinks-forward-link ()
 495   "Go to next `mlinks-mode' link in buffer."
 496   (interactive)
 497   (if (not (mlinks-has-links))
 498       (message "There is no way to go to next link for this major mode")
 499     (let ((res (mlinks-next-link)))
 500       (if res
 501           (progn
 502             (goto-char res)
 503             (mlinks-set-point-hilight-after-jump-to))
 504         (message "No next link found")))))
 505
 506
 507 (defun mlinks-goto ()
 508   "Follow `mlinks-mode' link at current point.
 509 Save the current position so that they can be move to again by
 510 `mlinks-prev-saved-position' and `mlinks-next-saved-position'.
 511
 512 Return non-nil if link was followed, otherewise nil."
 513   (interactive)
 514   (mlinks-goto-1 nil))
 515
 516 (defun mlinks-goto-other-window ()
 517   "Like `mlinks-goto' but opens in other window.
 518 Uses `switch-to-buffer-other-window'."
 519   (interactive)
 520   (mlinks-goto-1 'other-window))
 521
 522 (defun mlinks-goto-other-frame ()
 523   "Like `mlinks-goto' but opens in other frame.
 524 Uses `switch-to-buffer-other-frame'."
 525   (interactive)
 526   (mlinks-goto-1 'other-frame))
 527
 528 (defun mlinks-goto-1(where)
 529   (push-mark)
 530   (let* ((funs (mlinks-get-mode-value 'goto))
 531          (old (point-marker))
 532          (mlinks-temp-buffer-where where)
 533          (res (run-hook-with-args-until-success 'funs)))
 534     (if (not res)
 535         (progn
 536           (message "Don't know how to follow this MLink link")
 537           nil)
 538       (unless (= old (point-marker))
 539         (let* ((prev (car mlinks-places)))
 540           (when (or (not prev)
 541                     ;;(not (markerp prev))
 542                     (not (marker-buffer prev))
 543                     (/= old prev))
 544             (setq mlinks-places (cons old mlinks-places))
 545             (setq mlinks-places-n (length mlinks-places))))))))
 546
 547
 548 (defun mlinks-prev-saved-position ()
 549   "Go to previous position saved by `mlinks-goto'."
 550   (interactive)
 551   (unless (mlinks-goto-n (1- mlinks-places-n))
 552     (message "No previous MLink position")))
 553
 554 (defun mlinks-next-saved-position ()
 555   "Go to next position saved by `mlinks-goto'."
 556   (interactive)
 557   (unless (mlinks-goto-n (1+ mlinks-places-n))
 558     (message "No next MLink position")))
 559
 560 (defun mlinks-goto-n (to)
 561   (if (not mlinks-places)
 562       (message "No saved MLinks positions")
 563     (let ((minp 1)
 564           (maxp (length mlinks-places)))
 565       (if (<= to minp)
 566           (progn
 567             (setq to minp)
 568             (message "Going to first MLinks position"))
 569         (if (>= to maxp)
 570             (progn
 571               (setq to maxp)
 572               (message "Going to last MLinks position"))))
 573       (setq mlinks-places-n to)
 574       (let ((n (- maxp to))
 575             (places mlinks-places)
 576             place
 577             buffer
 578             point)
 579         (while (> n 0)
 580           (setq places (cdr places))
 581           (setq n (1- n)))
 582         (setq place (car places))
 583         (mlinks-switch-to-buffer (marker-buffer place))
 584         (goto-char place)))))
 585
 586 (defvar mlinks-temp-buffer-where nil)
 587 (defun mlinks-switch-to-buffer (buffer)
 588   (mlinks-switch-to-buffer-1 buffer mlinks-temp-buffer-where))
 589
 590 (defun mlinks-switch-to-buffer-1(buffer where)
 591   (cond
 592    ((null where)
 593     (switch-to-buffer buffer))
 594    ((eq where 'other-window)
 595     (switch-to-buffer-other-window buffer))
 596    ((eq where 'other-frame)
 597     (switch-to-buffer-other-frame buffer))
 598    (t
 599     (error "Invalid argument, where=%s" where))))
 600
 601 ;; FIXME: face, var
 602 (defun mlinks-custom (var)
 603   (customize-option var)
 604   )
 605
 606
 607
 608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 609 ;;; AppMenu support
 610
 611 (defun mlinks-appmenu ()
 612   (when mlinks-mode
 613     ;; Fix-me: reverse the list
 614     (let ((link-val (mlinks-link-at-point))
 615           (map (make-sparse-keymap "mlinks"))
 616           (num 2))
 617       (when (mlinks-get-mode-value 'prev)
 618         (define-key map [mlinks-next-link]
 619           (list 'menu-item "Next Link" 'mlinks-forward-link)))
 620       (when (mlinks-get-mode-value 'next)
 621         (define-key map [mlinks-prev-link]
 622           (list 'menu-item "Previous Link" 'mlinks-backward-link)))
 623       (when link-val
 624         (let* ((possible (when (member major-mode '(html-mode nxhtml-mode nxml-mode sqml-mode text-mode))
 625                            (mlinks-html-possible-href-actions link-val)))
 626                (mailto (assoc 'mailto possible))
 627                (view-web (assoc 'view-web possible))
 628                (view-web-base (assoc 'view-web-base possible))
 629                (edit (assoc 'edit possible))
 630                (file (nth 1 edit))
 631                (anchor (nth 2 edit))
 632                (choices)
 633                (answer)
 634                )
 635           (when (> (length map) num)
 636             (define-key map [mlinks-href-sep] (list 'menu-item "--")))
 637           (setq num (length map))
 638           (when view-web
 639             (define-key map [mlinks-href-view-web]
 640               (list 'menu-item "Browse Link Web Url"
 641                     `(lambda () (interactive)
 642                        (browse-url ,link-val)))))
 643           (when view-web-base
 644             (define-key map [mlinks-href-view-web-based]
 645               (list 'menu-item "Browse Link Web Url (base URL found)"
 646                     `(lambda () (interactive)
 647                        (browse-url (cdr ,view-web-base))))))
 648           (when mailto
 649             (define-key map [mlinks-href-mail]
 650               (list 'menu-item (concat "&Mail to " (substring link-val 7))
 651                     `(lambda () (interactive)
 652                        (mlinks-html-mail-to ,link-val)))))
 653           (when edit
 654             (when (and (file-exists-p file)
 655                        (not anchor)
 656                        (assoc 'upload possible))
 657               (let ((abs-file (expand-file-name file)))
 658                 (define-key map [mlinks-href-upload]
 659                   (list 'menu-item "Upload Linked File"
 660                         `(lambda () (interactive)
 661                            (html-upl-upload-file ,abs-file))))))
 662             (when (and (file-exists-p file)
 663                        (not anchor)
 664                        (assoc 'edit-gimp possible))
 665               (let ((abs-file (expand-file-name file)))
 666                 (define-key map [mlinks-href-edit-gimp]
 667                   (list 'menu-item "Edit Linked File with GIMP"
 668                         `(lambda () (interactive)
 669                            (gimpedit-edit-file ,abs-file))))))
 670             (when (and (file-exists-p file)
 671                        (assoc 'view-local possible))
 672               (let ((url (concat "file:///" (expand-file-name file))))
 673                 (when anchor
 674                   (let ((url-anchor (concat url "#" anchor)))
 675                     (define-key map [mlinks-href-view-file-at]
 676                       (list 'menu-item (concat "Browse Linked File URL at #" anchor)
 677                             `(lambda () (interactive)
 678                                (browse-url ,url-anchor))))))
 679                 (define-key map [mlinks-href-view-file]
 680                   (list 'menu-item "&Browse Linked File URL"
 681                         `(lambda () (interactive)
 682                            (browse-url ,url))))))
 683             (when (> (length map) num)
 684               (define-key map [mlinks-href-sep-2] (list 'menu-item "--")))
 685             (setq num (length map))
 686             (unless (equal file (buffer-file-name))
 687               (define-key map [mlinks-href-edit]
 688                 (list 'menu-item "&Open Linked File"
 689                       `(lambda () (interactive) (mlinks-goto))))
 690               (define-key map [mlinks-href-edit-window]
 691                 (list 'menu-item "&Open Linked File in Other Window"
 692                       `(lambda () (interactive) (mlinks-goto-other-window))))
 693               (define-key map [mlinks-href-edit-frame]
 694                 (list 'menu-item "&Open Linked File in New Frame"
 695                       `(lambda () (interactive) (mlinks-goto-other-frame))))
 696               )
 697             (when (and (file-exists-p file) anchor)
 698               (define-key map [mlinks-href-edit-at]
 699                 (list 'menu-item (concat "Open Linked File &at #" anchor)
 700                       `(lambda () (interactive)
 701                          (mlinks-goto)))))
 702             )
 703           (when (> (length map) num)
 704             (define-key map [mlinks-href-sep-1] (list 'menu-item "--")))
 705           (setq num (length map))
 706           (when link-val
 707             (define-key map [mlinks-href-copy-link]
 708               (list 'menu-item "&Copy Link Text"
 709                     'mlinks-copy-link-text)))))
 710       (when (> (length map) 2)
 711         map))))
 712
 713 (defun mlinks-add-appmenu ()
 714   "Add entries for MLinks to AppMenu."
 715   (when (featurep 'appmenu)
 716     (appmenu-add 'mlinks 100 'mlinks-mode "Current MLink" 'mlinks-appmenu)))
 717
 718 (defun mlinks-copy-link-text ()
 719   "Copy text of `mlinks-mode' link at point to clipboard."
 720   (interactive)
 721   (mlinks-point-hilighter)
 722   (let ((ovl mlinks-point-hilighter-overlay))
 723     (if (and ovl
 724              (overlayp ovl)
 725              (overlay-buffer ovl)
 726              (eq (current-buffer)
 727                  (overlay-buffer ovl))
 728              (<= (overlay-start ovl)
 729                  (point))
 730              (>= (overlay-end ovl)
 731                  (point)))
 732         (let* ((beg (overlay-start ovl))
 733                (end (overlay-end ovl))
 734                (str (buffer-substring beg end)))
 735           (copy-region-as-kill beg end)
 736           (message "Copied %d chars to clipboard" (length str)))
 737       (message "No link here to copy"))))
 738
 739
 740
 741
 742
 743 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 744 ;;;;;;;;;;;;;;;;;;;;;; text-mode etc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 745 (defvar mlinks-plain-urls-regexp
 746   (rx-to-string `(or (submatch (optional "mailto:")
 747                                (regexp ,(concat
 748                                          ;;"[a-z0-9$%(*-=?[_][^<>\")!;:,{}]*"
 749                                          "[a-z0-9$%(*=?[_-][^<>\")!;:,{}]*"
 750                                          "\@"
 751                                          "\\(?:[a-z0-9\-]+\.\\)+[a-z0-9]\\{2,4\\}")))
 752                      (submatch (or (regexp "https?://")
 753                                    "www.")
 754                                (1+ (any ,url-get-url-filename-chars))
 755                                )
 756                      )))
 757
 758 (defun mlinks-plain-urls-fontify (bound)
 759   (mlinks-fontify bound mlinks-plain-urls-regexp 0))
 760
 761 (defun mlinks-goto-plain-url ()
 762   (let* ((range (mlinks-link-range (point)))
 763          (link  (when range (buffer-substring-no-properties (car range) (cdr range)))))
 764     ;;(mlinks-html-href-act-on link)
 765     (when (= 0 (string-match mlinks-plain-urls-regexp link))
 766       (let ((which (if (match-end 1) 1 2)))
 767         (cond
 768          ((= 1 which)
 769           (mlinks-html-mail-to link)
 770           t)
 771          ((= 2 which)
 772           (browse-url link)
 773           t)
 774          (t nil))))))
 775
 776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 777 ;;;;;;;;;;;;;;;;;;;;;; nxhtml-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 778
 779 (defun mlinks-html-style-goto ()
 780   (mlinks-html-style-mode-fun t))
 781
 782 (defvar mlinks-html-link-regexp
 783   ;; This value takes care of nxhtml-strval-mode (and is therefore a little bit incorrect ...)
 784   ;;"\\(?:^\\|[[:space:]]\\)\\(?:href\\|src\\)[[:space:]]*=[[:space:]]*\"\\([^<«\"]*\\)\""
 785   (rx (or "^" space)
 786       (or "href" "src")
 787       (0+ space)
 788       "="
 789       (0+ space)
 790       (submatch
 791        (or
 792         (seq "\""
 793              (and
 794               (0+ (not (any "\""))))
 795              "\"")
 796         (seq "'"
 797              (and
 798               (0+ (not (any "\'"))))
 799              "'")))))
 800
 801 (defun mlinks-html-style-mode-fun (goto)
 802   (let (start
 803         end
 804         bounds)
 805     (save-excursion
 806       (forward-char)
 807       (when (< 0 (skip-chars-forward "^\"'" (line-end-position)))
 808         (forward-char)
 809         (save-match-data
 810           (when (looking-back
 811                  mlinks-html-link-regexp
 812                  (line-beginning-position -1))
 813             (let ((which (if (match-beginning 1) 1 2)))
 814               (setq start (1+ (match-beginning which)))
 815               (setq end   (1- (match-end which))))
 816             (setq bounds (cons start end))))))
 817     (when start
 818       (if (not goto)
 819           bounds
 820         (let ((href-val (buffer-substring-no-properties start end)))
 821           (mlinks-html-href-act-on href-val))
 822         t))))
 823
 824 (defun mlink-check-file-to-edit (file)
 825   (assert (file-name-absolute-p file))
 826   (let ((file-dir (file-name-directory file)))
 827     (unless (file-directory-p file-dir)
 828       (if (file-directory-p (file-name-directory file))
 829           (if (yes-or-no-p (format "Directory %s does not exist. Create it? " file-dir))
 830               (make-directory file-dir)
 831             (setq file nil))
 832         (if (yes-or-no-p (format "Directory %s and its parent does not exist. Create them? " file-dir))
 833             (make-directory file-dir t)
 834           (setq file nil))))
 835     file))
 836
 837 (defun mlinks-html-edit-at (file &optional anchor)
 838   (let ((abs-file (if (file-name-absolute-p file)
 839                       file
 840                     (expand-file-name file))))
 841     (if (or (file-directory-p abs-file)
 842             (string= abs-file
 843                      (file-name-as-directory abs-file)))
 844         (if (file-directory-p abs-file)
 845             (when (y-or-n-p (format "Do you want to edit the directory %s? : " abs-file))
 846               (dired abs-file))
 847           (message "Can't find directory %s" abs-file))
 848       (when (mlink-check-file-to-edit abs-file)
 849         (let ((b (find-file-noselect abs-file)))
 850           (mlinks-switch-to-buffer b))
 851         (when anchor
 852           (let ((here (point))
 853                 (anchor-regexp (concat "\\(?:id\\|name\\)[[:space:]]*=[[:space:]]*\"" anchor "\"")))
 854             (goto-char (point-min))
 855             (if (search-forward-regexp anchor-regexp nil t)
 856                 (backward-char 2)
 857               (message "Anchor \"%s\" not found" anchor)
 858               (goto-char here))))))))
 859
 860 (defun mlinks-html-mail-to (addr)
 861   (browse-url addr))
 862
 863 (defun mlinks-html-href-act-on (href-val)
 864   (if href-val
 865       (let* ((possible (mlinks-html-possible-href-actions href-val))
 866              (edit (assoc 'edit possible))
 867              (file (nth 1 edit))
 868              (anchor (nth 2 edit))
 869              )
 870         (cond (edit
 871                (mlinks-html-edit-at file anchor)
 872                t)
 873               ((assoc 'mailto possible)
 874                (when (y-or-n-p "This is a mail address.  Do you want to send a message to this mail address? ")
 875                  (mlinks-html-mail-to href-val)))
 876               ((assoc 'view-web possible)
 877                (when (y-or-n-p "Can't edit this URL, it is on the web.  View the URL in your web browser? ")
 878                  (browse-url href-val)))
 879               ((assoc 'view-web-base possible)
 880                (when (y-or-n-p "Can't edit, based URL is to the web.  View resulting URL in your web browser? ")
 881                  (browse-url (cdr (assoc 'view-web-base possible)))))
 882               (t
 883                (message "Do not know how to handle this URL"))
 884               ))
 885     (message "No value for href attribute")))
 886
 887 (defun mlinks-html-possible-href-actions (link)
 888   (let ((urlobj (url-generic-parse-url link))
 889         (edit nil)
 890         (possible nil))
 891     (cond ((member (url-type urlobj) '("http" "https"))
 892            (add-to-list 'possible (cons 'view-web link)))
 893           ((member (url-type urlobj) '("mailto"))
 894            (add-to-list 'possible (cons 'mailto link)))
 895           ((url-host urlobj)
 896            (message "Do not know how to handle this URL"))
 897           (t (setq edit t)))
 898     (when edit
 899       (let ((base-href (mlinks-html-find-base-href)))
 900         (when base-href
 901           (let ((baseobj (url-generic-parse-url base-href)))
 902             (setq edit nil)
 903             (cond ((member (url-type baseobj) '("http" "https"))
 904                    (add-to-list 'possible (cons 'view-web-base (url-expand-file-name link base-href))))
 905                   ((url-host urlobj)
 906                    (message "Do not know how to handle this URL"))
 907                   (t (setq edit t)))))
 908         (when edit
 909           (let* ((full (split-string (url-filename urlobj) "#"))
 910                  (file (nth 0 full))
 911                  (anchor (nth 1 full))
 912                  )
 913             (when (equal file "")
 914               (setq file (buffer-file-name)))
 915             (when base-href
 916               ;; We know at this point it is not a http url
 917               (setq file (expand-file-name file base-href)))
 918             (let ((ext (downcase (file-name-extension file))))
 919               (when (member ext '("htm" "html"))
 920                 (add-to-list 'possible (cons 'view-local (list file anchor))))
 921               (when (and (featurep 'gimpedit)
 922                          (member ext '("gif" "png" "jpg" "jpeg")))
 923                 (add-to-list 'possible (cons 'edit-gimp (list file anchor)))))
 924             (when (featurep 'html-upl)
 925               (add-to-list 'possible (cons 'upload (list file anchor))))
 926             (add-to-list 'possible (cons 'edit (list file anchor)))))))
 927     possible))
 928
 929 (defun mlinks-html-find-base-href ()
 930   "Return base href found in the current file."
 931   (let ((base-href))
 932     (save-excursion
 933       (goto-char (point-min))
 934       (while (and (not base-href)
 935                   (search-forward-regexp "<!--[^!]*-->\\|<base[[:space:]]" nil t))
 936         (when (equal " " (char-to-string (char-before)))
 937           (backward-char 6)
 938           (when (looking-at "<base [^>]*href *= *\"\\(.*?\\)\"")
 939             (setq base-href (match-string-no-properties 1))))))
 940     base-href))
 941
 942 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 943 ;;;;;;;;;;;;;;;;;;;;;; Custom-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 944 (defun mlinks-elisp-custom-goto ()
 945   (mlinks-elisp-mode-fun 'custom))
 946
 947 (defvar mlinks-custom-link-regexp
 948   (rx "`"
 949       (group
 950        (1+ (not (any "'"))))
 951       "'"))
 952
 953 (defun mlinks-custom-fontify (bound)
 954   (mlinks-fontify bound mlinks-custom-link-regexp 0))
 955
 956
 957 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 958 ;;;;;;;;;;;;;;;;;;;;;; emacs-lisp-mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 959 (defun mlinks-elisp-goto ()
 960   (mlinks-elisp-mode-fun 'source))
 961
 962 (defun mlinks-elisp-hili ()
 963   (mlinks-elisp-mode-fun nil))
 964
 965 (defun mlinks-elisp-mode-fun (goto)
 966   (let ((symbol-name (thing-at-point 'symbol)))
 967     (when symbol-name
 968       (let ((bounds-- (bounds-of-thing-at-point 'symbol))
 969             ret--)
 970         (if (save-excursion
 971               (goto-char (cdr bounds--))
 972               (looking-back (concat "(\\(?:require\\|featurep\\)\s+'" symbol-name)
 973                             (line-beginning-position)))
 974             (progn
 975               (setq ret-- bounds--)
 976               (when goto
 977                 (mlinks-elisp-mode-require symbol-name)))
 978           (when (mlinks-elisp-mode-symbol symbol-name goto)
 979             (setq ret-- bounds--)))
 980         ret--))))
 981
 982 (defun mlinks-elisp-function (symbol)
 983   "Go to an elisp function."
 984   (interactive "aElisp function: ")
 985   (mlinks-elisp-mode-symbol (symbol-name symbol) 'source))
 986
 987 (defun mlinks-elisp-mode-symbol (symbol-name-- goto--)
 988   ;; Fix-me: use uninterned variables (see mail from Miles)
 989   ;; Make these names a bit strange because they are boundp at the time of checking:
 990   (let ((symbol-- (intern-soft symbol-name--))
 991         defs--)
 992     (when (and symbol-- (boundp symbol--))
 993       (add-to-list 'defs-- 'variable))
 994     (when (fboundp symbol--)
 995       (add-to-list 'defs-- 'function))
 996     (when (facep symbol--)
 997       (add-to-list 'defs-- 'face))
 998     ;; Avoid some fails hits
 999     (when (memq symbol--
1000                 '(goto t
1001                        bounds-- funs-- ret--
1002                        symbol-- defs-- symbol-name-- goto--))
1003       (setq defs-- nil))
1004     (let (defs-places
1005            def)
1006       (if (not goto--)
1007           (progn
1008             defs--)
1009         (if (not defs--)
1010             (progn
1011               (message "Could not find definition of '%s" symbol-name--)
1012               nil)
1013           (dolist (type (cond
1014                          ((eq goto-- 'source)
1015                           '(nil defvar defface))
1016                          ((eq goto-- 'custom)
1017                           '(defvar defface))
1018                          (t
1019                           (error "Bad goto-- value: %s" goto--))))
1020             (condition-case err
1021                 (add-to-list 'defs-places
1022                              (cons
1023                               type
1024                               (save-excursion
1025                                 (let* ((bp (find-definition-noselect symbol-- type))
1026                                        (b (car bp))
1027                                        (p (cdr bp)))
1028                                   (unless p
1029                                     (with-current-buffer b
1030                                       (save-restriction
1031                                         (widen)
1032                                         (setq bp (find-definition-noselect symbol-- type)))))
1033                                   bp))))
1034               (error
1035                ;;(lwarn '(mlinks) :error "%s" (error-message-string err))
1036                (when t
1037                  (cond
1038                   ((eq (car err) 'search-failed))
1039                   ((and (eq (car err) 'error)
1040                         (string= (error-message-string err)
1041                                  (format "Don't know where `%s' is defined" symbol--))))
1042                   (t
1043                    (message "%s: %s" (car err) (error-message-string err))))))))
1044           (if (= 1 (length defs-places))
1045               (setq def (car defs-places))
1046             (let ((many nil)
1047                   lnk)
1048               (dolist (d defs-places)
1049                 (if (not lnk)
1050                     (setq lnk (cdr d))
1051                   (unless (equal lnk (cdr d))
1052                     (setq many t))))
1053               (if (not many)
1054                   (setq def (car defs-places))
1055                 (let* ((alts (mapcar (lambda (elt)
1056                                        (let ((type (car elt))
1057                                              str)
1058                                          (setq str
1059                                                (cond
1060                                                 ((not type)
1061                                                  "Function")
1062                                                 ((eq type 'defvar)
1063                                                  "Variable")
1064                                                 ((eq type 'defface)
1065                                                  "Face")))
1066                                          (cons str elt)))
1067                                      defs-places))
1068                        (stralts (mapcar (lambda (elt)
1069                                           (car elt))
1070                                         alts))
1071                        (completion-ignore-case t)
1072                        (stralt (completing-read "Type: " stralts nil t))
1073                        (alt (assoc stralt alts)))
1074                   (setq def (cdr alt))))))
1075           (when def
1076             (cond
1077              ((eq goto-- 'source)
1078               ;; Be sure to go to the real sources from CVS:
1079               (let* ((buf (car (cdr def)))
1080                      ;; Avoid going to source
1081                      ;;(file (find-source-lisp-file (with-current-buffer buf buffer-file-name)) )
1082                      (file (with-current-buffer buf buffer-file-name))
1083                      (orig-buf (find-file-noselect file)))
1084                 (mlinks-switch-to-buffer orig-buf)
1085                 (let ((p (cdr (cdr def))))
1086                   ;; Fix-me: Move this test to a more general place.
1087                   (if (or (< p (point-min))
1088                           (> p (point-max)))
1089                       ;; Check for cloned indirect buffers.
1090                       (progn
1091                         (setq orig-buf
1092                               (catch 'view-in-buf
1093                                 (dolist (indirect-buf (buffer-list))
1094                                   ;;(message "base-buffer=%s, orig-buf=%s, eq => %s" (buffer-base-buffer indirect-buf) orig-buf (eq (buffer-base-buffer indirect-buf) orig-buf))
1095                                   (when (eq (buffer-base-buffer indirect-buf) orig-buf)
1096                                     (with-current-buffer indirect-buf
1097                                       ;;(message "indirect-buf=%s" indirect-buf)
1098                                       (unless (or (< p (point-min))
1099                                                   (> p (point-max)))
1100                                         ;;(message "switching")
1101                                         ;;(mlinks-switch-to-buffer indirect-buf)
1102                                         (message "mlinks: Switching to indirect buffer because of narrowing")
1103                                         (throw 'view-in-buf indirect-buf)
1104                                         ))
1105                                     ))))
1106                         (when orig-buf
1107                           (mlinks-switch-to-buffer orig-buf))
1108                         ;;(message "cb=%s" (current-buffer))
1109                         (if (or (< p (point-min))
1110                                 (> p (point-max)))
1111                             (when (y-or-n-p (format "%s is invisible because of narrowing. Widen? " symbol--))
1112                               (widen)
1113                               (goto-char p))
1114                           (goto-char p)))
1115                     (goto-char p)))))
1116              ((eq goto-- 'custom)
1117               (mlinks-custom symbol--))
1118              (t
1119               (error "Back goto-- value again: %s" goto--)))))))))
1120
1121 (defun mlinks-elisp-mode-require (module)
1122   (let ((where mlinks-temp-buffer-where))
1123     (cond
1124      ((null where)
1125       (find-library module))
1126      ((eq where 'other-window)
1127       (other-window 1)
1128       (find-library module))
1129      ((eq where 'other-frame)
1130       (make-frame-command)
1131       (find-library module))
1132      (t
1133       (error "Invalid argument, where=%s" where)))))
1134
1135
1136
1137 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1138 ;;;;;;;;;;;;; Helpers when adopting for modes ;;;;;;;;;;;;;;;;;
1139
1140 ;;; Save this, do not delete this comment:
1141
1142 ;; (defun mlinks-hit-test ()
1143 ;;   "Just a helper function for adding support for new modes."
1144 ;;   (let* (
1145 ;;          (s0 (if (match-string 0) (match-string 0) ""))
1146 ;;          (s1 (if (match-string 1) (match-string 1) ""))
1147 ;;          (s2 (if (match-string 2) (match-string 2) ""))
1148 ;;          (s3 (if (match-string 3) (match-string 3) ""))
1149 ;;          )
1150 ;;     (message "match0=%s, match1=%s, match2=%s, match3=%s" s0 s1 s2 s3)))
1151
1152 ;; (defun mlinks-handle-reg-fun-list (reg-fun-list)
1153 ;;   "Just a helper function."
1154 ;;   (let (done
1155 ;;         regexp
1156 ;;         hitfun
1157 ;;         m
1158 ;;         p
1159 ;;         b
1160 ;;         )
1161 ;;     (dolist (rh reg-fun-list)
1162 ;;       (message "rh=%s" rh);(sit-for 2)
1163 ;;       (unless done
1164 ;;         (setq regexp (car rh))
1165 ;;         (setq hitfun (cadr rh))
1166 ;;         (message "regexp=%s, hitfun=%s" regexp hitfun);(sit-for 1)
1167 ;;         (when (and (save-match-data
1168 ;;                      (setq m (re-search-backward regexp (line-beginning-position) t))
1169 ;;                      (> p (match-beginning 0))))
1170 ;;           (setq done t)
1171 ;;           (setq b (match-beginning 0))
1172 ;;           (setq e (match-end 0))
1173 ;;           )
1174 ;;         (if (not (and b e
1175 ;;                       (< b p)
1176 ;;                       (< p e)))
1177 ;;             (message "MLinks Mode did not find any link here")
1178 ;;           (goto-char b)
1179 ;;           (if (not (looking-at regexp))
1180 ;;               (error "Internal error, regexp %s, no match looking-at" regexp)
1181 ;;             (let ((last (car mlinks-places))
1182 ;;                   (m (make-marker)))
1183 ;;               (set-marker m (line-beginning-position))
1184 ;;               (when (or (not last)
1185 ;;                         (/= m last))
1186 ;;                 (setq mlinks-places (cons m mlinks-places))))
1187 ;;             (funcall hitfun))
1188 ;;           )))))
1189
1190
1191
1192 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1193 ;;; Font Lock use
1194
1195 (defvar mlinks-link-update-pos-max nil)
1196 (make-variable-buffer-local 'mlinks-link-update-pos-max)
1197 (put 'mlinks-link-update-pos-max 'permanent-local t)
1198
1199 (defun mlinks-remove-font-lock ()
1200   "Remove info from font-lock."
1201   (when (mlinks-want-font-locking)
1202     (mlink-font-lock nil)))
1203
1204 (defun mlinks-add-font-lock ()
1205   "Add info to font-lock."
1206   (when (mlinks-want-font-locking)
1207     (mlink-font-lock t)))
1208
1209 (defun mlinks-want-font-locking ()
1210   (or (mlinks-get-mode-value 'fontify)
1211       (mlinks-get-mode-value 'next-mark)))
1212
1213
1214
1215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1216 ;;; Font Lock integration
1217
1218 (defun mlink-font-lock (on)
1219   (let* ((add-or-remove (if on 'font-lock-add-keywords 'font-lock-remove-keywords))
1220          (fontify-fun (car (mlinks-get-mode-value 'fontify)))
1221          (args (list nil `(( ,fontify-fun ( 0 mlinks-font-lock-face t ))))))
1222     (when fontify-fun
1223       ;; Note: Had a lot of trouble with this which I modelled first
1224       ;; after dlink. Using hi-lock as a model made it work with
1225       ;; mumamo too.
1226       ;;
1227       ;; Next arg, HOW, is needed to get it to work with mumamo. This
1228       ;; adds it last, like hi-lock.
1229       (when on (setq args (append args (list t))))
1230       (apply add-or-remove args)
1231       (font-lock-mode -1)
1232       (font-lock-mode 1))))
1233
1234 (defun mlinks-html-fontify (bound)
1235   (mlinks-fontify bound mlinks-html-link-regexp 1))
1236
1237 (defun mlinks-fontify (bound regexp border)
1238   (let ((start (point))
1239         end-start
1240         stop next-stop
1241         (more t)
1242         old-beg old-end
1243         (wn 1)
1244         ret)
1245     ;; Note: we shouldnot use save-match-data here. Instead
1246     ;; set-match-data is called below!
1247     (if (not (re-search-forward regexp bound t))
1248         (setq end-start bound)
1249       (setq ret t)
1250       (setq end-start (- (point) 2))
1251       (let* ((which (if (match-beginning 1) 1 2))
1252              (beg (+ (match-beginning which) border))
1253              (end (- (match-end which) border)))
1254         (put-text-property beg end 'mlinks-link t)
1255         (set-match-data (list (copy-marker end) (copy-marker beg)))))
1256     (setq stop start)
1257     (setq next-stop -1)
1258     (while (and (> 100 (setq wn (1+ wn)))
1259                 (setq next-stop (next-single-char-property-change stop 'mlinks-link nil end-start))
1260                 (/= next-stop stop))
1261       (setq stop next-stop)
1262       (if (get-text-property stop 'mlinks-link)
1263           (setq old-beg stop)
1264         (when old-beg
1265           (remove-list-of-text-properties old-beg stop '(mlinks-link 'mouse-face)))))
1266     ret))
1267
1268 (defun mlinks-next-link ()
1269   "Find next link, fontify as necessary."
1270   (let* ((here (point))
1271          (prev-pos (point))
1272          (fontified-here (get-text-property (max (point-min) (1- prev-pos)) 'fontified))
1273          (fontified-to (next-single-char-property-change prev-pos 'fontified))
1274          (pos (next-single-char-property-change prev-pos 'mlinks-link nil
1275                                                 (or fontified-to (point-max))))
1276          (fontified-all (and fontified-here (not fontified-to)))
1277          ready
1278          next-fontified-to)
1279     (while (not (or ready
1280                     (and fontified-all
1281                          (not pos))))
1282       (if pos
1283           (progn
1284             (unless (get-text-property pos 'mlinks-link)
1285               ;; Get to next link
1286               (setq prev-pos pos)
1287               (setq pos (next-single-char-property-change prev-pos 'mlinks-link nil
1288                                                           (or fontified-to (point-max)))))
1289             (when pos
1290               (setq ready (get-text-property pos 'mlinks-link))
1291               (setq prev-pos pos)
1292               (unless ready (setq pos nil))))
1293         (unless (or fontified-all fontified-to)
1294           (if (get-text-property prev-pos 'fontified)
1295               (setq fontified-all
1296                     (not (setq fontified-to
1297                                (next-single-char-property-change prev-pos 'fontified))))
1298             (setq fontified-to ( or (previous-single-char-property-change prev-pos 'fontified)
1299                                     1))))
1300         (setq next-fontified-to (min (+ fontified-to 5000)
1301                                      (point-max)))
1302         (mumamo-with-buffer-prepared-for-jit-lock
1303          (progn
1304            (put-text-property fontified-to next-fontified-to 'fontified t)
1305            (font-lock-fontify-region fontified-to next-fontified-to)))
1306         (setq fontified-to (next-single-char-property-change (1- next-fontified-to)
1307                                                              'fontified))
1308         (setq fontified-all (not fontified-to))
1309         (setq pos (next-single-char-property-change prev-pos 'mlinks-link nil
1310                                                     (or fontified-to (point-max))))))
1311     (when ready prev-pos)))
1312
1313 (defun mlinks-prev-link ()
1314   "Find previous link, fontify as necessary."
1315   (let* ((prev-pos (point))
1316          (fontified-from (previous-single-char-property-change prev-pos 'fontified))
1317          (fontified-here (get-text-property (max (point-min) (1- prev-pos)) 'fontified))
1318          (fontified-all (and fontified-here (not fontified-from)))
1319          (pos (when fontified-here
1320                 (previous-single-char-property-change prev-pos 'mlinks-link nil
1321                                                       (or fontified-from 1))))
1322          ready
1323          next-fontified-from)
1324     (while (not (or ready
1325                     (and fontified-all
1326                          (not pos))))
1327       (assert (numberp prev-pos) t)
1328       (if pos
1329           (progn
1330             (when (and (> (1- pos) (point-min))
1331                        (get-text-property (1- pos) 'mlinks-link))
1332               ;; Get out of current link
1333               (setq prev-pos pos)
1334               (setq pos (previous-single-char-property-change prev-pos 'mlinks-link nil
1335                                                               (or fontified-from 1))))
1336             (when pos
1337               (setq prev-pos pos)
1338               (setq ready (and (get-text-property pos 'fontified)
1339                                (or (= 1 pos)
1340                                    (not (get-text-property (1- pos) 'mlinks-link)))
1341                                (get-text-property pos 'mlinks-link)))
1342               (unless ready (setq pos nil))))
1343         (setq next-fontified-from (max (- fontified-from 5000)
1344                                        (point-min)))
1345         (mumamo-with-buffer-prepared-for-jit-lock
1346          (progn
1347            (put-text-property next-fontified-from fontified-from 'fontified t)
1348            (font-lock-fontify-region next-fontified-from fontified-from)))
1349         (setq fontified-from (previous-single-char-property-change
1350                               (1+ next-fontified-from) 'fontified))
1351         (setq fontified-all (not fontified-from))
1352         (setq pos (previous-single-char-property-change prev-pos 'mlinks-link nil
1353                                                         (or fontified-from 1)))))
1354     (when ready pos)))
1355
1356
1357 ;;; This is for the problem reported by some Asian users:
1358 ;;;
1359 ;;;   Lisp error: (invalid-read-syntax "] in a list")
1360 ;;;
1361 ;; Local Variables:
1362 ;; coding: utf-8
1363 ;; End:
1364
1365 (provide 'mlinks)
1366 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1367 ;;; mlinks.el ends here