1 ;;; tinyurl.el --- Mark and jump to any URL on current line.
3 ;; This file is not part of Emacs
7 ;; Copyright (C) 1997-2007 Jari Aalto
8 ;; Keywords: extensions
10 ;; Maintainer: Jari Aalto
12 ;; To get information on this program, call M-x tinyurl-version.
13 ;; Look at the code with folding.el.
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)
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
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.
30 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
37 ;; ....................................................... &t-install ...
38 ;; Put this file on your Emacs-Lisp load path, add following into your
39 ;; ~/.emacs startup file.
41 ;; (add-hook 'tinyurl-:load-hook 'tinyurl-install-to-packages)
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
48 ;; (turn-on-tinyurl-mode)
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)
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.
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)
66 ;; ;; Keybinding suggestions
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)
72 ;; ;; Select backend for EMAIL urls. See variable's documentation.
73 ;; (setq mail-user-agent 'message-user-agent)
75 ;; If you have any questions, use this function to contact author
77 ;; M-x tinyurl-submit-bug-report
82 ;; ..................................................... &t-commentary ...
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,
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
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.
105 ;; Overview of features
107 ;; o Requirements: XEmacs must contain package `overlay.el'.
108 ;; Emacs needs nothing special.
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...
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.
133 ;; Turning the URL recognizer on
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.
142 ;; If you want to turn the mode on or off for current buffer only, use
143 ;; `M-x' `tinyurl-mode-1'.
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.
149 ;; Caching URLs for later use (offline reading)
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
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'.
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.
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.
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
180 ;; Editing the url and selecting access method manually
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
187 ;; file:/users/foo/file.txt
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:
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.
200 ;; Ignoring URL in the buffer
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.
208 ;; Centralised URL handling
210 ;; If you called `M-x' `tinyurl-install-to-packages' or had installation:
212 ;; (add-hook 'tinyurl-:load-hook 'tinyurl-install-to-packages)
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'.
219 ;; Ignoring some buffers for mode turn on and offs
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
225 ;; (setq tinyurl-:exclude-function 'my-tinyurl-exclude)
227 ;; (defun my-tinyurl-exclude (buffer)
228 ;; "Exclude some buffers that use their own highlighting."
229 ;; (string-match "VM\\|Article" (buffer-name buffer)))
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.
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
247 ;; See also `tinyurl-:reject-url-regexp' for more simpler use.
249 ;; Choosing what agent handles which URL
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.
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.
260 ;; Changing the url handler list
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
269 ;; tinyurl-set-handler Meta mouse-2
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'
276 ;; Exclamation character marks pushable URL
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.)
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.
289 ;; Some previous line here
290 ;; !http://foo.com/dir/file.txt !<foo@bar.com>
291 ;; Another line below
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:
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.
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.
311 ;; You can use variable `tinyurl-:display-glyph' to control if the
312 ;; glyph is shown or not.
315 ;; Accepted email URL
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 < >.
322 ;; Support for programming language URLs
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
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.
336 ;; There is support for these perl statements:
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:
346 ;; ERROR at FILE line NBR.
348 ;; Perl pod page references are recognized in the format
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
365 ;; Please let me know if you know package or you have code that can
366 ;; find other languages' URLs.
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):
385 ;; o Remember to define `ff-search-directories' for *find-file.el*
386 ;; so that your C/C++ #include <url> will be found correctly.
388 ;; Filename filter e.g. running catdoc for MS Word files
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)
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.
404 ;; Code note: adding buttons to the current line
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.
411 ;; [Next applies only to Emacs with no `run-with-idle-timer' function]
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.
421 ;; Code note: overlay properties
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).
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.
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.
443 ;; Code Note: overlay management
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.
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.
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
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.
465 ;; Code Note: Adding support for new URL type
467 ;; If you see new url that you would like to have supported and you
468 ;; know lisp, then the changes needed are:
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
479 ;; To make changes do this:
481 ;; o copy original version to `tinyurl.el.orig'
483 ;; o Produce diff `diff -b -w -u tinyurl.el.orig tinyurl.el'
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.
489 ;; Sending a bug report
491 ;; If you have a line where url is highlighted, but it doesn't cover
492 ;; right characters, then do this:
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.
502 ;; Btw, in win32 the file url on `C:' disk is written like
504 ;; file://localhost/C|/foo/bar/baz.html#here
506 ;; And according to RFC, if you leave out the <host>, the localhost is
507 ;; automatically assumed.
509 ;; file:///C|/foo/bar/baz.html#here
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
519 ;; If you know what is causing this effect, let me know.
523 ;; Add support for Java-Find.el
536 (ti::package-use-dynamic-compilation)
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
557 ** tinyurl.el: Error, this Emacs does not have overlay functions.")))
559 (ti::package-defgroup-tiny TinyUrl tinyurl-: extensions
560 "Global URL highlighting and dispatcher minor mode.")
563 ;;{{{ setup: variables
565 ;;; ......................................................... &v-hooks ...
567 (defcustom tinyurl-:load-hook '(tinyurl-install-to-packages)
568 "*Hook run when file has been loaded."
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
579 Default function in this hook is `tinyurl-dispatch-ignore-p'.
581 Function call arguments:
584 '(buffer . point) Pointer to location of url in Emacs
586 Function should return:
588 non-nil To ignore urls and pass control back to underlying mode.
589 nil Accept url and proceed."
593 (defcustom tinyurl-:validate-hook '(tinyurl-validate-url-default)
594 "Validate called url. If some of these functions return t, url is accepted.
596 Function call arguments:
600 Function should return:
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"
608 ;;; .......................................................... &public ...
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."
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.
624 'tinyurl-plugged-always-p
627 See also: `tinyurl-:url-cache-buffer'"
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.
635 Function call argument:
639 Function should return:
641 t if buffer is ignored"
645 (defcustom tinyurl-:display-glyph (not (ti::colors-supported-p))
646 "*If non-nil, Display the Overlay glyph: !, ? or *.
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.
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
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")))
667 '("\\.pod$" . tinyurl-filter-pod)
669 (cons "\\.doc$" (concat doc " %s"))) ;View MS WORD files
670 (cons "\\.\\(jpg\\|jpeg\\|gif\\)$"
677 'ignore))) ;Ignore loading pictures
680 (concat nroff " -man"
683 ;; Pass ZIP pointer to win32 winzip
688 (tinyurl-call-process-win32
690 "If URL is filename, then check this table for filter.
691 The `%s' is substituted with the URL (filename) in SHELL-COMMAND string.
693 If there is Lisp FUNCTION, then it is called with argument URL.
697 '((REGEXP . SHELL-COMMAND) ;; nil element also accepted
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.
710 (setq file-filter-table
712 (if (executable-find \"catdoc\")
713 '(\"\\\\.doc$\" . \"catdoc %s\")) ;View MS WORD files
714 (if (executable-find \"xv\")
715 '(\".\\\\(jpg\\\\|jpeg\\\\|gif\\\\)$\" . \"xv %s\")
719 (string :tag "Shell command")
720 (function :tag "Function"))))
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'
727 Function call arguments:
728 string a possible url
729 type :optional A symbol describing url type. See `tinyurl-type'"
733 ;; This variable is set in `tinyurl-install'.
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].
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.
748 FUNCTION Either function or value. Functions are called interactively.
756 (overlay-plist (PROPERTY VAL PROPERTY VAL ..)))))
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."
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."
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
786 (defcustom tinyurl-:url-cache-buffer "*URL-cache*"
787 "Where to store urls when Emacs is disconnected from the Net."
791 (defcustom tinyurl-:reject-url-regexp
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'."
803 ;;; ......................................................... &private ...
805 (defvar tinyurl-:mode-manually-turned-off nil
806 "On/Off mark when `tinyurl-mode-1' has been changed interactively.")
808 (make-variable-buffer-local 'tinyurl-:mode-manually-turned-off)
810 ;; you can adjust this to include some more character, but please
811 ;; send message to maintainer if you do so.
813 ;; _ $ % & = are many times used in Message-ID's
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.")
819 (defvar tinyurl-:command-table-current nil
820 "The active command table name.")
822 (defvar tinyurl-:event nil
825 (defvar tinyurl-:timer-elt nil
828 (defvar tinyurl-:history nil
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.
837 If non-nil, The mouse-point is not scanned for urls. Only existing
838 overlays under point are read.
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
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.
849 (defcustom tinyurl-:overlay-plist
850 (let* ((face (if (ti::compat-window-system)
867 'begin-glyph (ti::funcall 'make-glyph "!")
870 "*Property list (PROP VAL PROP VAL ..) used for all overlays."
874 (defvar tinyurl-:win32-shell-execute-helper
876 (or (and (fboundp 'w32-shell-execute) ;; Emacs
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
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.")
888 ;;;###autoload (autoload 'tinyurl-version "tinyurl" "Display commentary." t)
890 (ti::macrof-version-bug-report
894 "$Id: tinyurl.el,v 2.85 2007/05/07 10:50:14 jaalto Exp $"
895 '(tinyurl-:version-id
897 tinyurl-:dispatch-hook
898 tinyurl-:validate-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
921 tinyurl-:mouse-yank-at-point
922 tinyurl-:overlay-plist
923 tinyurl-:win32-shell-execute-helper)
924 '(tinyurl-:debug-buffer)))
927 ;;{{{ mode and install
929 ;;;###autoload (autoload 'tinyurl-debug-toggle "tinyurl" "" t)
931 (eval-and-compile (ti::macrof-debug-standard "tinyurl" "-:"))
933 ;;; .......................................................... &v-mode ...
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)
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.
945 To read the complete documentation, run `tinyurl-commentary'
946 See also `tinyurl-version' (use prefix argument to see only version number).
950 \\{tinyurl-:mode-map}"
953 (progn ;Some mode specific things? No?
954 (tinyurl-modeline-update)
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)))
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.
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]
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)
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))
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))))
993 ;;; ----------------------------------------------------------------------
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]+"))))
1007 ;;; ----------------------------------------------------------------------
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)))
1018 ;;; ----------------------------------------------------------------------
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.
1028 The value of `tinyurl-:exclude-function' is consulted first."
1029 (when (tinyurl-mode-turn-on-ok-p)
1030 (turn-on-tinyurl-mode-1)))
1032 ;;; ----------------------------------------------------------------------
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
1040 (setq tinyurl-:mouse-yank-at-point t)
1041 (unless tinyurl-mode
1042 (turn-on-tinyurl-mode-1)))
1044 ;;; ----------------------------------------------------------------------
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)
1055 ;;; ----------------------------------------------------------------------
1057 (defun turn-on-tinyurl-mode-1 ()
1058 "Turn URL mode on for this buffer only."
1060 (unless tinyurl-mode
1061 (when (interactive-p)
1062 (setq tinyurl-:mode-manually-turned-off nil))
1063 (tinyurl-mode-1 1)))
1065 ;;; ----------------------------------------------------------------------
1067 (defun turn-off-tinyurl-mode-1 ()
1068 "Turn URL mode off for this buffer only."
1071 (when (interactive-p)
1072 (setq tinyurl-:mode-manually-turned-off t))
1073 (tinyurl-mode-1 0)))
1075 ;;; ----------------------------------------------------------------------
1077 (defun tinyurl-overlay-kill-in-buffer ()
1078 "Kill TinyUrl overlays from whole buffer. See also `tinyurl-overlay-kill'."
1080 (put 'tinyurl-mark-line 'point nil)
1081 (ti::overlay-remove-region
1082 (point-min) (point-max) '(owner tinyurl) 'prop-val-list))
1084 ;;; ----------------------------------------------------------------------
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)))
1095 ;;; ----------------------------------------------------------------------
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'."
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)))
1112 ;;; ----------------------------------------------------------------------
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))
1121 tinyurl-:mode-define-keys-hook)
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))
1129 ;; Exclude hidden buffers
1130 (when (not (string-match "^ " (buffer-name buffer)))
1131 (with-current-buffer buffer
1134 ;; Mark all buffers as "not modified"
1135 (setq tinyurl-:mode-manually-turned-off nil)
1136 (turn-on-tinyurl-mode-1-maybe))
1138 (turn-off-tinyurl-mode)
1139 (setq tinyurl-:mode-manually-turned-off t)))))))
1141 (message "TinyUrl: Global mode is %s. Stepped through %d buffers"
1147 (put 'tinyurl-mode 'self-call nil))))
1149 ;;; ----------------------------------------------------------------------
1151 (defun tinyurl-install (&optional uninstall)
1152 "Install or `UNINSTALL package."
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
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
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))))
1172 ;;; ----------------------------------------------------------------------
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."
1179 ;;; (list '(gnus-button-url
1180 ;;; gnus-button-embedded-url
1182 ;;; vm-mouse-send-url
1184 (ti::add-hooks '(rmail-show-message-hook
1185 vm-select-message-hook
1187 'turn-on-tinyurl-mode-mail
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
1197 ;; gnus-button-embedded-url gnus-button-url gnus-url-mailto
1198 (when nil ;Enabled now
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
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")))
1237 (defconst gnus-button-url 'tinyurl-dispatcher-1) ; GNUS
1239 (defconst vm-url-browser 'tinyurl-dispatcher-1))))
1241 ;;; ----------------------------------------------------------------------
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)))
1249 ;;; ----------------------------------------------------------------------
1251 (defun tinyurl-set-handler (table)
1252 "Set active url handler command TABLE."
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))
1262 ;;; ----------------------------------------------------------------------
1264 (defun tinyurl-plugged-p ()
1265 "Return plugged status."
1266 (or (get 'tinyurl-plugged-p 'mode)
1267 (ti::mail-plugged-p)))
1269 ;;; ----------------------------------------------------------------------
1271 (defun tinyurl-plugged-always-p ()
1272 "Return true plugged status."
1275 ;;; ----------------------------------------------------------------------
1276 ;;; Called by the Line marker process to keep track of the Gnus mode changes
1278 (defun tinyurl-plugged-update ()
1279 "Update plugged status."
1280 (put 'tinyurl-plugged-p 'mode (tinyurl-plugged-p)))
1282 ;;; ----------------------------------------------------------------------
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."
1289 (let* ((mode (get 'tinyurl-plugged-p 'mode)))
1291 (ti::bool-toggle mode arg)
1292 (put 'tinyurl-plugged-p 'mode mode)
1294 (message "TinyUrl: %s"
1295 (if mode "Plugged" "Unplugged")))
1297 (if (boundp 'gnus-plugged)
1298 (setq gnus-plugged mode))
1300 (tinyurl-modeline-update)
1301 (get 'tinyurl-plugged-p 'mode)))
1303 ;;; ----------------------------------------------------------------------
1305 (defun tinyurl-call-process-win32 (binary &rest args)
1306 "Call Win32 native BINARY with ARGS"
1309 ((stringp tinyurl-:win32-shell-execute-helper)
1310 (apply 'call-process
1311 tinyurl-:win32-shell-execute-helper
1317 ((functionp tinyurl-:win32-shell-execute-helper)
1318 (apply tinyurl-:win32-shell-execute-helper "open" args))
1321 "TinyUrl: `tinyurl-:win32-shell-execute-helper' not configured."))))
1323 ;;; ----------------------------------------------------------------------
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.
1329 The buffer ignore status is recorded to the plist of
1330 function ´tinyurl-default-exclude', which you can recall with:
1332 (get 'tinyurl-default-exclude 'exclude-list)"
1333 (with-current-buffer buffer
1334 (let* ((exclude-list (get 'tinyurl-default-exclude
1336 (nok-status (assq buffer exclude-list)))
1338 (let* ((name (symbol-name major-mode))
1341 "^w3-\\|^vm-\\|dired\\|archive\\|compil\\|grep$"
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"
1352 ;;; ----------------------------------------------------------------------
1354 (defun tinyurl-command-table-put (table key value)
1355 "Use command TABLE entry and change KEY's value to new VALUE."
1359 (while (setq elt (pop table))
1360 (when (eq (car elt) key)
1361 (setq elt (cons key value)
1365 (error "TinyUrl: No key %s found" key))
1368 ;;; ----------------------------------------------------------------------
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."
1378 (or (setq elt (assq key1 table))
1379 (error "TinyUrl: Key1 %s does not exist" key1))
1380 (setq list (nth 1 elt))
1382 (setq mem (car list))
1385 ;; Raise flag, change value
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))
1393 (error "No key2 '%s'" key2))
1395 (setcdr elt (list new)) ; Change key1's right hand list
1398 ;;; ----------------------------------------------------------------------
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)
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))))))))
1416 ;;; ----------------------------------------------------------------------
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))
1424 ((string-match "netscape" (symbol-name browse))
1429 ;; Don't know. Use whatever is there.
1433 ;;; ----------------------------------------------------------------------
1435 (defun tinyurl-user-command-table-default ()
1436 "Return default command table choice.
1437 This might be \"netscape\" or \"iexplore\"."
1439 (let* ((default (tinyurl-user-default-browser-type)))
1441 ((ti::win32-p) ;Win32
1442 (let ((net (executable-find "netscape")))
1444 (eq default 'netscape))
1446 ;; "c:/Program Files/Internet Explorer/iexplore.exe
1449 (if (not (ti::compat-window-system))
1451 ;; In Unix the name has "r" at the end
1452 (let* ((ie (executable-find "iexplorer")))
1456 ((eq default 'netscape)
1461 ;;; ----------------------------------------------------------------------
1463 (defun tinyurl-command-table-default-1 ()
1464 "Return default `tinyurl-:command-table' entry.
1465 If you change this function's source, run
1467 (tinyurl-install-command-table 'force)
1470 `tinyurl-:overlay-plist'"
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
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)
1496 tinyurl-:overlay-plist)))
1498 ;;; ----------------------------------------------------------------------
1500 (defmacro tinyurl-command-table-before-string (entry string)
1501 "Replace property 'before-string in ENTRY with STRING."
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))))))
1510 ;;; ----------------------------------------------------------------------
1511 ;;; This is a copy from function `browse-url'.
1512 (defun tinyurl-command-browse-url-default-browser-function-1
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)))))))
1525 ;;; ----------------------------------------------------------------------
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?")))
1534 ;;; ----------------------------------------------------------------------
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
1542 ;; (tinyurl-command-browse-url-default-browser-function)))
1543 (tinyurl-command-table-before-string entry "!")
1546 ;;; ----------------------------------------------------------------------
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 "!")
1557 ;;; ----------------------------------------------------------------------
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 "!")
1568 ;;; ----------------------------------------------------------------------
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 "!")
1578 ;;; ----------------------------------------------------------------------
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 "@")
1588 ;;; ----------------------------------------------------------------------
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 "*")
1598 ;;; ----------------------------------------------------------------------
1600 (defun tinyurl-command-table-w3 ()
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 "?")
1608 ;;; ----------------------------------------------------------------------
1610 (defun tinyurl-command-table-defaults ()
1611 "Return default value for `tinyurl-:command-table'."
1612 (delq nil ;remove empty entries
1614 (list "default" (tinyurl-command-table-default))
1616 (list "netscape" (tinyurl-command-table-netscape-win32))
1617 (list "netscape" (tinyurl-command-table-netscape)))
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)))))
1627 ;;; ----------------------------------------------------------------------
1629 (defun tinyurl-command-table-defaults-set ()
1630 "Set `tinyurl-:command-table' to defaults."
1632 (setq tinyurl-:command-table (tinyurl-command-table-defaults)))
1634 ;;; ----------------------------------------------------------------------
1636 (defun tinyurl-install-command-table (&optional force)
1637 "Set default values to `tinyurl-:command-table'. FORCE reset."
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))))
1650 ;;; ----------------------------------------------------------------------
1652 (defun tinyurl-modeline-update ()
1653 "Update modeline name."
1654 (tinyurl-install-command-table)
1655 (tinyurl-plugged-update)
1656 (setq tinyurl-:mode-name
1658 (downcase (ti::string-left tinyurl-:command-table-current 1))
1659 (if (funcall tinyurl-:plugged-function)
1661 (ti::compat-modeline-update))
1663 ;;; ----------------------------------------------------------------------
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)))
1671 ;;; ----------------------------------------------------------------------
1673 (defsubst tinyurl-table (table)
1674 "Return command TABLE."
1675 (or (nth 1 (assoc table tinyurl-:command-table))
1677 ;; (message "TinyUrl: [ERROR] No such command table: [%s] " table)
1679 ;;; ----------------------------------------------------------------------
1681 (defun tinyurl-table-current (&optional table)
1682 "Return copy of active command table.
1684 `tinyurl-:display-glyph'"
1685 (let* ((table (tinyurl-table
1687 tinyurl-:command-table-current))))
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
1696 (nth 1 (assq 'overlay-plist table))))
1699 (ti::funcall 'make-glyph ""))))
1702 ;;; ----------------------------------------------------------------------
1704 (defsubst tinyurl-overlay-plist (&optional table)
1705 "Return overlay plist of TABLE."
1706 (nth 1 (assq 'overlay-plist (tinyurl-table-current table))))
1708 ;;; ----------------------------------------------------------------------
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)))))
1714 (error "Tinyurl: Unknown type %s" type))
1715 (tinyurl-debug "tinyurl-agent-function" elt)
1718 ;;; ----------------------------------------------------------------------
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))
1724 ;;; ----------------------------------------------------------------------
1726 (defsubst tinyurl-types ()
1727 "Return known url types in `tinyurl-:command-table-current'."
1728 (mapcar 'car (tinyurl-table-current)))
1730 ;;; ----------------------------------------------------------------------
1732 (defun tinyurl-mouse-binding (event)
1733 "Jump to URL at point or call original function with mouse EVENT."
1735 (setq tinyurl-:event event)
1736 (tinyurl-dispatcher event 'mouse))
1738 ;;; ----------------------------------------------------------------------
1740 (defun tinyurl-mouse-binding-down (event)
1741 "Jump to URL at point or call original function with mouse EVENT."
1743 (setq tinyurl-:event event)
1744 (put 'tinyurl-:event 'down-event event))
1746 ;;; ----------------------------------------------------------------------
1748 (defun tinyurl-key-binding-default ()
1749 "Jump to URL at point or call original ESC RET key binding."
1751 (setq tinyurl-:event nil)
1753 (tinyurl-dispatcher "\e\C-m" 'key))
1755 ;;; ----------------------------------------------------------------------
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)))))
1761 (ti::overlay-get-prop list '(owner tinyurl)))))
1763 ;;; ----------------------------------------------------------------------
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)))
1769 ;;; ----------------------------------------------------------------------
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.")
1777 (buffer shell-command-output-buffer))
1778 (put 'tinyurl-filter-pod 'pod2text pod)
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)))))
1788 ;;; ----------------------------------------------------------------------
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)))
1799 ;;; ----------------------------------------------------------------------
1801 (defun tinyurl-overlay-kill-in-buffer ()
1802 "Kill TinyUrl overlays from whole buffer. See also `tinyurl-overlay-kill'."
1804 (put 'tinyurl-mark-line 'point nil)
1805 (ti::overlay-remove-region
1811 ;;; ----------------------------------------------------------------------
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
1821 ;;; ----------------------------------------------------------------------
1823 (defun tinyurl-dispatcher-1 (url)
1824 "Redirect URL to proper agent handler."
1826 (let* ((fid "tinyurl-dispatcher-1:")
1827 (tinyurl-:file-filter-table tinyurl-:file-filter-table) ;; make copy
1831 ;; ....................................................... do-it ...
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")
1840 (when current-prefix-arg
1841 (setq url (read-from-minibuffer
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)
1853 "(TinyUrl) Select type: "
1854 (ti::list-to-assoc-menu
1855 (mapcar 'symbol-name (tinyurl-types)))
1858 (if (tinyurl-type url)
1859 (symbol-name (tinyurl-type url))
1861 (when (and (setq tmp (tinyurl-get-filter url))
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))))))
1870 ;;; ----------------------------------------------------------------------
1872 (defun tinyurl-gnus-callback-at-point ()
1873 "Return gnus-callback text property at point."
1874 (get-text-property (point) 'gnus-callback))
1876 ;;; ----------------------------------------------------------------------
1878 (defun tinyurl-call-original-mouse (event)
1879 "Call original mouse-2 function, unless in compilation buffer."
1880 (let* ((mode (symbol-name major-mode))
1882 (let* ((local (current-local-map))
1886 (lookup-key local [mouse-2])
1887 (lookup-key local [(button2)])))
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
1894 (message "TinyUrl: Nothing to (yank) here.")
1895 (ti::compat-mouse-call-original 'tinyurl-mode event))))
1897 ;;; ----------------------------------------------------------------------
1899 (defun tinyurl-gnus-data-at-point ()
1900 "Return gnus-data text property at point."
1901 (get-text-property (point) 'gnus-data))
1903 ;;; ----------------------------------------------------------------------
1905 (defun tinyurl-dispatcher (&optional event type)
1906 "See if there is URL at point. Otherwise act like usual key/mouse call.
1910 EVENT mouse-event or key binding
1911 TYPE 'mouse or 'key. The EVENT type"
1913 (let* ((ov (tinyurl-overlay-get))
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
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.
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
1934 ;; ftp://foo.com/this.txt#tag
1935 ;; ftp://foo.com/perl.pl?params
1937 (when (eq type 'mouse)
1938 (tinyurl-set-mouse-maybe event))
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
1951 ;; Now clear events, so that these old ones are not used.
1952 (setq tinyurl-:event nil)
1953 (put 'tinyurl-:event 'down-event nil)
1956 (funcall gnus-callback gnus-data))
1958 (fboundp down-func))
1959 (tinyurl-call-original-mouse down-event))
1961 (tinyurl-call-original-mouse event)))))
1963 (ti::compat-key-call-original 'tinyurl-mode event))))
1965 (tinyurl-dispatcher-1 url)))))
1967 ;;; ----------------------------------------------------------------------
1969 (defun tinyurl-at-point (&optional verb)
1970 "Mark line for urls and go to the url at point if any. VERB."
1974 (let* ((ov (tinyurl-overlay-get))
1976 (buffer-substring-no-properties
1977 (overlay-start ov) (overlay-end ov)))))
1980 (funcall tinyurl-:url-handler-function))
1982 (message "TinyUrl: No url found.")))))
1984 ;;; ----------------------------------------------------------------------
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
1995 string Error Message."
1997 (let* ((fid "tinyurl-validate-url-default:")
1998 (info (ti::file-path-and-line-info url)) ;FILE:NBR --> FILE
1999 (type (tinyurl-type url))
2002 (setq url (car info)))
2006 ((string-match "^/\\(dev\\|proc\\)/" url)
2007 (format "TinyUrl: (url validate) Device file ignored"))
2010 "^\\(/usr\\(/local\\)?\\|/opt\\|/vol\\)?/s?bin/"
2011 ;; Ehm. What to do with Windows and Cygwin Files? This is
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)
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")
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/;
2045 (concat "TinyUrl: (url validate) Perl like statement rejected: "
2049 (tinyurl-debug fid url ret)
2052 ;;; ----------------------------------------------------------------------
2054 (defun tinyurl-validate-url-perl-method (url)
2055 "Check Perl Foo::Bar->new(...)."
2057 ((not (string-match "perl" (ti::id-info)))
2058 "TinyUrl: (perl url validate) rejected due to non-perl buffer")
2062 ;;; ----------------------------------------------------------------------
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 <.*@.*>
2068 <URL:http://groups.google.com/groups?as_q=&as_umsgid=3cgd8m0w.fsf@blue.sea.net>"
2070 ((string-match "http://\\|file:/\\|ftp://" url)
2071 "TinyUrl: (email url validate) rejected due to URI reference: %s" url)
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)
2081 ;;; ----------------------------------------------------------------------
2083 (defun tinyurl-find-url-lisp (url)
2084 "Find Emacs Llisp package URL."
2085 (let* ((file (ti::string-match "[\"']\\([^\"')]+\\)" 1 url)))
2087 (setq file (replace-regexp-in-string "c$" "" file))
2088 (setq file (ti::string-verify-ends file "\\.el" ".el")))
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))
2095 (find-file file)))))
2097 ;;; ----------------------------------------------------------------------
2099 (defun tinyurl-find-debian-bts-bug (url)
2100 "Find Debian BTS bug URL."
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)))))
2107 ;;; ----------------------------------------------------------------------
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"
2116 (line (ti::string-match
2117 "parse error in.*on line <b>\\([0-9]+\\)"
2120 (if (null line) ;Quiet byte compiler: unused var
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.
2128 ;;; ----------------------------------------------------------------------
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))
2134 ;; Check if the referenced pod page is on the current buffer
2136 ;; perlfunc - Perl builtin functions
2139 (setq point (ti::re-search-check (format "NAME\n +%s -" url)))
2142 (tinyperl-pod-by-manpage (tinyperl-pod-manpage-to-file url)))))
2144 ;;; ----------------------------------------------------------------------
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)))
2151 ;;; ----------------------------------------------------------------------
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]*"
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))
2164 (unless (re-search-forward regexp nil t)
2165 (message "TinyUrl: Hm, can't find sub using [%s]" regexp))))))
2167 ;;; ----------------------------------------------------------------------
2169 (defun tinyurl-find-url-perl-method (url)
2170 "Find Perl Foo::Bar->new(...) URL."
2173 (when (string-match "\\([^ \t\n]+\\)->\\([^ \t\n]+\\)" url)
2174 (setq file (match-string 1 url)
2175 method (match-string 2 url)))
2178 (message "TinyUrl: Opps, odd perl URL %s" url)
2181 (tinyurl-find-url-perl-1 file method)))))
2183 ;;; ----------------------------------------------------------------------
2185 (defun tinyurl-find-url-perl (url)
2186 "Find Perl `require' and `use' URL."
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))))
2196 (message "TinyUrl: Opps, odd perl URL %s" url)
2199 (tinyurl-find-url-perl-1 file)))))
2201 ;;; ----------------------------------------------------------------------
2203 (defun tinyurl-find-url-perl-compile (url &optional noerr)
2204 "Parse Perl compile output style URL.
2206 error in file FILE at line LINE
2209 If NOERR is non-nil, signal no error if file does not exist."
2210 (let* ((fid "tinyurl-find-url-perl-compile:")
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)
2220 (error "Tinyurl: Can't recognize URL [%s]" url))
2223 ((or (ti::find-file-or-window file line 'must-exist)
2225 (ti::find-file-or-window (file-name-nondirectory file)
2230 (error "TinyUrl: Can't locate %s" file))
2233 ;;; ----------------------------------------------------------------------
2235 (defun tinyurl-file-name-filter (url &optional line)
2236 "Check URL and LINE for filter in `tinyurl-:file-filter-table'.
2238 non-nil if Filter was used."
2239 (let* ((filter (tinyurl-get-filter url)))
2240 (tinyurl-debug "tinyurl-file-name-filter" url filter)
2243 (shell-command (format filter url))
2245 ((and (not (ti::bool-p filter))
2247 (funcall filter url)))))
2249 ;;; ----------------------------------------------------------------------
2251 (defun tinyurl-guess-line-number-at-point ()
2252 "Read current line and guess the line number."
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]+\\):")
2264 ;; test.pl:119:use integer;
2265 (string-to-int (match-string 1)))))))
2267 ;;; ----------------------------------------------------------------------
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)))
2276 (setq url (car info)))
2278 (setq line (tinyurl-guess-line-number-at-point)))
2280 ((string-match "://" url)
2281 (ti::string-url-to-ange-ftp url))
2282 ((string-match "file:\\(.*\\)" url)
2283 (match-string 1 url))
2286 (tinyurl-debug fid 'URL url 'INFO info 'LINE line)
2287 (unless (integerp line) ;; Make sure it's integer
2290 ((tinyurl-file-name-filter url line))
2292 (ti::select-frame-non-dedicated)
2293 (prog1 (ti::find-file-or-window url line (not 'must-exist) info)
2295 (goto-line (cdr info))))))))
2297 ;;; ----------------------------------------------------------------------
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))
2307 ;;; ----------------------------------------------------------------------
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)))
2315 ;;; ----------------------------------------------------------------------
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)))
2326 ;; skip basic references like: cut(1)
2327 (> (string-to-int page) 1))
2328 (format "%s(%s)" program page))
2333 ;;; ----------------------------------------------------------------------
2334 ;;; FIXME: What about various mailing list archives?
2335 ;;; FIXME: Perhaps Message-id query should be delegated to proper archives
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)
2344 "http://groups.google.com/groups?as_q=&as_umsgid="
2347 (tinyurl-agent-funcall 'url url))
2349 ;;; ----------------------------------------------------------------------
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))
2358 ;;; ----------------------------------------------------------------------
2360 (defun tinyurl-find-url-win32-netscape (url)
2361 "External URL handler."
2362 (tinyurl-call-process-win32 "netscape" url))
2364 ;;; ----------------------------------------------------------------------
2366 (defun tinyurl-find-url-win32-iexplore (url)
2367 "External URL handler."
2368 (tinyurl-call-process-win32 "iexplore" url))
2370 ;;; ----------------------------------------------------------------------
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
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)
2384 (message "TinyUrl: cached %s" url))))))
2386 ;;; ----------------------------------------------------------------------
2388 (defun tinyurl-url-clean (url type)
2389 "Clean URL if needed."
2390 (if (not (tinyurl-type-external-p url type))
2392 (if (stringp tinyurl-:cleaner-regexp)
2393 (replace-regexp-in-string
2394 tinyurl-:cleaner-regexp "" url)
2397 ;;; ----------------------------------------------------------------------
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:
2410 file-code-perl-pod-manpage
2411 file-code-perl-pod-module
2412 file-code-perl-method
2418 ;; .................................................... browser url ...
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)
2432 "#[0-9]+\\>\\|\\<\\(RF.\\|IT.\\|O\\) +[0-9]+" url)
2434 ;; ........................................................... code ...
2435 ((string-match "(\\(load\\|load-library\\|require\\) " url)
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)))
2458 ;;; ----------------------------------------------------------------------
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)))
2464 ;;; ----------------------------------------------------------------------
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")
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))
2485 (unless (re-search-forward "^To: " nil t)
2490 (unless (re-search-forward "^Subject: " nil t)
2492 (message "TinyUrl: [ERROR] Cannot continue,Subject: not found")
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
2503 ((string-match "-request@" clean)
2504 (insert "subscribe")))))))
2506 ;;; ----------------------------------------------------------------------
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)))
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)
2527 (message "TinyUrl: Strange Error, Couldn't detect URL type: [%s] [%s]"
2530 (tinyurl-handler-mail-after clean type))
2532 (if (and (tinyurl-type-external-p clean type)
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)))))))
2545 ;;; ----------------------------------------------------------------------
2547 (defun tinyurl-mark-process-post-command ()
2548 "Used in `post-command-hook'."
2551 (unless (integerp (setq counter (get 'tinyurl-mode '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)))))
2560 ;;; ----------------------------------------------------------------------
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)
2569 (goto-char (window-start))
2571 ;;; (ti::d! (ti::read-current-line))
2572 (let* ((end (line-end-position)))
2574 (get 'tinyurl-mark-line 'mouse)))
2575 (put 'tinyurl-mark-line 'mouse end)
2576 (tinyurl-mark-line))))))))
2578 ;;; ----------------------------------------------------------------------
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)))
2591 (get 'tinyurl-mark-line 'point)))
2592 (put 'tinyurl-mark-line 'point end)
2593 (tinyurl-mark-line)))
2594 (tinyurl-mark-mouse)))
2596 ;;; ----------------------------------------------------------------------
2598 (defun tinyurl-default-mark-table ()
2599 "Return default table used by `tinyurl-mark-line'.
2601 '( (REGEXP [SUB-MATCH] [SPAN-FLAG] [VALIDATE-HANDLER]) ..)
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
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)
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]+\\)?")
2632 (list (concat "\\<mailto:" white-re "*" nwhite-re "+") 0 'span)
2633 ;; This must come first
2634 (list "<URL:\\([^>]+\\)>" 1 'span)
2637 "\\(Message-Id:\\|References:\\|In Article\\)"
2638 white-re "*<[^>" white "]+>")
2643 "\\(\\(\\(ftp\\|https?\\|telnet\\|gopher\\|www\\|wais\\|news\\)://"
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
2651 ;; The regexp starts with "[^/], so that http://www match isn't
2652 ;; replaced with this.
2655 "[^/]www\\.\\([-a-z0-9]+\.\\)+[a-z][a-z][a-z]?"
2661 ;; #include <stdio.h>
2664 "^[ \t]*#include +<[^>]+>"
2665 "\\|^[ \t]*#include +\"[^\"]+\"")
2670 ;; RFA NNNNNN package -- ...
2671 ;; O NNNNNN package -- ...
2677 "\\|Closes:? +#[0-9]+\\>"
2678 "\\|\\<\\(RF.\\|IT\\.\\|O\\) +[0-9]+\\>")
2680 ;; Perl code statements
2682 ;; require 'library.pl';
2686 "\\<require[ \t\"']+[_a-z0-9.]+pl[ \t\"']*;"
2687 "\\|\\<use[ \t]+[_a-z0-9:]+[ \t]*;")
2689 ;; Perl Foo::Bar->new(...);
2690 '("\\<[A-Za-z]+::[A-Za-z]+\\(->[A-Za-z]+\\)?"
2693 tinyurl-validate-url-perl-method)
2694 ;; Browsing Perl POD pages
2696 ;; "See perlfunc manpage"
2698 ;; Devel::DProf manpage
2703 ;; "Regexp Quote-Like Operators" in perlop.
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]*$")
2713 ;; [Compiler output]
2714 ;; Perl error messages
2716 ;; Global symbol "x" requires explicit package name
2717 ;; at /users/foo/bin/file.pl line 289.
2719 ;; syntax error in file ./fle.pl at line 268
2722 " in file +" non-spc+ " +at +line +[0-9]+"
2723 "\\| at +" non-spc+ " +line +[0-9]+")
2725 ;; Manual pages . Examples from HP-UX
2727 ;; cut(1), ypmake(1M), unistd.h(5), typeahead(3X)
2728 ;; termios(7), sshd(8), html2ps(1) ssh-agent(1)
2731 "\\<[-_a-z.0-9]+([1-9][CMSX]?)"
2736 ;; (load-library "file.el")
2737 ;; (load-file "file.el")
2738 ;; (require 'feature)
2741 "(\\(load\\|load-library\\|load-file\\|require\\)[ \t\"']+"
2744 ;; ............................................ local files ...
2745 ;; Local files, this must be last because the regexp is "loose"
2746 ;; and would match if put above.
2748 ;; ~foo/dir/file.txt
2749 ;; /users/foo/file.txt
2750 ;; /usr/include/shadow.h:8
2752 ;; D:\dir\dir\file.txt
2753 ;; D:/dir/dir/file.txt
2754 ;; //server/dir/that/there
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
2761 ;; () grouped regexp reads: (SLASH NOT-SLASH|~SLASH)word*nbr?
2762 ;; The purpose is not to match double slash C++ comments //
2765 ;; Must be at the begining of line, or after whitespace
2767 "\\(" "\\(" drive "\\|//\\|[\\][\\]\\)?"
2768 slash-re "[^" white-file slash "]"
2769 "\\|~" slash-re "?\\)"
2772 ;; Must be 'alone' and separated from others.
2776 'tinyurl-validate-url-default)
2777 ;; Last try, the file may be inside Emacs already
2778 ;; this-file.el:12: The matched line...
2780 (concat "^\\(" nwhite-re "+\\)" compiler-number )
2783 'tinyurl-validate-url-default)))) ;; list of regexps end
2786 ;;; ----------------------------------------------------------------------
2788 (defun tinyurl-mark-line ()
2789 "Mark URLs with overlays on current line.
2791 list of overlays where the regexps matched.
2793 '((ov ov ..) (regexp regexp ..))"
2795 (let* ((fid "tinyurl-mark-line:")
2796 (plist (tinyurl-overlay-plist))
2797 (table (tinyurl-default-mark-table))
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.
2814 ;; Allow line span (setq end (line-end-position))
2817 (setq regexp (nth 0 elt)
2818 level (or (nth 1 elt) 0)
2819 end (line-end-position)
2821 function (nth 3 elt)
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.
2827 ;; Adjust calculated pos according to point-max
2829 ((eq type 'no-limit)
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)
2837 (+ 200 (line-beginning-position))
2840 (let ((pos (+ (point) (* 3 50))))
2841 (if (> pos (point-max))
2844 ;; ................................................... do work ...
2845 (tinyurl-debug fid "DOLIST-ELT: " end elt)
2850 (ti::overlay-re-search
2855 nil nil nil ;BACK REUSE REUSE-P
2856 '(owner tinyurl)))))
2858 (tinyurl-debug fid "OVERLAY-LIST" olist)
2861 ((not (overlayp ov))
2862 (message "TinyUrl: ERROR, non-overlay %s"
2863 (prin1-to-string ov))
2864 (tinyurl-debug fid 'NON-OVERLAY ov))
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.
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")
2876 (push regexp match-list)
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))))
2890 (add-hook 'tinyurl-:mode-define-keys-hook 'tinyurl-mode-define-keys)
2895 (run-hooks 'tinyurl-:load-hook)
2897 ;;; tinyurl.el ends here