Perl для CGI / Примеры Perl-сценариев

+ Введение Синтаксис Запросы и ответы Разное по теме MySQL в Perl Примеры
Реклама

Кто посещает мою страничку?

Вам иногда хотелось, наверное, узнать кто же смотрит на вашу страничку, откуда и когда ваша страничка посещалась. Бывают такие вопросы? Кто-то считает, что ответить на них нельзя. Но вы не верьте этому расхожему мнению. Один раз с подобными вопросами ко мне подошел мой одногрупник Диман. У него неплохой сайт и туда к нему всегда валит целая куча народа. Вот как раз разговор и зашел об этой куче народа. Результатом моего непродолжительного труда стал небольшой скрипт. В страничку он втыкается через тэг <IMG src="cgi-bin/get_ip.cgi"> он покажет вам изображение что не будет бросаться в глаза. Зато при своей работе он все запишет в файл ipdata.txt. В нем будет время и IP-адрес того, кто смотрел на вашу страничку:

#!/usr/bin/perl
#get_ip.cgi
$gif="../gifs/player.gif";
$data="ipdata.txt";
print "Content-Type: image/gif\n\n";
open(G,$gif);
print <G>;
close(G);
open(D,">>$data");
print D scalar localtime,' '.$ENV{'REMOTE_ADDR'}."\n";
close(D);

Гостевая книга

А вот еще пример того, как можно с умом использовать нехитрые знания. Гостевая книга, в которую каждый может записать свое вам пожелание. К ней прилагаются .gif -файлы,позволяющие указать свое настроение: . Запись происходит в базу данных guestbook.dat и при каждой новой записи в гостевую книгу скрипт извещает по почте хозяина гостевой книги, а тому кто в нее вошел по почте посылается сообщение об этом:

#!/usr/bin/perl
#guestbook.cgi
$myemail="paaa\@uic.nnov.ru";
$myname="lesha";
$mail="mail";
($sd,$sn)=($ENV{'SCRIPT_FILENAME'}=~/(.*)\/([^\/]*)/);
$datafile=$sd."\/guestbook.dat";
@Mailgifs=qw(../gifs/mood0.gif ../gifs/mood1.gif ../gifs/mood2.gif);
$Facetxt{$Mailgifs[0]}= ":)";
$Facetxt{$Mailgifs[1]}= ":|";
$Facetxt{$Mailgifs[2]}= ":(";

