mirror of
https://github.com/rkd77/elinks.git
synced 2024-12-04 14:46:47 -05:00
1418 lines
43 KiB
Perl
1418 lines
43 KiB
Perl
# Example ~/.elinks/hooks.pl
|
||
#
|
||
# Copyleft by Russ Rowan (See the file "COPYING" for details.)
|
||
#
|
||
# To get documentation for this file:
|
||
# pod2html hooks.pl > hooks.html && elinks hooks.html
|
||
# or
|
||
# perldoc hooks.pl
|
||
|
||
=head1 NAME
|
||
|
||
hooks.pl -- Perl hooks for the ELinks text WWW browser
|
||
|
||
=head1 DESCRIPTION
|
||
|
||
This file contains the Perl hooks for the ELinks text WWW browser.
|
||
|
||
These hooks change the browser's behavior in various ways. They allow
|
||
shortcuts to be used in the Goto URL dialog, modifying the source of a page,
|
||
proxy handling, and other things such as displaying a fortune at exit.
|
||
|
||
=cut
|
||
use strict;
|
||
use warnings;
|
||
use diagnostics;
|
||
|
||
=head1 CONFIGURATION FILE
|
||
|
||
This hooks file reads its configuration from I<~/.elinks/config.pl>.
|
||
The following is an example of the configuration file:
|
||
|
||
bork: yep # BORKify Google?
|
||
collapse: okay # Collapse all XBEL bookmark folders on exit?
|
||
email: # Set to show one's own bugs with the "bug" prefix.
|
||
external: wget # Send the current URL to this application.
|
||
fortune: elinks # *fortune*, *elinks* tip, or *none* on quit?
|
||
googlebeta: hell no # I miss DejaNews...
|
||
gotosearch: why not # Anything not a URL in the Goto URL dialog...
|
||
ipv6: sure # IPV4 or 6 address blocks with "ip" prefix?
|
||
language: english # "bf nl en" still works, but now "bf nl" does too
|
||
news: msnbc # Agency to use for "news" and "n" prefixes
|
||
search: elgoog # Engine for (search|find|www|web|s|f|go) prefixes
|
||
usenet: google # *google* or *standard* view for news:// URLs
|
||
weather: cnn # Server for "weather" and "w" prefixes
|
||
|
||
# news: bbc, msnbc, cnn, fox, google, yahoo, reuters, eff, wired,
|
||
# slashdot, newsforge, usnews, newsci, discover, sciam
|
||
# search: elgoog, google, yahoo, ask jeeves, a9, altavista, msn, dmoz,
|
||
# dogpile, mamma, webcrawler, netscape, lycos, hotbot, excite
|
||
# weather: weather underground, google, yahoo, cnn, accuweather,
|
||
# ask jeeves
|
||
|
||
I<Developer's usage>: The function I<loadrc()> takes a preference name as its
|
||
single argument and returns either an empty string if it is not specified,
|
||
I<yes> for a true value (even if specified like I<sure> or I<why not>), I<no>
|
||
for a false value (even if like I<nah>, I<off> or I<0>), or the lowercased
|
||
preference value (like I<cnn> for C<weather: CNN>).
|
||
|
||
=cut
|
||
sub loadrc($)
|
||
{
|
||
my ($preference) = @_;
|
||
my $configperl = $ENV{'HOME'} . '/.elinks/config.pl';
|
||
my $answer = '';
|
||
|
||
open RC, "<$configperl" or return $answer;
|
||
while (<RC>)
|
||
{
|
||
s/\s*#.*$//;
|
||
next unless (m/(.*):\s*(.*)/);
|
||
my $setting = $1;
|
||
my $switch = $2;
|
||
next unless ($setting eq $preference);
|
||
|
||
if ($switch =~ /^(yes|1|on|yea|yep|sure|ok|okay|yeah|why.*not)$/)
|
||
{
|
||
$answer = "yes";
|
||
}
|
||
elsif ($switch =~ /^(no|0|off|nay|nope|nah|hell.*no)$/)
|
||
{
|
||
$answer = "no";
|
||
}
|
||
else
|
||
{
|
||
$answer = lc($switch);
|
||
}
|
||
}
|
||
close RC;
|
||
|
||
return $answer;
|
||
}
|
||
|
||
|
||
|
||
=head1 GOTO URL HOOK
|
||
|
||
This is a summary of the shortcuts defined in this file for use in the Goto URL
|
||
dialog. They are similar to the builtin URL prefixes, but more flexible and
|
||
powerful.
|
||
|
||
=over
|
||
|
||
=item
|
||
I<Developer's usage>: The function I<goto_url_hook> is called when the hook is
|
||
triggered, taking the target URL and current URL as its two arguments. It
|
||
returns the final target URL.
|
||
|
||
These routines do a name->URL mapping - for example, the I<goto_url_hook()>
|
||
described above maps a certain prefix to C<google> and then asks the
|
||
I<search()> mapping routine described below to map the C<google> string to an
|
||
appropriate URL.
|
||
|
||
There are generally two URLs for each name. One to go to the particular URL's
|
||
main page, and another for a search on the given site (if any string is
|
||
specified after the prefix). A few of these prefixes will change their
|
||
behavior depending on the URL currently beung displayed in the browser.
|
||
|
||
=cut
|
||
# Don't call them "dumb". They hate that. Rather, "interactivity challenged".
|
||
################################################################################
|
||
### goto_url_hook ##############################################################
|
||
sub goto_url_hook
|
||
{
|
||
my $url = shift;
|
||
my $current_url = shift;
|
||
|
||
|
||
=item Bugmenot:
|
||
|
||
B<bugmenot> or B<bn>
|
||
|
||
=cut
|
||
############################################################################
|
||
# "bugmenot" (no blood today, thank you)
|
||
if ($url =~ '^(bugmenot|bn)$' and $current_url)
|
||
{
|
||
($current_url) = $current_url =~ /^.*:\/\/(.*)/;
|
||
my $bugmenot = 'http://bugmenot.com/view.php?url=' . $current_url;
|
||
#my $tempfile = $ENV{'HOME'} . '/.elinks/elinks';
|
||
#my $matrix = '1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
|
||
#for (0..int(rand(7) + 9))
|
||
#{
|
||
#$tempfile = $tempfile . substr($matrix, (length($matrix) - 1) - rand(length($matrix) + 1), 1);
|
||
#}
|
||
#my ($message, $login, $password);
|
||
#system('elinks -no-home -source "' . $bugmenot . '" >' . $tempfile . ' 2>/dev/null');
|
||
#open FILE, "<$tempfile" or return $bugmenot;
|
||
#$message = <FILE>;
|
||
#while (<FILE>)
|
||
#{
|
||
#next unless (m/^<dd>(.*)<br \/>(.*)<\/dd><\/dl>$/);
|
||
#$login = $1;
|
||
#$password = $2;
|
||
#}
|
||
#$login =~ s/(^\s*|\n|\s*$)//g if $login;
|
||
#$password =~ s/(^\s*|\n|\s*$)//g if $password;
|
||
#close FILE;
|
||
#unlink $tempfile;
|
||
#return $bugmenot unless $message =~ /[a-z]+/ and $message !~ /404/;
|
||
#unless ($message =~ s/.*(No accounts found\.).*/${1}/)
|
||
#{
|
||
#if ($login and $password)
|
||
#{
|
||
#$message = "Login: " . $login . "\nPassword: " . $password;
|
||
#}
|
||
#else
|
||
#{
|
||
#$message = 'No accounts found';
|
||
#}
|
||
#}
|
||
#system('elinks -remote "infoBox\(' . $message . ')" >/dev/null 2>&1 &');
|
||
#return $current_url; #FIXME
|
||
##return;
|
||
return $bugmenot . $current_url;
|
||
}
|
||
|
||
|
||
############################################################################
|
||
# Random URL generator
|
||
if ($url eq 'bored' or $url eq 'random')
|
||
{
|
||
my $word; # You can say *that* again...
|
||
srand();
|
||
open FILE, '</usr/share/dict/words'
|
||
or open FILE, '</usr/share/dict/linux.words'
|
||
or open FILE, '</usr/dict/words'
|
||
or open FILE, '</usr/dict/linux.words'
|
||
or open FILE, '</usr/share/dict/yawl.list'
|
||
or open FILE, $ENV{"HOME"} . '/.elinks/elinks.words'
|
||
or return 'http://google.com/webhp?hl=xx-bork';
|
||
rand($.) < 1 && ($word = $_) while <FILE>;
|
||
close FILE;
|
||
($word) = $word =~ /(.*)/;
|
||
return 'http://' . lc($word) . '.com';
|
||
}
|
||
|
||
|
||
=item Web search:
|
||
|
||
=over
|
||
|
||
=item Google: B<g> or B<google> (default)
|
||
|
||
=item Yahoo: B<y> or B<yahoo>
|
||
|
||
=item Ask Jeeves: B<ask> or B<jeeves>
|
||
|
||
=item Amazon A9: B<a9>
|
||
|
||
=item Altavista: B<av> or B<altavista>
|
||
|
||
=item Microsoft: B<msn> or B<microsoft>
|
||
|
||
=item Mozilla Open Directory: B<dmoz>, B<odp>, B<mozilla>
|
||
|
||
=item Dogpile: B<dp> or B<dogpile>
|
||
|
||
=item Mamma: B<ma> or B<mamma>
|
||
|
||
=item Webcrawler: B<wc> or B<webcrawler>
|
||
|
||
=item Netscape: B<ns> or B<netscape>
|
||
|
||
=item Lycos: B<ly> or B<lycos>
|
||
|
||
=item Hotbot: B<hb> or B<hotbot>
|
||
|
||
=item Excite: B<ex> or B<excite>
|
||
|
||
=item Elgoog: B<eg>, B<elgoog>, B<hcraes>, B<dnif>, B<bew>, B<og>
|
||
|
||
=back
|
||
|
||
default engine: B<search>, B<find>, B<www>, B<web>, B<s>, B<f>, B<go>
|
||
|
||
=over
|
||
|
||
The I<%search_engines> hash maps each engine name to two URLs, I<home> and
|
||
I<search>. With I<search>, the query is appended to the URL.
|
||
|
||
The search engines mapping is done by the I<search()> function, taking the
|
||
search engine name as its first parameter and optional search string as its
|
||
second parameter. It returns the mapped target URL.
|
||
|
||
=back
|
||
|
||
=back
|
||
|
||
=cut
|
||
############################################################################
|
||
# Search engines
|
||
my %search_prefixes;
|
||
$search_prefixes{'^(g|google)(| .*)$'} = 'google'; # Google (default)
|
||
$search_prefixes{'^(y|yahoo)(| .*)$'} = 'yahoo'; # Yahoo
|
||
$search_prefixes{'^(ask|jeeves)(| .*)$'} = 'ask jeeves'; # Ask Jeeves
|
||
$search_prefixes{'^a9(| .*)$'} = 'a9'; # Amazon A9
|
||
$search_prefixes{'^(av|altavista)(| .*)$'} = 'altavista'; # Altavista
|
||
$search_prefixes{'^(msn|microsoft)(| .*)$'} = 'msn'; # Microsoft
|
||
$search_prefixes{'^(dmoz|odp|mozilla)(| .*)$'} = 'dmoz'; # Mozilla Open Directory
|
||
$search_prefixes{'^(dp|dogpile)(| .*)$'} = 'dogpile'; # Dogpile
|
||
$search_prefixes{'^(ma|mamma)(| .*)$'} = 'mamma'; # Mamma
|
||
$search_prefixes{'^(wc|webcrawler)(| .*)$'} = 'webcrawler'; # Webcrawler
|
||
$search_prefixes{'^(ns|netscape)(| .*)$'} = 'netscape'; # Netscape
|
||
$search_prefixes{'^(ly|lycos)(| .*)$'} = 'lycos'; # Lycos
|
||
$search_prefixes{'^(hb|hotbot)(| .*)$'} = 'hotbot'; # Hotbot
|
||
$search_prefixes{'^(ex|excite)(| .*)$'} = 'excite'; # Excite
|
||
$search_prefixes{'^(eg|elgoog|hcraes|dnif|bew|og)(| .*)$'} = 'elgoog'; # Elgoog
|
||
|
||
sub search
|
||
{
|
||
my %search_engines =
|
||
(
|
||
"elgoog" => {
|
||
home => 'http://alltooflat.com/geeky/elgoog/m/index.cgi',
|
||
search => 'http://alltooflat.com/geeky/elgoog/m/index.cgi?page=%2fsearch&cgi=get&q='},
|
||
"google" => {
|
||
home => 'http://google.com!bork!',
|
||
search => 'http://google.com/search?!bork!q='},
|
||
"yahoo" => {
|
||
home => 'http://yahoo.com',
|
||
search => 'http://search.yahoo.com/search?p='},
|
||
"ask jeeves" => {
|
||
home => 'http://ask.com',
|
||
search => 'http://web.ask.com/web?q='},
|
||
"a9" => {
|
||
home => 'http://a9.com',
|
||
search => 'http://a9.com/?q='},
|
||
"altavista" => {
|
||
home => 'http://altavista.com',
|
||
search => 'http://altavista.com/web/results?q='},
|
||
"msn" => {
|
||
home => 'http://msn.com',
|
||
search => 'http://search.msn.com/results.aspx?q='},
|
||
"dmoz" => {
|
||
home => 'http://dmoz.org',
|
||
search => 'http://search.dmoz.org/cgi-bin/search?search='},
|
||
"dogpile" => {
|
||
home => 'http://dogpile.com',
|
||
search => 'http://dogpile.com/info.dogpl/search/web/'},
|
||
"mamma" => {
|
||
home => 'http://mamma.com',
|
||
search => 'http://mamma.com/Mamma?query='},
|
||
"webcrawler" => {
|
||
home => 'http://webcrawler.com',
|
||
search => 'http://webcrawler.com/info.wbcrwl/search/web/'},
|
||
"netscape" => {
|
||
home => 'http://search.netscape.com',
|
||
search => 'http://channels.netscape.com/ns/search/default.jsp?query='},
|
||
"lycos" => {
|
||
home => 'http://lycos.com',
|
||
search => 'http://search.lycos.com/default.asp?query='},
|
||
"hotbot" => {
|
||
home => 'http://hotbot.com',
|
||
search => 'http://hotbot.com/default.asp?query='},
|
||
"excite" => {
|
||
home => 'http://search.excite.com',
|
||
search => 'http://search.excite.com/info.xcite/search/web/'},
|
||
);
|
||
|
||
my ($engine, $search) = @_;
|
||
my $key = $search ? 'search' : 'home';
|
||
$engine = 'google' unless $search_engines{$engine}
|
||
and $search_engines{$engine}->{$key};
|
||
my $url = $search_engines{$engine}->{$key};
|
||
if ($engine eq 'google')
|
||
{
|
||
my $bork = '';
|
||
if (loadrc('bork') eq 'yes')
|
||
{
|
||
if (not $search)
|
||
{
|
||
$bork = "/webhp?hl=xx-bork";
|
||
}
|
||
else
|
||
{
|
||
$bork = "hl=xx-bork&";
|
||
}
|
||
}
|
||
$url =~ s/!bork!/$bork/;
|
||
}
|
||
if ($search)
|
||
{
|
||
$search =~ s/%/%25/g;
|
||
$search =~ s/&/%26/g;
|
||
$search =~ s/\s/%20/g;
|
||
$search =~ s/\+/%2b/g;
|
||
$search =~ s/#/%23/g;
|
||
$url .= $search;
|
||
}
|
||
return $url;
|
||
}
|
||
|
||
my ($search) = $url =~ /^\S+\s+(.*)/;
|
||
if ($url =~ /^(search|find|www|web|s|f|go)(| .*)$/)
|
||
{
|
||
return search(loadrc('search'), $search);
|
||
}
|
||
foreach my $prefix (keys %search_prefixes)
|
||
{
|
||
next unless $url =~ /$prefix/;
|
||
return search($search_prefixes{$prefix}, $search);
|
||
}
|
||
|
||
|
||
=over
|
||
|
||
=item News agencies:
|
||
|
||
=over
|
||
|
||
=item British Broadcasting Corporation: B<bbc> (default)
|
||
|
||
=item MSNBC: B<msnbc>
|
||
|
||
=item Cable News Network: B<cnn>
|
||
|
||
=item FOXNews: B<fox>
|
||
|
||
=item Google News: B<gn>
|
||
|
||
=item Yahoo News: B<yn>
|
||
|
||
=item Reuters: B<rs> or B<reuters>
|
||
|
||
=item Electronic Frontier Foundation: B<eff>
|
||
|
||
=item Wired: B<wd> or B<wired>
|
||
|
||
=item Slashdot: B</.> or B<sd> or B<slashdot>
|
||
|
||
=item NewsForge: B<nf> or B<newsforge>
|
||
|
||
=item U.S.News & World Report: B<us> or B<usnews>
|
||
|
||
=item New Scientist: B<newsci> or B<nsci>
|
||
|
||
=item Discover Magazine: B<dm>
|
||
|
||
=item Scientific American: B<sa> or B<sciam>
|
||
|
||
=back
|
||
|
||
default agency: B<n>, B<news>
|
||
|
||
=over
|
||
|
||
The I<%news_servers> hash maps each engine name to two URLs, I<home> and
|
||
I<search>. With I<search>, the query is appended to the mapped URL.
|
||
|
||
The news servers mapping is done by the I<news()> function, taking the search
|
||
engine name as its first parameter and optional search string as its second
|
||
parameter. It returns the mapped target URL.
|
||
|
||
=back
|
||
|
||
=back
|
||
|
||
=cut
|
||
############################################################################
|
||
# News
|
||
my %news_prefixes;
|
||
$news_prefixes{'^bbc(| .*)$'} = 'bbc'; # British Broadcasting Corporation (default)
|
||
$news_prefixes{'^msnbc(| .*)$'} = 'msnbc'; # MSNBC
|
||
$news_prefixes{'^cnn(| .*)$'} = 'cnn'; # Cable News Network
|
||
$news_prefixes{'^fox(| .*)$'} = 'fox'; # FOXNews
|
||
$news_prefixes{'^gn(| .*)$'} = 'google'; # Google News
|
||
$news_prefixes{'^yn(| .*)$'} = 'yahoo'; # Yahoo News
|
||
$news_prefixes{'^(reuters|rs)(| .*)$'} = 'reuters'; # Reuters
|
||
$news_prefixes{'^eff(| .*)$'} = 'eff'; # Electronic Frontier Foundation
|
||
$news_prefixes{'^(wired|wd)(| .*)$'} = 'wired'; # Wired
|
||
$news_prefixes{'^(\/\.|slashdot|sd)(| .*)$'} = 'slashdot'; # Slashdot
|
||
$news_prefixes{'^(newsforge|nf)(| .*)$'} = 'newsforge'; # NewsForge
|
||
$news_prefixes{'^(us|usnews)(| .*)$'} = 'usnews'; # U.S.News & World Report
|
||
$news_prefixes{'^(nsci|newsci)(| .*)$'} = 'newsci'; # New Scientist
|
||
$news_prefixes{'^dm(| .*)$'} = 'discover'; # Discover Magazine
|
||
$news_prefixes{'^(sa|sciam)(| .*)$'} = 'sciam'; # Scientific American
|
||
|
||
sub news
|
||
{
|
||
my %news_servers =
|
||
(
|
||
"bbc" => {
|
||
home => 'http://news.bbc.co.uk',
|
||
search => 'http://newssearch.bbc.co.uk/cgi-bin/search/results.pl?q='},
|
||
"msnbc" => { # The bastard child of Microsoft and the National Broadcasting Corporation
|
||
home => 'http://msnbc.com',
|
||
search => 'http://msnbc.msn.com/?id=3053419&action=fulltext&querytext='},
|
||
"cnn" => {
|
||
home => 'http://cnn.com',
|
||
search => 'http://search.cnn.com/pages/search.jsp?query='},
|
||
"fox" => {
|
||
home => 'http://foxnews.com',
|
||
search => 'http://search.foxnews.com/info.foxnws/redirs_all.htm?pgtarg=wbsdogpile&qkw='},
|
||
"google" => {
|
||
home => 'http://news.google.com',
|
||
search => 'http://news.google.com/news?q='},
|
||
"yahoo" => {
|
||
home => 'http://news.yahoo.com',
|
||
search => 'http://news.search.yahoo.com/search/news/?p='},
|
||
"reuters" => {
|
||
home => 'http://reuters.com',
|
||
search => 'http://reuters.com/newsSearchResultsHome.jhtml?query='},
|
||
"eff" => {
|
||
home => 'http://eff.org',
|
||
search => 'http://google.com/search?sitesearch=http://eff.org&q='},
|
||
"wired" => {
|
||
home => 'http://wired.com',
|
||
search => 'http://search.wired.com/wnews/default.asp?query='},
|
||
"slashdot" => {
|
||
home => 'http://slashdot.org',
|
||
search => 'http://slashdot.org/search.pl?query='},
|
||
"newsforge" => {
|
||
home => 'http://newsforge.com',
|
||
search => 'http://newsforge.com/search.pl?query='},
|
||
"usnews" => {
|
||
home => 'http://usnews.com',
|
||
search => 'http://www.usnews.com/search/Search?keywords='},
|
||
"newsci" => {
|
||
home => 'http://newscientist.com',
|
||
search => 'http://www.newscientist.com/search.ns?doSearch=true&articleQuery.queryString='},
|
||
"discover" => {
|
||
home => 'http://discover.com',
|
||
search => 'http://www.discover.com/search-results/?searchStr='},
|
||
"sciam" => {
|
||
home => 'http://sciam.com',
|
||
search => 'http://sciam.com/search/index.cfm?QT=Q&SC=Q&Q='},
|
||
);
|
||
|
||
my ($server, $search) = @_;
|
||
my $key = $search ? 'search' : 'home';
|
||
$server = 'bbc' unless $news_servers{$server}
|
||
and $news_servers{$server}->{$key};
|
||
my $url = $news_servers{$server}->{$key};
|
||
$url .= $search if $search;
|
||
return $url;
|
||
}
|
||
|
||
if ($url =~ /^(news|n)(| .*)$/)
|
||
{
|
||
return news(loadrc('news'), $search);
|
||
}
|
||
foreach my $prefix (keys %news_prefixes)
|
||
{
|
||
next unless $url =~ /$prefix/;
|
||
return news($news_prefixes{$prefix}, $search);
|
||
}
|
||
|
||
|
||
=over
|
||
|
||
=item Locators:
|
||
|
||
=over
|
||
|
||
=item Internet Movie Database: B<imdb>, B<movie>, or B<flick>
|
||
|
||
=item US zip code search: B<zip> or B<usps> (# or address)
|
||
|
||
=item IP address locator / address space: B<ip>
|
||
|
||
=item WHOIS / TLD list: B<whois> (current url or specified)
|
||
|
||
=item Request for Comments: B<rfc> (# or search)
|
||
|
||
=item Weather: B<w> or B<weather>
|
||
|
||
=item Yahoo! Finance / NASD Regulation: B<stock>, B<ticker>, or B<quote>
|
||
|
||
=item Snopes: B<ul>, B<urban>, or B<legend>
|
||
|
||
=item Torrent search / ISOHunt: B<bt>, B<torrent>, or B<bittorrent>
|
||
|
||
=item Wayback Machine: B<ia>, B<ar>, B<arc>, or B<archive> (current url or specified)
|
||
|
||
=item Freshmeat: B<fm> or B<freshmeat>
|
||
|
||
=item SourceForge: B<sf> or B<sourceforge>
|
||
|
||
=item Savannah: B<sv> or B<savannah>
|
||
|
||
=item Gna!: B<gna>
|
||
|
||
=item BerliOS: B<bl> or B<berlios>
|
||
|
||
=item Netcraft Uptime Survey: B<whatis> or B<uptime> (current url or specified)
|
||
|
||
=item Who's Alive and Who's Dead: Wanted, B<dead> or B<alive>!
|
||
|
||
=item Google Library / Project Gutenberg: B<book> or B<read>
|
||
|
||
=item Internet Public Library: B<ipl>
|
||
|
||
=item VIM Tips: B<vt> (# or search)
|
||
|
||
=item Urban Dictionary: B<urbandict> or B<ud> <I<word>>
|
||
|
||
=back
|
||
|
||
=over
|
||
|
||
The I<%locators> hash maps each engine name to two URLs, I<home> and I<search>.
|
||
|
||
B<!current!> string in the URL is substitued for the URL of the current
|
||
document.
|
||
|
||
B<!query!> string in the I<search> URL is substitued for the search string. If
|
||
no B<!query!> string is found in the URL, the query is appended to the mapped
|
||
URL.
|
||
|
||
The locators mapping is done by the I<location()> function, taking the search
|
||
engine name as its first parameter, optional search string as its second
|
||
parameter and the current document's URL as its third parameter. It returns
|
||
the mapped target URL.
|
||
|
||
=back
|
||
|
||
=cut
|
||
############################################################################
|
||
# Locators
|
||
my %locator_prefixes;
|
||
$locator_prefixes{'^(imdb|movie|flick)(| .*)$'} = 'imdb'; # Internet Movie Database
|
||
$locator_prefixes{'^(stock|ticker|quote)(| .*)$'} = 'stock'; # Yahoo! Finance / NASD Regulation
|
||
$locator_prefixes{'^(urban|legend|ul)(| .*)$'} = 'bs'; # Snopes
|
||
$locator_prefixes{'^(bittorrent|torrent|bt)(| .*)$'} = 'torrent'; # Torrent search / ISOHunt
|
||
$locator_prefixes{'^(archive|arc|ar|ia)(| .*)$'} = 'archive'; # Wayback Machine
|
||
$locator_prefixes{'^(freshmeat|fm)(| .*)$'} = 'freshmeat'; # Freshmeat
|
||
$locator_prefixes{'^(sourceforge|sf)(| .*)$'} = 'sourceforge'; # SourceForge
|
||
$locator_prefixes{'^(savannah|sv)(| .*)$'} = 'savannah'; # Savannah
|
||
$locator_prefixes{'^gna(| .*)$'} = 'gna'; # Gna!
|
||
$locator_prefixes{'^(berlios|bl)(| .*)$'} = 'berlios'; # BerliOS
|
||
$locator_prefixes{'^(alive|dead)(| .*)$'} = 'dead'; # Who's Alive and Who's Dead
|
||
$locator_prefixes{'^(book|read)(| .*)$'} = 'book'; # Google Library / Project Gutenberg
|
||
$locator_prefixes{'^ipl(| .*)$'} = 'ipl'; # Internet Public Library
|
||
$locator_prefixes{'^(urbandict|ud)(| .*)$'} = 'urbandict'; # Urban Dictionary
|
||
$locator_prefixes{'^ubs(| .*)$'} = 'ubs'; # Usenet binary search
|
||
|
||
my %weather_locators =
|
||
(
|
||
'weather underground' => 'http://wunderground.com/cgi-bin/findweather/getForecast?query=!query!',
|
||
'google' => 'http://google.com/search?q=weather+"!query!"',
|
||
'yahoo' => 'http://search.yahoo.com/search?p=weather+"!query!"',
|
||
'cnn' => 'http://weather.cnn.com/weather/search?wsearch=!query!',
|
||
'accuweather' => 'http://wwwa.accuweather.com/adcbin/public/us_getcity.asp?zipcode=!query!',
|
||
'ask jeeves' => 'http://web.ask.com/web?&q=weather !query!',
|
||
);
|
||
|
||
sub location
|
||
{
|
||
my %locators =
|
||
(
|
||
'imdb' => {
|
||
home => 'http://imdb.com',
|
||
search => 'http://imdb.com/Find?select=All&for='},
|
||
'stock' => {
|
||
home => 'http://nasdr.com',
|
||
search => 'http://finance.yahoo.com/l?s='},
|
||
'bs' => {
|
||
home => 'http://snopes.com',
|
||
search => 'http://search.atomz.com/search/?sp-a=00062d45-sp00000000&sp-q='},
|
||
'torrent' => {
|
||
home => 'http://isohunt.com',
|
||
search => 'http://google.com/search?q=filetype:torrent !query!!bork!'},
|
||
'archive' => {
|
||
home => 'http://web.archive.org/web/*/!current!',
|
||
search => 'http://web.archive.org/web/*/'},
|
||
'freshmeat' => {
|
||
home => 'http://freshmeat.net',
|
||
search => 'http://freshmeat.net/search/?q='},
|
||
'sourceforge' => {
|
||
home => 'http://sourceforge.net',
|
||
search => 'http://sourceforge.net/search/?q='},
|
||
'savannah' => {
|
||
home => 'http://savannah.nongnu.org',
|
||
search => 'http://savannah.nongnu.org/search/?type_of_search=soft&words='},
|
||
'gna' => {
|
||
home => 'http://gna.org',
|
||
search => 'https://gna.org/search/?type_of_search=soft&words='},
|
||
'berlios' => {
|
||
home => 'http://www.berlios.de',
|
||
search => 'http://developer.berlios.de/search/?type_of_search=soft&words='},
|
||
'dead' => {
|
||
home => 'http://www.whosaliveandwhosdead.com',
|
||
search => 'http://google.com/search?btnI&sitesearch=http://whosaliveandwhosdead.com&q='},
|
||
'book' => {
|
||
home => 'http://gutenberg.org',
|
||
search => 'http://google.com/search?q=book+"!query!"'},
|
||
'ipl' => {
|
||
home => 'http://ipl.org',
|
||
search => 'http://ipl.org/div/searchresults/?words='},
|
||
'urbandict' => {
|
||
home => 'http://urbandictionary.com/random.php',
|
||
search => 'http://urbandictionary.com/define.php?term='},
|
||
'ubs' => {
|
||
home => 'http://binsearch.info',
|
||
search => 'http://binsearch.info/?q='},
|
||
);
|
||
|
||
my ($server, $search, $current_url) = @_;
|
||
my $key = $search ? 'search' : 'home';
|
||
return unless $locators{$server} and $locators{$server}->{$key};
|
||
my $url = $locators{$server}->{$key};
|
||
my $bork = ""; $bork = "&hl=xx-bork" unless (loadrc("bork") ne "yes");
|
||
$url =~ s/!bork!/$bork/g;
|
||
$url =~ s/!current!/$current_url/g;
|
||
$url .= $search if $search and not $url =~ s/!query!/$search/g;
|
||
return $url;
|
||
}
|
||
|
||
foreach my $prefix (keys %locator_prefixes)
|
||
{
|
||
next unless $url =~ /$prefix/;
|
||
return location($locator_prefixes{$prefix}, $search, $current_url);
|
||
}
|
||
|
||
if ($url =~ '^(zip|usps)(| .*)$'
|
||
or $url =~ '^ip(| .*)$'
|
||
or $url =~ '^whois(| .*)$'
|
||
or $url =~ '^rfc(| .*)$'
|
||
or $url =~ '^(weather|w)(| .*)$'
|
||
or $url =~ '^(whatis|uptime)(| .*)$'
|
||
or $url =~ '^vt(| .*)$')
|
||
{
|
||
my ($thingy) = $url =~ /^[a-z]* (.*)/;
|
||
my ($domain) = $current_url =~ /([a-z0-9-]+\.(com|net|org|edu|gov|mil))/;
|
||
|
||
my $locator_zip = 'http://usps.com';
|
||
my $ipv = "ipv4-address-space"; $ipv = "ipv6-address-space" if loadrc("ipv6") eq "yes";
|
||
my $locator_ip = 'http://www.iana.org/assignments/' . $ipv;
|
||
my $whois = 'http://reports.internic.net/cgi/whois?type=domain&whois_nic=';
|
||
my $locator_whois = 'http://www.iana.org/cctld/cctld-whois.htm';
|
||
$locator_whois = $whois . $domain if $domain;
|
||
my $locator_rfc = 'http://ietf.org';
|
||
my $locator_weather = 'http://weather.noaa.gov';
|
||
my $locator_whatis = 'http://uptime.netcraft.com';
|
||
$locator_whatis = 'http://uptime.netcraft.com/up/graph/?host=' . $domain if $domain;
|
||
my $locator_vim = 'http://www.vim.org/tips';
|
||
if ($thingy)
|
||
{
|
||
$locator_zip = 'http://zip4.usps.com/zip4/zip_responseA.jsp?zipcode=' . $thingy;
|
||
$locator_zip = 'http://zipinfo.com/cgi-local/zipsrch.exe?zip=' . $thingy if $thingy !~ '^[0-9]*$';
|
||
$locator_ip = 'http://melissadata.com/lookups/iplocation.asp?ipaddress=' . $thingy;
|
||
$locator_whois = $whois . $thingy;
|
||
$locator_rfc = 'http://rfc-editor.org/cgi-bin/rfcsearch.pl?num=37&searchwords=' . $thingy;
|
||
$locator_rfc = 'http://ietf.org/rfc/rfc' . $thingy . '.txt' unless $thingy !~ '^[0-9]*$';
|
||
my $weather = loadrc("weather");
|
||
$locator_weather = $weather_locators{$weather};
|
||
$locator_weather ||= $weather_locators{'weather underground'};
|
||
$locator_weather =~ s/!query!/$thingy/;
|
||
$locator_whatis = 'http://uptime.netcraft.com/up/graph/?host=' . $thingy;
|
||
$locator_vim = 'http://www.vim.org/tips/tip_search_results.php?order_by=rating&keywords=' . $thingy;
|
||
$locator_vim = 'http://www.vim.org/tips/tip.php?tip_id=' . $thingy unless $thingy !~ '^[0-9]*$';
|
||
}
|
||
return $locator_zip if ($url =~ '^(zip|usps)(| .*)$');
|
||
return $locator_ip if ($url =~ '^ip(| .*)$');
|
||
return $locator_whois if ($url =~ '^whois(| .*)$');
|
||
return $locator_rfc if ($url =~ '^rfc(| .*)$');
|
||
return $locator_weather if ($url =~ '^(weather|w)(| .*)$');
|
||
return $locator_whatis if ($url =~ '^(whatis|uptime)(| .*)$');
|
||
return $locator_vim if ($url =~ '^vt(| .*)$');
|
||
}
|
||
|
||
|
||
=item Google Groups:
|
||
|
||
B<deja>, B<gg>, B<groups>, B<gr>, B<nntp>, B<usenet>, B<nn>
|
||
|
||
=cut
|
||
############################################################################
|
||
# Google Groups (DejaNews)
|
||
if ($url =~ '^(deja|gg|groups|gr|nntp|usenet|nn)(| .*)$')
|
||
{
|
||
my ($search) = $url =~ /^[a-z]* (.*)/;
|
||
my $beta = "groups.google.co.uk";
|
||
$beta = "groups-beta.google.com" unless (loadrc("googlebeta") ne "yes");
|
||
my $bork = "";
|
||
if ($search)
|
||
{
|
||
$bork = "&hl=xx-bork" unless (loadrc("bork") ne "yes");
|
||
my ($msgid) = $search =~ /^<(.*)>$/;
|
||
return 'http://' . $beta . '/groups?as_umsgid=' . $msgid . $bork if $msgid;
|
||
return 'http://' . $beta . '/groups?q=' . $search . $bork;
|
||
}
|
||
else
|
||
{
|
||
$bork = "/groups?hl=xx-bork" unless (loadrc("bork") ne "yes");
|
||
return 'http://' . $beta . $bork;
|
||
}
|
||
}
|
||
|
||
|
||
=item MirrorDot:
|
||
|
||
B<md> or B<mirrordot> <I<URL>>
|
||
|
||
=cut
|
||
############################################################################
|
||
# MirrorDot
|
||
if ($url =~ '^(mirrordot|md)(| .*)$')
|
||
{
|
||
my ($slashdotted) = $url =~ /^[a-z]* (.*)/;
|
||
if ($slashdotted)
|
||
{
|
||
return 'http://mirrordot.com/find-mirror.html?' . $slashdotted;
|
||
}
|
||
else
|
||
{
|
||
return 'http://mirrordot.com';
|
||
}
|
||
}
|
||
|
||
|
||
############################################################################
|
||
# The Bastard Operator from Hell
|
||
if ($url =~ '^bofh$')
|
||
{
|
||
return 'http://prime-mover.cc.waikato.ac.nz/Bastard.html';
|
||
}
|
||
|
||
|
||
=item Coral cache:
|
||
|
||
B<cc>, B<coral>, or B<nyud> <I<URL>>
|
||
|
||
=cut
|
||
############################################################################
|
||
# Coral cache <URL>
|
||
if ($url =~ '^(coral|cc|nyud)( .*)$')
|
||
{
|
||
my ($cache) = $url =~ /^[a-z]* (.*)/;
|
||
$cache =~ s/^http:\/\///;
|
||
($url) = $cache =~ s/\//.nyud.net:8090\//;
|
||
return 'http://' . $cache;
|
||
}
|
||
|
||
|
||
=item AltaVista Babelfish:
|
||
|
||
B<babelfish>, B<babel>, B<bf>, B<translate>, B<trans>, or B<b> <I<from>> <I<to>>
|
||
|
||
"babelfish german english" or "bf de en"
|
||
|
||
=cut
|
||
############################################################################
|
||
# AltaVista Babelfish ("babelfish german english" or "bf de en")
|
||
if (($url =~ '^(babelfish|babel|bf|translate|trans|b)(| [a-zA-Z]* [a-zA-Z]*)$')
|
||
or ($url =~ '^(babelfish|babel|bf|translate|trans|b)(| [a-zA-Z]*(| [a-zA-Z]*))$'
|
||
and loadrc("language") and $current_url))
|
||
{
|
||
$url = 'http://babelfish.altavista.com' if ($url =~ /^[a-z]*$/);
|
||
if ($url =~ /^[a-z]* /)
|
||
{
|
||
my $tongue = loadrc("language");
|
||
$url = $url . " " . $tongue if ($tongue ne "no" and $url !~ /^[a-z]* [a-zA-Z]* [a-zA-Z]*$/);
|
||
$url =~ s/ chinese/ zt/i;
|
||
$url =~ s/ dutch/ nl/i;
|
||
$url =~ s/ english/ en/i;
|
||
$url =~ s/ french/ fr/i;
|
||
$url =~ s/ german/ de/i;
|
||
$url =~ s/ greek/ el/i;
|
||
$url =~ s/ italian/ it/i;
|
||
$url =~ s/ japanese/ ja/i;
|
||
$url =~ s/ korean/ ko/i;
|
||
$url =~ s/ portugese/ pt/i;
|
||
$url =~ s/ russian/ ru/i;
|
||
$url =~ s/ spanish/ es/i;
|
||
my ($from_language, $to_language) = $url =~ /^[a-z]* (.*) (.*)$/;
|
||
($current_url) = $current_url =~ /^.*:\/\/(.*)/;
|
||
$url = 'http://babelfish.altavista.com/babelfish/urltrurl?lp='
|
||
. $from_language . '_' . $to_language . '&url=http%3A%2F%2F' . $current_url;
|
||
}
|
||
return $url;
|
||
}
|
||
|
||
|
||
############################################################################
|
||
# XYZZY
|
||
if ($url =~ '^xyzzy$')
|
||
{
|
||
# $url = 'http://sundae.triumf.ca/pub2/cave/node001.html';
|
||
srand();
|
||
my $yzzyx;
|
||
my $xyzzy = int(rand(8));
|
||
$yzzyx = 1 if ($xyzzy == 0); # Colossal Cave Adventure
|
||
$yzzyx = 2 if ($xyzzy == 1); # Dungeon
|
||
$yzzyx = 227 if ($xyzzy == 2); # Zork Zero: The Revenge of Megaboz
|
||
$yzzyx = 3 if ($xyzzy == 3); # Zork I: The Great Underground Empire
|
||
$yzzyx = 4 if ($xyzzy == 4); # Zork II: The Wizard of Frobozz
|
||
$yzzyx = 5 if ($xyzzy == 5); # Zork III: The Dungeon Master
|
||
$yzzyx = 6 if ($xyzzy == 6); # Zork: The Undiscovered Underground
|
||
$yzzyx = 249 if ($xyzzy == 7); # Hunt the Wumpus
|
||
return 'http://ifiction.org/games/play.php?game=' . $yzzyx;
|
||
}
|
||
|
||
|
||
############################################################################
|
||
# ...and now, Deep Thoughts. by Jack Handey
|
||
if ($url =~ '^(jack|handey)$')
|
||
{
|
||
return 'http://glug.com/handey';
|
||
}
|
||
|
||
|
||
=item W3C page validators:
|
||
|
||
B<vhtml> or B<vcss> <I<URL>> (or current url)
|
||
|
||
=cut
|
||
############################################################################
|
||
# Page validators [<URL>]
|
||
if ($url =~ '^vhtml(| .*)$' or $url =~ '^vcss(| .*)$')
|
||
{
|
||
my ($page) = $url =~ /^.* (.*)/;
|
||
$page = $current_url unless $page;
|
||
return 'http://validator.w3.org/check?uri=' . $page if $url =~ 'html';
|
||
return 'http://jigsaw.w3.org/css-validator/validator?uri=' . $page if $url =~ 'css';
|
||
}
|
||
|
||
|
||
=item ELinks:
|
||
|
||
=over
|
||
|
||
=item Home: B<el> or B<elinks>
|
||
|
||
=item Bugzilla: B<bz> or B<bug> (# or search optional)
|
||
|
||
=item Documentation and FAQ: B<doc(|s|umentation)> or B<faq>
|
||
|
||
=back
|
||
|
||
There's no place like home...
|
||
|
||
=cut
|
||
############################################################################
|
||
# There's no place like home
|
||
if ($url =~ '^(el(|inks)|b(ug(|s)|z)(| .*)|doc(|umentation|s)|faq|help|manual)$')
|
||
{
|
||
my ($bug) = $url =~ /^.* (.*)/;
|
||
if ($url =~ '^b')
|
||
{
|
||
my $bugzilla = 'http://bugzilla.elinks.cz';
|
||
if (not $bug)
|
||
{
|
||
if (loadrc("email"))
|
||
{
|
||
$bugzilla = $bugzilla .
|
||
'/buglist.cgi?bug_status=NEW&bug_status=ASSIGNED&bug_status=REOPENED&email1='
|
||
. loadrc("email") . '&emailtype1=exact&emailassigned_to1=1&emailreporter1=1';
|
||
}
|
||
return $bugzilla;
|
||
}
|
||
elsif ($bug =~ '^[0-9]*$')
|
||
{
|
||
return $bugzilla . '/show_bug.cgi?id=' . $bug;
|
||
}
|
||
else
|
||
{
|
||
return $bugzilla . '/buglist.cgi?short_desc_type=allwordssubstr&short_desc=' . $bug;
|
||
}
|
||
}
|
||
else
|
||
{
|
||
my $doc = '';
|
||
$doc = '/documentation' if $url =~ '^doc';
|
||
$doc = '/faq.html' if $url =~ '^(faq|help)$';
|
||
$doc = '/documentation/html/manual.html' if $url =~ '^manual$';
|
||
return 'http://elinks.cz' . $doc;
|
||
}
|
||
}
|
||
|
||
|
||
=item The Dialectizer:
|
||
|
||
B<dia> <I<dialect>> <I<URL>> (or current url)
|
||
|
||
Dialects: I<redneck>, I<jive>, I<cockney>, I<fudd>, I<bork>, I<moron>, I<piglatin>, or I<hacker>
|
||
|
||
=cut
|
||
############################################################################
|
||
# the Dialectizer (dia <dialect> <url>)
|
||
if ($url =~ '^dia(| [a-z]*(| .*))$')
|
||
{
|
||
my ($dialect) = $url =~ /^dia ([a-z]*)/;
|
||
$dialect = "hckr" if $dialect and $dialect eq 'hacker';
|
||
my ($victim) = $url =~ /^dia [a-z]* (.*)$/;
|
||
$victim = $current_url if (!$victim and $current_url and $dialect);
|
||
$url = 'http://rinkworks.com/dialect';
|
||
if ($dialect and $dialect =~ '^(redneck|jive|cockney|fudd|bork|moron|piglatin|hckr)$' and $victim)
|
||
{
|
||
$victim =~ s/^http:\/\///;
|
||
$url = $url . '/dialectp.cgi?dialect=' . $dialect . '&url=http%3a%2f%2f' . $victim . '&inside=1';
|
||
}
|
||
return $url;
|
||
}
|
||
|
||
|
||
=item Sender:
|
||
|
||
B<send>
|
||
|
||
=over
|
||
|
||
Send the current URL to the application specified by the configuration variable
|
||
'I<external>'. Optionally, override this by specifying the application as in
|
||
'I<send> <I<application>>'.
|
||
|
||
=back
|
||
|
||
=cut
|
||
############################################################################
|
||
# send the current URL to another application
|
||
if ($url =~ '^send(| .*)$' and $current_url)
|
||
{
|
||
my ($external) = $url =~ /^send (.*)/;
|
||
if ($external)
|
||
{
|
||
system($external . ' "' . $current_url . '" 2>/dev/null &');
|
||
return $current_url; #FIXME
|
||
#return;
|
||
}
|
||
else
|
||
{
|
||
if (loadrc("external"))
|
||
{
|
||
system(loadrc("external") . ' "' . $current_url . '" 2>/dev/null &');
|
||
return $current_url; #FIXME
|
||
#return;
|
||
}
|
||
}
|
||
}
|
||
|
||
|
||
=item Dictionary:
|
||
|
||
B<dict>, B<d>, B<def>, or B<define> <I<word>>
|
||
|
||
=cut
|
||
############################################################################
|
||
# Dictionary
|
||
if ($url =~ '^(dict|d|def|define)(| .*)$')
|
||
{
|
||
my $dict = 'http://dict.org/bin/Dict?Form=Dict1&Strategy=*&Database=*&Query=';
|
||
my ($word) = $url =~ /^[a-z]* (.*)/;
|
||
unless ($word)
|
||
{
|
||
open FILE, '</usr/share/dict/words'
|
||
or open FILE, '</usr/share/dict/linux.words'
|
||
or open FILE, '</usr/dict/words'
|
||
or open FILE, '</usr/dict/linux.words'
|
||
or open FILE, '</usr/share/dict/yawl.list'
|
||
or return 'http://ypass.net/dictionary/index.html?random=1';
|
||
rand($.) < 1 && ($word = $_) while <FILE>;
|
||
close FILE;
|
||
}
|
||
return $dict . $word;
|
||
}
|
||
|
||
|
||
=item Google site search
|
||
|
||
B<ss> <I<domain>> <I<string>>
|
||
|
||
=over
|
||
|
||
Use Google to search the current site or a specified site. If a domain is not
|
||
given, use the current one.
|
||
|
||
=back
|
||
|
||
=cut
|
||
############################################################################
|
||
# Google site search
|
||
if ($url =~ '^ss(| .*)$')
|
||
{
|
||
my ($site, $search) = $url =~ /^ss\s(\S+)\s(.*)/;
|
||
if (isurl($site) =~ 'false')
|
||
{
|
||
$search = $site . $search if $site;
|
||
$site = undef;
|
||
}
|
||
unless ($site and $search)
|
||
{
|
||
($search) = $url =~ /^ss\s(.*)/;
|
||
$site = $current_url if $current_url and $current_url !~ '^file://';
|
||
}
|
||
if ($site and $search and $site ne 1 and $search ne 1)
|
||
{
|
||
return 'http://google.com/search?sitesearch=' . $site . '&q=' . $search;
|
||
}
|
||
return $current_url; #FIXME
|
||
#return;
|
||
}
|
||
|
||
|
||
=item Anything not a prefix, URL, or local file will be treated as a search
|
||
using the search engine defined by the 'search' configuration option if
|
||
'gotosearch' is set to some variation of 'yes'.
|
||
|
||
=cut
|
||
############################################################################
|
||
# Anything not otherwise useful is a search
|
||
if ($current_url and loadrc("gotosearch") eq "yes")
|
||
{
|
||
return search(loadrc("search"), $url) if isurl($url) =~ 'false';
|
||
}
|
||
|
||
|
||
return $url;
|
||
}
|
||
|
||
|
||
=back
|
||
|
||
|
||
=head1 FOLLOW URL HOOK
|
||
|
||
These hooks effect a URL before ELinks has a chance to load it.
|
||
|
||
=over
|
||
|
||
=item
|
||
I<Developer's usage>: The function I<follow_url_hook> is called when the hook
|
||
is triggered, taking the target URL as its only argument. It returns the final
|
||
target URL.
|
||
|
||
=cut
|
||
################################################################################
|
||
### follow_url_hook ############################################################
|
||
sub follow_url_hook
|
||
{
|
||
my $url = shift;
|
||
|
||
=item Bork! Bork! Bork!
|
||
|
||
Rewrites many I<google.com> URLs.
|
||
|
||
=cut
|
||
# Bork! Bork! Bork!
|
||
if ($url =~ 'google\.com' and loadrc("bork") eq "yes")
|
||
{
|
||
if ($url =~ '^http://(|www\.|search\.)google\.com(|/search)(|/)$')
|
||
{
|
||
return 'http://google.com/webhp?hl=xx-bork';
|
||
}
|
||
elsif ($url =~ '^http://(|www\.)groups\.google\.com(|/groups)(|/)$'
|
||
or $url =~ '^http://(|www\.|search\.)google\.com/groups(|/)$')
|
||
{
|
||
return 'http://google.com/groups?hl=xx-bork';
|
||
}
|
||
}
|
||
|
||
=item NNTP over Google
|
||
|
||
Translates any I<nntp:> or I<news:> URLs to Google Groups HTTP URLs.
|
||
|
||
=cut
|
||
# nntp? try Google Groups
|
||
if ($url =~ '^(nntp|news):' and loadrc("usenet") ne "standard")
|
||
{
|
||
my $beta = "groups.google.co.uk";
|
||
$beta = "groups-beta.google.com" unless (loadrc("googlebeta") ne "yes");
|
||
$url =~ s/\///g;
|
||
my ($group) = $url =~ /[a-zA-Z]:(.*)/;
|
||
my $bork = "";
|
||
$bork = "hl=xx-bork&" unless (loadrc("bork") ne "yes");
|
||
return 'http://' . $beta . '/groups?' . $bork . 'group=' . $group;
|
||
}
|
||
|
||
# strip trailing spaces
|
||
$url =~ s/\s*$//;
|
||
|
||
return $url;
|
||
}
|
||
|
||
|
||
=back
|
||
|
||
|
||
=head1 PRE FORMAT HTML HOOK
|
||
|
||
When an HTML document is downloaded and is about to undergo the final
|
||
rendering, this hook is called. This is frequently used to get rid of ads, but
|
||
also various ELinks-unfriendly HTML code and HTML snippets which are irrelevant
|
||
to ELinks but can obfuscate the rendered document.
|
||
|
||
Note that these hooks are applied B<only> before the final rendering, not
|
||
before the gradual re-renderings which happen when only part of the document is
|
||
available.
|
||
|
||
=over
|
||
|
||
=item
|
||
I<Developer's usage>: The function I<pre_format_html_hook> is called when the
|
||
hook is triggered, taking the document's URL and the HTML source as its two
|
||
arguments. It returns the rewritten HTML code.
|
||
|
||
=cut
|
||
################################################################################
|
||
### pre_format_html_hook #######################################################
|
||
sub pre_format_html_hook
|
||
{
|
||
my $url = shift;
|
||
my $html = shift;
|
||
# my $content_type = shift;
|
||
|
||
|
||
=item Slashdot Sanitation
|
||
|
||
Kills Slashdot's Advertisements. (This one is disabled due to weird behavior
|
||
with fragments.)
|
||
|
||
=cut
|
||
# /. sanitation
|
||
if ($url =~ 'slashdot\.org')
|
||
{
|
||
# $html =~ s/^<!-- Advertisement code. -->.*<!-- end ad code -->$//sm;
|
||
# $html =~ s/<iframe.*><\/iframe>//g;
|
||
# $html =~ s/<B>Advertisement<\/B>//;
|
||
}
|
||
|
||
|
||
=item Obvious Google Tips Annihilator
|
||
|
||
Kills some irritating Google tips.
|
||
|
||
=cut
|
||
# yes, I heard you the first time
|
||
if ($url =~ 'google\.com')
|
||
{
|
||
$html =~ s/Teep: In must broosers yuoo cun joost heet zee retoorn key insteed ooff cleecking oon zee seerch boottun\. Bork bork bork!//;
|
||
$html =~ s/Tip:<\/font> Save time by hitting the return key instead of clicking on "search"/<\/font>/;
|
||
}
|
||
|
||
|
||
=item SourceForge AdSmasher
|
||
|
||
Wipes out SourceForge's Ads.
|
||
|
||
=cut
|
||
# SourceForge ad smasher
|
||
if ($url =~ 'sourceforge\.net')
|
||
{
|
||
$html =~ s/<!-- AD POSITION \d+ -->.*?<!-- END AD POSITION \d+ -->//smg;
|
||
$html =~ s/<b> \; \; \;Site Sponsors<\/b>//g;
|
||
}
|
||
|
||
|
||
=item Gmail's Experience
|
||
|
||
Gmail has obviously never met ELinks...
|
||
|
||
=cut
|
||
# Gmail has obviously never met ELinks
|
||
if ($url =~ 'gmail\.google\.com')
|
||
{
|
||
$html =~ s/^<b>For a better Gmail experience, use a.+?Learn more<\/a><\/b>$//sm;
|
||
}
|
||
|
||
|
||
=item Source readability improvements
|
||
|
||
Rewrites some evil characters to entities and vice versa. These will be
|
||
disabled until such time as pre_format_html_hook only gets called for
|
||
content-type:text/html.
|
||
|
||
=cut
|
||
# demoronizer
|
||
# if ($content_type =~ 'text/html')
|
||
# {
|
||
# $html =~ s/<2F>/\—/g;
|
||
# $html =~ s/\ü/<2F>/g;
|
||
# $html =~ s/\'(?!;)/'/g;
|
||
# $html =~ s/]\n>$//gsm;
|
||
#$html =~ s/%5B/[/g;
|
||
#$html =~ s/%5D/]/g;
|
||
#$html =~ s/%20/ /g;
|
||
#$html =~ s/%2F/\//g;
|
||
#$html =~ s/%23/#/g;
|
||
# }
|
||
|
||
|
||
return $html;
|
||
}
|
||
|
||
|
||
=back
|
||
|
||
|
||
=head1 PROXY FOR HOOK
|
||
|
||
The Perl hooks are asked whether to use a proxy for a given URL (or what proxy
|
||
to actually use). You can use it if you don't want to use a proxy for certain
|
||
Intranet servers but you need to use it in order to get to the Internet, or if
|
||
you want to use some anonymizer for access to certain sites.
|
||
|
||
=over
|
||
|
||
=item
|
||
I<Developer's usage>: The function I<proxy_for_hook> is called when the hook is
|
||
triggered, taking the target URL as its only argument. It returns the proxy
|
||
URL, empty string to use no proxy or I<undef> to use the default proxy URL.
|
||
|
||
=cut
|
||
################################################################################
|
||
### proxy_for_hook #############################################################
|
||
sub proxy_for_hook
|
||
{
|
||
my $url = shift;
|
||
|
||
|
||
=item No proxy for local files
|
||
|
||
Prevents proxy usage for local files and C<http://localhost>.
|
||
|
||
=cut
|
||
# no proxy for local files
|
||
if ($url =~ '^(file://|(http://|)(localhost|127\.0\.0\.1)(/|:|$))')
|
||
{
|
||
return "";
|
||
}
|
||
|
||
return;
|
||
}
|
||
|
||
|
||
=back
|
||
|
||
|
||
=head1 QUIT HOOK
|
||
|
||
The Perl hooks can also perform various actions when ELinks quits. These can
|
||
be things like retouching the just saved "information files", or doing some fun
|
||
stuff.
|
||
|
||
=over
|
||
|
||
=item
|
||
I<Developer's usage>: The function I<quit_hook> is called when the hook is
|
||
triggered, taking no arguments nor returning anything. ('cause, you know, what
|
||
would be the point?)
|
||
|
||
=cut
|
||
################################################################################
|
||
### quit_hook ##################################################################
|
||
sub quit_hook
|
||
{
|
||
|
||
|
||
=item Collapse XBEL Folders
|
||
|
||
Collapses XBEL bookmark folders. This is obsoleted by
|
||
I<bookmarks.folder_state>.
|
||
|
||
=cut
|
||
# collapse XBEL bookmark folders (obsoleted by bookmarks.folder_state)
|
||
my $bookmarkfile = $ENV{'HOME'} . '/.elinks/bookmarks.xbel';
|
||
if (-f $bookmarkfile and loadrc('collapse') eq 'yes')
|
||
{
|
||
open BOOKMARKS, "+<$bookmarkfile";
|
||
my $bookmark;
|
||
while (<BOOKMARKS>)
|
||
{
|
||
s/<folder folded="no">/<folder folded="yes">/;
|
||
$bookmark .= $_;
|
||
}
|
||
seek(BOOKMARKS, 0, 0);
|
||
print BOOKMARKS $bookmark;
|
||
truncate(BOOKMARKS, tell(BOOKMARKS));
|
||
close BOOKMARKS;
|
||
}
|
||
|
||
|
||
=item Words of Wisdom
|
||
|
||
A few words of wisdom from ELinks the Sage.
|
||
|
||
=cut
|
||
# words of wisdom from ELinks the Sage
|
||
if (loadrc('fortune') eq 'fortune')
|
||
{
|
||
system('echo ""; fortune -sa 2>/dev/null');
|
||
die;
|
||
}
|
||
die if (loadrc('fortune') =~ /^(none|quiet)$/);
|
||
my $cookiejar = 'elinks.fortune';
|
||
my $ohwhynot = `ls /usr/share/doc/elinks*/$cookiejar 2>/dev/null`;
|
||
open COOKIES, $ENV{"HOME"} . '/.elinks/' . $cookiejar
|
||
or open COOKIES, '/etc/elinks/' . $cookiejar
|
||
or open COOKIES, '/usr/share/elinks/' . $cookiejar
|
||
or open COOKIES, $ohwhynot
|
||
or die system('echo ""; fortune -sa 2>/dev/null');
|
||
my (@line, $fortune);
|
||
$line[0] = 0;
|
||
while (<COOKIES>)
|
||
{
|
||
$line[$#line + 1] = tell if /^%$/;
|
||
}
|
||
srand();
|
||
while (not $fortune)
|
||
{
|
||
seek(COOKIES, $line[int rand($#line + 1)], 0);
|
||
while (<COOKIES>)
|
||
{
|
||
last if /^%$/;
|
||
$fortune .= $_;
|
||
}
|
||
}
|
||
close COOKIES;
|
||
print "\n", $fortune;
|
||
}
|
||
|
||
|
||
=back
|
||
|
||
|
||
=head1 SEE ALSO
|
||
|
||
elinks(1), perl(1)
|
||
|
||
|
||
=head1 AUTHORS
|
||
|
||
Russ Rowan, Petr Baudis
|
||
|
||
=cut
|
||
|
||
|
||
|
||
sub isurl
|
||
{
|
||
my ($url) = @_;
|
||
return 'false' if not $url;
|
||
opendir(DIR, '.');
|
||
my @files = readdir(DIR);
|
||
closedir(DIR);
|
||
foreach my $file (@files)
|
||
{
|
||
return 'true' if $url eq $file;
|
||
}
|
||
return 'true' if $url =~ /^(\/|~)/;
|
||
return 'true' if $url =~ /([0-9]{1,3}\.){3}[0-9]{1,3}($|\/|\?|:[0-9]{1,5})/;
|
||
return 'true' if $url =~ /^((::|)[[:xdigit:]]{1,4}(:|::|)){1,8}($|\/|\?|:[0-9]{1,5})/ and $url =~ /:/;
|
||
if ( $url =~ /^(([a-zA-Z]{3,}(|4|6):\/\/|(www|ftp)\.)|)[a-zA-Z0-9]+/
|
||
and ($url =~ /[a-zA-Z0-9-]+\.(com|org|net|edu|gov|int|mil)($|\/|\?|:[0-9]{1,5})/
|
||
or $url =~ /[a-zA-Z0-9-]+\.(biz|info|name|pro|aero|coop|museum)($|\/|\?|:[0-9]{1,5})/
|
||
or $url =~ /[a-zA-Z0-9-]+\.[a-zA-Z]{2}($|\/|\?|:[0-9]{1,5})/))
|
||
{
|
||
return 'true';
|
||
}
|
||
return 'true' if $url =~ /^about:/;
|
||
|
||
return 'false';
|
||
}
|
||
|
||
|
||
|
||
# vim: ts=4 sw=4 sts=0 nowrap
|