Tfe

Old stuff/Perl/xchat/old_script/urls.pl

#!/usr/bin/perl -w
use strict;




# parametres xchat
 IRC::register("link GRABBER", "1.0", "","");
 IRC::print("Link GRABBERby tfe\n mail me at: i.muriel@wanadoo.fr for any suggestions");
 IRC::add_message_handler ("PRIVMSG",'grablink');

 sub grablink {
 my($line) = shift(@_);
 my $fichier = "liens.txt";
 my ($domain,$full,@contenu,$trouve,$nick,$mask,$channel,$texte,$tout);
 
 $trouve = "0";



$_ = $line;


($nick,$mask,$channel,$texte)= (/\:([^\!]*)\!([^\s]*)\sPRIVMSG\s([^\s]*)\s\:(.*)/i);
#                                          : nick    ! mask     PRIVMSG   #channel  :texte


if ($texte =~ /(^|\s)(http|ftp|https):\/\/([\w\.\-]+\.\w{2,4})(\/|\s|$)/ and $texte !~ /file\|/)
# detection d un domain genre \w.{2,4}
{
	$domain = "$2:\/\/$3\/";	
	if ($texte =~ /$domain([^\s]*)(\/|\s|$)/) {	$full = "$domain$1"; IRC::print("$domain$1");}
	else { $full = $domain;  }
	
	open(INFO,$fichier);
	$trouve = "0";
	
	while (<INFO>)
	{
		s/\n//;	
		
		if (/$full/) { $trouve = "1"; push(@contenu,"$_"); }
		#si y a tout
		else 
		{
			if (/$domain/) {  push(@contenu,"$_ $full"); $trouve = "1";  }
			else { 	    push(@contenu,"$_"); }
		}
		
		#si y a au moins le domain    
		
	}
	if ($trouve ne '1') { 
	    if ($domain ne $full ) {push(@contenu,"$domain $full");  }
	    else { push(@contenu,"$domain"); }
	    }
	close INFO;


open(INFO,">$fichier");
print INFO join("\n",@contenu);
close INFO;

}
else { $_ = $line; }




$_ = $line;
 }