sub urldecode{
local($val)=@_;
$val=~s/\+/ /g;
$val=~s/%([0-9a-hA-H]{2})/pack('C',hex($1))/eg;
return $val;
}
sub strhtm{
local($val)=@_;
$val=~s/&/&/g;
$val=~s/</</g;
$val=~s/>/>/g;
$val=~s/(http:\/\/\S+)/<A href="$1">$1<\/A>/g;
return $val;
}
$cont_len=$ENV{'CONTENT_LENGTH'};
if($ENV{'REQUEST_METHOD'} eq 'GET'){$query=$ENV{'QUERY_STRING'};}
else {sysread(STDIN,$query,$cont_len);}
if($query eq ''){
print "Content-type: text/html\n\n";
print <<HTML_generating;
<HTML><HEAD><TITLE>Wellcome to my guestbook</TITLE></HEAD>
<BODY bgcolor="cyan">
<CENTER><H1>Wellcome to my guestbook</H1></CENTER>
<HR><FORM action="guestbook.cgi" METHOD="POST">
<TABLE border=0>
<TR><TD>Name:</TD><TD colspan=3><INPUT NAME="Name"></TD></TR>
<TR><TD>E-mail:</TD><TD colspan=3><INPUT NAME="Email"></TD></TR>
<TR><TD>URL:</TD><TD colspan=3><INPUT NAME="URL"></TD></TR>
<TR><TD>Message:</TD><TD colspan=3><TEXTAREA NAME="Message" rows=6 cols=64></TEXTAREA></TD></TR>
<TR><TD>Mood:</TD><TD><IMG src="$Mailgifs[0]"></TD><TD><IMG src="$Mailgifs[1]"></TD><TD><IMG src="$Mailgifs[2]"></TD></TR>
<TR><TD> </TD><TD><INPUT TYPE="radio" NAME="Mood" VALUE="$Mailgifs[0]"></TD>
<TD><INPUT TYPE="radio" NAME="Mood" VALUE="$Mailgifs[1]"></TD>
<TD><INPUT TYPE="radio" NAME="Mood" VALUE="$Mailgifs[2]"></TD></TR>
<TR><TD colspan=2><INPUT TYPE="submit" VALUE="Send"></TD>
<TD colspan=2><INPUT TYPE="reset" VALUE="Clean"></TD></TR>
</TABLE></FORM>
<HR><BR>
HTML_generating
open(DATAFILE,"$datafile")|| die "Cannot open $datafile $!\n";
@GUESTDATA=<DATAFILE>;
print @GUESTDATA;
close(DATAFILE);
print "</BODY></HTML>";
}
else{
foreach(@fields=split(/&/,$query)){
if(/^Name=(.*)/){$Name=&urldecode($1);}
if(/^Email=(.*)/){$Email=&urldecode($1);}
if(/^URL=(.*)/){$URL=&urldecode($1);}
if(/^Message=(.*)/){$Message=&urldecode($1);}
if(/^Mood=(.*)/){$Mood=&urldecode($1);}
}
$MESSAGE=&strhtm($Message);
if(-e $datafile){unless (-r $datafile && -w $datafile){die "Cannot access $datafile\n";}}
$Newmsg="<IMG src=\"$Mood\"><BR><A href =\"mailto:$Email\">$Name</A>".
"(<A href=\"$URL\">$URL</A>):<BR>\n$MESSAGE<HR>\n";
open(DATAFILE,"+<$datafile") || die "Cannot open $datafile $!\n";
@GUESTDATA=<DATAFILE>;
@GUESTDATA=($Newmsg,@GUESTDATA);
seek(DATAFILE,0,0);
print DATAFILE @GUESTDATA;
close(DATAFILE);
print "Content-type: text/html\n\n";
print "<HTML><HEAD><TITLE>Congratulations</TITLE></HEAD>\n";
print "<BODY bgcolor=\"cyan\">\n<CENTER><H1>Congratulations:you have successfully entered to $myname\'s";
print "guestbook.Thank you!</H1></CENTER><HR>$Newmsg</BODY></HTML>";
open(MAIL,"|$mail $Email");
print MAIL "Guestbook\n";
print MAIL "You have entered to $myname\'s guestbook\n";
print MAIL "Thank you.\n\t\t\t\t$myname";
close(MAIL);
format NOTIFYMAIL=
Guestbook
========================== Guestbook Entry =======================
| Time: |Name: |
| @<<<<<<<<<<<<<<<<<<<<<<<<|@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |
scalar localtime,$Name
+--------------------------+-------------------------------------+
| Email: |URL: |
| @<<<<<<<<<<<<<<<<<<<<<<<<|@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |
$Email,$URL
+--------------------------+-------------------------------------+
| ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |
$Message
| ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |
$Message
| ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |
$Message
| ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<< |
$Message,$Facetxt{$Mood}
==================================================================
.
open(NOTIFYMAIL,"|$mail $myemail");
write NOTIFYMAIL;
close(NOTIFYMAIL);
}

Счетчик посещений

Наверное тоже одним из часто встречающихся приложений CGI являются счетчики посещений. Они стоят практически на каждой страничке, возможно даже и у вас. Но иногда вас не устраивает тот факт, что счетчик лежит где-то в другом месте. Из-за этого скажем невозможно начать счет с произвольного числа. Или некоторые счетчики по разному фильтруют 'Reload'. Да и мало ли? Ну а иногда вам хочется просто сделать другой дизайн цифр. Если вы CGI-программист, то возможно имеет смысл написать свой счетчик. И делать с ним что захочется. Вот я так-же написал.

