#!/usr/bin/perl -w
#
# LinkURI v0.01.02-2 -- URL validity checker for webmasters
# Copyright (C) 1999  Kai Puolamaki <Kai.Puolamaki@iki.fi>
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
# LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
# OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
# WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
#
#
# IMPORTANT: Set you email-address here, as required by the robot exclusion
#            protocol:
#            http://info.webcrawler.com/mak/projects/robots/robots.html
my $myemail=undef;
# my $myemail='me@foo.com.example';
#

require LWP;
require LWP::RobotUA;
require HTML::Parser;
require HTML::LinkExtor;
require URI::URL;
use Getopt::Std;
use strict;

my @callback_links=();
my @spider_links=();
my @site_links=();
my %verified_links=();
my %opt;
my $robotname='LinkkURI/0.01.02';

$myemail or 
    die "You must define variable \$myemail that contains your email
address. It is required by the Robot Exclusion Protocol.
See the documentation at the beginning of the script code.\n";

# We want to use RobotUA.  RobotUA waits by default one minute before
# requesting another file from the same host.  If you don't need to
# bother of the web server load (e.g. you are crawling your local
# server) you can use the regular UserAgent instead: it has no built-in 
# delay.
#   my $ua=LWP::UserAgent->new;     #not-a-robot
    my $ua=LWP::RobotUA->new($robotname,$myemail);

getopts('c:b:v:Vr', \%opt);
    
if($opt{'c'}) {
    if($opt{'b'}) {
	&crawl_site($opt{'b'},$opt{'c'});
    }
    else {
	&crawl_site($opt{'c'});
    }
}
elsif($opt{'V'}) {
    &verify_urls(&web_get_urls(&read_urls));
}
elsif($opt{'v'}) {
    &verify_urls(&web_get_urls($opt{'v'}));
}
elsif($opt{'r'}) {
    &verify_urls(&read_urls);
}
else {
    die <<"EOT";
LinkURI v0.01.02 -- URL validity checker for webmasters
Copyright (C) 1999  Kai Puolamaki <Kai.Puolamaki\@iki.fi>

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

usage: linkkuri -c URL [-b base-URL] Crawl whole website
       linkkuri -V [file ...]        Verify links in pages from stdin/file(s)
       linkkuri -v URL               Verify links in one web page
       linkkuri -r [file ...]        Re-verify URL:s from stdin/file(s)

LinkkURI always gives output in format "error-code url", where url are
the url appearing in the pages. Error codes are listed for example in:
http://www.hwg.org/lists/hwg-servers/response_codes.html

WARNING: Be careful with the website crawl (-c and -V option). You
don't want to crawl too much, BOFH might get nervous... Try to ensure
that your crawler stays on one site (it should, but people are
creative in these kinds of things...). Don't try to crawl
(i.e. download) somebody else's site. 

This program tries to be environmentally friendly, though: pages are
fetched only once. If only header is needed, then only header is
requested. Before downloading a page for links linkkuri checks the
header for text/html content type. The program uses Robot Exclusion
Protocol by default (see
http://info.webcrawler.com/mak/projects/robots/robots.html ). Web host
is contacted at most once per minute. Be responsible and set your
email address to the beginning of the source code, as required by the
above mentioned protocol.

Usage examples:

1) Find all files in your website:
    linkkuri -c http://domain.example/ > mysite.txt
2) Check all links at your website:
    linkkuri -V < mysite.txt > links.txt
3) Find all non-working links at your website:
    grep -v '^2' links.txt
4) Re-check the non-working links next day:
    grep -v '^2' links.txt | linkkuri -r | grep -v '^2' > stillnotworking.txt
5) Check links at a single page:
    linkkuri -v http://domain.example/page.html
6) Check links at a single file (may not work with RobotUA):
    linkkuri -v file:/directory/path/name.html

The web page for this program may be found from:
http://www.iki.fi/kaip/linkkuri.html
EOT
}

sub read_urls {
    my $x;
    my $y;
    my @u=();
    while(<>) {
	chomp;
	($x,$y)= split;
	push(@u,$y);
    }
    return @u;
}
	
    
sub contains {
    my $x=shift;
    my $y;
    
    while($y=shift) {
	return 1 if URI::eq($x,$y);
    }
    return 0;
}

sub crawl_site {
    my $base=URI->new(shift)->canonical;
    my $first=shift;
    my @new=();
    my @unverified=();
    my $n=1;
    my $count=0;
    my $x;

    defined($base->host) or 
	die "crawl_site: invalid base URL \"$base\".\n";
    $first=URI->new($first?$first:$base)->canonical;
    @unverified=($first);
    while($n>0) {
	$count += $n;
	$count<100 or
	    die "crawl_site: too many web pages crawled, limit exceeded.\n
You may want to increase the limit by editing the script.\n";
	@new=grep 
	{ $base eq substr($_,0,length($base)) and
	      $base->host eq (URI->new($_)->canonical)->host }
	&web_get_urls(@unverified);
	@unverified=();
	$n=0;
	foreach $x (@new) {
	    unless($verified_links{$x} or &contains($x,@unverified)) {
		push(@unverified, $x);
		$n++;
	    }
	}
    } 
}
    

sub verify_urls {
    my $url;
    my $code;
    my $count=0;
    while($url=shift) {
	unless($verified_links{$url}) {
	    $code=&get_code($url);
	    $verified_links{$url}=$code;
	    print "$code $url\n";
	    $count++;
	}
    }
    return $count;
}
	

sub callback {
    my($tag, %attr) = @_;

    push(@callback_links, URI->new(values %attr)->canonical);
}    


sub web_get_urls {
    my $url;
    my @result=();
    my $x;

    
    while($url=shift) {
	$url=URI->new($url)->canonical;
	@callback_links=($url);
	my $request=HTTP::Request->new(HEAD => $url);
	my $response;
	
	$response=$ua->request($request);
	if($response->as_string =~ /\nContent-Type:\s*text\/html[^\w]/i or 
	   not $response->is_success) {
	    my $p=HTML::LinkExtor->new(\&callback);
	    $request=HTTP::Request->new(GET => $url);
	    $response=$ua->request($request,sub {$p->parse($_[0])});
	}
	foreach $x (@callback_links) {
	    $x=URI::URL::url($x, $response->base)->abs;
	    $x->fragment(undef) if $x->fragment;
	    unless(&contains($x, @result) or (not defined($x->scheme)) or 
		   ($x->scheme eq 'news') or ($x->scheme eq 'mailto')) {
		push(@result, $x);
	    }
	}

	$verified_links{$url}=$response->code;
	print $verified_links{$url} , " $url\n";
    }
    return @result;
}


sub get_code {
    my $request=HTTP::Request->new(HEAD => URI->new(shift));
    my $response;
    
    $response=$ua->request($request);
    return $response->code;
}