hooks.pl

一个很有名的浏览器

B<sf> or B<sourceforge>

=cut
$locator_prefixes{'^(sourceforge|sf)(| .*)$'} = 'sourceforge';

=item Savannah

B<sv> or B<savannah>

=cut
$locator_prefixes{'^(savannah|sv)(| .*)$'} = 'savannah';

=item Gna!

B<gna>

=cut
$locator_prefixes{'^gna(| .*)$'} = 'gna';

=item Netcraft Uptime Survey

B<whatis> or B<uptime> (current url or specified)

=cut

=item Who's Alive and Who's Dead

Wanted, B<dead> or B<alive>!

=cut
$locator_prefixes{'^(alive|dead)(| .*)$'} = 'dead';

=item Google Library / Project Gutenberg

B<book> or B<read>

=cut
$locator_prefixes{'^(book|read)(| .*)$'} = 'book';

=item Internet Public Library

B<ipl>

=cut
$locator_prefixes{'^ipl(| .*)$'} = 'ipl';


#######################################################################

=back

=head2 ELinks

=over 4

=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

=cut


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 goto_url_hook
{
	my $url = shift;
	my $current_url = shift;

	# "bugmenot" (no blood today, thank you)
	if ($url eq 'bugmenot' && $current_url)
	{
		($current_url) = $current_url =~ /^.*:\/\/(.*)/;
		return 'http://bugmenot.com/view.php?url=' . $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';
	}

	# Search engines
	my ($search) = $url =~ /^\S+\s+(.*)/;
	if ($url =~ /^(search|find|www|web|s|f|go)(| .*)$/)
	{
		return search(loadrc('search'), $search);
	}
	if ($url =~ s/^("|\'|')(.+)$/$2/)
	{
		return search(loadrc('search'), $url);
	}
	foreach my $prefix (keys %search_prefixes)
	{
		next unless $url =~ /$prefix/;
		return search($search_prefixes{$prefix}, $search);
	}

	# News
	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);
	}

	# Locators
	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)(| .*)$') {
		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;
		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;
		}
		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)(| .*)$');
	}

	# 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;
		}
	}

	# 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';
	}

	# 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;
	}

	# 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(6));
		$yzzyx = 1   if ($xyzzy == 0); # Colossal Cave Adventure
		$yzzyx = 227 if ($xyzzy == 1); # Zork Zero: The Revenge of Megaboz
		$yzzyx = 3   if ($xyzzy == 2); # Zork I: The Great Underground Empire
		$yzzyx = 4   if ($xyzzy == 3); # Zork II: The Wizard of Frobozz
		$yzzyx = 5   if ($xyzzy == 4); # Zork III: The Dungeon Master
		$yzzyx = 6   if ($xyzzy == 5); # Zork: The Undiscovered Underground
		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';
	}

	# 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';
	}

	# There's no place like home
	if ($url =~ '^(el(|inks)|b(ug(|s)|z)(| .*)|doc(|umentation|s)|faq)$')
	{
		my ($bug) = $url =~ /^.* (.*)/;
		if ($url =~ '^b')
		{
			my $bugzilla = 'http://bugzilla.elinks.or.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$';
			return 'http://elinks.or.cz' . $doc;
		}
	}

	# 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;
	}


	# Anything not otherwise useful could be a search
	if ($current_url and loadrc("gotosearch") eq "yes")
	{
		return search(loadrc("search"), $url);
	}

	return $url;
}



=head1 GLOBAL URL REWRITES

These rewrites happen everytime ELinks is about to follow an URL and load it,
so this is an order of magnitude more powerful than the Goto URL rewrites.

I<Developer's usage>: The function I<follow_url_hook> is called when the hook
is triggered, taking the target URI as its only argument.  It returns the final
target URI.

These are the default rewrite rules:

=over 4

=cut

sub follow_url_hook
{
	my $url = shift;

=item Google's Bork!

Rewrites many I<google.com> URIs to use the phenomenal I<xx-bork> localization.

=cut
	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

Rewrites any I<nntp:>/I<news:> URIs to Google Groups HTTP URIs.

=cut
	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

=cut



=head1 HTML REWRITING RULES

When an HTML document is downloaded and is about to undergo the final
rendering, the rewrites described here are done first.  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 well that these rules are applied B<only> before the final rendering, not
before the gradual re-renderings which happen when only part of the document is
yet available.

I<Developer's usage>: The function I<pre_format_html_hook> is called when the hook
is triggered, taking the document's URI and the HTML source as its two arguments.
It returns the rewritten HTML code.

These are the default rewrite rules:

=over 4

=cut

sub pre_format_html_hook
{
	my $url = shift;
	my $html = shift;

=item Slashdot Sanitation

Kills Slashdot's Advertisements.

I<This rewrite rule is B<DISABLED> now due to certain weird behaviour
it causes.>

=cut
	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 Google tips which are obvious anyway to any ELinks user.

=cut
	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
	if ($url =~ 'sourceforge\.net')
	{
		$html =~ s/<!-- AD POSITION \d+ -->.*?<!-- END AD POSITION \d+ -->//smg;
		$html =~ s/<b>&nbsp\;&nbsp\;&nbsp\;Site Sponsors<\/b>//g;
	}

=item Gmail's Experience

Gmail has obviously never met ELinks for it to suggest another browser for a better
Gmail experience.

=cut
	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.

=cut
	# TODO: Line wrapping? --pasky
	$html =~ s/