Скрипт данного счетчика обслуживает несколько счетчиков, им вы присваиваете идентификаторы. Поэтому вы спокойно можете втыкать независимые счетчики в разные страницы сайта и даже давать это делать друзьям. В общем он прост в использовании: <IMG src="cgi-bin/counter.cgi?id=name">, где name - любое уникальное имя идентифицирующее счетчик. Вы также можете задать необязательный параметр dig который задает количество цифр в счетчике. Например: <IMG src="cgi-bin/counter.cgi?id=doom2&dig=9">. Получится примерно вот так: . GIF в счетчике с прозрачными областями, что дает дополнительную гибкость. К примеру для улучшения внешнего вида с помощью другого фона его иногда имеет смысл запихнуть в "таблицу": <TABLE><TR><TD bgcolor="black"><IMG src="cgi-bin/counter.cgi?id=doom2&dig=9"></TD></TR></TABLE>:

Свои данные он пишет примерно в такой файл counter.dat:

doom2
4 127.0.0.1 906992351
quake2
1 127.0.0.1 906992700
quake
3 127.0.0.1 906992668
doom
1 127.0.0.1 906991960

Вы спросите, зачем столько информации? Чтобы отфильтровывать нажатия Reload. Если с одного IP-адреса между заходами промежуток меньше чем 30 секунд, то счетчик не инкреминтируется (так поступает счетчик в Rambler'е).

Теперь об исходнике. Скрипт получился великоват, потому что здесь большую часть занимает генерация .gif - файлов. Выглядит громоздко, зато пашет как трактор ;)):

