ПервоБОТный Perl

#######################
# synthetic's HTTP package #
# mailto: synthetic@inbox.ru #
#######################

package synlib;
$VERSION=0.1;

BEGIN {
eval "use Socket";
if(!defined $INC{'Socket.pm'}){die "No socket support by this system"}
# умираем если данная система не поддерживает сокет
}

use Exporter;
@ISA=('Exporter');
# импортируем названия процедур
@EXPORT=qw(&list &http_request &Encode_base64 &Decode_base64 
&fetch_conf &is_port_opened &fetch_attrs &sendmail);

sub list{
# процедура по выделению массива из файлов типа ЛИСТ
# т.е. в файле каждая строка это пароль или что-нибудь еще
my($file) = @_;
my(@list);
local(*FILE);
open(FILE,$file) or die "$! : $file";
while(<FILE>){
chomp;
push(@list,$_);
}
close(FILE);
return @list;
}

sub http_request{
# процедура http запроса
# может использовать GET, POST методы
my($type,$remote,$hout,$hin,$post_data) = @_;
my($paddr,$proto, $iaddr,$data,$pack,$packd,$r, $port,$head,$body, @header,@sp,$i);
# создаем массив ошибок 🙂
my @err=(
"No errors",
"Can't resolve hostname","Socket() error",
"Couldn't connect to host","Error sending packets",
"sockaddr_in() error : $!","getprotobyname() error: $!"
);
# удаляем строку "http://", из адреса если есть
$remote =~ s/^http\:\/\///ig;
($remote,$port) = split(/\:/,$remote,2); # разделяем адрес на хост и порт
($remote,$path) = split(/\//,$remote,2); # разделяем хост на хост и порт
# если порт не назначен назначаем 80
$port=80 if !$port;
# очищаем выходной хеш
%$hout=();
$r=0;
if(!($iaddr = gethostbyname($remote))){
$r=1;
# если произошла ошибка запоминаем номер ошибки
}
$paddr = sockaddr_in($port, $iaddr) or die "Error: $!";
$proto = getprotobyname('tcp') or die "Error: $!";
# строка переноса в header'e
$crlf = "\r\n\r\n";

# создаем сокет, если произошла ошибка запоминаем ее номер
if(!socket(SOCK, PF_INET, SOCK_STREAM, $proto)){
$r=2 if !$r;
}
# соединяемся с хостом 
if(!connect(SOCK, $paddr)){
$r=3 if !$r;
}
if($hin){
# если есть входной хеш
# записываем все его параметры в $addp
# для последующей посылки его в сокет
foreach $key (sort keys %$hin){
$addp .= "$key: $$hin{$key}\r\n";
}
}
if($post_data){
# если есть данные для передачи методом POST
# формируем заголовок передачи с параметрами
foreach $key (sort keys %$post_data){
$packd .= "$key=$$post_data{$key}&";
}
chop($packd); 
# взято из RFC 2068
$pack .= "POST http://$remote/$path\r\n";
$pack .= "Content-Length: ".length($packd)."\r\n";
# добавляем к пакету данных параметры входного хеша
$pack .= $addp;
$pack .= "Content-Type: application/x-www-form-urlencoded\r\n";
$pack .= "\r\n";
$pack .= $packd;
}else{
$pack .= "$type /$path HTTP/1.0\r\n";
$pack .= "Host: $remote\r\n";
# добавляем к пакету данных параметры входного хеша
$pack .= $addp;
$pack .= "Accept: */*\r\n";
$pack .= "Referer: $remote\r\n";
$pack .= "User-Agent: Mozilla/1.3\r\n";
$pack .= "Connection: Close\r\n";
}
$pack .= $crlf;

# посылаем данные в сокет
if(!send(SOCK,$pack,0)){
$r=4 if !$r;
}
$data = "";
# принимаем данные из сокета
while(<SOCK>){
$data .= $_;
}
# разделяем данные на head и body
($head,$body) = split(/$crlf/,$data,2);
# теперь разделяем header на поля
# первое поле - статус документа
@header = split(/\n/,$head);
# все записываем в выходной хеш начальным значением synthetic
# resp_code - код ответа
# resp_name - имя ответа
$$hout{'synthetic'}->{'resp_code'} = (split(/\s+/,$header[0],3))[1];
$$hout{'synthetic'}->{'resp_name'} = (split(/\s+/,$header[0],3))[2];
# также каждый параметр поля заносится в хеш
# под его именем в нижнем регистре
for($i=1;$i<=$#header;$i++){
chomp($header[$i]);
@sp = split(/\:\s+/,$header[$i],2);
$sp[0] = lc($sp[0]);
$$hout{'synthetic'}->{$sp[0]}=$sp[1];
}
# закрываем сокет
close(SOCK);
# не забываем записать ошибки в хеш
# а также часто используемые имена
$$hout{'synthetic'}->{'error'} = $err[$r];
$$hout{'synthetic'}->{'body'} = $body;
$$hout{'synthetic'}->{'header'} = $head;
$$hout{'synthetic'}->{'status'} = $header[0];
# возвращаем 1 после завершения функции
return 1;
}

sub fetch_attrs{
# эта функция не идеальна, требует доработки или переработки
# но нужные параметры "выгребает" хорошо
# не выгребает типа такого: alt=" go >>>"
my($data,$aout,$grab,$flg) = @_;
######################
# fetch_attrs(<text>,<array-out>,<grab-hash>,<unique flag>); #
######################
my(%seen,$item,$i,$link,@val,$aft);
# создаем хеш сэмплов для выгребания параметров
атрибутов по умол.
# если не задан $grab используем ниже приведенный
хеш
%LINKS =
(
a => 'href', # из тега <a> достаем параметр
атрибута href
form => 'action', # и т.д.
frame => 'src',
); 
$_ = $data;

%LINKS = %$grab if $grab;
# далее с помощью регексп достаем полностью
тег (открывающий)
# далее теми же регекспами выгребаем оставшееся
# с учетом RFC 2068
foreach $t (sort keys %LINKS){
while(m/(<$t.*?>)/ig){
if(ref $LINKS{$t}){
@val = @{$LINKS{$t}}
}else{
@val = $LINKS{$t};
}
for($i=0;$i<=$#val;$i++){
$link = $1;
if($1 !~ /$val[$i]/i){
next;
}
$link =~ m/$val[$i]=/ig;
$aft = $';
if(str($aft,0) eq "\""){
$aft = substr($aft,1,length($aft));
$aft =~ m/\"/ig;
$aft = $`;
}elsif(str($aft,0) eq "'"){
$aft = substr($aft,1,length($aft));
$aft =~ m/\'/ig;
$aft = $`; 
}else{
$aft =~ m/\s|>/ig;
$aft = $`;
}
push(@$aout,$aft);
}
}

}
# если флаг не задан оставляем только уникальные элементы
if(!$flg){
%seen=();
foreach $item (@$aout){
$seen{$item}++;
}
@$aout = sort keys %seen;
}
# end of sub
}

sub str{
return substr($_[0],$_[1],1);
}

sub sendmail{
# функция для отправки почты через стандартную программу юникс систем
# sendmail, ее ссылку также можно поменять через последний аргумент функции
my($from,$to,$subject,$body,$mailprog) = @_;
$mailprog = "|/usr/lib/sendmail -oi -t -odq" if !$mailprog;
open(MAIL,$mailprog) or die $!;
print MAIL <<"EOF";
From: $from
To: $to
Subject: $subject

$body
EOF
close(MAIL);
}

sub fetch_conf{
# эта функция достает конфиг. параметры юникс формата
my($conf,$hout) = @_;
local(*CONF);my(@data);
open(CONF,$conf) or die "Couldn't open conf: $!";
while(<CONF>){
if(!/^#/){
chomp;
@data = split(/\s+/,$_,2);
if($data[0] and $data[1]){
$$hout{$data[0]}=$data[1]
}
}
}
close(CONF);
}

sub is_port_opened {
# я думаю из названия можно определить 🙂
# проверяет открыт ли $port у $target
my($target,$port)=@_;
if(!(socket(S,PF_INET,SOCK_STREAM,0))){return 0}
if(connect(S,sockaddr_in($port,inet_aton($target)))){
close(S);
return 1
}
return 0
}

##########################
# далее идут функ. взятые из разных модулей #
##########################

# далее две функции шифрорвания всзяты из MIME::Base64
# специально для http аутентификации

sub Encode_base64 { 
my $res = "";
my $eol = $_[1];
$eol = "\n" unless defined $eol;
pos($_[0]) = 0;
while ($_[0] =~ /(.{1,45})/gs) {
$res .= substr(pack('u', $1), 1);
chop($res);}
$res =~ tr|` -_|AA-Za-z0-9+/|;
my $padding = (3 - length($_[0]) % 3) % 3;
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
if (length $eol) {
$res =~ s/(.{1,76})/$1$eol/g;
} $res; }

use synlib;
$host = "http://www.vasya.com/cgi-bin/gb.pl?nickname=123&email=vasya@mail.ru&mess=fuckoff";

use synlib;
$host = "http://www.vasya.com/cgi-bin/gb.pl";
# теперь нам нужно только имя скрипта
# создаем хеш с ником e-mail'ом или еще какими-нибудь параметрами
$in{'nickname'} = "Vasya";
$in{'email'} = "vasya@mail.ru";
$in{'mess'} = "Hello I'm Vasya Pupkin kiss my ass !";

use synlib.pm;
# ниже настраиваем аргументы функции sendmail
$from = "from@who";
$to = "your@mail";
$subject = "New links added ".localtime(time);
# далее параметры самой программы
$error_tries = 3;
$host = "http://www.somesite.com/";
$timeout = 60;

$errors=0;
while(1){
# спим заданное время в секундах, т.е. $timeout секунд
sleep $timeout;
http_request("GET",$host,\%http);
# если была ошибка выводим ее и прибавляем 1 к ошибкам
if($http{synthetic}->{error}){
print "Error: ".$http{synthetic}->{error};
$errors++;
}else{
# иначе выгребаем ссылки:
# достаем из хтмл текста только ссылки (с помощью данного хеша)
%tag=(
a => href
);
fetch_attrs(0,$http{synthetic}->{body},\@links);
# тут уже делаем что угодно с @links
if($first == 1){
$first=0;
@old_links = @links;
}else{
$len = $#links;
if($#old_links > $#links){
$len = $#old_links;
}
for($i=0;$i<=$len+1;$i++){
if($old_links[$i] ne $links[$i]){
# посылаем почту 
sendmail($from,$to,$subject,"New link: $links[$i]");
}
}
}
}
# если было три ошибки завершаем цикл
if($errors == 3){last}