#!/usr/bin/perl
#
package Linkcheck;

use strict;
use warnings;

our $VERSION = '0.011';

#################
# init
#############################
sub new{
my ($class) = shift;
my $self = {};

bless $self,$class;

my ($name,$wert,%links,%javascriptlinks,%internelinks,%externelinks);
my %maillinks=();
my $jscou=-1;
my $mailcou=-1;
my $basis=shift;
my @links=();
my $site='';
my $cou = my $internelinkscou = my $externelinkscou =0;

# Basis aufbereiten -> \n weg, letzte Leerzeichen weg und abschließendes / weg
chomp ($basis);
$basis=~ s/\s*$//;
$basis=~ s/\/+$//;

if ($basis !~ m!^https?://!i ){
			$self->{is_ok}=0;
			return $self;
			}

if (@_ == 0){
$site='';
$site=&lade_seite($basis);

if ($site eq '-1'){ # Seite konnte nicht geladen werden -> not OK
					$self->{is_ok}=0;
					return $self;
					}
} else {
	$site=join(' ',@_);
	}

$self->{is_ok}=1;

#$site=~ s/\n/ /g;
#$site=~ s/\r/ /g;
#$site=~ s/\t/ /g;

my @newparts=();
$self->{site}=$site;
$site=~ s/\s/ /g;

$site=~ s/<a +?name=.*?>//gis; # <a name=... löschen

@links=$site=~ /(<a .+?>.*?<\/a.*?>)/gis; # <a Links
push @links,$site=~ /(<area .+?>)/gis; # Areas verarbeiten

# Frames verarbeiten
my @frames=$site=~ /(<frame .+?>)/gis;
foreach (@frames){
					$_=~ s/ src\=/href\=/;
					$_=~ s/frame /a /;
					}
push @links,@frames;
@frames=();

# IFrames verarbeiten
my @iframes=$site=~ /(<iframe .+?>)/gis;
foreach (@iframes){
					$_=~ s/ src\=/href\=/;
					$_=~ s/iframe /a /;
					}
push @links,@iframes;
@iframes=();

$site='';



foreach my $aklink (@links){
						my $linktext='';
						# Falls ein Parameter nur aus "" oder '' besteht, soll er erhalten bleiben, deswegen maskieren
						$aklink=~ s/\"\"/\"--asdfghjklempty--\"/g;
						$aklink=~ s/\'\'/\'--asdfghjklempty--\'/g;
						$aklink=~ s/<\/a.*?>//;
						$aklink=~ s/\"/ /g;
						$aklink=~ s/\'/ /g;
						$aklink=~ s/\=/ \= /g;

						$aklink=~ s/\/*>(.*?)$//s; #abschließendes /> entfernen

						$linktext=$1;


						#print $linktext;
						$aklink=~ s/<a(rea)?\s+//i;

						$aklink=~ s/\s+/ /g;
						$aklink=~ s/ \= /\=/g;

						my @aklink=split(" ",$aklink);
						my $akpart='';

						@newparts=();
						my $nolink=0;
						foreach (@aklink){
										 	if (index ($_,'=') != -1){	# index ist schneller als ~ /=/
										 								push (@newparts,$akpart);
										 								$akpart=$_;

																		}
																		else
																		{
																		$akpart.=" $_";
																		}
										}
						push (@newparts,$akpart);

						shift @newparts; # erster Eintrag ist leer, also raus

						foreach (@newparts){
											next if ($_ eq '');
											my $firsteq=index($_,"=");

											# name ist der Bezeichner innerhalb eines a href...
											# also z.B. href oder target
											#
											# slow method:
											# my @parts=split("=",$_);
											# $name=shift(@parts);
											# $name=lc($name);
											# faster with substr
											$name=lc(substr($_,0,$firsteq));

											# wert der Wert des Bezeichners
											# $wert=join("=",@parts);


											$wert=substr($_,$firsteq+1,length($_)-$firsteq-1);

											#wenn Wert ne '', also nicht leer
											if ($wert ne '--asdfghjklempty--'){
																		$links{$cou}{$name}=$wert;
																		}
											}

		if (defined $links{$cou}{href}){
								$links{$cou}{linktext}=$linktext;

								if ($links{$cou}{href}=~ /mailto/i){
																	$links{$cou}{href}=~ s/mailto\://i;
																	$maillinks{$mailcou}=$links{$cou}{href};
																	$mailcou++;
																	$nolink=1;
																	}

								if ($links{$cou}{href}=~ /javascript/i){
														$links{$cou}{href}=~ s/javascript\://i;
														$javascriptlinks{$jscou}=$links{$cou}{href};
														$jscou++;
														$nolink=1;

																		}
										}

								if (defined $links{$cou}{href} && $nolink == 0){
														# Link in absoluten Link umwandeln
														# abschließende Leerzeichen entfernen
														# und abschließende / entfernen

														$links{$cou}{href}=&make_link_absolut($basis,$links{$cou}{href});

														$links{$cou}{href}=~ s/\s*$//;
                                                        $links{$cou}{href}=~ s/\/+$//;
                                                        $links{$cou}{href}=~ s/\#.*$//;

														# ist Link intern oder extern?
														my @basisparts=split(/\//,$basis);
														my @linkparts=split(/\//,$links{$cou}{href});

														if ($basisparts[0] eq $linkparts[0] &&
															$basisparts[2] eq $linkparts[2]){
																							$internelinks{$internelinkscou}=$cou;
																							$internelinkscou++;
																							}
																							else
																							{
																							$externelinks{$externelinkscou}= $cou;
																							$externelinkscou++;
																							}
														# Ende Test intern / extern

														$cou++;

														} else {
																# gibts kein href??? dann ist der Link ungültig! bzw. ein Maillink oder Javascript
																delete $links{$cou};
																}

						}

#foreach my $aknum (keys %links){
#					print "\n";
#					next if $aknum eq 'count';
#					foreach my $akkey (keys %{$links{$aknum}}){
#													print "$aknum. $akkey=$links{$aknum}{$akkey}\n";
#													}
#					}

$self->{links}={%links};
$self->{maillinks}={%maillinks};
$self->{javascriptlinks}={%javascriptlinks};
$self->{exlinks}={%externelinks};
$self->{inlinks}={%internelinks};

$self->{mailcou}=$mailcou;
$self->{jscou}=$jscou;
$self->{count}=$cou;
$self->{internelinks}=$internelinkscou;
$self->{externelinks}=$externelinkscou;

return $self;
}# new

################
# löscht aus Skalar Zeilenumbrüche, doppelte oder mehrfache Leerteichen, HTML-Tags und ersetzt das img-Tag durch " IMAGE "
################################
sub Clear{
my $self=shift;
my $text=shift;
$text=~ s/<img.*?>/ IMAGE /gis;
$text=~ s/<.*?>/ /g;

#$text=~ s/\n/ /g;
#$text=~ s/\r/ /g;
#$text=~ s/\t/ /g;

$text=~ s/\s+/ /g;

return $text;
}


##############################
# ist ein Link auf der Basisseite zur Zielseite?
# -1 wenn nein, ansonsten gibts die Nummer des zuerst gefundenen Links zurück (0..x)
###############################################
sub Is_Linked{
my $self=shift;
my $target=shift;
my %links=%{$self->{links}};

$target=~ s/\s*$//;
$target=~ s/\/+$//;

foreach my $aknum (keys %links){

								# wenn link = target dann Nummer zurück
								if ($links{$aknum}{href} eq $target){return $aknum;}
								}
								# ansonsten ne -1 für -> NIX gefunden
								return -1;
}


###################
# konnte alles richtig initialisiert werden? Konnte Startseite eingelesen werden?
# 0 -> Nö
# 1 -> Alles schön!
#
# is it ready for Linkcheck? Yes = 1, No = 0
#
#################################
sub Is_OK{
my $self=shift;

return $self->{is_ok};
}


###################
# relative Links in absolute wandeln
# change links from relative to absolute
######################################################
sub make_link_absolut{
use URI::URL;

my $basis=shift || '';
my $datei=shift || '';

return -1 if ($datei eq '');
return -1 if ($basis eq '');

# wenn kein abschließendes / vorhanden, dann prüfen ob Verzeichnis oder Datei als Basis
if (substr($basis,length($basis)-1,1) ne '/'){
my @basis_parts=split(/\//,$basis);

# Wenn Basis = Hauptdomain
if (@basis_parts == 3){
# wenn Basis = Hauptdomain und in Link ist ein ../, dann mit Fehler zurück
return -1 if (index ($datei,'..') != -1);

#ansosnsten ein / anhängen
$basis.='/';
} else {
#wenn Unterverzeichnis oder Datei
my $lastpart=$basis_parts[-1];
if (index($lastpart,'.') eq '-1'){$basis.='/';}
}
}

my $link=new URI::URL ($datei,$basis);
my $abslink=$link->abs;
return $abslink;
}


############
# href holen
# get href
######################
sub Get_href{
my $self=shift;
my %links=%{$self->{links}};
my $number=shift;

return if (!defined $links{$number}{href});
return $links{$number}{href};
}

############
# Linktext holen
# get linktext
######################
sub Get_linktext{
my $self=shift;
my %links=%{$self->{links}};
my $number=shift;

return if (!defined $links{$number}{linktext});
return $links{$number}{linktext};
}

############
# auf nofollow prüfen
# check for rel=nofollow
######################
sub Get_nofollow{
my $self=shift;
my %links=%{$self->{links}};
my $number=shift;

if (defined $links{$number}{rel}){

								$links{$number}{rel}=~ s/\s//g;
								$links{$number}{rel}=lc($links{$number}{rel});
								return 1 if ($links{$number}{rel} eq 'nofollow');
								}
return;
}

############
# Title holen
# get title-tag
######################
sub Get_title{
my $self=shift;
my %links=%{$self->{links}};
my $number=shift;
return if (!defined $links{$number}{title});
return $links{$number}{title};
}

############
# Target holen
# get target
#######################
sub Get_target{
my $self=shift;
my %links=%{$self->{links}};
my $number=shift;
return if (!defined $links{$number}{target});
return $links{$number}{target};
}


############
# Alle Parameter eines Links holen
# get all params of a link
#######################
sub Get_all_params{
my $self=shift;
my %links=%{$self->{links}};
my $number=shift;

my %params=();
return if (!defined $links{$number});

foreach (keys %{$links{$number}}){
								$params{$_}=$links{$number}{$_};
								}

return %params;
}

############
# Anzahl Links holen
# returns number of links
######################
sub Get_count{
my $self=shift;
my $anzahl=$self->{count};
return $anzahl-1;
}

########################
# Anzahl der Maillinks zurückgeben
# returns number of maillinks
####################################
sub Get_maillinks_count{
my $self=shift;
my %maillinks=%{$self->{maillinks}};
my @result=();

foreach (keys %maillinks){push (@result,$maillinks{$_});}
my $anzahl= &del_double(@result);
return $anzahl;
}

####
# Anzahl der Javascriptlinks zurückgeben
# returns number of javascriptlinks
####################
sub Get_javascriptlinks_count{
my $self=shift;
return $self->{jscou};
}

####
#	Alle Maillinks als Array zurückgeben
# returns all mailadresses
####################
sub Get_all_maillinks{
my $self=shift;
my %maillinks=%{$self->{maillinks}};
my @result=();
foreach (keys %maillinks){push (@result,$maillinks{$_});}
@result=&del_double(@result);
return @result;
}

####
# Alle externen Links als Array zurückgeben
# returns all external links
#
# Vorsicht -> zurückgegeben werden die Referenznummern der Links -> also 0 - x
# parameter kann man dann abfragen mit z.B. Get_target($nummer); usw.
#
###########################################################################################
sub Get_all_external_links{
my $self=shift;
my %externallinks=%{$self->{exlinks}};
my @result=();
foreach my $akkey (keys %externallinks){
										push (@result,$externallinks{$akkey});
										}
return @result;
}

####
# Alle internen Links als Array zurückgeben
# returns all internal links
#
# Vorsicht -> zurückgegeben werden die Referenznummern der Links -> also 0 - x
# parameter kann man dann abfragen mit z.B. Get_target($nummer); usw.
#
####################
sub Get_all_internal_links{
my $self=shift;
my %internallinks=%{$self->{inlinks}};
my @result=();
foreach (keys %internallinks){
								push (@result,$internallinks{$_});
								}
return @result;
}

##################################
# gibt Anzahl externer Links zurück
# returns number of external links
#####################################################
sub Get_external_links_count{
my $self=shift;
return $self->{externelinks};
}

##################################
# gibt Anzahl interner Links zurück
# returns number of internal links
##################################################
sub Get_internal_links_count{
my $self=shift;
return $self->{internelinks};
}

################################################################
#
# entfernt aus einer Liste doppelte einträge
#
# Parameter: @liste, die sortiert werden soll
#
################################################################
sub del_double{
my %all=();
@all{@_}=1;
return (keys %all);
}


################
# load a site from the Net
#################################
sub lade_seite{

use LWP::Simple;
use LWP::UserAgent;

my $link=shift;
my $agent;
my $seite = '';

	$link=~ s/\n//g;
        $agent = LWP::UserAgent->new;
        $agent->timeout(20); 						# timeout after 20 Seconds
		$agent->agent('Mozilla/4.7 [en] (WinNT; I) [Netscape]');	# say: I am the Mozilla
        my $request = HTTP::Request->new('GET',$link);
        $request ->header( 'Referer' => 'http://www.google.de');	# and say: i come from Google...
	my $result = $agent->request($request);
	$seite= $result->content();

	if ($seite eq ''){ 	return -1; 	}

return $seite;
}

1;




__END__

=head1 NAME

Linkcheck - Findet und testet Links auf Webseiten oder in Skalaren bzw. Arrays

=head1 SYNOPSIS

  use Linkcheck;

  my $lc = Linkcheck->new(Url);
  #or
  my $lc = Linkcheck->new(Base,Skalar);
  #or
  my $lc = Linkcheck->new(Base,Array);

  if ($lc->Is_OK != 1){die "Can not initialize Linkcheck";}



  }

=head1 DESCRIPTION
Dieses Modul durchsucht Webseiten oder Skalare und Arrays nach darin enthaltenen Links.
Falls kein Skalar oder Array angegeben wird, wird die Webseite, die dann auch die Basis darstellt, automatisch eingelesen. Möglich sind nur Webdokumente, die per http erreichbar sind. ftp, https oder sonstiges funktioniert NICHT!

Gefundene relative Links werden automatisch in absolute Links umgewandelt.
Zusätzlich kann einfach geprüft werden, ob sich bestimmte Links im Dokument ( Skalar - Array ) befinden.

Gefunden werden Links der folgenden schreibweisen:
<a href="test.htm" target="_blank">Linktext</a>
<a href='test.htm' target='_blank'>Linktext</a>
<a href="test.htm"target="_blank">Linktext</a>
<a href=test.htm target="_blank">Linktext</a>
also mit "-Zeichen, '-zeichen oder auch ohne Trennzeichen
das Modul ist also relativ fehlertolerant.

Gefunden werden alle Parameter einschließlich des rel=nofollow

Direkt abgefragt werden können die Parameter
- href
- linktext
- target
- rel=nofollow
- Anzahl der Links gesamt
- Anzahl externer Links
- Anzahl interner Links
- Anzahl Maillinks
- Anzahl Javascript-Links
- Alle Maillinks als Array
- Alle externen Links als Verweise
- Alle internen Links als Verweise

=head1 METHODS

=head2 new

  Initialisiert den Linkchecker.
  Falls ein Skalar oder Array mit den zu durchsuchenden Daten übergeben wird, die Base als Basis für die im Dokument gefundenen Links. Relative Links werden in absolute umgewandelt.
  Falls kein Skalar oder Array übergeben wird lädt der Linkchecker das Dokument aus dem Web.
  my $lc = Linkcheck->new(Url);
  #or
  my $lc = Linkcheck->new(Base,Skalar);
  #or
  my $lc = Linkcheck->new(Base,Array);



=head2 Is_OK

 Prüft, ob die Initialisierung geklappt hat
 if ($lc_>Is_OK == 1){
			# start processing document
			} else {
				# create an error
				}

=head2 Is_Linked
	Ist ein bestimmter Link vorhanden?
	Wenn ja, gibt es die interne Nummer zurück, wenn nein eine -1

	if ($lc->Is_Linked('http://www.domain.com') != -1){
								# Link found
							}
							else
							{
								#Link not found
							}

=head2 Clear
	Entfernt alle HTML-Tags, \n,\t, \s und doppelte Leerzeichen aus Skalar. Zusätzlich wird ein <img...>-Tag in " IMAGE " verwandelt.
	Kann verwendet werden, um die Linktexte zu "säubern".

	$text=$lc->Clear($text);

=head2 Get_all_params
	Holt alle Parameter eines Links als Hash

	%Params=$lc->Get_all_params($num);
	foreach (keys %Params){print "Parameter: $_, Value $Params{$_}\n";}


=head2 Get_href
	Holt href eines Links

	$href=$lc->Get_href($num);


=head2 Get_linktext
	Holt Linktext eines Links

	$linktext=$lc->Get_linktext($num);


=head2 Get_nofollow
	Prüft auf rel=nofollow;
	Gibt eine 1 zurück, wenn nofollow gefunden wurde.

	$nofollow=$lc->Get_nofollow($num);

=head2 Get_title
	Gibt den Title-Tag zurück, falls vorhanden

	$title=$lc->Get_title($num);


=head2 Get_target
	Gibt den target-Tag zurück, falls vorhanden

	$target=$lc->Get_target($num);

=head2 Get_count
		Gibt die Anzahl der gefundenen Links zurück

		$conut=$lc->Get_count;

=head2 Get_maillinks_count
		Gibt die Anzahl der gefundenen Mail-Links zurück

		$maillinkscount=$lc->Get_maillinks_count;

=head2 Get_javascriptlinks_count
		Gibt die Anzahl der gefundenen Javascript-Links zurück

		$javascriptlinkscount=$lc->Get_javascriptlinks_count;

=head2 Get_all_maillinks
		Gibt alle Mailadressen als Array zurück.

		@mailadresses=$lc->Get_all_maillinks;

=head2 Get_all_external_links
		Gibt Referenznummern aller externen Links als Array zurück.

		@external_links=$lc->Get_all_external_links;

=head2 Get_all_internal_links
		Gibt Referenznummern aller internen Links als Array zurück.

		@internal_links=$lc->Get_all_internal_links;

=head2 Get_external_links_count
		Gibt die Anzahl der externen Links zurück.

		$external_links_count=$lc->Get_external_links_count;

=head2 Get_internal_links_count
		Gibt die Anzahl der internen Links zurück.

		$internal_links_count=$lc->Get_internal_links_count;

=back

=head1 EXAMPLE

use Linkcheck;

$t=Linkcheck->new('http://127.0.0.1/index.html');

if ($t->Is_OK != 1){
					print "Error beim initialisieren";
					exit;
					}


if ($t->Is_Linked('http://www.hidemail.de/blog') != -1){
													$num=$t->Is_Linked('http://www.hidemail.de/blog');

													print "title: ".$t->Get_title($num)."\n" if $t->Get_title($num);
													print "href= ".$t->Get_href($num)."\n";
													print "Linktext= ".$t->Get_linktext($num)."\n";
													print "target= ".$t->Get_target($num)."\n";

													my %params=$t->Get_all_params($num);

													print "\nAlle Parameter:\n";
													foreach (keys %params){print "$_ : $params{$_}\n";}

											}

print "\n\nEs wurden ".$t->Get_maillinks_count." Maillinks gefunden" ;

if ($t->Get_maillinks_count > 0 ){print ": \n";
									my @maillinks= $t->Get_all_maillinks;
									foreach (@maillinks){print "$_\n";}
									} else {
											print ".\n";
											}


print "Es gibt ".$t->Get_external_links_count." externe Links\n";
print "Es gibt ".$t->Get_internal_links_count." interne Links\n";


print "\n\nAlle externen Links:\n";
$cou=1;
foreach ($t->Get_all_external_links){
									print "$cou: ".$t->Get_href($_)."\nLinktext: ".$t->Clear($t->Get_linktext($_))."\n\n";
									$cou++;
									}


print "\n\nAlle internen Links:\n";
$cou=1;
foreach ($t->Get_all_internal_links){
									print "$cou: ".$t->Get_href($_)."\nLinktext: ".$t->Clear($t->Get_linktext($_))."\n\n";
									$cou++;
									}


=head1 AUTHOR

Peter Baumann, con_tact@hide_mail.de (please delete ALL the _-signs...)

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Peter Baumann

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.


=cut\n\nAlle externen Links:\n";
$cou=1;
foreach ($t->Get_all_external_links){
									print "$cou: ".$t->Get_href($_)."\nLinktext: ".$t->Clear($t->Get_linktext($_))."\n\n";
									$cou++;
									}


print "\n\nAlle internen Links:\n";
$cou=1;
foreach ($t->Get_all_internal_links){
									print "$cou: ".$t->Get_href($_)."\nLinktext: ".$t->Clear($t->Get_linktext($_))."\n\n";
									$cou++;
									}


=head1 AUTHOR

Peter Baumann, con_tact@hide_mail.de (please delete ALL the _-signs...)

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Peter Baumann

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.


=cut