#!/usr/bin/perl
#newcount.cgi
###############
$LOCK_EX=2;
$LOCK_UN=8;
$datafile="counter.dat";
###############
$Dig[0]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[1]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x01\x01\x01\x02\x01\x01\x01".
"\x01\x01\x01\x02\x02\x01\x01\x01".
"\x01\x01\x01\x01\x02\x01\x01\x01".
"\x01\x01\x01\x01\x02\x01\x01\x01".
"\x01\x01\x01\x01\x02\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[2]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x01\x01\x01\x01\x02\x01".
"\x01\x01\x01\x01\x02\x02\x02\x01".
"\x01\x01\x02\x02\x01\x01\x01\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[3]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x01\x01\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[4]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x01\x01\x02\x02\x01\x01\x01".
"\x01\x01\x02\x01\x02\x01\x01\x01".
"\x01\x02\x01\x01\x02\x01\x01\x01".
"\x01\x02\x02\x02\x02\x01\x01\x01".
"\x01\x01\x01\x01\x02\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[5]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x02\x01\x01\x01\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x01\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[6]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x02\x01".
"\x01\x02\x01\x01\x01\x01\x01\x01".
"\x01\x02\x02\x02\x02\x02\x01\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[7]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x02\x02\x02\x02\x02\x01\x01".
"\x01\x01\x01\x01\x01\x02\x01\x01".
"\x01\x01\x01\x01\x02\x01\x01\x01".
"\x01\x01\x01\x02\x01\x01\x01\x01".
"\x01\x01\x01\x02\x01\x01\x01\x01".
"\x01\x01\x02\x02\x02\x01\x01\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[8]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x02\x02\x02\x02\x01\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
$Dig[9]=(
"\x01\x01\x01\x01\x01\x01\x01\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x02\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x02\x01".
"\x01\x02\x01\x01\x01\x01\x02\x01".
"\x01\x01\x02\x02\x02\x02\x02\x01".
"\x01\x01\x01\x01\x01\x01\x01\x01"
);
###############
sub urldecode{
local($val)=@_;
$val=~s/\+/ /g;
$val=~s/%([0-9A-H]{2})/pack('C',hex($1))/ge;
return $val;
}
sub gifcompress{
local($bmp)=@_;
local(@Tbl);
local($rootsize)=(8); #bits per pixel
local($i,$bmp_i,$c,$k,$ck,$code,$tbl_i,$comp_size);
local($cc,$eoi);
local($bits)=('');
local($RV)=('');
$bmp_i=0;
foreach $i(0..2**$rootsize-1){$Tbl[$i]=pack('C',$i);}
$tbl_i=2**$rootsize+2;
$cc=2**$rootsize;
$eoi=2**$rootsize+1;
$comp_size=$rootsize+1;
$c='';
$bits.=substr(unpack('b16',pack('S',$cc)),0,$comp_size);
if($cc==(2**$compsize -1)){$comp_size++;}
while($bmp_i<length($bmp)){
$k=substr($bmp,$bmp_i,1);
$ck=$c.$k;
$code=-1;
for($i=0;$i<$tbl_i;$i++){if($Tbl[$i] eq $ck){$code=$i;}}
if($code!=-1){
$c=$ck;
}
else{
$Tbl[$tbl_i]=$ck;$tbl_i++;#add
$code=-1;for($i=0;$i<$tbl_i;$i++){if($i!=$eoi&&$i!=$cc){if($Tbl[$i] eq $c){$code=$i;}}}
$bits.=substr(unpack('b16',pack('S',$code)),0,$comp_size);
if($code==(2**$compsize -1)){$comp_size++;}
if($code==4095){$bits.=substr(unpack('b16',pack('S',$cc)),0,$comp_size);foreach $i(0..2**$rootsize-1){$Tbl[$i]=pack('C',$i);};$tbl_i=2**$rootsize+2;$comp_size=$rootsize+1;$c='';}
$c=$k;
}
$bmp_i++;
}
$code=-1;for($i=0;$i<$tbl_i;$i++){if($i!=$eoi&&$i!=$cc){if($Tbl[$i] eq $c){$code=$i;}}}
$bits.=substr(unpack('b16',pack('S',$code)),0,$comp_size);
if($code==(2**$compsize -1)){$comp_size++;}
if($code==4095){$bits.=substr(unpack('b16',pack('S',$cc)),0,$comp_size);foreach $i(0..2**$rootsize-1){$Tbl[$i]=pack('C',$i);};$tbl_i=2**$rootsize+2;$comp_size=$rootsize+1;$c='';}
$bits.=substr(unpack('b16',pack('S',$eoi)),0,$comp_size);
local($bytes)=('');
for($i=0;$i<length($bits)/8;$i++){
$bytes.=pack('b8',substr($bits,$i*8,8));
}
$RV=pack('C',$rootsize);
for($i=0;$i<length($bytes)/255;$i++){
$block=substr($bytes,$i*255,255);
$RV.=pack('C',length($block));
$RV.=$block;
}
$RV.=pack('C',0);
return $RV;
}

