emacs_el/tiny-tools/tiny/tinyurl.el

   1 ;;; tinyurl.el --- Mark and jump to any URL on current line.
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1997-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinyurl-version.
  13 ;; Look at the code with folding.el.
  14
  15 ;; This program is free software; you can redistribute it and/or modify it
  16 ;; under the terms of the GNU General Public License as published by the Free
  17 ;; Software Foundation; either version 2 of the License, or (at your option)
  18 ;; any later version.
  19 ;;
  20 ;; This program is distributed in the hope that it will be useful, but
  21 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  22 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  23 ;; for more details.
  24 ;;
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with program; see the file COPYING. If not, write to the
  27 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  28 ;; Boston, MA 02110-1301, USA.
  29 ;;
  30 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  31
  32 ;;}}}
  33 ;;{{{ Install
  34
  35 ;;; Install:
  36
  37 ;; ....................................................... &t-install ...
  38 ;; Put this file on your Emacs-Lisp load path, add following into your
  39 ;; ~/.emacs startup file.
  40 ;;
  41 ;;      (add-hook 'tinyurl-:load-hook  'tinyurl-install-to-packages)
  42 ;;      (require 'tinyurl)
  43 ;;
  44 ;;      ;; To activate the mode globally add code below
  45 ;;      ;; Alternatively call global mode M-x tinyurl-mode or
  46 ;;      ;; buffer based mode M-x tinyurl-mode-1
  47 ;;
  48 ;;      (turn-on-tinyurl-mode)
  49 ;;
  50 ;;      ;; If you do not have permenent internet connection, add this
  51 ;;      ;; It will follow Gnus plugged mode state.
  52 ;;      (setq tinyurl-:plugged-function 'tinyurl-plugged-p)
  53 ;;
  54 ;; You can also use the preferred way: autoload. Only when you call the
  55 ;; `M-x' `tinyurl-mode', this package loads. The following setup is
  56 ;; faster than above, but it doesn't install this package automatically to
  57 ;; VM, RMAIL, MH, gnus as the `require' method does. Call
  58 ;; `M-x' `tinyurl-install-to-packages' for those.
  59 ;;
  60 ;;      (add-hook 'tinyurl-:load-hook         'tinyurl-install-to-packages)
  61 ;;      (autoload 'tinyurl-mode               "tinyurl" "" t)
  62 ;;      (autoload 'tinyurl-mode-1             "tinyurl" "" t)
  63 ;;      (autoload 'turn-on-tinyurl-mode-1     "tinyurl" "" t)
  64 ;;      (autoload 'turn-off-tinyurl-mode-1    "tinyurl" "" t)
  65 ;;
  66 ;;      ;;  Keybinding suggestions
  67 ;;
  68 ;;      (global-set-key "\C-cmuu"  'tinyurl-mode)
  69 ;;      (global-set-key "\C-cmu1"  'tinyurl-mode-1)
  70 ;;      (global-set-key "\C-cmup"  'tinyurl-plugged-mode-toggle)
  71 ;;
  72 ;;      ;;  Select backend for EMAIL urls. See variable's documentation.
  73 ;;      (setq mail-user-agent 'message-user-agent)
  74 ;;
  75 ;;   If you have any questions, use this function to contact author
  76 ;;
  77 ;;       M-x tinyurl-submit-bug-report
  78
  79 ;;}}}
  80 ;;{{{ Documentation
  81
  82 ;; ..................................................... &t-commentary ...
  83
  84 ;;; Commentary:
  85
  86 ;;  Preface, oct 1997
  87 ;;
  88 ;;      One day a collegue had a problem with his VM and he
  89 ;;      explained to me that he wanted the `mouse-2' to run netscape
  90 ;;      browser instead of the default Emacs `w3' browser. While he was
  91 ;;      waving his cursor over the http link, I suddendly realized: that
  92 ;;      this would be useful in RMAIL buffers too. (I later moved straight to
  93 ;;      GNUS). It seemed that every package had its own url handling: VM, TM,
  94 ;;      GNUS, MH.
  95 ;;
  96 ;;      But really, how about the rest of the buffers and modes? There was
  97 ;;      no general ULR dispatcher minor mode that would work with any buffer
  98 ;;      and with any mode.
  99 ;;
 100 ;;      Now there is; it is possible browse any buffer or document and
 101 ;;      jump to URLs on the line. Works for programing modes too. You
 102 ;;      just position the cursor somewhere on the line, wait 2 seconds
 103 ;;      and the URLs in the current line are marked.
 104 ;;
 105 ;;  Overview of features
 106 ;;
 107 ;;      o   Requirements: XEmacs must contain package `overlay.el'.
 108 ;;          Emacs needs nothing special.
 109 ;;
 110 ;;      o   General URL handler: not just the regular http, ftp, but
 111 ;;          also for programming languages like Perl/Lisp/C++ and
 112 ;;          man page cut(1) references and jumping to Debian bug
 113 ;;          reports (+ WNPP) and more...
 114 ;;
 115 ;;      o   When the global minor mode is on, wait few seconds and the
 116 ;;          current line will be scanned for urls. Because not all
 117 ;;          terminals show clolor, there is additional "!" character added to
 118 ;;          the front of URL for calling you to *push* it.
 119 ;;      o   Once the minor mode is turned on, it occupies every buffer,
 120 ;;          but there is also function to turn the mode on or off per buffer
 121 ;;          basis, see `tinyurl-mode-1'. When new file is loaded,
 122 ;;          `tinyurl-mode' is activated for the buffer too.
 123 ;;      o   Defines binding `mouse-2' and `M-RET' to call the url at
 124 ;;          point. These bindings are electric: If there is no button to push,
 125 ;;          the original binding is called according to underlying mode.
 126 ;;      o   You can change the url handler sets on the fly: e.g.
 127 ;;          call lynx for a while, then switch to Netscape or use your custom
 128 ;;          browser. See `M-x' `tinyurl-set-handler'
 129 ;;      o   Centralised url handling. If you call `tinyurl-install-to-packages'
 130 ;;          then GNUS, TM, VM etc. now call TinyUrl and you only need to
 131 ;;          configure things in one place.
 132 ;;
 133 ;;  Turning the URL recognizer on
 134 ;;
 135 ;;      Load package with `require' or via autoload (see installation
 136 ;;      instruction at the top of file) and call `M-x' `tinyurl-mode' to
 137 ;;      toggle the global minor mode on and off. The modeline displays `Ux'
 138 ;;      when the mode is active. A character like (x) is a short name
 139 ;;      for browser that will activate, e.g. "n" for "netscape" browser,
 140 ;;      (l) for lynx and (w) w3.
 141 ;;
 142 ;;      If you want to turn the mode on or off for current buffer only, use
 143 ;;      `M-x' `tinyurl-mode-1'.
 144 ;;
 145 ;;      The minor mode is turned on for all newly created (C-x C-f) or
 146 ;;      visited files, but if you make a new buffer with `M-x'
 147 ;;      `switch-to-buffer', the URL mode is not turned on in those buffers.
 148 ;;
 149 ;;  Caching URLs for later use (offline reading)
 150 ;;
 151 ;;      The offline reading is possible with Gnus, where status can be
 152 ;;      toggled between "plugged" and "unplugged". If variable
 153 ;;      `tinyurl-:plugged-function' is set to default unpluggged condition
 154 ;;      detector function `tinyurl-plugged-p', it returns nil if Gnus is in
 155 ;;      unplugged state.
 156 ;;
 157 ;;      The current implementation relies on gnus (`M-x' `gnus') to detect
 158 ;;      the off-line, on-line status of the network connection. This
 159 ;;      means that all "buttons" are cached to separate buffer unless you
 160 ;;      tell that you're connected via `M-x' `gnus-agent-toggle-plugged'.
 161 ;;
 162 ;;      You can place your own unplugged state detector to variable
 163 ;;      `tinyurl-:plugged-function'. Cache buffer used is
 164 ;;      `tinyurl-:url-cache-buffer', which is *URL-cache* by default.
 165 ;;
 166 ;;      You can force TinyUrl to change plug status by calling `M-x'
 167 ;;      `tinyurl-plugged-mode-toggle'. This internal flag overrides anything
 168 ;;      else in the system. The indicator "!" in the modeline tells if
 169 ;;      TinyUrl thinks it is in plugged state. You may need to call this
 170 ;;      function if you don't use Gnus as a primary MUA.
 171 ;;
 172 ;;      Shortly:
 173 ;;
 174 ;;      o   If you use Gnus, toggle Agent with J j to plugged/unplugged
 175 ;;          and TinyUrl will follow Gnus's state.
 176 ;;      o   If you don't use gnus, or do not have it loaded, call
 177 ;;          function `tinyurl-plugged-mode-toggle' to tell the state of the
 178 ;;          net connection.
 179 ;;
 180 ;;  Editing the url and selecting access method manually
 181 ;;
 182 ;;      You can pass a prefix argument like `C-u' before you press
 183 ;;      `mouse-2' or `M-RET' and edit two parameters: a) The URL location
 184 ;;      itself and b) the access method. Say e.g. that your default command
 185 ;;      table is netscape and you see url
 186 ;;
 187 ;;          file:/users/foo/file.txt
 188 ;;
 189 ;;      The `file:/' would be normally considered external and accessed via
 190 ;;      `url' method, which in this case is netscape. But you would like
 191 ;;      to use Emacs `find-file' instead. Send `C-u' and leave the url as
 192 ;;      is and change access method to:
 193 ;;
 194 ;;          file
 195 ;;
 196 ;;      That's it. Remember however that you have full control and
 197 ;;      if you choose nonsense access method, which has nothing to do with
 198 ;;      the url, then you also carry the results, whatever they may be.
 199 ;;
 200 ;;  Ignoring URL in the buffer
 201 ;;
 202 ;;      You can use hook `tinyurl-:dispatch-hook' to check URL. If any of
 203 ;;      the functions return t, then the original binding in the mode is
 204 ;;      called and the TinyUrl is not used. E.g. In Dired buffer you want to
 205 ;;      ignore all URLs. There is default function
 206 ;;      `tinyurl-dispatch-ignore-p' that does just this.
 207 ;;
 208 ;;  Centralised URL handling
 209 ;;
 210 ;;      If you called `M-x' `tinyurl-install-to-packages' or had installation:
 211 ;;
 212 ;;          (add-hook 'tinyurl-:load-hook  'tinyurl-install-to-packages)
 213 ;;
 214 ;;      then GNUS, VM, TM, and other packages redirect urls to TinyUrl.
 215 ;;      This way you don't have to setup each package to your taste.
 216 ;;      Plus you got the benefit that you can change url handler set
 217 ;;      on the fly with `tinyurl-set-handler'.
 218 ;;
 219 ;;  Ignoring some buffers for mode turn on and offs
 220 ;;
 221 ;;      If you want to exclude some buffers from the mode turn on or offs,
 222 ;;      say *VM* which does its own highlighting, then define your
 223 ;;      custom function like this
 224 ;;
 225 ;;          (setq tinyurl-:exclude-function 'my-tinyurl-exclude)
 226 ;;
 227 ;;          (defun my-tinyurl-exclude (buffer)
 228 ;;             "Exclude some buffers that use their own highlighting."
 229 ;;             (string-match "VM\\|Article" (buffer-name buffer)))
 230 ;;
 231 ;;      This only concern the golobal `tinyurl-mode' function. You can
 232 ;;      still use `tinyurl-mode-1' anywhere to toggle the mode setting.
 233 ;;      You use this variable when you don't want `tinyurl-mode' to
 234 ;;      appear in buffer at all.
 235 ;;
 236 ;;  Validating url
 237 ;;
 238 ;;      The `tinyurl-mark-line' function doesn't check the validity of a
 239 ;;      matched regexp that was marked as pushable url. It's a dummy
 240 ;;      function that can only attach "buttons" and does nothing about
 241 ;;      their contents. But when you actually push the url, the url is run
 242 ;;      through functions in `tinyurl-:validate-hook'. When any of the
 243 ;;      function returns t, it is a *go* sign. The default handler
 244 ;;      `tinyurl-validate-url-default' rejects any url that matches
 245 ;;      "foo|bar|quux".
 246 ;;
 247 ;;      See also `tinyurl-:reject-url-regexp' for more simpler use.
 248 ;;
 249 ;;  Choosing what agent handles which URL
 250 ;;
 251 ;;      There is predefined `tinyurl-:command-table' which is consulted where
 252 ;;      URL request should be delegated. By default http:// or ftp:/ or file:/
 253 ;;      requests are handed by `browse-url-netscape' and remote tar or gz
 254 ;;      fileas are loaded with ange-ftp.
 255 ;;
 256 ;;      You can completely customize the URL delegation by writing your
 257 ;;      own url handler set and placing it to `tinyurl-:url-handler-function'.
 258 ;;      Copy the default setup and make your own modifications.
 259 ;;
 260 ;;  Changing the url handler list
 261 ;;
 262 ;;      When you click the url to run the viewer, the current url handler
 263 ;;      list determines what method is used. E.g. If you normally want
 264 ;;      netscape to handle your URL, then the current set is labelled
 265 ;;      "netscape". But in some situations, where you want to e.g. view text
 266 ;;      files or your resources in PC EXceed are low, or you want fast browser;
 267 ;;      then there is also "lynx" set. You change the browser set with command
 268 ;;
 269 ;;          tinyurl-set-handler   Meta mouse-2
 270 ;;
 271 ;;      The modeline will show the first string from your active set; `Un'
 272 ;;      for Netscape, `Ul' for lynx set and `Uw' for w3 based set. You can
 273 ;;      add as many handler sets as you want by adding them to
 274 ;;      `tinyurl-:command-table'
 275 ;;
 276 ;;  Exclamation character marks pushable URL
 277 ;;
 278 ;;      NOTE: THE VISIBLE CHACTER APPLIES ONLY TO TERMINALS THAT DO NOT
 279 ;;      SUPPORT COLORS TO MARK PUSHABLE URLS. (Usually an Emacs started
 280 ;;      with -nw, or running inside a terminal.)
 281 ;;
 282 ;;      When you see character "!" (netscape) or "?" (W3 browser) to appear
 283 ;;      in the front of the URLs, then you know that items are pushable.
 284 ;;      You can call the URL by clicking it with `mouse-2' or tapping
 285 ;;      `M-RET'. In the following line, two url's have been detected. The
 286 ;;      first one sends normal http request and the second one would create
 287 ;;      mail buffer for the address.
 288 ;;
 289 ;;          Some previous line here
 290 ;;          !http://foo.com/dir/file.txt  !<foo@bar.com>
 291 ;;          Another line below
 292 ;;
 293 ;;      Elswhere your `mouse-2' and `M-RET' behave as usual. If you would
 294 ;;      like to paste(the mouse-2) somewhere in the "previous" or "another"
 295 ;;      line, that would work as you expected. But you can't paste inside
 296 ;;      the URL, because the URL is currently activated. If you need to do
 297 ;;      something like that, then you can use either of these strategies:
 298 ;;
 299 ;;      o   Use `C-y' to yamk the text inside marked url.
 300 ;;      o   move cursor out of the URL line; wait few seconds for
 301 ;;          "!" to disappear (the line is cleared). Go back and paste before
 302 ;;          you see "!" to appear back again.
 303 ;;      o   Turn off the mode off with `M-x' `tinyurl-mode-1' for a while if
 304 ;;          you don't need the URL features right now.
 305 ;;
 306 ;;        _Note_: The character "!" that you see, is not a real editable
 307 ;;        character, but part of the overlay. While your text may appear to
 308 ;;        be modified. That is not what happened. See Emacs info pages for
 309 ;;        more about overlays.
 310 ;;
 311 ;;      You can use variable `tinyurl-:display-glyph' to control if the
 312 ;;      glyph is shown or not.
 313 ;;
 314 ;;
 315 ;;  Accepted email URL
 316 ;;
 317 ;;      The default accepted format is <foo@site.com> and if you see
 318 ;;      foo@site.com, that will not be recognized. Your can get this
 319 ;;      accepted by changing `tinyurl-:email-regexp'. You could use \\< and
 320 ;;      \\> (word border marker) regexps instead of default characters < >.
 321 ;;
 322 ;;  Support for programming language URLs
 323 ;;
 324 ;;      I'll gladly support any other languages. If you know the language
 325 ;;      you're using, drop me a mail and help me to undertand how I would
 326 ;;      add support to it. Especially I'd like to hear specs from Java
 327 ;;      programmers.
 328 ;;
 329 ;;     C/C++
 330 ;;
 331 ;;      The default agent to find C/C++ .h files is find-file.el's
 332 ;;      `ff-find-other-file'. This will handle your #include urls.
 333 ;;
 334 ;;     Perl
 335 ;;
 336 ;;      There is support for these perl statements:
 337 ;;
 338 ;;          use package;
 339 ;;          require package;
 340 ;;
 341 ;;      Functions that recognize those are under `tinyurl-find-url-perl*'.
 342 ;;      The default find path for perl is `@INC'. Perl related urls are
 343 ;;      delegated to separate tinyperl.el package. In addition perl compile
 344 ;;      error lines are recognized:
 345 ;;
 346 ;;          ERROR at FILE line NBR.
 347 ;;
 348 ;;      Perl pod page references are recognized in the format
 349 ;;
 350 ;;          perlfunc manpage
 351 ;;          See [perltoc]
 352 ;;
 353 ;;     Emacs lisp
 354 ;;
 355 ;;      The url handler function is `tinyurl-find-url-lisp' and Emacs
 356 ;;      `load-path' is searched. The usual urls "load-file", "load-library"
 357 ;;      "autoload" "load" are recognized. If you need to jump to function
 358 ;;      or variable definitions, you want to use a TinyLisp package, which
 359 ;;      offers minor mode solely for Emacs lisp programming purposes:
 360 ;;      Profiling, debugging, snooping hooks, you emacs packages, browsing
 361 ;;      code etc.
 362 ;;
 363 ;;     Other languages
 364 ;;
 365 ;;      Please let me know if you know package or you have code that can
 366 ;;      find other languages' URLs.
 367 ;;
 368 ;;     Debian support
 369 ;;
 370 ;;      Debian <http://www.debian.org> uses mail based bug tracking system
 371 ;;      where each assigned task is uniquely identified. The task can
 372 ;;      be a regular bug report send via command reportbug(1) or it can
 373 ;;      be a control message where developers can hand over maintenance
 374 ;;      of packages or in turn take over maintenance of orphaned packages.
 375 ;;      Visit page <http://www.debian.org/devel/wnpp> to see what the
 376 ;;      messages look like. The messages are best monitored and read
 377 ;;      through Gnus NNTP backend using newsgroup
 378 ;;      *nntp+news.gmane.org:gmane.linux.debian.devel.wnpp*. URLs like
 379 ;;      this are buttonized (requires package tinydebian.el):
 380 ;;
 381 ;;          Bug#NNNNNN
 382 ;;
 383 ;;     Memory list
 384 ;;
 385 ;;      o   Remember to define `ff-search-directories' for *find-file.el*
 386 ;;          so that your C/C++ #include <url> will be found correctly.
 387 ;;
 388 ;;  Filename filter e.g. running catdoc for MS Word files
 389 ;;
 390 ;;      There is table `tinyurl-:file-filter-table' which can be used to
 391 ;;      handle found url. Eg if you want to treat all files ending
 392 ;;      to extension .doc as MS word files and feed them through
 393 ;;      `catdoc' http://www.ice.ru/~vitus/works/ which spits 7bit
 394 ;;      out, you can associate shell action to handle url. Respectively
 395 ;;      if you want to use `xv' for viewing your images, you can associate
 396 ;;      that to the url. The default table handles these cases if you
 397 ;;      have xv and catdoc present. See variable description for more
 398 ;;      information. (You can also use your custom lisp url handler there)
 399 ;;
 400 ;;        If you want to load the raw file into emacs, just supply
 401 ;;        prefix argument when you push url and you will be given choice
 402 ;;        to by-pass the set filters (if there is any) for the url.
 403 ;;
 404 ;;  Code note: adding buttons to the current line
 405 ;;
 406 ;;      The idle timer process is used to mark current line's urls with
 407 ;;      overlays. Please wait few seconds on a line and the ulrs that
 408 ;;      can be *pushed* are marked. If there is no idle timer available,
 409 ;;      then a `post-command-hook' is used.
 410 ;;
 411 ;;     [Next applies only to Emacs with no `run-with-idle-timer' function]
 412 ;;
 413 ;;      Using `post-command-hook' is not an ideal solution, but at least
 414 ;;      this package works with older Emacs versions. The threshold how
 415 ;;      quicly the line is scanned for url buttons is determined by
 416 ;;      variable `tinyurl-:post-command-hook-threshold'. The deafult value
 417 ;;      7 should give you enough time to use `mouse-2' (paste) before the
 418 ;;      line is buttonized. Remember that *vawing* you mouse creates
 419 ;;      events, so you can force buttonizing the line quite quickly.
 420 ;;
 421 ;;  Code note: overlay properties
 422 ;;
 423 ;;      The overlays have nice feature where you can add string to be
 424 ;;      displayed to the side of an overlay. See the overlay properties in
 425 ;;      the Emacs info pages for more. The overlay `priority' in this
 426 ;;      package is by default set to highest possible, so that the URL
 427 ;;      highighting is guarranteed to be dislayed. If you use some other
 428 ;;      package that also uses overlays, then decrease that package's
 429 ;;      overlay priorities. (If the package doesn't allow you to adjust the
 430 ;;      priorities, contact the package maintainer. To my opinion the
 431 ;;      priority value should be defined for all overlays).
 432 ;;
 433 ;;      The only part that you should touch in the property list of the
 434 ;;      overlays, is the displayed string. You can choose anything you
 435 ;;      want, but prefer one character. By default the "!" is shown in
 436 ;;      both Windowed and non-windowed version.
 437 ;;
 438 ;;      The overlays have property `owner' which tells to whom
 439 ;;      particular overlays belong. In this case the owner is this package,
 440 ;;      `tinyurl'. It is a good practise for all overlays to identify
 441 ;;      themselves via this 'owner property.
 442 ;;
 443 ;;  Code Note: overlay management
 444 ;;
 445 ;;      Let's consider what `font-lock' does for buffer for a moment: it
 446 ;;      marks whole buffer with faces (colors). While design this package,
 447 ;;      the goal was not to add buffer with full of clickable overlays,
 448 ;;      while that could have been done easily. The reason is efficiency
 449 ;;      and avoiding "highlight" bloat.
 450 ;;
 451 ;;      Instead old overlays are removed and new ones are created only for
 452 ;;      current line, typically the count is between 1 .. 4. When you move
 453 ;;      to another place, these old overlays are destroyed and new ones
 454 ;;      created. The current line may now may have only 1 URL, so only one
 455 ;;      overlay was needed this time.
 456 ;;
 457 ;;      For that reason you must wait for idle timer process to do its
 458 ;;      work on current line, before you can see those clickable URL
 459 ;;      buttons.
 460 ;;
 461 ;;      Using only small number of overlays keeps the code clean and user
 462 ;;      friendly. It's also faster than buttonizing whole 500K faq
 463 ;;      document in one pass.
 464 ;;
 465 ;;  Code Note: Adding support for new URL type
 466 ;;
 467 ;;      If you see new url that you would like to have supported and you
 468 ;;      know lisp, then the changes needed are:
 469 ;;
 470 ;;      o   `tinyurl-mark-line', Add regexp to match the URL. Think carefully
 471 ;;          where to put the regexp and make is as restrictive as you can.
 472 ;;          Remember that first OR match is picked.
 473 ;;      o   `tinyurl-type', Add new type for URL
 474 ;;      o   `tinyurl-command-table-default-1' Add default handler
 475 ;;      o   Write the URL handler.
 476 ;;      o   Run `tinyurl-command-table-defaults-set' to make the new handler
 477 ;;          seen in the default agent function list
 478 ;;
 479 ;;      To make changes do this:
 480 ;;
 481 ;;      o   copy original version to `tinyurl.el.orig'
 482 ;;      o   Make changes
 483 ;;      o   Produce diff `diff -b -w -u  tinyurl.el.orig tinyurl.el'
 484 ;;
 485 ;;      Then send diff to the maintainer. Use unified diff format (-u) if
 486 ;;      possible. Second chance is to use context diff (-c). Other diff
 487 ;;      formats are not accepted.
 488 ;;
 489 ;;  Sending a bug report
 490 ;;
 491 ;;      If you have a line where url is highlighted, but it doesn't cover
 492 ;;      right characters, then do this:
 493 ;;
 494 ;;      o   `M-x' `tinyurl-submit-bug-report'
 495 ;;      o   Copy the _WHOLE_ line to the mail buffer.
 496 ;;      o   Turn on debug with `M-x' `tinyurl-debug-toggle'
 497 ;;      o   Be sure Url gets highlighted. End debug with
 498 ;;          `M-x' `tinyurl-debug-toggle' and copy the content of
 499 ;;          *tinyurl-debug* to the mail
 500 ;;      o   Attach desctiption of the bug and send mail.
 501 ;;
 502 ;;      Btw, in win32 the file url on `C:' disk is written like
 503 ;;
 504 ;;          file://localhost/C|/foo/bar/baz.html#here
 505 ;;
 506 ;;      And according to RFC, if you leave out the <host>, the localhost is
 507 ;;      automatically assumed.
 508 ;;
 509 ;;          file:///C|/foo/bar/baz.html#here
 510 ;;
 511 ;;  Known Bugs
 512 ;;
 513 ;;      The URL is highlighted by setting `mouse-face' to property
 514 ;;      `highligh'. But I have seen that Emacs 19.34 in HP Unix with X
 515 ;;      window sometimes won't show the highlight when cursor is moved
 516 ;;      over the URL. Go figure why. I have heard similar reports from
 517 ;;      XEmacs 20.4.
 518 ;;
 519 ;;      If you know what is causing this effect, let me know.
 520 ;;
 521 ;;  Todo
 522 ;;
 523 ;;      Add support for Java-Find.el
 524
 525 ;;}}}
 526
 527 ;;; Change Log:
 528
 529 ;;; Code:
 530
 531 ;;{{{ setup: require
 532
 533 (require 'tinylibm)
 534
 535 (eval-when-compile
 536   (ti::package-use-dynamic-compilation)
 537   (require 'advice))
 538
 539 (eval-and-compile
 540   (defvar gnus-plugged)
 541   (defvar browse-url-browser-function)
 542   (defvar gnus-button-url)
 543   (defvar vm-url-browser)
 544   (defvar browse-url-browser-function)
 545   (autoload 'man                                "man"       "" t)
 546   (autoload 'ffap                               "ffap"      "" t)
 547   (autoload 'ff-find-other-file                 "find-file" "" t)
 548   (autoload 'tinydebian-bug-browse-url-by-bug   "tinydebian"  "" t)
 549   (autoload 'tinyperl-pod-by-manpage            "tinyperl"  "" t)
 550   (autoload 'tinyperl-pod-by-module             "tinyperl"  "" t)
 551   (autoload 'tinyperl-pod-manpage-to-file       "tinyperl"  "" t)
 552   (autoload 'tinyperl-locate-library            "tinyperl"  "" t)
 553   (autoload 'tinyperl-library-find-file         "tinyperl"  "" t)
 554   (autoload 'turn-on-tinyperl-pod-view-mode     "tinyperl"  "" t)
 555   (ti::overlay-require-macro
 556     (message "\
 557 ** tinyurl.el: Error, this Emacs does not have overlay functions.")))
 558
 559 (ti::package-defgroup-tiny TinyUrl tinyurl-: extensions
 560   "Global URL highlighting and dispatcher minor mode.")
 561
 562 ;;}}}
 563 ;;{{{ setup: variables
 564
 565 ;;; ......................................................... &v-hooks ...
 566
 567 (defcustom tinyurl-:load-hook '(tinyurl-install-to-packages)
 568   "*Hook run when file has been loaded."
 569   :type  'hook
 570   :group 'TinyUrl)
 571
 572 (defcustom tinyurl-:dispatch-hook  '(tinyurl-dispatch-ignore-p)
 573   "When calling urls, check if it is allowed.
 574 this hook's purpose is to check current buffer, current line or anything
 575 else to determine if pushing URL is ste wanted action. Eg in dired
 576 buffer the pushing acting should not be respected but passed back
 577 to Dired.
 578
 579 Default function in this hook is `tinyurl-dispatch-ignore-p'.
 580
 581 Function call arguments:
 582
 583   url                   Matched url text
 584   '(buffer . point)     Pointer to location of url in Emacs
 585
 586 Function should return:
 587
 588   non-nil   To ignore urls and pass control back to underlying mode.
 589   nil       Accept url and proceed."
 590   :type  'hook
 591   :group 'TinyUrl)
 592
 593 (defcustom tinyurl-:validate-hook '(tinyurl-validate-url-default)
 594   "Validate called url. If some of these functions return t, url is accepted.
 595
 596 Function call arguments:
 597
 598   string:    URL
 599
 600 Function should return:
 601
 602   t         Accept and continue with url
 603   string    Display message STRING and ignore url
 604   nil       Display default message 'url ignored' and ignore url"
 605   :type  'hook
 606   :group 'TinyUrl)
 607
 608 ;;; .......................................................... &public ...
 609
 610 (defcustom tinyurl-:auto-activate-function
 611   'turn-on-tinyurl-mode-automatically
 612   "*Function to check if there are URLs in current buffer.
 613 This function will automatically turn on `tinyurl-mode-1' for the
 614 current buffer it it returns t."
 615   :type  'function
 616   :group 'TinyUrl)
 617
 618 (defcustom tinyurl-:plugged-function  'tinyurl-plugged-always-p
 619   "Function to determine disconnected state.
 620 Function takes no arguments and should return t if Emacs is disconnected
 621 and unable to serve external URL requests.
 622
 623 Possible values:
 624   'tinyurl-plugged-always-p
 625   'tinyurl-plugged-p
 626
 627 See also: `tinyurl-:url-cache-buffer'"
 628   :type  'function
 629   :group 'TinyUrl)
 630
 631 (defcustom tinyurl-:exclude-function 'tinyurl-default-exclude
 632   "*Function to prohibit (de)activatiting `turl-mode' for a buffer.
 633 This function is called when TinyUrl mode is booted up or shut down.
 634
 635 Function call argument:
 636
 637   buffer-pointer
 638
 639 Function should return:
 640
 641   t         if buffer is ignored"
 642   :type  'function
 643   :group 'TinyUrl)
 644
 645 (defcustom tinyurl-:display-glyph (not (ti::colors-supported-p))
 646   "*If non-nil, Display the Overlay glyph: !, ? or *.
 647
 648 The shown character depends on the active command table.
 649 If you have non-windowed Emacs which cannot
 650 display faces on tty, then make sure this variable is t or you won't
 651 notice the buttonized urls.
 652
 653 In Windowed Emacs the glyph may be redundant, because the face
 654 property already highlights the URLs. Try if you like setting nil better in
 655 non windowed Emacs."
 656   :type  'boolean
 657   :group 'TinyUrl)
 658
 659 (defcustom tinyurl-:file-filter-table
 660   (let* ((doc    (executable-find "catdoc"))
 661          (gimp   (executable-find "gimp"))
 662          (xv     (executable-find "xv"))
 663          (nroff  (executable-find "nroff"))
 664          (col    (executable-find "col"))
 665          (winzip (executable-find "winzip")))
 666     (list
 667      '("\\.pod$" . tinyurl-filter-pod)
 668      (if doc
 669          (cons "\\.doc$"  (concat doc " %s"))) ;View MS WORD files
 670      (cons "\\.\\(jpg\\|jpeg\\|gif\\)$"
 671            (cond
 672             (gimp
 673              (concat gimp " %s"))
 674             (xv
 675              (concat xv " %s"))
 676             (t
 677              'ignore)))                 ;Ignore loading pictures
 678      (if (and nroff col)
 679          (cons "\\.[1-9]$"
 680                (concat nroff " -man"
 681                        " %s | "
 682                        col " -bx")))
 683      ;; Pass ZIP pointer to win32 winzip
 684      (if winzip
 685          (cons "\\.zip$"
 686                (function
 687                 ((lambda (arg)
 688                    (tinyurl-call-process-win32
 689                     winzip  arg))))))))
 690   "If URL is filename, then check this table for filter.
 691 The `%s' is substituted with the URL (filename) in SHELL-COMMAND string.
 692
 693 If there is Lisp FUNCTION, then it is called with argument URL.
 694
 695 Format:
 696
 697   '((REGEXP . SHELL-COMMAND)      ;; nil element also accepted
 698     (REGEXP . FUNCTION)
 699     ..)
 700
 701 Example:
 702
 703   The default value for this variable is set like this. If you
 704   have executables `xv' and `catdoc', then the shell commands are
 705   defined. If you don't have, then the slot if filled with nil,
 706   which is acceptable value. The Picture file handler is set to
 707   `ignore' function, if no `xv' is present to prevent loading
 708   pictures into Emacs buffer.
 709
 710  (setq file-filter-table
 711        (list
 712         (if (executable-find \"catdoc\")
 713             '(\"\\\\.doc$\"  . \"catdoc %s\"))  ;View MS WORD files
 714         (if (executable-find \"xv\")
 715             '(\".\\\\(jpg\\\\|jpeg\\\\|gif\\\\)$\" .  \"xv %s\")
 716           'ignore)))"
 717   :type '(repeat
 718           (list regexp (choice
 719                         (string   :tag "Shell command")
 720                         (function :tag "Function"))))
 721   :group  'Tinyurl)
 722
 723 (defcustom tinyurl-:url-handler-function 'tinyurl-handler-main
 724   "Function to take care of delegating the URL to correct Agent.
 725 The default function `tinyurl-:command-table' uses `tinyurl-:command-table'
 726
 727 Function call arguments:
 728   string      a possible url
 729   type        :optional A symbol describing url type. See `tinyurl-type'"
 730   :type  'function
 731   :group 'TinyUrl)
 732
 733 ;;  This variable is set in `tinyurl-install'.
 734
 735 (defcustom tinyurl-:command-table nil
 736   "*What Agent to run when URL is beeing dispatched.
 737 This table cab have multiple different Agent-tables and the currently
 738 used table is stored at `tinyurl-:command-table'. See command
 739 \\[tinyurl-set-handler].
 740
 741 The elements:
 742
 743   TYPE      can be 'mail 'url 'file or 'other. These are the types that
 744             trigger calling VALUE as function. There is special type name
 745             'overlay-plist which is used for displaying the overlay.
 746             Refer to function `tinyurl-type' for all possible TYPE values.
 747
 748   FUNCTION  Either function or value. Functions are called interactively.
 749
 750 Format:
 751
 752  '((COMPLETION-NAME
 753     (
 754      (TYPE . VALUE)
 755      ..
 756      (overlay-plist (PROPERTY VAL PROPERTY VAL ..)))))
 757
 758 References:
 759
 760   You can contruct one entry to this table with
 761   functions `tinyurl-command-table-put' `tinyurl-command-table-put-2nd'
 762   and `tinyurl-command-table-default-1'. See tinyurl.el's source code and
 763   function `tinyurl-command-table-netscape' how to use these."
 764   :type  'sexp
 765   :group 'TinyUrl)
 766
 767 (defcustom tinyurl-:email-regexp
 768   ;; It's best to require some more characters to avoid mishits.
 769   ;; There is always ".com" ".fi", at least three characters.
 770   (let ((word  "[^ \t\r\n,:!?%@|'#&]"))
 771     (concat "<" word "+@" word "+\\." word word word "?>"))
 772   "Regexp to match email address approximately."
 773   :type  'string
 774   :group 'TinyUrl)
 775
 776 (defcustom tinyurl-:post-command-hook-threshold 25
 777   "How often `tinyurl-mark-process-post-command' run after post command.
 778 This variable is used only if funtion `run-with-idle-timer' does
 779 not exist. If the value is 1, then function `tinyurl-mark-process-post-command'
 780 runs after each keypress. You should keep the value in range 10 .. 30,
 781 depending on how quickly you want the process to scan the line for url
 782 buttons."
 783   :type  'integer
 784   :group 'TinyUrl)
 785
 786 (defcustom tinyurl-:url-cache-buffer  "*URL-cache*"
 787   "Where to store urls when Emacs is disconnected from the Net."
 788   :type 'string
 789   :group  'TinyUrl)
 790
 791 (defcustom tinyurl-:reject-url-regexp
 792   (concat
 793    ;; "/\\(usr\\|opt\\)\\(/local\\|/ucb\\)?/s?bin"
 794    ;; "\\|^/bin\\|/dev/"
 795    "\\.\\(exe\\|com\\|o\\)$")
 796   "Rgexp to reject URL. This is only used if URL is of type `file'."
 797   :type  'regexp
 798   :group 'TinyUrl)
 799
 800 ;;}}}
 801 ;;{{{ setup: private
 802
 803 ;;; ......................................................... &private ...
 804
 805 (defvar tinyurl-:mode-manually-turned-off nil
 806   "On/Off mark when `tinyurl-mode-1' has been changed interactively.")
 807
 808 (make-variable-buffer-local 'tinyurl-:mode-manually-turned-off)
 809
 810 ;; you can adjust this to include some more character, but please
 811 ;; send message to maintainer if you do so.
 812 ;;
 813 ;; _ $ % & = are many times used in Message-ID's
 814
 815 (defvar tinyurl-:cleaner-regexp "[^+~:/?()#%&=_$@.a-zA-Z0-9-]+"
 816   "When reading the url from buffer, delete characters matching in this regexp.
 817 After cleaning, we should have ready URL.")
 818
 819 (defvar tinyurl-:command-table-current nil
 820   "The active command table name.")
 821
 822 (defvar tinyurl-:event nil
 823   "Last mouse event.")
 824
 825 (defvar tinyurl-:timer-elt nil
 826   "Timer element.")
 827
 828 (defvar tinyurl-:history  nil
 829   "Url history.")
 830
 831 (defvar tinyurl-:mouse-yank-at-point nil ;; mouse-yank-at-point
 832   "Point used when url is clicked.
 833 If nil, when you click on point, the line is immediately
 834 scanned for urls and if the there was url under mouse point, then url
 835 will be followed. If there was no url then call original mouse binding.
 836
 837 If non-nil, The mouse-point is not scanned for urls. Only existing
 838 overlays under point are read.
 839
 840 In short: the t gives the usual 'run marked urls only' and t will say
 841 'install buttins to line, run url at point where the click happened if
 842 there was url'")
 843
 844 ;;      Keyboard user's want to see the highlight immediately, so
 845 ;;      a 'face setting is better than the 'mouse-face, which is only
 846 ;;      seen when mouse is waved over the URL. 'face is immediately
 847 ;;      shown in the line.
 848
 849 (defcustom tinyurl-:overlay-plist
 850   (let* ((face (if (ti::compat-window-system)
 851                    'mouse-face
 852                  'face)))
 853     (if (ti::emacs-p)
 854         (list
 855          'rear-nonsticky   t
 856          'rear-sticky      nil
 857          'priority         1
 858          face              'highlight
 859          'before-string    "!"
 860          'url              t
 861          'owner            'tinyurl)
 862       (list
 863        'rear-nonsticky    t
 864        'rear-sticky       nil
 865        'priority          1
 866        face               'highlight
 867        'begin-glyph       (ti::funcall 'make-glyph "!")
 868        'url               t
 869        'owner             'tinyurl)))
 870   "*Property list (PROP VAL PROP VAL ..) used for all overlays."
 871   :type  'sexp
 872   :group 'TinyUrl)
 873
 874 (defvar tinyurl-:win32-shell-execute-helper
 875   (when (ti::win32-p)
 876     (or (and (fboundp 'w32-shell-execute) ;; Emacs
 877              'w32-shell-execute)
 878         (and (fboundp 'mswindows-shell-execute) ;; XEmacs
 879              'mswindows-shell-execute)
 880         (executable-find "shellex")     ;; Newer Emacs.
 881         (executable-find "shellex.exe") ;; Emacs 20.2 does not check .exe
 882         (error "\
 883 ** TinyUrl: Automatic setup failed. See ´tinyurl-:win32-shell-execute-helper'.
 884 Can't find 'shellex' along `exec-path' with function `executable-find'.
 885 Visit http://www.tertius.com/projects/library/ and get shellex.exe")))
 886   "*Win32 program or Emacs function to launch native Win32 programs.")
 887
 888 ;;;###autoload (autoload 'tinyurl-version "tinyurl" "Display commentary." t)
 889 (eval-and-compile
 890   (ti::macrof-version-bug-report
 891    "tinyurl.el"
 892    "tinyurl"
 893    tinyurl-:version-id
 894    "$Id: tinyurl.el,v 2.85 2007/05/07 10:50:14 jaalto Exp $"
 895    '(tinyurl-:version-id
 896      tinyurl-:debug
 897      tinyurl-:dispatch-hook
 898      tinyurl-:validate-hook
 899      tinyurl-:load-hook
 900      timer-idle-list
 901      timer-list
 902      itimer-list
 903      tinyurl-:load-hook
 904      tinyurl-:dispatch-hook
 905      tinyurl-:validate-hook
 906      tinyurl-:display-glyph
 907      tinyurl-:file-filter-table
 908      tinyurl-:plugged-function
 909      tinyurl-:exclude-function
 910      tinyurl-:url-handler-function
 911      tinyurl-:command-table
 912      tinyurl-:email-regexp
 913      tinyurl-:post-command-hook-threshold
 914      tinyurl-:url-cache-buffer
 915      tinyurl-:reject-url-regexp
 916      tinyurl-:cleaner-regexp
 917      tinyurl-:command-table-current
 918      tinyurl-:event
 919      tinyurl-:timer-elt
 920      tinyurl-:history
 921      tinyurl-:mouse-yank-at-point
 922      tinyurl-:overlay-plist
 923      tinyurl-:win32-shell-execute-helper)
 924    '(tinyurl-:debug-buffer)))
 925
 926 ;;}}}
 927 ;;{{{ mode and install
 928
 929 ;;;###autoload (autoload 'tinyurl-debug-toggle "tinyurl" "" t)
 930
 931 (eval-and-compile (ti::macrof-debug-standard "tinyurl" "-:"))
 932
 933 ;;; .......................................................... &v-mode ...
 934
 935 ;;;###autoload (autoload 'tinyurl-mode            "tinyurl" "" t)
 936 ;;;###autoload (autoload 'turn-on-tinyurl-mode    "tinyurl" "" t)
 937 ;;;###autoload (autoload 'turn-off-tinyurl-mode   "tinyurl" "" t)
 938 ;;;###autoload (autoload 'tinyurl-commentary      "tinyurl" "" t)
 939
 940 (eval-and-compile
 941   (ti::macrof-minor-mode-wizard
 942    "tinyurl-" " U" nil  "Url" 'TinyUrl "tinyurl-:"
 943    "Mark URLs buttons on the line and call appropriate url handlers.
 944
 945 To read the complete documentation, run `tinyurl-commentary'
 946 See also `tinyurl-version' (use prefix argument to see only version number).
 947
 948 Defined keys:
 949
 950 \\{tinyurl-:mode-map}"
 951
 952    "Url mode"
 953    (progn                              ;Some mode specific things? No?
 954      (tinyurl-modeline-update)
 955      (cond
 956       (tinyurl-mode
 957        (put 'tinyurl-mode 'global t)
 958        (unless (memq 'tinyurl-find-file-hook find-file-hooks)
 959          (add-hook 'find-file-hooks 'tinyurl-find-file-hook)))
 960       (t
 961        (put 'tinyurl-mode 'global nil)
 962        (when (memq 'tinyurl-find-file-hook find-file-hooks)
 963          (remove-hook 'find-file-hooks 'tinyurl-find-file-hook))))
 964      (when (null (get 'tinyurl-mode 'self-call))
 965        (tinyurl-mode-action tinyurl-mode verb)))
 966    ;;  The Menubar item takes space and is not useful at least not
 967    ;;  now, because there is no other functionality in this mode.
 968    nil
 969    nil
 970 ;;;  "Tiny URL mode"
 971 ;;;  (list                                      ;arg 10
 972 ;;;   tinyurl:mode-easymenu-name
 973 ;;;   ["Find url or call original key ESC RET" tinyurl-key-binding-default t]
 974 ;;;   ["Mode help"                             tinyurl-mode-help                 t]
 975 ;;;   )
 976    (progn
 977      ;;  No, there is no key for `tinyurl-set-handler'. We try to
 978      ;;  minimize the used keys in this minor mode. Call M-x
 979      ;;  tinyurl-set-handler if you need to change this (not likely in
 980      ;;  Non-windowed Emacs)
 981      (cond
 982       ((ti::emacs-p)
 983        (define-key root-map [?\e mouse-2]        'tinyurl-set-handler)
 984        ;;  We have to define this, because widget.el uses down-mouse-2
 985        ;;  and we must see it first.
 986        (define-key root-map [down-mouse-2]       'tinyurl-mouse-binding-down)
 987        (define-key root-map [mouse-2]            'tinyurl-mouse-binding))
 988       (t
 989        (define-key root-map [(meta button2)]     'tinyurl-set-handler)
 990        (define-key root-map [(button2)]          'tinyurl-mouse-binding)))
 991      (define-key root-map "\e\C-m" 'tinyurl-key-binding-default))))
 992
 993 ;;; ----------------------------------------------------------------------
 994 ;;;
 995 (defun tinyurl-mode-turn-on-ok-p ()
 996   "Check if 'tinyurl-mode-1' is allowed to be turned on for the buffer.
 997 The buffer is seached for basic URL references and checked against
 998 `tinyurl-:exclude-function'."
 999   (and (null tinyurl-mode)
1000        (or  (null tinyurl-:exclude-function)
1001             (null (funcall tinyurl-:exclude-function (current-buffer))))
1002        (ti::re-search-check
1003         (concat "\\(ftp\\|https?\\)://"
1004                 "\\|<[^ \t\n]+@[^ \t\n]+>"
1005                 "\\|mailto:[^ \t\n]+@[^ \t\n]+"))))
1006
1007 ;;; ----------------------------------------------------------------------
1008 ;;;
1009 ;;;###autoload
1010 (defun turn-on-turn-off-tinyurl-mode-1-maybe ()
1011   "Activate or deactivate `tinyurl-mode-1' in current buffer.
1012 Try to find ftp, http or email URL.
1013 The value of `tinyurl-:exclude-function' is consulted first."
1014   (if (tinyurl-mode-turn-on-ok-p)
1015       (turn-on-tinyurl-mode-1)
1016     (turn-off-tinyurl-mode-1)))
1017
1018 ;;; ----------------------------------------------------------------------
1019 ;;;
1020 ;;;###autoload
1021 (defun turn-on-tinyurl-mode-1-maybe ()
1022   "Activate `tinyurl-mode-1' in current buffer if ftp, http or email is found.
1023 This function is meant to be used in e.g. Article display
1024 hooks in Mail Agents.
1025
1026 References:
1027
1028   The value of `tinyurl-:exclude-function' is consulted first."
1029   (when (tinyurl-mode-turn-on-ok-p)
1030     (turn-on-tinyurl-mode-1)))
1031
1032 ;;; ----------------------------------------------------------------------
1033 ;;;
1034 ;;;###autoload
1035 (defun turn-on-tinyurl-mode-mail ()
1036   "Turn on  `tinyurl-mode-1' and make `tinyurl-:mouse-yank-at-point' local."
1037   (make-local-variable 'tinyurl-:mouse-yank-at-point)
1038   ;;  We set this to t, so that clicking url means scanning line
1039   ;;  immediately.
1040   (setq tinyurl-:mouse-yank-at-point t)
1041   (unless tinyurl-mode
1042     (turn-on-tinyurl-mode-1)))
1043
1044 ;;; ----------------------------------------------------------------------
1045 ;;;
1046 (defun turn-on-tinyurl-mode-automatically ()
1047   "This function is called from idle timer process `tinyurl-mark-process'.
1048 If `tinyurl-:mode-global-turned-off' is set, do nothing."
1049   (when (and (get  'tinyurl-mode 'global)
1050              (null tinyurl-:mode-global-turned-off)
1051              (tinyurl-mode-turn-on-ok-p))
1052     (turn-on-tinyurl-mode-1)
1053     t))
1054
1055 ;;; ----------------------------------------------------------------------
1056 ;;;
1057 (defun turn-on-tinyurl-mode-1 ()
1058   "Turn URL mode on for this buffer only."
1059   (interactive)
1060   (unless tinyurl-mode
1061     (when (interactive-p)
1062       (setq tinyurl-:mode-manually-turned-off nil))
1063     (tinyurl-mode-1 1)))
1064
1065 ;;; ----------------------------------------------------------------------
1066 ;;;
1067 (defun turn-off-tinyurl-mode-1 ()
1068   "Turn URL mode off for this buffer only."
1069   (interactive)
1070   (when tinyurl-mode
1071     (when (interactive-p)
1072       (setq tinyurl-:mode-manually-turned-off t))
1073     (tinyurl-mode-1 0)))
1074
1075 ;;; ----------------------------------------------------------------------
1076 ;;;
1077 (defun tinyurl-overlay-kill-in-buffer  ()
1078   "Kill TinyUrl overlays from whole buffer. See also `tinyurl-overlay-kill'."
1079   (interactive)
1080   (put 'tinyurl-mark-line 'point nil)
1081   (ti::overlay-remove-region
1082    (point-min) (point-max) '(owner tinyurl) 'prop-val-list))
1083
1084 ;;; ----------------------------------------------------------------------
1085 ;;;
1086 (defun tinyurl-overlay-kill  ()
1087   "Kill used overlays.
1088 This function only kills overlays recoded to internal list.
1089 Thje internal list may be inaccurate an to definitely wipe out
1090 TinyUrl overlays, use `tinyurl-overlay-kill-in-buffer'."
1091   (put 'tinyurl-mark-line 'point nil)
1092   (dolist (ov (get 'tinyurl-mark-line 'ov-list))
1093     (delete-overlay ov)))
1094
1095 ;;; ----------------------------------------------------------------------
1096 ;;;###autoload
1097 (defun tinyurl-mode-1 (arg)
1098   "Turn mode on or off with mode ARG for current buffer only.
1099 If you want to turn on or off globally, use function `tinyurl-mode'."
1100   (interactive "P")
1101   (unless (assq 'tinyurl-mode minor-mode-map-alist)
1102     (tinyurl-install-mode))
1103   (ti::bool-toggle tinyurl-mode arg)
1104   (tinyurl-modeline-update)
1105   (unless tinyurl-mode                  ;Cleanup overlays on exit
1106     (tinyurl-overlay-kill-in-buffer)
1107     (tinyurl-overlay-kill))
1108   (when (interactive-p)
1109     (setq tinyurl-:mode-manually-turned-off (not tinyurl-mode)))
1110   tinyurl-mode)
1111
1112 ;;; ----------------------------------------------------------------------
1113 ;;;
1114 (defun tinyurl-mode-action (&optional mode verb)
1115   "Turn MODE `tinyurl-mode' on or off everywhere. See `tinyurl-mode'.
1116 This function must not be called directly, not even from Lisp. Use
1117 function `tinyurl-mode' function instead. VERB."
1118   (unless (get 'tinyurl-mode 'self-call)
1119     (run-hooks 'tinyurl-:mode-define-keys-hook))
1120   (let* ((i 0)
1121          tinyurl-:mode-define-keys-hook)
1122     (unwind-protect
1123         (progn
1124           ;;  Raise the flag to prevent calling us
1125           (put 'tinyurl-mode 'self-call t)
1126           ;;  For every buffer, either turn mode on or off.
1127           (dolist (buffer (buffer-list))
1128             (incf  i)
1129             ;;  Exclude hidden buffers
1130             (when (not (string-match "^ " (buffer-name buffer)))
1131               (with-current-buffer buffer
1132                 (cond
1133                  (mode
1134                   ;;  Mark all buffers as "not modified"
1135                   (setq tinyurl-:mode-manually-turned-off nil)
1136                   (turn-on-tinyurl-mode-1-maybe))
1137                  (t
1138                   (turn-off-tinyurl-mode)
1139                   (setq tinyurl-:mode-manually-turned-off t)))))))
1140       (when verb
1141         (message "TinyUrl: Global mode is %s. Stepped through %d buffers"
1142                  (if mode
1143                      "on"
1144                    "off")
1145                  i)
1146         (sit-for 1))
1147       (put 'tinyurl-mode 'self-call nil))))
1148
1149 ;;; ----------------------------------------------------------------------
1150 ;;;###autoload
1151 (defun tinyurl-install (&optional uninstall)
1152   "Install or `UNINSTALL package."
1153   (interactive "P")
1154   (put 'tinyurl-plugged-p 'mode nil)
1155   (ti::compat-timer-cancel-function 'tinyurl-mark-process)
1156   (tinyurl-install-mode)
1157   (ti::add-hooks '(Man-mode-hook
1158                    compilation-mode-hook)
1159                  'turn-on-tinyurl-mode-1
1160                  uninstall)
1161   (remove-hook 'post-command-hook 'tinyurl-mark-process-post-command)
1162   (tinyurl-install-command-table)
1163   ;;  If the idle timer is available, use it. Otherwise we would have
1164   ;;  no other option but occupy post command hook
1165   (unless uninstall
1166     (if (ti::idle-timer-supported-p)
1167         (setq tinyurl-:timer-elt
1168               (ti::funcall 'run-with-idle-timer 2 t 'tinyurl-mark-process))
1169       (add-hook 'post-command-hook
1170                 'tinyurl-mark-process-post-command))))
1171
1172 ;;; ----------------------------------------------------------------------
1173 ;;;
1174 (defun tinyurl-install-to-packages (&optional restore-original)
1175   "Make TinyUrl default top level url handler: GNUS, TM, VM etc.
1176 Optionally RESTORE-ORIGINAL url handlers."
1177   (interactive "P")
1178   (let* ()
1179 ;;;         (list '(gnus-button-url
1180 ;;;                 gnus-button-embedded-url
1181 ;;;                 tm:browse-url
1182 ;;;                 vm-mouse-send-url
1183 ;;;                 ))
1184     (ti::add-hooks '(rmail-show-message-hook
1185                      vm-select-message-hook
1186                      mh-show-mode-hook)
1187                    'turn-on-tinyurl-mode-mail
1188                    restore-original)
1189     ;; Using advice
1190     ;; 1) package may not be loaded yet, advice activated when it loads.
1191     ;; 2) Changing the MUA varibles would maen requiring the feature,
1192     ;;    and then changing the defaults, but what guarrantees that user
1193     ;;    doesn't reset the vars somewhere else?
1194     ;; 3) Gnus adds all button to the article, but tinyurl only looks
1195     ;;    current line
1196     ;; See gnus-art.el
1197     ;; gnus-button-embedded-url gnus-button-url gnus-url-mailto
1198     (when nil                           ;Enabled now
1199       (require 'advice)
1200       (defadvice gnus-button-url (around tinyurl dis)
1201         "Replace function and call `tinyurl-:url-handler-function'"
1202         (let ((URL  (ti::string-remove-whitespace (ad-get-arg 0))))
1203           (funcall tinyurl-:url-handler-function URL)))
1204       (defadvice gnus-article-push-button (around tinyurl dis)
1205         "Replace function and call `tinyurl-:url-handler-function'"
1206         (let ((URL  (ti::string-remove-whitespace (ad-get-arg 0))))
1207           (funcall tinyurl-:url-handler-function URL)))
1208       (defadvice gnus-button-embedded-url (around tinyurl dis)
1209         "Replace function and call `tinyurl-:url-handler-function'"
1210         (let ((URL  (ti::string-remove-whitespace (ad-get-arg 0))))
1211           (funcall tinyurl-:url-handler-function URL)))
1212       (defadvice gnus-url-mailto (around tinyurl dis)
1213         "Replace function and call `tinyurl-:url-handler-function'"
1214         (let ((URL  (ti::string-remove-whitespace (ad-get-arg 0))))
1215           (funcall tinyurl-:url-handler-function URL)))
1216       ;;  vm-mouse-send-url (url &optional browser)
1217       (defadvice vm-mouse-send-url (around tinyurl act)
1218         "Replace function and call `tinyurl-:url-handler-function'"
1219         (funcall tinyurl-:url-handler-function (ad-get-arg 0))))
1220     ;;  TM/SEMI Unfortunately has no hook that runs when preview
1221     ;;  buffer is created with
1222     (when nil
1223       (require 'advice)
1224       (defadvice tm:browse-url  (around tinyurl act) ;TM.el
1225         "Replace function and call `tinyurl-:url-handler-function'"
1226         (tinyurl-at-point 'verb))
1227       (defadvice mime-viewer/make-preview-buffer (after tinyurl act)
1228         "Call `turn-on-tinyurl-mode-mail'."
1229         (turn-on-tinyurl-mode-mail))
1230       (defadvice mime-edit-preview-message  (after tinyurl act)
1231         "Call `turn-on-tinyurl-mode-mail'."
1232         (turn-on-tinyurl-mode-mail))
1233       (if restore-original
1234           (ti::advice-control list "tinyurl" 'disable)
1235         (ti::advice-control list "tinyurl")))
1236     (when (ti::win32-p)
1237       (defconst gnus-button-url 'tinyurl-dispatcher-1) ; GNUS
1238       ;; VM
1239       (defconst vm-url-browser 'tinyurl-dispatcher-1))))
1240
1241 ;;; ----------------------------------------------------------------------
1242 ;;;
1243 (defun tinyurl-find-file-hook ()
1244   "Turn on tinyurl mode if `tinyurl-:mode-global' is non-nil."
1245   (when (and (get 'tinyurl-mode 'global)
1246              (null tinyurl-mode))
1247     (turn-on-tinyurl-mode-1)))
1248
1249 ;;; ----------------------------------------------------------------------
1250 ;;;
1251 (defun tinyurl-set-handler (table)
1252   "Set active url handler command TABLE."
1253   (interactive
1254    (list (completing-read
1255           "TinyUrl, use command table: " tinyurl-:command-table nil t)))
1256   (setq tinyurl-:command-table-current table)
1257   (tinyurl-modeline-update))
1258
1259 ;;}}}
1260 ;;{{{ misc
1261
1262 ;;; ----------------------------------------------------------------------
1263 ;;;
1264 (defun tinyurl-plugged-p ()
1265   "Return plugged status."
1266   (or (get 'tinyurl-plugged-p 'mode)
1267       (ti::mail-plugged-p)))
1268
1269 ;;; ----------------------------------------------------------------------
1270 ;;;
1271 (defun tinyurl-plugged-always-p ()
1272   "Return true plugged status."
1273   t)
1274
1275 ;;; ----------------------------------------------------------------------
1276 ;;; Called by the Line marker process to keep track of the Gnus mode changes
1277 ;;;
1278 (defun tinyurl-plugged-update ()
1279   "Update plugged status."
1280   (put 'tinyurl-plugged-p 'mode (tinyurl-plugged-p)))
1281
1282 ;;; ----------------------------------------------------------------------
1283 ;;;
1284 (defun tinyurl-plugged-mode-toggle (&optional arg verb)
1285   "Set plugged status according to ARG. 1 means plugged and 0 unplugged.
1286 When mode is nil, assume unplugged unless `ti::mail-plugged-p'
1287 \(Gnus) says otherwise."
1288   (interactive "P")
1289   (let* ((mode (get 'tinyurl-plugged-p 'mode)))
1290     (ti::verb)
1291     (ti::bool-toggle mode arg)
1292     (put 'tinyurl-plugged-p 'mode mode)
1293     (if verb
1294         (message "TinyUrl: %s"
1295                  (if mode "Plugged" "Unplugged")))
1296
1297     (if (boundp 'gnus-plugged)
1298         (setq gnus-plugged mode))
1299
1300     (tinyurl-modeline-update)
1301     (get 'tinyurl-plugged-p 'mode)))
1302
1303 ;;; ----------------------------------------------------------------------
1304 ;;;
1305 (defun tinyurl-call-process-win32 (binary &rest args)
1306   "Call Win32 native BINARY with ARGS"
1307   (interactive)
1308   (cond
1309    ((stringp tinyurl-:win32-shell-execute-helper)
1310     (apply 'call-process
1311            tinyurl-:win32-shell-execute-helper
1312            nil
1313            nil
1314            nil
1315            ;; binary
1316            args))
1317    ((functionp tinyurl-:win32-shell-execute-helper)
1318     (apply tinyurl-:win32-shell-execute-helper "open" args))
1319    (t
1320     (message
1321      "TinyUrl: `tinyurl-:win32-shell-execute-helper' not configured."))))
1322
1323 ;;; ----------------------------------------------------------------------
1324 ;;;
1325 (defun tinyurl-default-exclude  (buffer)
1326   "Default function for `tinyurl-:exclude-function' to ignore BUFFER.
1327 Ignores VM, W3, DIRED, ARCHIVE, COMPILE, GREP buffers.
1328
1329 The buffer ignore status is recorded to the plist of
1330 function ´tinyurl-default-exclude', which you can recall with:
1331
1332   (get 'tinyurl-default-exclude 'exclude-list)"
1333   (with-current-buffer buffer
1334     (let* ((exclude-list  (get 'tinyurl-default-exclude
1335                                'exclude-list))
1336            (nok-status    (assq buffer exclude-list)))
1337       (unless nok-status
1338         (let* ((name (symbol-name major-mode))
1339                (stat (string-match
1340                       (concat
1341                        "^w3-\\|^vm-\\|dired\\|archive\\|compil\\|grep$"
1342                        "\\|archive")
1343                       name)))
1344           (when stat
1345             (pushnew (cons buffer 'exclude) exclude-list :test 'equal)
1346             (put 'tinyurl-default-exclude 'exclude-list exclude-list)
1347             (message "TinyUrl: Excluded buffer ´%s' Major-mode: %s"
1348                      (buffer-name)
1349                      name)
1350             stat))))))
1351
1352 ;;; ----------------------------------------------------------------------
1353 ;;;
1354 (defun tinyurl-command-table-put (table key value)
1355   "Use command TABLE entry and change KEY's value to new VALUE."
1356   (let* (elt
1357          new
1358          ok)
1359     (while (setq elt (pop table))
1360       (when (eq (car elt) key)
1361         (setq elt (cons key value)
1362               ok  t))
1363       (push elt new))
1364     (or ok
1365         (error "TinyUrl: No key %s found" key))
1366     (nreverse new)))
1367
1368 ;;; ----------------------------------------------------------------------
1369 ;;;
1370 (defun tinyurl-command-table-put-2nd (table key1 key2 value)
1371   "Use command TABLE, find KEY1, change 2nd level KEY2's value to new VALUE.
1372 The TABLE is modified in place."
1373   (let* (elt
1374          list
1375          mem
1376          new
1377          ok)
1378     (or (setq elt (assq key1 table))
1379         (error "TinyUrl: Key1 %s does not exist" key1))
1380     (setq list (nth 1 elt))
1381     (while list
1382       (setq mem (car list))
1383       (push mem new)
1384       (when (eq mem key2)
1385         ;;   Raise flag, change value
1386         (setq ok t)
1387         (push value new)
1388         ;; skip next element, because this is the old value.
1389         (setq list (cdr list)))
1390       (setq list (cdr list)))
1391     (setq new (nreverse new))
1392     (unless ok
1393       (error "No key2 '%s'" key2))
1394
1395     (setcdr elt (list new))            ; Change key1's right hand list
1396     table))
1397
1398 ;;; ----------------------------------------------------------------------
1399 ;;;
1400 (defun tinyurl-browse-url-browser-function ()
1401   "Return default `browse-url-browser-function'."
1402   (when (and (boundp 'browse-url-browser-function)
1403              browse-url-browser-function)
1404     ;; If the value is not a function it should be a list of pairs
1405     ;; (REGEXP . FUNCTION)
1406     (cond
1407      ((functionp browse-url-browser-function)
1408       (if (not (eq browse-url-browser-function
1409                    'tinyurl-dispatcher-1))
1410           browse-url-browser-function))
1411      ((listp browse-url-browser-function)
1412       (dolist (elt browse-url-browser-function)
1413         (when (string-match "netscape" (symbol-name (cdr-safe elt)))
1414           (return (cdr elt))))))))
1415
1416 ;;; ----------------------------------------------------------------------
1417 ;;;
1418 (defun tinyurl-user-default-browser-type ()
1419   "What kind of browser user used before? \"netscape\" or \"iexplore."
1420   (let* ((browse  (tinyurl-browse-url-browser-function))
1421          (user-default
1422           (when browse
1423             (cond
1424              ((string-match "netscape" (symbol-name browse))
1425               'netscape)
1426              ((ti::win32-p)
1427               'iexplore)
1428              (t
1429               ;;  Don't know. Use whatever is there.
1430               'default)))))
1431     user-default))
1432
1433 ;;; ----------------------------------------------------------------------
1434 ;;;
1435 (defun tinyurl-user-command-table-default ()
1436   "Return default command table choice.
1437 This might be \"netscape\" or \"iexplore\"."
1438   (interactive)
1439   (let* ((default (tinyurl-user-default-browser-type)))
1440     (cond
1441      ((ti::win32-p)                     ;Win32
1442       (let ((net (executable-find "netscape")))
1443         (if (and net
1444                  (eq default 'netscape))
1445             "netscape"
1446           ;; "c:/Program Files/Internet Explorer/iexplore.exe
1447           "iexplore")))
1448      (t                                 ;Unix
1449       (if (not (ti::compat-window-system))
1450           "w3"
1451         ;;  In Unix the name has "r" at the end
1452         (let* ((ie (executable-find "iexplorer")))
1453           (cond
1454            (ie
1455             "iexplore")
1456            ((eq default 'netscape)
1457             "netscape")
1458            (t
1459             "default"))))))))
1460
1461 ;;; ----------------------------------------------------------------------
1462 ;;;
1463 (defun tinyurl-command-table-default-1 ()
1464   "Return default `tinyurl-:command-table' entry.
1465 If you change this function's source, run
1466
1467   (tinyurl-install-command-table 'force)
1468
1469 References:
1470  `tinyurl-:overlay-plist'"
1471   (list
1472    ;; could also use `tinyurl-find-url-mail'
1473    '(mail               . tinyurl-find-url-mail-browse-url)
1474    '(url-message-id     . tinyurl-find-url-message-id)
1475    '(url-http           . tinyurl-find-url-http)  ;; www.x.com
1476    '(url-ftp            . tinyurl-find-url-file)  ;; ftp://site.com
1477    '(url                . browse-url)
1478    '(url-ange           . find-file) ;; /foo@site.com:
1479    '(url-debian-bts     . tinyurl-find-debian-bts-bug) ;; Bug#NNNNNN
1480    '(file               . tinyurl-find-url-file)
1481    '(file-packed        . tinyurl-find-url-file)
1482    '(file-code-c        . ff-find-other-file)
1483    '(file-code-lisp     . tinyurl-find-url-lisp)
1484    '(file-code-perl             . tinyurl-find-url-perl)
1485    '(file-code-perl-pod-manpage . tinyurl-find-url-perl-pod-manpage)
1486    '(file-code-perl-pod-module  . tinyurl-find-url-perl-pod-module)
1487    '(file-code-perl-method      . tinyurl-find-url-perl-method)
1488    '(compiler-perl-in-file-at-line      . tinyurl-find-url-perl-compile)
1489    '(compiler-perl-at-line              . tinyurl-find-url-perl-compile)
1490    '(compiler-php-at-line               . tinyurl-find-url-php-compile)
1491    '(file-other         . ffap)
1492    '(man                . tinyurl-find-url-man)
1493    '(other              . tinyurl-find-url-file)
1494    (list
1495     'overlay-plist
1496     tinyurl-:overlay-plist)))
1497
1498 ;;; ----------------------------------------------------------------------
1499 ;;;
1500 (defmacro tinyurl-command-table-before-string (entry string)
1501   "Replace property 'before-string in ENTRY with STRING."
1502   (`
1503    (if (ti::emacs-p)
1504        (tinyurl-command-table-put-2nd
1505         (, entry) 'overlay-plist 'before-string  (, string))
1506      (tinyurl-command-table-put-2nd
1507       (, entry) 'overlay-plist 'begin-glyph
1508       (ti::funcall 'make-glyph (, string))))))
1509
1510 ;;; ----------------------------------------------------------------------
1511 ;;; This is a copy from function `browse-url'.
1512 (defun tinyurl-command-browse-url-default-browser-function-1
1513   (&optional url)
1514   "Return function from `browse-url-browser-function' for URL.
1515 URL defaults to http"
1516   (when (boundp 'browse-url-browser-function)
1517     (if (functionp browse-url-browser-function)
1518         browse-url-browser-function
1519       ;; The `function' can be an alist; look down it for first match
1520       ;; and apply the function (which might be a lambda).
1521       (dolist (elt browse-url-browser-function)
1522         (when (string-match (car elt) (or url "http"))
1523           (return (cdr elt)))))))
1524
1525 ;;; ----------------------------------------------------------------------
1526 ;;;
1527 (defun tinyurl-command-browse-url-default-browser-function ()
1528   "Find brose-url.el function that would  call the default broser.
1529 If not found, signal error."
1530   (or (tinyurl-command-browse-url-default-browser-function-1)
1531       (error "TinyUrl: `browse-url-browser-function' is not set.
1532 Has brose-url.el been loaded?")))
1533
1534 ;;; ----------------------------------------------------------------------
1535 ;;;
1536 (defun tinyurl-command-table-default ()
1537   "Return \"default\" entry."
1538   (let* ((entry (tinyurl-command-table-default-1)))
1539     ;; (setq entry (tinyurl-command-table-put
1540     ;;              entry
1541     ;;              'url
1542     ;;              (tinyurl-command-browse-url-default-browser-function)))
1543     (tinyurl-command-table-before-string entry "!")
1544     entry))
1545
1546 ;;; ----------------------------------------------------------------------
1547 ;;;
1548 (defun tinyurl-command-table-netscape ()
1549   "Return Netscape entry."
1550   (let* ((entry (tinyurl-command-table-default-1)))
1551     (when (executable-find "netscape")
1552       (setq entry (tinyurl-command-table-put
1553                    entry 'url 'browse-url-netscape))
1554       (tinyurl-command-table-before-string entry "!")
1555       entry)))
1556
1557 ;;; ----------------------------------------------------------------------
1558 ;;;
1559 (defun tinyurl-command-table-iexplore ()
1560   "Return Unix Iexplorer entry."
1561   (let* ((entry (tinyurl-command-table-default-1)))
1562     (when (executable-find "iexplorer") ;; Extra "r" in name
1563       (setq entry (tinyurl-command-table-put
1564                    entry 'url 'browse-url-iexplore))
1565       (tinyurl-command-table-before-string entry "!")
1566       entry)))
1567
1568 ;;; ----------------------------------------------------------------------
1569 ;;;
1570 (defun tinyurl-command-table-netscape-win32 ()
1571   "Return Netscape entry."
1572   (let* ((entry (tinyurl-command-table-default-1)))
1573     (setq entry (tinyurl-command-table-put
1574                  entry 'url 'tinyurl-find-url-win32-netscape))
1575     (tinyurl-command-table-before-string entry "!")
1576     entry))
1577
1578 ;;; ----------------------------------------------------------------------
1579 ;;;
1580 (defun tinyurl-command-table-iexplore-win32 ()
1581   "Return Netscape entry."
1582   (let* ((entry (tinyurl-command-table-default-1)))
1583     (setq entry (tinyurl-command-table-put
1584                  entry 'url 'tinyurl-find-url-win32-iexplore))
1585     (tinyurl-command-table-before-string entry "@")
1586     entry))
1587
1588 ;;; ----------------------------------------------------------------------
1589 ;;;
1590 (defun tinyurl-command-table-lynx ()
1591   "Return Lynx entry."
1592   (let* ((entry (tinyurl-command-table-default-1)))
1593     (setq entry (tinyurl-command-table-put
1594                  entry 'url 'browse-url-lynx-emacs))
1595     (tinyurl-command-table-before-string entry "*")
1596     entry))
1597
1598 ;;; ----------------------------------------------------------------------
1599 ;;;
1600 (defun tinyurl-command-table-w3 ()
1601   "Return W3 entry."
1602   (let* ((entry (tinyurl-command-table-default-1)))
1603     (setq entry (tinyurl-command-table-put
1604                  entry 'url 'browse-url-w3))
1605     (tinyurl-command-table-before-string entry "?")
1606     entry))
1607
1608 ;;; ----------------------------------------------------------------------
1609 ;;;
1610 (defun tinyurl-command-table-defaults ()
1611   "Return default value for `tinyurl-:command-table'."
1612   (delq nil                             ;remove empty entries
1613         (list
1614          (list "default" (tinyurl-command-table-default))
1615          (if (ti::win32-p)
1616              (list "netscape" (tinyurl-command-table-netscape-win32))
1617            (list "netscape" (tinyurl-command-table-netscape)))
1618          (if (ti::win32-p)
1619              (list "iexplore" (tinyurl-command-table-iexplore-win32))
1620            (list "iexplore" (tinyurl-command-table-iexplore)))
1621          ;; FIXME: Ahem, there is Lynx for Win32; but I don't know
1622          ;; if anybody uses it.
1623          (unless (ti::win32-p)
1624            (list "lynx"  (tinyurl-command-table-lynx)))
1625          (list "w3"    (tinyurl-command-table-w3)))))
1626
1627 ;;; ----------------------------------------------------------------------
1628 ;;;
1629 (defun tinyurl-command-table-defaults-set ()
1630   "Set `tinyurl-:command-table' to defaults."
1631   (interactive)
1632   (setq tinyurl-:command-table (tinyurl-command-table-defaults)))
1633
1634 ;;; ----------------------------------------------------------------------
1635 ;;;
1636 (defun tinyurl-install-command-table (&optional force)
1637   "Set default values to `tinyurl-:command-table'. FORCE reset."
1638   (if force
1639       (tinyurl-command-table-defaults-set)
1640     (or tinyurl-:command-table
1641         (tinyurl-command-table-defaults-set)))
1642   ;;  Some safety measure needed..
1643   (unless (stringp (caar tinyurl-:command-table))
1644     (error "TinyUrl: Setting `tinyurl-:command-table' failed."))
1645   ;;  Set default only if it is NIL
1646   (unless (stringp tinyurl-:command-table-current)
1647     (setq tinyurl-:command-table-current
1648           (tinyurl-user-command-table-default))))
1649
1650 ;;; ----------------------------------------------------------------------
1651 ;;;
1652 (defun tinyurl-modeline-update ()
1653   "Update modeline name."
1654   (tinyurl-install-command-table)
1655   (tinyurl-plugged-update)
1656   (setq tinyurl-:mode-name
1657         (concat " U"
1658                 (downcase (ti::string-left tinyurl-:command-table-current 1))
1659                 (if (funcall tinyurl-:plugged-function)
1660                     "!" "")))
1661   (ti::compat-modeline-update))
1662
1663 ;;; ----------------------------------------------------------------------
1664 ;;;
1665 (defsubst tinyurl-set-mouse-maybe (event)
1666   "Set point to mouse EVENT and mark URLs in the line."
1667   (when (and event (null tinyurl-:mouse-yank-at-point))
1668     (goto-char (ti::mouse-point event))
1669     (tinyurl-mark-line)))
1670
1671 ;;; ----------------------------------------------------------------------
1672 ;;;
1673 (defsubst tinyurl-table (table)
1674   "Return command TABLE."
1675   (or (nth 1 (assoc table tinyurl-:command-table))
1676       (prog1 nil)))
1677         ;; (message "TinyUrl: [ERROR] No such command table: [%s] " table)
1678
1679 ;;; ----------------------------------------------------------------------
1680 ;;;
1681 (defun tinyurl-table-current (&optional table)
1682   "Return copy of active command table.
1683 References:
1684   `tinyurl-:display-glyph'"
1685   (let* ((table (tinyurl-table
1686                  (or table
1687                      tinyurl-:command-table-current))))
1688     (when (and table
1689                (null tinyurl-:display-glyph))
1690       ;;  Make local copy and changing `before-string' to ""
1691       (setq table (copy-tree table))
1692       (setcar (nthcdr 1 (member
1693                          (if (ti::emacs-p)
1694                              'before-string
1695                            'begin-glyph)
1696                          (nth 1 (assq 'overlay-plist table))))
1697               (if (ti::emacs-p)
1698                   ""
1699                 (ti::funcall 'make-glyph ""))))
1700     table))
1701
1702 ;;; ----------------------------------------------------------------------
1703 ;;;
1704 (defsubst tinyurl-overlay-plist (&optional table)
1705   "Return overlay plist of TABLE."
1706   (nth 1 (assq 'overlay-plist (tinyurl-table-current table))))
1707
1708 ;;; ----------------------------------------------------------------------
1709 ;;;
1710 (defsubst tinyurl-agent-function (type)
1711   "Return agent function for TYPE. See `tinyurl-:command-table'."
1712   (let ((elt (cdr (assq type (tinyurl-table-current)))))
1713     (unless elt
1714       (error "Tinyurl: Unknown type %s" type))
1715     (tinyurl-debug "tinyurl-agent-function" elt)
1716     elt))
1717
1718 ;;; ----------------------------------------------------------------------
1719 ;;;
1720 (defsubst tinyurl-agent-funcall (type url)
1721   "Call correct function according to TYPE and pass it an URL."
1722   (funcall (tinyurl-agent-function type) url))
1723
1724 ;;; ----------------------------------------------------------------------
1725 ;;;
1726 (defsubst tinyurl-types ()
1727   "Return known url types in `tinyurl-:command-table-current'."
1728   (mapcar 'car (tinyurl-table-current)))
1729
1730 ;;; ----------------------------------------------------------------------
1731 ;;;
1732 (defun tinyurl-mouse-binding (event)
1733   "Jump to URL at point or call original function with mouse EVENT."
1734   (interactive "e")
1735   (setq tinyurl-:event event)
1736   (tinyurl-dispatcher event 'mouse))
1737
1738 ;;; ----------------------------------------------------------------------
1739 ;;;
1740 (defun tinyurl-mouse-binding-down (event)
1741   "Jump to URL at point or call original function with mouse EVENT."
1742   (interactive "e")
1743   (setq tinyurl-:event event)
1744   (put 'tinyurl-:event 'down-event event))
1745
1746 ;;; ----------------------------------------------------------------------
1747 ;;;
1748 (defun tinyurl-key-binding-default ()
1749   "Jump to URL at point or call original ESC RET key binding."
1750   (interactive)
1751   (setq tinyurl-:event nil)
1752   (tinyurl-mark-line)
1753   (tinyurl-dispatcher "\e\C-m" 'key))
1754
1755 ;;; ----------------------------------------------------------------------
1756 ;;;
1757 (defsubst tinyurl-overlay-get (&optional point)
1758   "Reeturn overlay from current POINT if there is any '(owner tinyurl)."
1759   (let* ((list (overlays-at (or point (point)))))
1760     (if list
1761         (ti::overlay-get-prop list '(owner tinyurl)))))
1762
1763 ;;; ----------------------------------------------------------------------
1764 ;;;
1765 (defsubst tinyurl-get-filter (url)
1766   "Return filter or any for URL."
1767   (cdr-safe (ti::list-find (delq nil tinyurl-:file-filter-table) url)))
1768
1769 ;;; ----------------------------------------------------------------------
1770 ;;;
1771 (defun tinyurl-filter-pod (url)
1772   "Handle Perl pod URL."
1773   (let* ((pod   (or (get 'tinyurl-filter-pod 'pod2text)
1774                     (executable-find "pod2text")
1775                     (message "TinyUrl: No `pod2text' command found.")
1776                     nil))
1777          (buffer  shell-command-output-buffer))
1778     (put 'tinyurl-filter-pod 'pod2text pod)
1779     (if (null pod)
1780         (find-file url)
1781       (call-process pod nil buffer nil url)
1782       (when (and (get-buffer buffer)
1783                  (featurep 'tinyperl))
1784         (with-current-buffer buffer
1785           (turn-on-tinyperl-pod-view-mode))
1786         (ti::pop-to-buffer-or-window buffer)))))
1787
1788 ;;; ----------------------------------------------------------------------
1789 ;;;
1790 (defun tinyurl-overlay-kill  ()
1791   "Kill used overlays.
1792 This function only kills overlays recoded to internal list.
1793 The internal list may be inaccurate. To completely wipe out
1794 TinyUrl owned overlays, use `tinyurl-overlay-kill-in-buffer'."
1795   (put 'tinyurl-mark-line 'point nil)
1796   (dolist (ov (get 'tinyurl-mark-line 'ov-list))
1797     (delete-overlay ov)))
1798
1799 ;;; ----------------------------------------------------------------------
1800 ;;;
1801 (defun tinyurl-overlay-kill-in-buffer  ()
1802   "Kill TinyUrl overlays from whole buffer. See also `tinyurl-overlay-kill'."
1803   (interactive)
1804   (put 'tinyurl-mark-line 'point nil)
1805   (ti::overlay-remove-region
1806    (point-min)
1807    (point-max)
1808    '(owner tinyurl)
1809    'prop-val-list))
1810
1811 ;;; ----------------------------------------------------------------------
1812 ;;;
1813 (defun tinyurl-dispatch-ignore-p  (&rest dummy)
1814   "Check if control is passed back to underlying mode. Ignore DUMMY."
1815   (memq major-mode '(archive-mode
1816                      dired-mode
1817                      dired-virtual-mode
1818                      tar-mode
1819                      zip-mode)))
1820
1821 ;;; ----------------------------------------------------------------------
1822 ;;;
1823 (defun tinyurl-dispatcher-1  (url)
1824   "Redirect URL to proper agent handler."
1825   (interactive)
1826   (let* ((fid                       "tinyurl-dispatcher-1:")
1827          (tinyurl-:file-filter-table  tinyurl-:file-filter-table) ;; make copy
1828          url-type
1829          tmp
1830          ret)
1831     ;; ....................................................... do-it ...
1832     (cond
1833      ((and tinyurl-:validate-hook
1834            (not (eq t (setq ret (run-hook-with-args-until-success
1835                                  'tinyurl-:validate-hook url)))))
1836       (if (not (stringp ret))
1837           (message "TinyUrl: url ignored. See tinyurl:-url-validate-hook")
1838         (message ret)))
1839      (t ;; it's ok
1840       (when current-prefix-arg
1841         (setq url (read-from-minibuffer
1842                    "(TinyUrl) edit: "
1843                    url
1844                    nil
1845                    nil
1846                    'tinyurl-:history))
1847         ;; User can also control the access method, But beware.
1848         ;; Trying to call Url that is not Perl type is disastrous
1849         (unless (ti::nil-p url)
1850           (setq url-type
1851                 (intern
1852                  (completing-read
1853                   "(TinyUrl) Select type: "
1854                   (ti::list-to-assoc-menu
1855                    (mapcar 'symbol-name (tinyurl-types)))
1856                   nil
1857                   'match-needed
1858                   (if (tinyurl-type url)
1859                       (symbol-name (tinyurl-type url))
1860                     nil)))))
1861         (when (and (setq tmp (tinyurl-get-filter url))
1862                    (y-or-n-p
1863                     (format "(TinyUrl) By-pass filter [%s]? "
1864                             (prin1-to-string tmp))))
1865           (setq tinyurl-:file-filter-table nil))) ;; when
1866       (tinyurl-debug fid url-type tinyurl-:url-handler-function url)
1867       (if (not (ti::nil-p url))
1868           (funcall tinyurl-:url-handler-function url url-type))))))
1869
1870 ;;; ----------------------------------------------------------------------
1871 ;;;
1872 (defun tinyurl-gnus-callback-at-point ()
1873   "Return gnus-callback text property at point."
1874   (get-text-property (point) 'gnus-callback))
1875
1876 ;;; ----------------------------------------------------------------------
1877 ;;;
1878 (defun tinyurl-call-original-mouse (event)
1879   "Call original mouse-2 function, unless in compilation buffer."
1880   (let* ((mode      (symbol-name major-mode))
1881          (function
1882           (let* ((local (current-local-map))
1883                  tinyurl-mode)
1884             (or (and local
1885                      (if (ti::emacs-p)
1886                          (lookup-key local [mouse-2])
1887                        (lookup-key local [(button2)])))
1888                 (if (ti::emacs-p)
1889                     (lookup-key global-map [mouse-2])
1890                   (lookup-key global-map [(button2)]))))))
1891     (if (and (string-match "yank" (symbol-name function))
1892              (or (string-match "compil" mode) ;compilation, compile
1893                  buffer-read-only))
1894         (message "TinyUrl: Nothing to (yank) here.")
1895       (ti::compat-mouse-call-original 'tinyurl-mode event))))
1896
1897 ;;; ----------------------------------------------------------------------
1898 ;;;
1899 (defun tinyurl-gnus-data-at-point ()
1900   "Return gnus-data text property at point."
1901   (get-text-property (point) 'gnus-data))
1902
1903 ;;; ----------------------------------------------------------------------
1904 ;;;
1905 (defun tinyurl-dispatcher (&optional event type)
1906   "See if there is URL at point. Otherwise act like usual key/mouse call.
1907
1908 Input:
1909
1910   EVENT     mouse-event or key binding
1911   TYPE      'mouse or 'key. The EVENT type"
1912
1913   (let* ((ov     (tinyurl-overlay-get))
1914          (url    (and ov
1915                       (ti::overlay-buffer-substring ov 'no-properties)))
1916          (nok-p  (or (null url)
1917                      (and tinyurl-:dispatch-hook
1918                           (run-hook-with-args-until-success
1919                            'tinyurl-:dispatch-hook
1920                            url
1921                            (cons (current-buffer) (point))))))
1922          ;; (mouse-2 . gnus-article-push-button)
1923          ;; (gnus-callback gnus-article-toggle-cited-text)
1924          (gnus-callback  (tinyurl-gnus-callback-at-point))
1925          (gnus-data      (tinyurl-gnus-data-at-point)))
1926     ;;  Notice that if you add text near the overlay, the overlay
1927     ;;  starts stretching an the beg end point do not accurately
1928     ;;  designate the URL.
1929     ;;
1930     ;;  Also see this example url that may be in quotes, "ftp://foo.com/"
1931     ;;  or surrounded by parenthesis, whatever. We remove invalid
1932     ;;  characters. The "#" must stay, ebacsue it's NAME tag inside URL
1933     ;;
1934     ;;    ftp://foo.com/this.txt#tag
1935     ;;    ftp://foo.com/perl.pl?params
1936
1937     (when (eq type 'mouse)
1938       (tinyurl-set-mouse-maybe event))
1939     (cond
1940      (nok-p
1941       (cond
1942        ((eq type 'mouse)
1943         ;;  The underlying application may have defined down-event; like
1944         ;;  widget.el does in Gnus. In that case; we must give priority
1945         ;;  to down-event. Otherwise call normal mouse-2 event.
1946         (let* ((down-event (get 'tinyurl-:event 'down-event))
1947                (down-func  (if down-event
1948                                (ti::compat-mouse-call-original-function
1949                                 'tinyurl-mode
1950                                 down-event))))
1951           ;;  Now clear events, so that these old ones are not used.
1952           (setq tinyurl-:event nil)
1953           (put 'tinyurl-:event 'down-event nil)
1954           (cond
1955            (gnus-callback
1956             (funcall gnus-callback gnus-data))
1957            ((and down-func
1958                  (fboundp down-func))
1959             (tinyurl-call-original-mouse down-event))
1960            (t
1961             (tinyurl-call-original-mouse event)))))
1962        (t
1963         (ti::compat-key-call-original 'tinyurl-mode event))))
1964      (t
1965       (tinyurl-dispatcher-1 url)))))
1966
1967 ;;; ----------------------------------------------------------------------
1968 ;;;
1969 (defun tinyurl-at-point (&optional verb)
1970   "Mark line for urls and go to the url at point if any. VERB."
1971   (interactive)
1972   (ti::verb)
1973   (tinyurl-mark-line)
1974   (let* ((ov    (tinyurl-overlay-get))
1975          (URL   (and ov
1976                      (buffer-substring-no-properties
1977                       (overlay-start ov) (overlay-end ov)))))
1978     (cond
1979      (URL
1980       (funcall tinyurl-:url-handler-function))
1981      (verb
1982       (message "TinyUrl: No url found.")))))
1983
1984 ;;; ----------------------------------------------------------------------
1985 ;;;
1986 (defun tinyurl-validate-url-default (url)
1987   "Default URL validate.
1988 - Discard foo|bar|quux urls and character $, like in $THIS_DIR.
1989 - Discard Files that do not exist.
1990 - Discard all /dev or /proc files
1991
1992 Return:
1993
1994   t         URL accepted
1995   string    Error Message."
1996
1997   (let* ((fid  "tinyurl-validate-url-default:")
1998          (info (ti::file-path-and-line-info url)) ;FILE:NBR --> FILE
1999          (type (tinyurl-type url))
2000          ret)
2001     (if info
2002         (setq url (car info)))
2003     (setq
2004      ret
2005      (cond
2006       ((string-match "^/\\(dev\\|proc\\)/" url)
2007        (format "TinyUrl: (url validate) Device file ignored"))
2008       ((string-match
2009         (concat
2010          "^\\(/usr\\(/local\\)?\\|/opt\\|/vol\\)?/s?bin/"
2011          ;; Ehm. What to do with Windows and Cygwin Files? This is
2012          ;; an approximation
2013          "\\|^C:[\\/]win")
2014         url)
2015        (format "TinyUrl: (url validate) Binary file ignored"))
2016       ((ti::file-name-remote-p url)
2017        t)                               ;do not check ange-ftp
2018       ((or (string-match "\\<\\(foo\\|bar\\|quux\\)" url)
2019            (string-match "\\$" url))
2020        (format "TinyUrl: (url validate) Invalid keyword '%s' in URL [%s]"
2021                (match-string 0 url)
2022                url))
2023       ((and (string-match "^[~/\\]\\|^[a-z]:[/\\]" url)
2024             ;; Ange is called if file contains :, prevent it
2025             (not (string-match "^/[a-z]+@[0-9a-z.-]+:" url))
2026             (not (file-exists-p url)))
2027        (format "TinyUrl: (url validate) File not found [%s]" url))
2028       ((and (string-match "file" (symbol-name type))
2029             (stringp tinyurl-:reject-url-regexp)
2030             (string-match tinyurl-:reject-url-regexp url))
2031        "TinyUrl: (url validate) rejected by `tinyurl-:reject-url-regexp'")
2032       ((and (string-match (or (ti::id-info nil 'cache) "")  "perl")
2033             (save-excursion
2034               (beginning-of-line)
2035               (looking-at
2036                (concat
2037                 ".*\\("
2038                 "=~\\|!~\\|=!"          ; =~  or !~ =!
2039                 "\\|! *m?/"             ; if ( ! /this/ )
2040                 "\\|if[ \t]+m?/"        ; $1 if /match/
2041                 "\\|=[ \t]+m?/"         ; = m/this/
2042                 "\\|\\<s/"              ; s/this/that
2043                 "\\|\\<qq?/"            ; q/word word word/;
2044                 "\\)"))))
2045        (concat "TinyUrl: (url validate) Perl like statement rejected: "
2046                (match-string 1)))
2047       (t
2048        t)))
2049     (tinyurl-debug fid url ret)
2050     ret))
2051
2052 ;;; ----------------------------------------------------------------------
2053 ;;;
2054 (defun tinyurl-validate-url-perl-method (url)
2055   "Check Perl Foo::Bar->new(...)."
2056   (cond
2057    ((not (string-match "perl" (ti::id-info)))
2058     "TinyUrl: (perl url validate) rejected due to non-perl buffer")
2059    (t
2060     t))) ;; accept
2061
2062 ;;; ----------------------------------------------------------------------
2063 ;;;
2064 (defun tinyurl-validate-url-email (url)
2065   "Accept email url only if it doesn't overlap with http://.
2066 E.g. Following url would be targetted as email, because it has <.*@.*>
2067
2068 <URL:http://groups.google.com/groups?as_q=&as_umsgid=3cgd8m0w.fsf@blue.sea.net>"
2069   (cond
2070    ((string-match "http://\\|file:/\\|ftp://" url)
2071     "TinyUrl: (email url validate) rejected due to URI reference: %s" url)
2072    ((not (string-match
2073           "[0-9a-z.-]+@[0-9a-z]+\\(\\.[0-9a-z-]+\\)*\\.[a-z]+>?$" url))
2074     "TinyUrl: (email url validate) does no look like mail address: %s" url)
2075    (t
2076     t))) ;; accept
2077
2078 ;;}}}
2079 ;;{{{ URL handler
2080
2081 ;;; ----------------------------------------------------------------------
2082 ;;;
2083 (defun tinyurl-find-url-lisp (url)
2084   "Find Emacs Llisp package URL."
2085   (let* ((file (ti::string-match "[\"']\\([^\"')]+\\)" 1 url)))
2086     (when file
2087       (setq file (replace-regexp-in-string "c$" "" file))
2088       (setq file (ti::string-verify-ends file "\\.el" ".el")))
2089     (cond
2090      ((null file)
2091       (message "TinyUrl: Odd url %s" url))
2092      ((null (setq file (locate-library file)))
2093       (message "TinyUrl: %s  not found from lisp `load-path'" url))
2094      (t
2095       (find-file file)))))
2096
2097 ;;; ----------------------------------------------------------------------
2098 ;;;
2099 (defun tinyurl-find-debian-bts-bug (url)
2100   "Find Debian BTS bug URL."
2101   (let (bug)
2102     (when (setq bug (ti::string-match "\\([0-9]+\\)" 1 url))
2103       (if (eq (length bug) 6)
2104           (tinydebian-bug-browse-url-by-bug bug)
2105         (message "TinyUrl: Incorrect bug number %s" bug)))))
2106
2107 ;;; ----------------------------------------------------------------------
2108 ;;;
2109 (defun tinyurl-find-url-php-compile (url)
2110   "Find PHP compiler error URL."
2111   ;; <b>Parse error</b>:  parse error in <b>FILE.php</b> on line <b>161</b><br>
2112   (let* ((file (ti::string-match
2113                 "parse error in <b>\\([^<\n]+\\)</b> *on line"
2114                 1
2115                 url))
2116          (line (ti::string-match
2117                 "parse error in.*on line <b>\\([0-9]+\\)"
2118                 1
2119                 url)))
2120     (if (null line)                   ;Quiet byte compiler: unused var
2121         (setq line nil))
2122     ;; FIXME:  Actually the general FILE-FIND URL method already can grab
2123     ;; the filename and jump to the correct location, so I'm not sure we need
2124     ;; specific PHP url handler.
2125     (if file ;; This is no-op, quiet byte compiler for now.
2126         (setq file file))))
2127
2128 ;;; ----------------------------------------------------------------------
2129 ;;;
2130 (defun tinyurl-find-url-perl-pod-manpage (url)
2131   "Find perl POD manpage URL."
2132   (setq url (ti::string-match "perl[^] ,.\n\t]+" 0 url))
2133   (let* (point)
2134     ;; Check if the referenced pod page is on the current buffer
2135     ;; NAME
2136     ;;    perlfunc - Perl builtin functions
2137     ;;
2138     ;; DESCRIPTION
2139     (setq point (ti::re-search-check (format "NAME\n +%s -" url)))
2140     (if point
2141         (goto-char point)
2142       (tinyperl-pod-by-manpage (tinyperl-pod-manpage-to-file url)))))
2143
2144 ;;; ----------------------------------------------------------------------
2145 ;;;
2146 (defun tinyurl-find-url-perl-pod-module (url)
2147   "Find perl POD page: URL."
2148   (setq url (replace-regexp-in-string " +manpage" "" url))
2149   (tinyperl-pod-by-module (tinyperl-pod-manpage-to-file url)))
2150
2151 ;;; ----------------------------------------------------------------------
2152 ;;;
2153 (defun tinyurl-find-url-perl-1 (file &optional method)
2154   "Go to Perl FILE and put point to optional METHOD."
2155   (let* ((regexp (if method
2156                      (concat "^[ \t]*sub[ \t\n\r]*"
2157                              method
2158                              "\\>")))
2159          elt)
2160     (if (null (setq elt (tinyperl-locate-library file)))
2161         (message "TinyUrl: No Perl module found, %s" file)
2162       (switch-to-buffer (tinyperl-library-find-file elt))
2163       (when method
2164         (unless (re-search-forward regexp nil t)
2165           (message "TinyUrl: Hm, can't find sub using [%s]" regexp))))))
2166
2167 ;;; ----------------------------------------------------------------------
2168 ;;;
2169 (defun tinyurl-find-url-perl-method (url)
2170   "Find Perl Foo::Bar->new(...) URL."
2171   (let* (file
2172          method)
2173     (when (string-match "\\([^ \t\n]+\\)->\\([^ \t\n]+\\)" url)
2174       (setq file   (match-string 1 url)
2175             method (match-string 2 url)))
2176     (cond
2177      ((null file)
2178       (message "TinyUrl: Opps, odd perl URL %s" url)
2179       (sleep-for 1))
2180      (t
2181       (tinyurl-find-url-perl-1 file method)))))
2182
2183 ;;; ----------------------------------------------------------------------
2184 ;;;
2185 (defun tinyurl-find-url-perl (url)
2186   "Find Perl `require' and `use' URL."
2187   (let* (file)
2188     (cond
2189      ((setq file (ti::string-match
2190                   "use[ \t]+\\([^ \t\n;]+\\)" 1 url))
2191       (setq file (concat file ".pm")))
2192      ((setq file (ti::string-match
2193                   "require[ \t'\"]+\\([^ '\"\t\n;]+\\)" 1 url))))
2194     (cond
2195      ((null file)
2196       (message "TinyUrl: Opps, odd perl URL %s" url)
2197       (sleep-for 1))
2198      (t
2199       (tinyurl-find-url-perl-1 file)))))
2200
2201 ;;; ----------------------------------------------------------------------
2202 ;;;
2203 (defun tinyurl-find-url-perl-compile  (url &optional noerr)
2204   "Parse Perl compile output style URL.
2205
2206     error in file FILE at line LINE
2207     at FILE line LINE.
2208
2209 If NOERR is non-nil, signal no error if file does not exist."
2210   (let* ((fid "tinyurl-find-url-perl-compile:")
2211          file
2212          line)
2213     (cond
2214      ((or (string-match "in file +\\([^ \t\n]+\\) at line \\([0-9]+\\)" url)
2215           (string-match "at +\\([^ \t\n]+\\) line \\([0-9]+\\)" url))
2216       (setq file (match-string 1 url)
2217             line (string-to-int (match-string 2 url)))))
2218     (tinyurl-debug fid 'url url 'file file 'line line)
2219     (if (null file)
2220         (error "Tinyurl: Can't recognize URL [%s]" url))
2221
2222     (cond
2223      ((or (ti::find-file-or-window file line 'must-exist)
2224           ;;  drop path name
2225           (ti::find-file-or-window (file-name-nondirectory file)
2226                                    line 'must-exist))
2227       t)                                ;ok
2228      (t
2229       (unless noerr
2230         (error "TinyUrl: Can't locate %s" file))
2231       nil))))
2232
2233 ;;; ----------------------------------------------------------------------
2234 ;;;
2235 (defun tinyurl-file-name-filter  (url &optional line)
2236   "Check URL and LINE for filter in `tinyurl-:file-filter-table'.
2237 Return:
2238   non-nil if Filter was used."
2239   (let* ((filter (tinyurl-get-filter url)))
2240     (tinyurl-debug "tinyurl-file-name-filter" url filter)
2241     (cond
2242      ((stringp filter)
2243       (shell-command (format filter url))
2244       t)
2245      ((and (not (ti::bool-p filter))
2246            (fboundp filter))
2247       (funcall filter url)))))
2248
2249 ;;; ----------------------------------------------------------------------
2250 ;;;
2251 (defun tinyurl-guess-line-number-at-point ()
2252   "Read current line and guess the line number."
2253   (let* ()
2254     (save-excursion
2255       (beginning-of-line)
2256       (cond
2257        ((looking-at ".*[ \t]+line[ \t]+\\([0-9]+\\)")
2258         (string-to-int (match-string 1)))
2259        ((looking-at ".*on line +<b>\\([0-9]+\\)</b>")
2260         ;; PHP writes HTML =>   </b> on line <b>161</b><br>
2261         (string-to-int (match-string 1)))
2262        ((looking-at "^.+:\\([0-9]+\\):")
2263         ;;  Grep output
2264         ;; test.pl:119:use integer;
2265         (string-to-int (match-string 1)))))))
2266
2267 ;;; ----------------------------------------------------------------------
2268 ;;;
2269 (defun tinyurl-find-url-file (url &optional line)
2270   "Go to ULR and optional LINE.
2271 If LINE is not given, it is guessed freom the context.
2272 Convert URL ftp:// to ange-ftp format and use `find-file'."
2273   (let* ((fid  "tinyurl-find-url-file: ")
2274          (info (ti::file-path-and-line-info url)))
2275     (when info
2276       (setq url (car info)))
2277     (unless line
2278       (setq line (tinyurl-guess-line-number-at-point)))
2279     (setq url (cond
2280                ((string-match "://" url)
2281                 (ti::string-url-to-ange-ftp url))
2282                ((string-match "file:\\(.*\\)" url)
2283                 (match-string 1 url))
2284                (t
2285                 url)))
2286     (tinyurl-debug fid 'URL url 'INFO info 'LINE line)
2287     (unless (integerp line) ;; Make sure it's integer
2288       (setq line nil))
2289     (cond
2290      ((tinyurl-file-name-filter url line))
2291      (t
2292       (ti::select-frame-non-dedicated)
2293       (prog1 (ti::find-file-or-window url line (not 'must-exist) info)
2294         (when info
2295           (goto-line (cdr info))))))))
2296
2297 ;;; ----------------------------------------------------------------------
2298 ;;;
2299 (defun tinyurl-find-url-mail-browse-url (url)
2300   "Call brose-url with argument URL"
2301   (unless (string-match "^mailto:" url)
2302     ;;  Needed due to `browse-url-browser-function' which contains
2303     ;;     '(("^mailto:" . browse-url-mail) ...
2304     (setq url (concat "mailto:"  url))
2305     (browse-url url)))
2306
2307 ;;; ----------------------------------------------------------------------
2308 ;;;
2309 (defun tinyurl-find-url-mail (url)
2310   "Ignore URL and call 'mail."
2311   (if (fboundp 'compose-mail)
2312       (call-interactively 'compose-mail) ;New Emacs
2313     (call-interactively 'mail-other-window)))
2314
2315 ;;; ----------------------------------------------------------------------
2316 ;;;
2317 (defun tinyurl-find-url-man (url)
2318   "Manpage URL handler."
2319   ;; Url can have leading or trailing spaces: "   crontab  (5)   "
2320   (let* ((program (if (string-match "[^ \t\r\n()]+" url)
2321                       (match-string 0 url)))
2322          (page    (if (string-match "(\\([^ \t\r\n()]+\\)" url)
2323                       (match-string 1 url)))
2324          (ref     (cond
2325                    ((and page
2326                          ;; skip basic references like: cut(1)
2327                          (> (string-to-int page) 1))
2328                     (format "%s(%s)" program page))
2329                    (program
2330                     program))))
2331     (man ref)))
2332
2333 ;;; ----------------------------------------------------------------------
2334 ;;; FIXME: What about various mailing list archives?
2335 ;;; FIXME: Perhaps Message-id query should be delegated to proper archives
2336 ;;;
2337 (defun tinyurl-find-url-message-id (url)
2338   "Get URL by Message-id."
2339   (unless (setq url (ti::string-match "<\\([^ \t\n>]+\\)>" 1 url))
2340     (error "TinyMail: invalid Message-id. Missing <>"))
2341   (tinyurl-debug "tinyurl-find-url-message-id" url)
2342   (setq url
2343         (concat
2344          "http://groups.google.com/groups?as_q=&as_umsgid="
2345          url
2346          ""))
2347   (tinyurl-agent-funcall 'url url))
2348
2349 ;;; ----------------------------------------------------------------------
2350 ;;;
2351 (defun tinyurl-find-url-http (url)
2352   "Simple 'www.*' URL handler."
2353   (unless (string-match "://" url)
2354     (setq url (concat "http://" url)))
2355   (tinyurl-debug "tinyurl-find-url-http" url)
2356   (tinyurl-agent-funcall 'url url))
2357
2358 ;;; ----------------------------------------------------------------------
2359 ;;;
2360 (defun tinyurl-find-url-win32-netscape (url)
2361   "External URL handler."
2362   (tinyurl-call-process-win32 "netscape" url))
2363
2364 ;;; ----------------------------------------------------------------------
2365 ;;;
2366 (defun tinyurl-find-url-win32-iexplore (url)
2367   "External URL handler."
2368   (tinyurl-call-process-win32 "iexplore" url))
2369
2370 ;;; ----------------------------------------------------------------------
2371 ;;;
2372 (defun tinyurl-cache-url (url)
2373   "Add URL to the beginning of buffer `tinyurl-:url-cache-buffer'."
2374   (let* ((buffer (get-buffer-create tinyurl-:url-cache-buffer)))
2375     (tinyurl-debug "tinyurl-cache-url" url)
2376     (if (eq (current-buffer) buffer)
2377         (error "TinyUrl: Can't cache URL in `tinyurl-:url-cache-buffer'")
2378       (with-current-buffer buffer
2379         (ti::pmin)
2380         (unless tinyurl-mode (tinyurl-mode-1 1))
2381         (if (re-search-forward (format "^%s$" (regexp-quote url)) nil t)
2382             (message "TinyUrl: already cached %s" url)
2383           (insert url "\n")
2384           (message "TinyUrl: cached %s" url))))))
2385
2386 ;;; ----------------------------------------------------------------------
2387 ;;;
2388 (defun tinyurl-url-clean (url type)
2389   "Clean URL if needed."
2390   (if (not (tinyurl-type-external-p url type))
2391       url
2392     (if (stringp tinyurl-:cleaner-regexp)
2393         (replace-regexp-in-string
2394          tinyurl-:cleaner-regexp "" url)
2395       url)))
2396
2397 ;;; ----------------------------------------------------------------------
2398 ;;;
2399 (defun tinyurl-type (url)
2400   "Return type of URL. Or all types if TYPES id non-nil, URL is then ignored.
2401 Returned types (symbols) are:
2402
2403   (external) url
2404              url-http
2405              url-ftp url-ange
2406              url-debian-bts
2407   (other)    mail
2408              file-code-lisp
2409              file-code-perl
2410              file-code-perl-pod-manpage
2411              file-code-perl-pod-module
2412              file-code-perl-method
2413              file-code-c
2414              file-packed
2415              file
2416              compiler-perl"
2417   (cond
2418    ;; .................................................... browser url ...
2419    ((string-match
2420      "Message-id:\\|References:\\|In[ \n\t]+Article[ \n\t]+"
2421      url) 'url-message-id)
2422    ((string-match  "\\(https?\\|telnet\\|wais\\|news\\|file\\):" url) 'url)
2423    ((string-match  "^[ \t]*www\\." url)         'url-http)
2424    ;;  my.site.com/dir/dir
2425    ((string-match  "^[^/]+\\....?/" url)        'url-http)
2426    ;;  Treat .html files through browser
2427    ((string-match  "ftp:[^ \t\n]+\\.s?html?" url) 'url-http)
2428    ((string-match  "ftp:" url)                    'url-ftp)
2429    ((string-match  "/[^@\n]+@[^@\n]+:" url)     'url-ange)
2430    ((string-match  "@\\|mailto:" url)           'mail)
2431    ((string-match
2432      "#[0-9]+\\>\\|\\<\\(RF.\\|IT.\\|O\\) +[0-9]+" url)
2433     'url-debian-bts)
2434    ;; ........................................................... code ...
2435    ((string-match  "(\\(load\\|load-library\\|require\\) " url)
2436     'file-code-lisp)
2437    ((string-match  "use \\|require " url)       'file-code-perl)
2438    ((string-match  "::.*->" url)                'file-code-perl-method)
2439    ;;  in the perlipc manpage.
2440    ;;  See p.264 in [perlipc]
2441    ((string-match "perl[^ \t\n]+[ \t\n]+manpage\\|\\[perl[^ \n\t]+\\]" url)
2442     'file-code-perl-pod-manpage)
2443    ((string-match "\\<perl[^ \t\n]+\\." url)
2444     'file-code-perl-pod-manpage)
2445    ((string-match "::.*manpage" url)            'file-code-perl-pod-module)
2446    ((string-match  "#include" url)              'file-code-c)
2447    ;; ...................................................... compilers ...
2448    ((string-match " parse error in <b>.*</b> on line" url)
2449     'compiler-php-at-line)
2450    ((string-match " in file.*at line " url)     'compiler-perl-in-file-at-line)
2451    ((string-match " at .* line " url)           'compiler-perl-at-line)
2452    ;; ................................................... system files ...
2453    ((string-match "\\.tar\\|\\.gz\\.tgz" url)   'file-packed)
2454    ((string-match "[/\\]" url)                  'file)
2455    ((string-match "^[^ \t\n]+:[0-9]+:" url)     'file) ;; file.txt:line:
2456    ((string-match "[a-z.]+(.*)" url)            'man)))
2457
2458 ;;; ----------------------------------------------------------------------
2459 ;;;
2460 (defun tinyurl-type-external-p (url type)
2461   "Check if TYPE is external. URL is unused."
2462   (string-match "url\\|ftp" (symbol-name type)))
2463
2464 ;;; ----------------------------------------------------------------------
2465 ;;;
2466 (defun tinyurl-handler-mail-after (url &optional type)
2467   "Compose URL as mail. Optional TYPE can be given."
2468   (let ((fid "tinyurl-handler-mail-after")
2469         point
2470         to
2471         subject)
2472     (catch 'done
2473       ;;  ffap would send mailto: to the ffap-url-fetcher which
2474       ;;  usually is 'browse-url-netscape, but you really
2475       ;;  don't want to compose mail with it...
2476       (setq url (replace-regexp-in-string "mailto:" "" url))
2477       ;; mailto:a@b.com?subject=test
2478       (setq to      (ti::string-match "[^?]+" 0 url)
2479             subject (ti::string-match "\\?Subject=\\([^?]+\\)" 1 url))
2480       ;;  This can also be a external call, like Mozilla mail...
2481       (tinyurl-debug fid 'url url 'to to 'subject subject)
2482       (tinyurl-agent-funcall 'mail url)
2483       (setq point (point))
2484       (ti::pmin)
2485       (unless (re-search-forward "^To: " nil t)
2486         (goto-char point)
2487         (throw 'done))
2488       (insert to)
2489       (ti::pmin)
2490       (unless (re-search-forward "^Subject: "  nil t)
2491         (goto-char point)
2492         (message "TinyUrl: [ERROR] Cannot continue,Subject: not found")
2493         (throw 'done))
2494       (when subject
2495         (insert (replace-regexp-in-string "[%]20" " " subject))
2496         (ti::mail-text-start 'move))
2497       ;;   We can be a bit smarter, Usually the mailing linst have
2498       ;;   address xxx-request@foo.com, so add implicit "subsribe"
2499       ;;   to the subject fields. User may add "un" if he wants that
2500       ;;   instead.
2501       (save-excursion
2502         (cond
2503          ((string-match "-request@" clean)
2504           (insert "subscribe")))))))
2505
2506 ;;; ----------------------------------------------------------------------
2507 ;;;
2508 (defun tinyurl-handler-main (url &optional type)
2509   "Handle URL and forward it to right agent function. TYPE of url can be given.
2510 References: `tinyurl-:command-table'"
2511   (let* ((fid       "tinyurl-handler-main")
2512          (raw-list '(url-message-id
2513                      compiler-perl-in-file-at-line
2514                      compiler-perl-at-line))
2515          (unplugged (not (funcall tinyurl-:plugged-function)))
2516          func
2517          to
2518          subject
2519          clean)
2520     (or type
2521         (setq type (tinyurl-type url)))
2522     (setq clean  (tinyurl-url-clean url type))
2523     (tinyurl-debug fid 'TYPE type 'URL url 'CLEAN clean 'PLUGGED unplugged)
2524     (message "TinyUrl: Accessing %s" clean)
2525     (cond
2526      ((eq type nil)
2527       (message "TinyUrl: Strange Error, Couldn't detect URL type: [%s] [%s]"
2528                url clean))
2529      ((eq type 'mail)
2530       (tinyurl-handler-mail-after clean type))
2531      (t
2532       (if (and (tinyurl-type-external-p clean type)
2533                unplugged)
2534           (tinyurl-cache-url url)
2535         (setq func (tinyurl-agent-function type))
2536         (tinyurl-debug fid 'LAST-CASE-TYPE type 'FUNC func 'URL url clean)
2537         (tinyurl-debug fid 'FUNCALL func 'URL url 'CLEAN clean)
2538         (if (memq type raw-list)
2539             (funcall func url)          ;RAW
2540           (funcall func clean)))))))
2541
2542 ;;}}}
2543 ;;{{{ Marking line
2544
2545 ;;; ----------------------------------------------------------------------
2546 ;;;
2547 (defun tinyurl-mark-process-post-command  ()
2548   "Used in `post-command-hook'."
2549   (when tinyurl-mode
2550     (let* (counter)
2551       (unless (integerp (setq counter (get 'tinyurl-mode 'counter)))
2552         (setq counter 0))
2553       (incf  counter)
2554       (put 'tinyurl-mode 'counter counter)
2555       ;;  Activate only every 5th time.
2556       (when (zerop (% counter tinyurl-:post-command-hook-threshold))
2557         (put 'tinyurl-mode 'counter 0)
2558         (tinyurl-mark-process)))))
2559
2560 ;;; ----------------------------------------------------------------------
2561 ;;;
2562 (defun tinyurl-mark-mouse ()
2563   "Mark URLs on current mouse line."
2564   (when (fboundp 'mouse-position)
2565     (multiple-value-bind (line col)
2566         (ti::compat-mouse-position-coordinates)
2567       (when (and line col)
2568         (save-excursion
2569           (goto-char (window-start))
2570           (forward-line line)
2571 ;;;          (ti::d! (ti::read-current-line))
2572           (let* ((end (line-end-position)))
2573             (when (not (eq end
2574                            (get 'tinyurl-mark-line 'mouse)))
2575               (put 'tinyurl-mark-line 'mouse end)
2576               (tinyurl-mark-line))))))))
2577
2578 ;;; ----------------------------------------------------------------------
2579 ;;;
2580 (defun tinyurl-mark-process ()
2581   "Mark URLs on current line and `mouse-position'."
2582   (when (and (or tinyurl-mode
2583                  (and (null tinyurl-:mode-manually-turned-off)
2584                       (get  'tinyurl-mode 'global)
2585                       ;; Auto-activate if URL appear anywhere in buffer
2586                       (and (fboundp tinyurl-:auto-activate-function)
2587                            (funcall tinyurl-:auto-activate-function)))))
2588     ;; Check if we have already marked this line
2589     (let* ((end (line-end-position)))
2590       (when (not (eq end
2591                      (get 'tinyurl-mark-line 'point)))
2592         (put 'tinyurl-mark-line 'point end)
2593         (tinyurl-mark-line)))
2594     (tinyurl-mark-mouse)))
2595
2596 ;;; ----------------------------------------------------------------------
2597 ;;;
2598 (defun tinyurl-default-mark-table ()
2599   "Return default table used by `tinyurl-mark-line'.
2600 Format:
2601   '( (REGEXP [SUB-MATCH] [SPAN-FLAG] [VALIDATE-HANDLER]) ..)
2602
2603 REGEXP      To mark the URL
2604 SUB-MATCH   In REGEXP to match URL
2605 SPAN-FLAG   If non-nil, then regexp match does not end to the end of
2606             current line.
2607 VALIDATE-HANDLER    Function to discard and check marked url"
2608   (let* ((site       "[-a-z0-9.]+")
2609          (white      " \t\r\n\f")       ;whitespace
2610          (white-file " *?\t\r\n\f")     ;whitespace, exclude wildcards
2611          (white-re   (concat "[" white "]"))
2612          (nwhite-re  (concat "[^" white "]"))
2613          (word       (concat "[^][(){}<>$^*?:\"'" white "]")) ;; filename word
2614          (word+      (concat word "+"))
2615 ;;;      (word*      (concat word "*"))
2616          (url-word+  (concat "[^][{}<>$^*\"'" white "]+")) ;; include ?
2617          (url-word*  (concat "[^][{}<>$^*\"'" white "]*"))
2618          (non-spc    (concat "[^\"';" white "]"))
2619          (non-spc+   (concat non-spc "+"))
2620          ;;      (non-spc*  (concat non-spc "*"))
2621          (slash    (if (ti::win32-p)
2622                        "\\/"            ;Accept both
2623                      "/"))              ;only in Unix
2624          (slash-re (format "[%s]" slash))
2625          (drive    (if (ti::win32-p)
2626                        "[a-zA-Z]:"      ; D:\dir\file.txt
2627                      ""))               ; In Unix no drive letter
2628          (compiler-number "\\(:[0-9]+:\\)")
2629          (maybe-number "\\(:[0-9]+\\)?")
2630          (table
2631           (list
2632            (list (concat "\\<mailto:" white-re "*" nwhite-re "+") 0 'span)
2633            ;; This must come first
2634            (list "<URL:\\([^>]+\\)>" 1 'span)
2635            (list
2636             (concat
2637              "\\(Message-Id:\\|References:\\|In Article\\)"
2638              white-re "*<[^>" white  "]+>")
2639             0
2640             'span)
2641            (list
2642             (concat
2643              "\\(\\(\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\|news\\)://"
2644              "\\|file:/\\)\\)"
2645              url-word+)
2646             0)
2647            (list tinyurl-:email-regexp 0 nil 'tinyurl-validate-url-email)
2648            ;; If it starets with "www" and ends to 2-3 characters, it must
2649            ;; be http pointer
2650            ;;
2651            ;; The regexp starts with "[^/], so that http://www match isn't
2652            ;; replaced with this.
2653            (list
2654             (concat
2655              "[^/]www\\.\\([-a-z0-9]+\.\\)+[a-z][a-z][a-z]?"
2656              url-word*
2657              "\\>")
2658             0)
2659            ;; C/C++
2660            ;;
2661            ;;   #include <stdio.h>
2662            (list
2663             (concat
2664              "^[ \t]*#include +<[^>]+>"
2665              "\\|^[ \t]*#include +\"[^\"]+\"")
2666             0)
2667            ;; Debian
2668            ;;
2669            ;;   bug#NNNNNN
2670            ;;   RFA NNNNNN package -- ...
2671            ;;   O NNNNNN package -- ...
2672            ;;   Closes: #NNNNNN
2673            ;;
2674            (list
2675             (concat
2676              "\\<bug#[0-9]+\\>"
2677              "\\|Closes:? +#[0-9]+\\>"
2678              "\\|\\<\\(RF.\\|IT\\.\\|O\\) +[0-9]+\\>")
2679             0)
2680            ;; Perl code statements
2681            ;;
2682            ;;   require 'library.pl';
2683            ;;   use      Module;
2684            (list
2685             (concat
2686              "\\<require[ \t\"']+[_a-z0-9.]+pl[ \t\"']*;"
2687              "\\|\\<use[ \t]+[_a-z0-9:]+[ \t]*;")
2688             0)
2689            ;;  Perl Foo::Bar->new(...);
2690            '("\\<[A-Za-z]+::[A-Za-z]+\\(->[A-Za-z]+\\)?"
2691              0
2692              nil
2693              tinyurl-validate-url-perl-method)
2694            ;; Browsing Perl POD pages
2695            ;;
2696            ;;   "See perlfunc manpage"
2697            ;;   "See [perlfaq2]"
2698            ;;   Devel::DProf manpage
2699            ;;
2700            ;; SEE ALSO
2701            ;;    perlrequick.
2702            ;;    perlretut.
2703            ;;    "Regexp Quote-Like Operators" in perlop.
2704            (list
2705             (concat
2706              "\\<perl" nwhite-re "+" white-re "+manpage"
2707              "\\|\\[perl" nwhite-re "+\\]"
2708              "\\|[A-Z][a-z]+::[A-Z][a-z]" white-re "+manpage"
2709              "\\|^[ \t]+perl" nwhite-re "+\\.[ \t]*$"
2710              "\\|in[ \t]+perl" nwhite-re "+\\.[ \t]*$")
2711             0
2712             'span)
2713            ;; [Compiler output]
2714            ;; Perl error messages
2715            ;;
2716            ;;       Global symbol "x" requires explicit package name
2717            ;;       at /users/foo/bin/file.pl line 289.
2718            ;;
2719            ;;       syntax error in file ./fle.pl at line 268
2720            (list
2721             (concat
2722              " in file +" non-spc+ " +at +line +[0-9]+"
2723              "\\| at +"   non-spc+ " +line +[0-9]+")
2724             0)
2725            ;; Manual pages . Examples from HP-UX
2726            ;;
2727            ;;   cut(1), ypmake(1M), unistd.h(5), typeahead(3X)
2728            ;;   termios(7), sshd(8), html2ps(1) ssh-agent(1)
2729            ;;   crontab(5)
2730            (list
2731             "\\<[-_a-z.0-9]+([1-9][CMSX]?)"
2732             0)
2733            ;; Lisp
2734            ;;
2735            ;;  (load            "file.el")
2736            ;;  (load-library    "file.el")
2737            ;;  (load-file       "file.el")
2738            ;;  (require 'feature)
2739            (list
2740             (concat
2741              "(\\(load\\|load-library\\|load-file\\|require\\)[ \t\"']+"
2742              word+)
2743             0)
2744            ;; ............................................ local files ...
2745            ;; Local files, this must be last because the regexp is "loose"
2746            ;; and would match if put above.
2747            ;;
2748            ;;   ~foo/dir/file.txt
2749            ;;   /users/foo/file.txt
2750            ;;   /usr/include/shadow.h:8
2751            ;;
2752            ;;   D:\dir\dir\file.txt
2753            ;;   D:/dir/dir/file.txt
2754            ;;   //server/dir/that/there
2755            ;;
2756            ;; This still highlights statement like /.*
2757            ;; Can't do nothing about that. I don't want to make enourmously
2758            ;; complex regexp NOT to match false filenames. So we have to
2759            ;; bear with some mishits
2760            ;;
2761            ;; () grouped regexp reads:  (SLASH NOT-SLASH|~SLASH)word*nbr?
2762            ;; The purpose is not to match double slash C++ comments //
2763            (list
2764             (concat
2765              ;; Must be at the begining of line, or after whitespace
2766              "\\(^\\|[ \t]\\)"
2767              "\\(" "\\(" drive "\\|//\\|[\\][\\]\\)?"
2768              slash-re "[^" white-file slash "]"
2769              "\\|~" slash-re "?\\)"
2770              word+
2771              maybe-number
2772              ;;  Must be 'alone' and separated from others.
2773              "\\([ \t]\\|$\\)")
2774             0
2775             nil
2776             'tinyurl-validate-url-default)
2777            ;; Last try, the file may be inside Emacs already
2778            ;;  this-file.el:12:   The matched line...
2779            (list
2780             (concat "^\\(" nwhite-re "+\\)" compiler-number )
2781             0
2782             nil
2783             'tinyurl-validate-url-default)))) ;; list of regexps end
2784     table))
2785
2786 ;;; ----------------------------------------------------------------------
2787 ;;;
2788 (defun tinyurl-mark-line ()
2789   "Mark URLs with overlays on current line.
2790 Return:
2791    list of overlays where the regexps matched.
2792
2793   '((ov ov ..) (regexp regexp ..))"
2794   (interactive)
2795   (let* ((fid      "tinyurl-mark-line:")
2796          (plist    (tinyurl-overlay-plist))
2797          (table    (tinyurl-default-mark-table))
2798          regexp
2799          level
2800          function
2801          url
2802          ov-stat
2803          olist
2804          ov-list
2805          match-list
2806          end
2807          type)
2808     ;;  Delete old overlays first
2809     (tinyurl-overlay-kill)
2810     (tinyurl-modeline-update) ;; update plugged status
2811     ;;   Now mark all urls with overlays on current line
2812     ;;   OV-LIST contains generated overlays.
2813     (save-excursion
2814       ;; Allow line span (setq end (line-end-position))
2815       (beginning-of-line)
2816       (dolist (elt table)
2817         (setq regexp   (nth 0 elt)
2818               level    (or (nth 1 elt) 0)
2819               end      (line-end-position)
2820               type     (nth 2 elt)
2821               function (nth 3 elt)
2822               olist    nil)
2823         ;;  If it is allowed to span multiple lines,
2824         ;;  then limit the scanning to average of 3 lines
2825         ;;  whose length is estimated 50 characters.
2826         ;;
2827         ;;  Adjust calculated pos according to point-max
2828         (cond
2829          ((eq type 'no-limit)
2830           (setq end nil))
2831          ((and (eq type 'span)
2832                ;; There must be spanning url in this line
2833                (string-match regexp
2834                              (buffer-substring-no-properties
2835                               (line-beginning-position)
2836                               (min
2837                                (+ 200 (line-beginning-position))
2838                                (point-max)))))
2839           (setq end
2840                 (let ((pos (+ (point) (* 3 50))))
2841                   (if (> pos (point-max))
2842                       (point-max)
2843                     pos)))))
2844         ;; ................................................... do work ...
2845         (tinyurl-debug fid "DOLIST-ELT: " end elt)
2846         (if (and plist
2847                  (stringp regexp))
2848             (setq olist
2849                   (nth 1
2850                        (ti::overlay-re-search
2851                         regexp
2852                         level
2853                         plist
2854                         end             ;MAX-POINT
2855                         nil nil nil     ;BACK REUSE REUSE-P
2856                         '(owner tinyurl)))))
2857         (when olist
2858           (tinyurl-debug fid "OVERLAY-LIST" olist)
2859           (dolist (ov olist)
2860             (cond
2861              ((not (overlayp ov))
2862               (message "TinyUrl: ERROR, non-overlay %s"
2863                        (prin1-to-string ov))
2864               (tinyurl-debug fid 'NON-OVERLAY ov))
2865              (t
2866               (setq url (ti::overlay-buffer-substring ov 'no-properties))
2867               ;;  - If some previous regexp marks identical overlay,
2868               ;;    do not add it to the list.
2869               (when (and ov-list
2870                          (not (member url ov-list)))
2871                 (setq ov-stat (or (null function)
2872                                   (funcall function url)))
2873                 (tinyurl-debug fid 'STATUS ov-stat 'FUNC function 'URL url "\n")
2874                 (cond
2875                  ((eq ov-stat t)
2876                   (push regexp match-list)
2877                   (push ov     ov-list))
2878                  (t
2879                   (delete-overlay ov))))))))))
2880     ;;  Save the created overlay list, we don't want to bloat buffer
2881     ;;  full of overlays.
2882     (put 'tinyurl-mark-line 'ov-list    ov-list)
2883     (put 'tinyurl-mark-line 'match-list match-list)
2884     (tinyurl-debug fid "RET OV-LIST" ov-list)
2885     (when (and ov-list match-list)      ;Return value
2886       (list ov-list match-list))))
2887
2888 ;;}}}
2889
2890 (add-hook 'tinyurl-:mode-define-keys-hook 'tinyurl-mode-define-keys)
2891
2892 (tinyurl-install)
2893
2894 (provide   'tinyurl)
2895 (run-hooks 'tinyurl-:load-hook)
2896
2897 ;;; tinyurl.el ends here