sub gengif2{
local($Number,$digits,$c_r,$c_g,$c_b)=@_;
local($Ascii_Num,$Zeropad);
$Ascii_Num=''.$Number;
$digits=($digits>length($Ascii_Num)?$digits:length($Ascii_Num));
$Zeropad='0' x $digits;
substr($Zeropad,- length($Ascii_Num),length($Ascii_Num))=$Ascii_Num;
$Ascii_Num=$Zeropad;
local($sym,$pos,$i);
local($bmp)="\x00" x ($digits * 8 * 8);
foreach $pos(0..length($Ascii_Num)-1){
$sym=substr($Ascii_Num,$pos,1);
foreach $i(0..7){
substr($bmp,$i*$digits*8 + $pos*8,8)=substr($Dig[$sym],$i*8,8);
}
}
local($g_x,$g_y);
$g_x=$digits*8;
$g_y=8;
local($transp_index)=(1);
local($RV)=('GIF89a');
local($lscr)=(pack('SS',$g_x,$g_y).pack('B8','11110111').pack('C',0).pack('C',0));
local($pal)=(pack('CCC',0x0,0x0,0x0).pack('CCC',0x7f,0x7f,0x7f).pack('CCC',$c_r,$c_g,$c_b).
pack('CCC',0x7f,0x0,0x0).pack('CCC',0x0,0x7f,0x0).pack('CCC',0x0,0x0,0x7f));
local($tmp)=(pack('C',0) x 768);
substr($tmp,0,length($pal))=$pal;
$pal=substr($tmp,0,768);

local($gr_ext)=(pack('C',0x21).pack('C',0xf9).pack('C',4).pack('B8','00001001').pack('S',0).pack('C',$transp_index).pack('C',0));

local($imgdescr)=(pack('C',0x2c).pack('SSSS',0,0,$g_x,$g_y).pack('B8','00000000'));

local($gifdata)=(&gifcompress($bmp));
local($gifend)=(pack('C',0x3b));
$RV=$RV.$lscr.$pal.$gr_ext.$imgdescr.$gifdata.$gifend;
return $RV;
}
######################
binmode(STDOUT);
$|=1;
#print "Content-Type: image/gif\n\n";
#print &gengif2($Number,$digits,$c_r,$c_g,$c_b);
#print &gengif2(1234567890,9,100,0,0);

$query=$ENV{'QUERY_STRING'};
if($query eq ''){print "Content-Type: image/gif\n\n";print &gengif2(1234567890,10,100,0,0);}
else{
@fields=split(/&/,$query);
foreach(@fields){
if(/^id=(.*)/){$id=&urldecode($1);}
if(/^dig=(.*)/){$dig=&urldecode($1);}
}
$digits=$dig;
$digits=9 unless($dig);
$cur_ip=$ENV{'REMOTE_ADDR'};
$cur_time=time;
open(DATA,"+<$datafile");
flock(DATA,$LOCK_EX);
@Dat=<DATA>;
chop(@Dat);
%Counters=@Dat;
($count,$ip,$t)=split(/\s+/,$Counters{$id});
$count++ if(($ip!=$cur_ip)||($cur_time-$t>30));
$ip=$cur_ip;
$t=$cur_time;
$Counters{$id}=join(' ',$count,$ip,$t);
seek(DATA,0,0);
foreach(keys %Counters){
print DATA "$_\n";
print DATA "$Counters{$_}\n";
}
truncate(DATA,tell(DATA));
flock(DATA,$LOCK_UN);
close(DATA);
print "Content-Type: image/gif\n\n";
print &gengif2($count,$dig,100,0,0);
}

Если вам циферки не понравились вы их легко сможете заменить.

Вместо заключения

Вот и подошла к концу моя книга. Надеюсь, что она найдет поддержку в широких слоях интернет-сообщества. В ней я постарался изложить простым и понятным языком немного из того, что знаю. Очень надеюсь, что я достиг своей цели (если вы дочитали мое учебное пособие до конца). И также я очень надеюсь, что те цели, которые вы перед собой ставили при прочтении данной книги станут осуществимыми. Если вы прочитали эту книгу, и вам понравилось, порекомендуйте ее своим знакомым web-дизайнерам и начинающим интернет-программистам. Для них она будет очень полезна. Также жду ваших отзывов и предложений. Я постараюсь ответить на интересующие вас вопросы. Если вам данная тема понравится, то я обязательно подумаю над тем, чтобы написать продолжение, в котором расскажу о тех вопросах, с которыми сталкивается профессиональный интернет-программист в своей работе.

И еще раз хочу дать совет и пожелание: если что-нибудь у вас не получается, не огорчайтесь и не опускайте руки, всегда есть способ сделать любое, пусть даже с первого взгляда сложное дело. Тем более в наших руках такая мощная вещь как интернет, и от нас зависит, каким он будет через месяц, через год, через два, через десять лет. И если вы действительно приложите усилия, то ваш сайт станет достойным всеобщего восхищения.

Реклама
Карта сайта