Примеры скриптов на Perl

1. Приём параметров из формы

2. Базы данных. СУБД Access и ODBC

3. Чтение из текстового файла по одной записи

4. Чтение из файла и вывод в другой текстовый файл.

5. Регулярные выражения. Часть I

6. Регулярные выражения. Часть II

7. Использование графической библиотеки GD.

8. Ссылки, подпрограммы и массивы

9. Массивы

10. Хеши

11. Модуль DBI

12. Модуль MySQL

13. Создание собственного модуля

14. Использование собственного модуля

15. Передача файла с компьютера клиента на Веб-сервер

16. Методы модуля CGI для автоматического формирования HTML-документа

17. Пакеты

18. Рекурсивная функция

Пример 1. Приём параметров из формы

Рассматривается сайт из двух страниц. Первая страница служит для ввода пользователем признаков поиска клиентов. Она хранится в файле fil_WEB.html.

Первая страница

<HTML>
<H2>Клиенты фирмы</H2>
<FORM method="GET" action="/cgi/fil_WEB.pl">
Фамилия <INPUT TYPE=text name=Fio><P>
Город <SELECT name=Gor>
<option>
<option>Киев
<option>Новгород
<option>Псков
<option>С-Петербург
</select><P>
Телефон <INPUT TYPE=text name=Tel><P>
<INPUT TYPE=submit value=Выполнить>
</form>
</html>
Вторая страница формируется скриптом по запросу, поступающему с первой страницы. Данные обо всех клиентах читаются из текстового файла. Из них отбираются и выводятся в виде HTML-документа данные, удовлетворяющие запросу.

Скипт, формирующий вторую страницу

use CGI qw(:param);
$fil='fio_adr.txt'; # Файл с данными о клиентах
$fio=param("Fio");
$gor=param("Gor");
$tel=param("Tel");
print "Content-type: text/html\n\n";
open(F1,"< $fil");
print "<HTML><TABLE border=1>";
<F1>;
print "<TR><TH>Фамилия, имя, отчество<TH>Телефон<TH>Город<TH>Улица, дом, кв.";
#Чтение файла по одной записи
while(<F1>)
{   chomp;				# Удаление символа конца строки
    split(/\t/);	# расщепление строки по колонкам
    if(index($_[0],$fio)==0 and index($_[2],$gor)==0)
    {print "<TR>";
    	foreach $a (@_){print "<TD>$a";} #Формирование строки HTML-таблицы
		}
}
print"</table></html>";

Присмотр примера 1 в браузере

Пример 2. Базы данных. СУБД Access и ODBC

В примере база данных используется для хранения паролей 
пользователей и данных о клиентах фирмы.
Пример состоит из четырёх файлов:
- Fio_parol.html - форма для ввода пароля;
- Paro1.pl - скрипт анализа пароля;
- Klie.html - форма для ввода пользователем запроса;
- Klient.pl - скрипт формирования страницы результатов выполнения запроса. 

Первая страница (Fio_parol.html)

Служит для ввода пароля
<html>
<body>
<center>К Л И Е Н Т Ы
<form name="client" method="post" action="/cgi/Paro1.pl">
Имя (username)
<input type=text name="usernam"><br><br>
Пароль
<input type=password name="Par"><br><br>
<input type=submit value=Выполнить>
</Form>
</body>
</html>

Скрипт анализа пароля (Paro1.pl)

Если пароль правильный, то открывается Klie.html,
иначе - возврат к первой странице Fio_parol.html
#!/usr/bin/perl     
=Content Анализ пароля
В таблице registracija регистрируются IP-адрес и время
всех удачных и неудачных попыток ввода пароля.
Если в течение 600 секунд было совершено более двух
неудачных попыток, то вход на сайт блокируется.
В примере используется redirect для выбора HTML-файла
=cut
use Win32::ODBC;
use CGI qw(param redirect);
$Qstring=new CGI;
$IPaddr=$ENV{'REMOTE_ADDR'};   #чтение IP адреса пользователя
$Usern=$Qstring->param("usernam");
$Pass=$Qstring->param("Par");
#
if(!($db=new Win32::ODBC("dsn=Klient")))
{  print "Content-type: text/html\n\n";
  print "<html><h1>База данных не открылась!</h1></html>\n";
  exit;
}
$tnow=time;
$t=$tnow-600; #интервал,в течение которого можно пытаться ввести пароль
$sq="SELECT count(*) as L FROM registracija where ".
   "IPaddr='$IPaddr' and vremja>$t and reg='нет'";
$db->Sql($sq);
$db->FetchRow();
$L=$db->Data("L");
if( $L>2) 
{  $reg="нет";
   vBazu();
   print "Content-type: text/html\n\n";
   print "<html><h1>ВХОД ЗАПРЕЩЁН!</h1></html>\n";
}
else #Проверка пароля
{    #Формирование запроса
     $sq="SELECT count(*)as k " 
     ."FROM passWo where usern='$Usern' and pass='$Pass'";
     $db->Sql($sq);
     $db->FetchRow()  ;
     $k=$db->Data("k");
     $tNow=time;
     if($k==1)
     {    $fi="Klie.html";
         $reg="да";
         vBazu();      #сначала занести в базу результаты ввода пароля,
         print redirect("/Kam.loc/klie.html"); # .. - на каталог выше
     }
     else
     {   $reg="нет";
         vBazu();
         $fi="/Kam.loc/Fio_parol.html";
         $queryCGI=new CGI(""); # объектный стиль
         print $queryCGI->redirect($fi);
     }
}
#****** Запоминание в базе результатов ввода пароля *********
sub vBazu
{$sqIns=
"INSERT INTO registracija VALUES('$IPaddr',$tNow,'$reg')";
    $db->Sql($sqIns);
}

Третья страница (Klie.html)

Служит для ввода пользователем запроса
Можно выбрать любое сочетание трёх параметров 
(ФИО, город, телефон), можно не выбирать один, 
два или все три параметра.
Если не задавать все три параметра, то будут 
выведены данные обо всех клиентах фирмы.

<HTML>
<body>
<center>
<form name="client" action="/cgi/klient.pl">
Введите ФИО
<input type=text name=fio><br><br>
Введите город
<Select size='1' name="Gor">
<option>
<option>Киев
<option>Новгород
<option>Псков
<option>С-Петербург
</Select><br><br>
Введите телефон
<input type=text name=Tel><br><br>
<input type=submit value=Выполнить>
</Form>
</body>
</html>
</pre>

Скрипт формирующий страницу результатов выполнения запроса (Klient.pl)

#!\usr\bin\perl
#Выбока из  из базы данных
use Win32::ODBC;
use CGI qw(:param);
print "Content-type: text/html\n\n";

print "<html>\n";
$Qstring=new CGI;
$fio=$Qstring->param("fio");
$Gor=$Qstring->param("Gor");
$Tel=$Qstring->param("Tel");
if(!($db=new Win32::ODBC("dsn=Klient")))
{print "База данных не открылась. Проверьте настройки ODBC</html>\n";
exit;
}
#Формирование запроса
$whe="";
$sq="SELECT * FROM FIO_adr";
if($fio){$whe="fio LIKE '$fio%'";}
$a="gorod='$Gor'";
if($Gor)
{ if($whe ne ""){$whe.=" and $a";}
        else{$whe.=$a;}
}
$a="telefon LIKE '$Tel%'";
if($Tel)
{ if($whe){$whe.=" and $a";}
        else{$whe.="$a";}
}
if($whe){$sq.=" WHERE $whe";}
#print $sq,"<BR>\n";
$db->Sql($sq);
$k=0;
while($db->FetchRow())
{        @z=$db->Data;
print "@z<BR>\n";
$k++;
}
print "Имя сервера ",$ENV{"SERVER_NAME"}; # может понадобиться при отладке
if($k==0)
{print "<font color='red' size=6><b>Данных, удовлетворяющих запросу, нет</b></font>";}
print "</html>\n";
Для работы примера необходимо настроить ODBC
Просмотр примера 2 в браузере

Пример 3. Чтение из файла по одной записи

В примере рассматривается чтение одного из двух текстовых файлов
Файл SortOtlad.txt находится в рабочем каталоге, установленном
по умолчанию в отладочной системе, и читается при отладке данного скрипта.
Файл Sortirovka1.txt находится в корневом каталоге сайта Kam.ru и читается
при вызове пользователем данного скрипта из браузера. В обоих файлах хранится
по одной таблице с данными о сотрудниках какой-то организации. Таблица состоит
из четырёх колонок (ФИО, телефон,Город, Дом_улица_кв), отделённых друг от друга
символом табуляции.
Для определения текущего рабочего каталога используется функция getcwd()
из библиотечного модуля Cwd.
Функция chdir действует так же, как и команда cd операционной системы
#!/usr/bin/perl
#Чтение файла последовательно по одной записи
use Cwd;
$dir=getcwd(); # Чтение пути к текущему рабочему каталогу
if($dir=~ /Perl\/WEB_PL/)
{$fil='SortOtlad.txt.txt';}
else
{ 	chdir ".."; #переход в родительский каталог
	$fil='Sortirovka1.txt';
}
if(-e $fil){Obrabotka();} #Проверка существования файла
else{print "файл $fil не найден";}
#****** Подпрограмма чтения текстового файла ********
sub Obrabotka
{  	open(F1,"< $fil");#Открытие файла для чтения
  	$i=0;
    while (< F1 >)# чтение по одной записи в переменную $_
    { chomp;		# удаление символов конца строки
     @a=split(/\t/);# расщепление строки на поля по символу табуляции
     $fio[$i]= $a[0];
     $gor[$i]=$a[2];
     $i++;
    }
   close F1;
   print "Content-type: text/html\n\n";
 
print <<EOT;
<html><table border=1 cellspacing=1 align=center>
<caption align=top><H2>Список всех клиентов</h2></caption>
<tr><th>ФИО<th>Город
EOT
#Пример вывода многострочной таблицы в цикле одной функцией print
   for($k = 1; $k < $i; $k++)
   {print "<tr><td> $fio[$k]<td> $gor[$k] \n"; }

   print "<table></html>\n";
}
Просмотр примера 3 в браузере

Пример 4. Чтение из файла и вывод в другой текстовый файл

#!\usr\bin\perl
=Comment Пример с чтением из файла и выводом в другой текстовый файл.
Oператор  $fi2="-";  используется для переназначение вывода на консоль
при отладке программы
=cut
use CGI qw(param);
@na=param;
foreach $elem (@na)
{$_=param($elem);
        eval"\$$elem='$_'";
}
$fil="fio_adr.txt";
$fi2='fio_adr2.htm'; #файл для вывода результатов
if(-e $fil){Obrabotka();} # Проверка существования файла
else{print "файл $fil не найден";}
sub Obrabotka
{   open(F1,"< $fil");
    @t=<F1>;	#Чтение всего файла в массив
    close F1;
    $i=0;
    foreach $a (@t)
    {  chomp($a);
       @st=split(/\t/,$a);
       if(index($st[0],$fio)==0 and index($st[2],$Gor)==0)          
       {  $fio[$i]= $st[0];
#         $tel[$i]=$st[1];
          $gor[$i]=$st[2];
#         $Duk[$i]=$st[3];
          $i++;
       } 
   }
# стандартный вывод (обычно, на экран),служит для отладки
#   $fi2="-";        
   open(F2,"> $fi2");
   print "Content-type: text/html\n\n";
print F2<<MET;
<html><table border=1 cellspacing=1 align=center>
<caption align=top><H2>Список всех клиентов</h2></caption>
<tr><th>ФИО<th>Город
MET
#Пример вывода многострочного документа одной функцией print
   for ($k=1;$k<$i;$k++) # формирование и вывод в файл HTML-таблицы
   {   print F2 "<tr><td> $fio[$k]<td> $gor[$k] \n"; 
   }
   print F2 "</table></html>\n";
   close F2;
}

Пример 5. Регулярные выражения. Часть I

Результаты выполнения примера приведены в конце текста программы после __END__
$a="aaperlbbb PERL nnnn Perlmmmm";
print $a,"\n";
#Найти слово Perl
if($a=~m/Perl/)
{	print "******pr без i\n";
	pr();}
else{print "Perl не найден\n";}
#Не различать большие и маленькие буквы
if($a=~m/Perl/i)
{	print "*****pr c i \n";
	pr();}
else{print "Perl не найден\n";}
#Искать по всей строке все perl
$i=0;#количество найденных слов perl 
if($a=~m/Perl/ig)
{	print "*****pr c ig номер найденного слова $& ",++$i,"\n";
	pr();
}
else{print "Perl не найден\n";}
#Напечатать номер позиции после каждого perl
while($a=~m/Perl/ig)
{	print "номер  найденного слова $& ",++$i;
	print " Позиция после  $& - ", pos $a,"\n";} 
#По всей строке $a ищется слово "perl"
#модификатор g - искать по всей строке
#модификатор i - не различать верхний и нижний регистры
# В массив @perls занести все найденные слова "perl"
if(@perls=$a=~/perl/gi)
# %s - формат для печати строки 
# %d -формат целого числа
{printf "В строке \"%s\" Perl встречается %d разa.\n",$a,scalar @perls;}
# Подсчитывается количество вхождений образца в строку
 $N=scalar @perls; # $N - длина массива
 $m=$#perls;
 print "В строке \"$a\" Perl встречается $N разa.\n";
 print "Индекс последнего элемента массива \@Perl равен $m .\n";
 print "Массив \@Perls: \n @perls\n";
#***********************
sub pr
{print <<EOT;
Часть строки до найденной части - $`
Найденая часть - $&
После - $'
EOT
#Функция pos без модификатора g не работает
print "Номер символа после Perl=", pos $a,"\n";
}	
__END__
# Р е з у л ь т а т ы
aaperlbbb PERL nnnn Perlmmmm
******pr без i
Часть строки до найденной части - aaperlbbb PERL nnnn 
Найденая часть - Perl
После - mmmm
Номер символа после Perl=
*****pr c i 
Часть строки до найденной части - aa
Найденая часть - perl
После - bbb PERL nnnn Perlmmmm
Номер символа после Perl=
*****pr c ig номер найденного слова perl 1
Часть строки до найденной части - aa
Найденая часть - perl
После - bbb PERL nnnn Perlmmmm
Номер символа после Perl=6
номер  найденного слова PERL 2 Позиция после  PERL - 14
номер  найденного слова Perl 3 Позиция после  Perl - 24
В строке "aaperlbbb PERL nnnn Perlmmmm" Perl встречается 3 разa.
В строке "aaperlbbb PERL nnnn Perlmmmm" Perl встречается 3 разa.
Индекс последнего элемента массива @Perl равен 2 .
Массив @Perls: 
 perl PERL Perl



Пример 6. Регулярные выражения. Часть 2

Результаты выполнения примера приведены в конце текста программы после __END__
#Поиск подстроки заданного формата, но с неизвестным содержанием
$a="Итоги торгов 25.04.2003 на ММВБ" ;
if($a=~m/(\d\d)\.(\d\d)\.(\d\d)/)
{print "1 $& $1/$2/$3\n";}
$a=~m/\d\d\.\d\d\.(\d{4}|\d{1,2})/;
print "2 \$\& $& \$1=$1\n";
$a="Итоги торгов 25-04-2003 на ММВБ" ;
if($a=~m/(\d\d)[.\/-](\d\d)[.\/-](\d{2,4})/)
{print "3 $1-$2-$3\n";}
$a="Итоги торгов 5-04-03 на ММВБ" ;
if($a=~m/(\d{1,2})[\.\/\-](\d{1,2})[\.\/-](\d{2,4})/)
{print "4 $1-$2-$3\n";}
$b="Итоги торгов 31-24-03 на ММВБ" ;
if($b=~m/(\d{1,2})[.\/-](\d{1,2})[.\/-](\d{2,4})/)
{print "5 $1-$2-$3\n";}
if($b=~m/([0-3]\d)[.\/-](\d{1,2})[.\/-](\d{2,4})/)
{print "Проверяется день $1-$2-$3\n";}
else{print "Ошибка в дне даты\n";}
#Почти полный анализ с проверкой дней в месяце и номера в месяце
if($b=~m/([0-2]\d|3[0-1]).(1[012]|0[1-9]).(\d{2,4})/)
{print "Проверка дня 2. $1-$2-$3\n";}
else{print "Ошибка 2 в дне даты\n";}
$c="Город Ленинград основан в 1703 году. Ленинград - город-герой";
$d=$c;
#while($c=~s/Ленинград/Санкт-Петербург/g){};
$c=~s/Ленинград/Санкт-Петербург/g;
print " Рег.выраж. $c\n";
$e="Ленинград";
substr($e,0,0)="     Cтрана.   ";
print $e,"\n";
substr($c,-37)=~s/ /*/g;
print $c,"\n";
#$c=~s/ /*/g;
#print $c,"\n";
$e=~s/^ *//;
print "Удалены нач.пробелы $e\n";
$e="Cтрана.    ";
$e=~s/ *$//;
print "$e Конц.пробелы \n";
$L='Ленинград';$SP="Санкт-Петербург";
$pos=-1;
while(($pos=index($d,$L))>-1)
{substr($d,$pos++,9,$SP);
}
print "SUBSTR $d\n";
$f="Навиков Новиков Новичков";
$f=~/Нович?ков/;
print "Искать с начала $` **$&**  $'\n";
$f=~/Нович?ков$/;
print "Искать с конца $` **$&**  $'\n";
while($f=~/Нович?ков/g){print " **$&** \n";}
# 
$x="a xxx c xxxxxxx c xxx c d";

$x=~/.*c/; #соответствует максимально возможное к-во символов до с
print " $` \$\&=$&\n";
$x=~/.*?c/; #соответствует минимально возможное к-во символов до с
print " $` \$\&=$&\n";
$x=~/x+/; #соответствует вся первая встретившаяся последовательность хх...,т.е. певый максимум
print " $` \$\&=$&\n";
$x=~/x+?/; #соответствует первый х
print " $` \$\&=$&\n";
$x=~/x/; 		#соответствует первый х
print "**** $` \$\&=$&\n";

# Найти все последовательности х подряд
while($x=~/x+/g){print "$& c позиции ", pos($x), "\n";}
#**********
$b="Сегодня в городе дождь";
$a=(substr $b,-5,4)."и";
print $a ,"\n";
$a=(substr $b,-5);
print $a ,"\n";
$a=(substr $b,17);
print $a ,"\n";
substr $b,10,6,'Москве';
print $b,"\n ";
$b="Фортран, Perl";
$b=~tr/а-я,a-z/А-Я,A-Z/;
print $b,"\n Версия Perl $]\n  ";
__END__
Результаты
1 25.04.20 25/04/20
2 $& 25.04.2003 $1=2003
3 25-04-2003
4 5-04-03
5 31-24-03
Проверяется день 31-24-03
Ошибка 2 в дне даты
 Рег.выраж. Город Санкт-Петербург основан в 1703 году. Санкт-Петербург - город-герой
     Cтрана.   Ленинград
Город Санкт-Петербург основан в 1703*году.*Санкт-Петербург*-*город-герой
Удалены нач.пробелы Cтрана.   Ленинград
Cтрана. Конц.пробелы 
SUBSTR Город Санкт-Петербург основан в 1703 году. Санкт-Петербург - город-герой
Искать с начала Навиков  **Новиков**   Новичков
Искать с конца Навиков Новиков  **Новичков**  
 **Новиков** 
 **Новичков** 
  $&=a xxx c xxxxxxx c xxx c
  $&=a xxx c
 a  $&=xxx
 a  $&=x
**** a  $&=x
xxx c позиции 5
xxxxxxx c позиции 15
xxx c позиции 21
дожди
дождь
дождь
Сегодня в Москве дождь
 ФОРТРАН, PERL
 Версия Perl 5.008008
  

Пример 7. Использование графической библиотеки GD

   Пример состоит из двух страниц. На первой (файл Mnogug.html)
пользователь задаёт число сторон многоугольника.Вторая страница,
на которой изображается заданный многоугольник, формируется
скриптом

Первая страница

<html>
<HEAD><TiTLE>Многоугольники</title></head>
<body>
<H2 ALIGN="CENTER">Многоугольники</H2>
<form name="mnog" action="http://kam.ru/cgi/mnogo.pl">
Введите количество сторон
<input type=text name=n><br><br>
<input type=submit value=Выполнить>
</Form>
</body>
</html>

Скрипт, формирующий страницу с заданным многоугольником

#!\usr\bin\perl
#ГРАФИКА. ПОСТРОЕНИЕ МНОГОУГОЛЬНИКА С ЗАДАННЫМ ЧИСЛОМ СТОРОН
use GD;
use CGI qw(:param);
print "Content-type: text/html\n\n";
$Qstring=new CGI;
$n=$Qstring->param("n");
$im =  GD::Image::-> new(200,200);				#  Два способа
#$im =  new GD::Image(200,200);						#  создания объекта
 $red = $im->colorAllocate(255,0,0);      #задаётся цвет фона
 $blue = $im->colorAllocate(0,0,255);
# Построение полигона
# $n=5;
  $poly = new GD::Polygon;
  $pi=3.14159;
  $fi=2*$pi/$n;
  for ($i=0;$i<$n;$i++)
  {  $psi= ($i)*$fi-$pi/2;
     $x=sprintf("%4.0f",(cos($psi)+1)*40)+60;
     $y=sprintf("%4.0f",(sin($psi)+1)*40)+60;
#     print "x=$x y=$y \n";
     $poly->addPt($x,$y);
  }
 $im->filledPolygon($poly,$blue);
 $Fn="poli.png";
 chdir "..\\www" 	;#Настройка на каталог ..\home\Kam.ru\www 
  open(PFIL,">$Fn");
    # make sure we are writing to a binary stream
                binmode PFIL;
# ВЫВОД ИЗОБРАЖЕНИЯ В ФАЙЛ
 print PFIL $im->png;
 print "<html>\n";
 print "<HEAD><TiTLE>Многоугольники</title>";
 print "<BODY><H1 align=\"center\"><font color=#700000 >МНОГОУГОЛЬНИК</font></H1>";
#Apach будет искать poli.png в  F:\Webservers\home\Kam.ru\
 print "<DIV align=\"center\"><IMG SRC=../$Fn ></div>";
print "</body></html>\n";
Просмотр примера 7 в браузере

Пример 8. Ссылки, подпрограммы и массивы

=head1 ARRAY
	Примеры передачи в подпрограммы массивов
Рассматривается передача массивов: 

=over 2

=item 1
по ссылке

=item 2
по имени

=item 3
вместе со скалярами

=back 

Рассматривается изменение фактических
параметров через семантическую связь по ссылке

=cut

@a=(1,2,3);				# создание массива
@b=(5,6,7,8);
# передача массива по ссылке \@a
print "s=",sum_ref(\@a),"\n"; 
=C
 В подпрограмме r_t() изменяется значение 
 переменной $r. Массив @_ - локальный, но 
 его элементы связаны с фактическими параметрами.
 Эта связь называется семантической передачей по ссылке.
 Изменение @_[0] привело к изменению $r
=cut
$r=10;$t=20;
r_t($r,$t);
print "r=$r t=$t\n"; 			# $r=11 !!!
#Подсчёт суммы всех фактических параметров
print "s=",sum_mas($r,@a,$t),"\n";
# Передача двух массивов
print "s=",sum_mas($r,@a,@b),"\n";
# Передача ссылок на два массива
sravnenie(\@a,\@b);
#************* П О Д П Р О Г Р А М М Ы ********************
#Изменяется первый элемент массива 
# формальных параметров
# Вместе с ним меняется и фактический параметр 
sub r_t{@_[0]++;} 
#Передача ссылки на массив
sub sum_ref
{	my ($x)=@_;
	my $s=0;
	print "x=$x\n";
	foreach $z (@$x){$s+=$z;}
	return $s;
}
# Сложение всех передаваемых параметров,
# в том числе, элементов массивов
sub sum_mas
{	my $s=0;	
	foreach $z (@_){$s+=$z;}
	return $s;
}	
# Передача ссылок на два массива
sub sravnenie
{	my($m1,$m2)=@_;  # $m1, $m2 - ссылки на массивы
	if(@$m1>@$m2){print "Первый массив длиннее\n";}
	else				 {print "Второй массив длиннее\n";}
}	
__END__
********* Р Е З У Л Ь Т А Т Ы **********
x=ARRAY(0x225f68) - содержимое ссылки
s=6								- сумма элементов массива @a
r=11 t=20					- изменён фактический параметр $r
s=37							- сумма элементов массива @a и 
										переменных $r и $t
s=43							- сумма элементов массивов @a и @b и 
									  переменной $r
Второй массив длиннее - передача ссылок на массивы
 

Пример 9. Массивы

#F:\perl\bin\perl -w
=head1 ********* М А С С И В Ы *********************
Примеры формирования одно- и двумерных массивов
Использование ссылок
 Формирование массива из трёх элементов
=cut
@a=(11,21,32); #Все элементы числовые
#Добавление к массиву элемента. Тип элемента - текстовый
$a[3]="четыре";
$x=@a;
$y=$#a;
print "длина массива=$x\n наибольшее значение индекса=$y\n a4=$a[3]\n";
@b=(5,6,7,8);
print "b=@b\n";
#одномерный массив, в котором за элементами массива @a следуют элементы массива @b
@c=(@a,@b); 
print "c[5]=$c[5]\n";
#***********Двумерный массив************************
# [@a] и \@a - ссылки на массив @a
@c=([@a],[@b]);
$L=@c;
print "Длина двумерного массива \$L=\@с=$L, т.е.- количество строк в массиве\n"; 
print "c[1][1]=$c[1][1]\n";
@c=(\@a,\@b); 
print "c[1][1]=$c[1][1]\n";
# в квадратных скобках - анонимные массивы, а [] - ссылка на содежимое кв. скобок
@c=([11,21,32,"четыре"],
		[5,6,7,8]);
print "c[1][1]=$c[1][1]\n";
print "c=@c\n"; #Так распечатать двумерный массив нельзя
$L=@{$c[1]};
print "длина 2-й строки двумерного массива с \$L=",$L,"\n";
$I=$#{$c[1]};
print "Наибольший индекс 2-й строки двумерного массива с \$I=$I\n";
print "s=",sum_ref(\@a),"\n";
$r=10;$t=20;
print "s=",sum_mas($r,@a,$t),"\n";
=head ***** печать двумерного массива ******
$c[$i] содержит ссылку на одномерный массив
разыменовать эту ссылку можно как блок,
т.е. заключив выражение с индексом в фигурные скобки 
=cut
print "Вариант 1. Один оператор print\@{\$c[\$i]}; выводит целую строку \n";
for($i=0;$i<=$#c;$i++) {print @{$c[$i]},"\n";}
print "Вариант 2. Поэлементная печать\n";
for($i=0;$i<=$#c;$i++) 
{	for($j=0;$j<=$#{$c[$i]};$j++)
	{	print $c[$i][$j]," ";}
	print "\n";
}
sub sum_ref
{	my ($x)=@_;
	my $s=0;
	print "x=$x\n";
	foreach $z (@$x){$s+=$z;}
	return $s;}
sub sum_mas
{	my $s=0;	
	foreach $z (@_){$s+=$z;}
	return $s;}	
__END__
************** Р Е З У Л Ь Т А Т Ы **************
длина массива=4
 наибольшее значение индекса=3
 a4=четыре
b=5 6 7 8
c[5]=6
c[1][1]=6
c[1][1]=6
c[1][1]=6
c=ARRAY(0x1563ab0) ARRAY(0x15635dc)
x=ARRAY(0x1555e48)
s=64
s=94
Вариант 1. Один оператор print@{$c[$i]}; выводит целую строку 
112132четыре
5678
Вариант 2. Поэлементная печать
11 21 32 четыре 
5 6 7 8 

Пример 10. Хеши

=comment это начало длинного комментария, идущего до строки =сut
#<<<<<<<<<<<<<<<<<<<< Х Е Ш И >>>>>>>>>>>>>>>>>>>>>>
Примеры создания, вывода на печать хешей 
и добавления в хеш новых элементов
=cut
%a=("K1",11,
"K2",21,
"K3",32); 
foreach $ke (sort keys(%a)) #В хеше элементы расположены в неизвестном порядке
{print "a{$ke}=$a{$ke}\n";}
%b=("цвет"=>"красный",
		"вес"=>"30 г",
		cena=>30);
print "цвет - $b{'цвет'}\n";	

# ошибка: нужны кавычки для русских букв 
#print $b{цвет},"\n";	
print "цена - ",$b{cena},"\n";	
$a{K4}="Новый элемент";
print "a{K4}=$a{K4}\n";
$w=scalar(keys(%a));
print "Количество ключей в хеше a - $w \n";
%he=qw(a b c d);
@KE=sort(keys(%he));
print"ключи @KE\n";
foreach $ke (sort keys(%he))
{print "he{$ke}=$he{$ke}\n";}
__END__
ПОсле строки __ЕND__ транслятор текст не просматривает
********* Р Е З У Л Ь Т А Т Ы ****************
a{K1}=11
a{K2}=21
a{K3}=32
цвет - красный
цена - 30
a{K4}=Новый элемент
Количество ключей в хеше a - 4 
he{a}=b
he{c}=d

Пример 11. Модуль DBI

=Comment Пример работы с базой данных MySQL с помощью
модуля DBI
ВНИМАНИЕ! Должен быть запущен Apach  и вместе с ним MySQL server
=cut

use DBI;
$data_source="dbi:mysql:alfa";
#$user="gamma";
$user="root";
#$password="kbh";
$password="";
$dbh = DBI->connect($data_source, $user, $password)
           || die $DBI::errstr;
$statement="Select * From student";
$sth = $dbh->prepare($statement);
$rv = $sth->execute;		#$rv - количество выбранных строк
print "\$rv=$rv    \n";
while(@row_ary  = $sth->fetchrow_array)
{#print "$row_ary[0] $row_ary[1]\n" ; 
print "@row_ary\n" ;  }

=comment Примеры использования ->prepare($statement)

	$sth = $dbh->prepare("SELECT foo, bar FROM table WHERE baz=?");
#например  $baz=5;
  $sth->execute( $baz );

#Пример загрузки данных из файла в базу данных
	$sth = $dbh->prepare
	("INSERT INTO table(foo,bar,baz) VALUES (?,?,?)");
  while() #чтение строки из файла
  {
    chomp;
    my ($foo,$bar,$baz) = split /,/;
        $sth->execute( $foo, $bar, $baz );
  }
=cut

Пример 12. Модуль MySQL

#d:\\webservers\usr\bin
=Comment Пример работы с базой данных с помощью
модуля Mysql
ВНИМАНИЕ! Должен быть запущен Apach и вместе с ним MySQL server
=cut
use Mysql;
$host='localhost';
$database="gamma";
#$user="gamma";
$user="root";
#$password="kbh";
$password="";
$dbh = Mysql->connect($host, $database, $user, $password);
$sql_statement="Select * From student ";
 $sth = $dbh->query($sql_statement);
while( @arr = $sth->fetchrow )
 {print "$arr[0] $arr[1]\n";    }

  

Пример 13. Создание собственного модуля

=head1 NAME
Пример модуля
Модуль содержит переменную и функцию
Функция распечатывает пути к библиотекам 

=cut

package MyModul;
require Exporter;
our @ISA=qw(Exporter);
our @EXPORT=qw(soob $alfa);
#our @EXPORT_OK=qw($alfa);
our $VERSION=1.0;
#
$alfa="fa";
sub soob
{print "Мой модуль работает\n";
print "Объект ISA=@ISA\n";}
1;

Пример 14. Использование собственного модуля

=head1 Пример работы 

=over 2

=item 1
с собственным модулем,

=item 2
с подсоединённым c помощью require файлом,

=item 3
использования разных пространств имён

=back

Директива strict 'vars' требует явного объявления всех переменных.
Глобальные переменные объявляются с помощью функции our

=cut

#require "MyModul.pm";
use strict 'vars';
use MyModul;
soob();
print "alfa=$alfa\n";
print "\@INC=@INC \n";
print "До require\n";
our $X=10; # $X объявляется в этой программе и видна в my_var1.pl,
           #	т.е. пространство пакета Main распространяется и  
           #на файл my_var1.pl,	подсоединённый с помощью require
require "F:\\PERL\\WEB_PL\\my_var1.pl";
our $t=2;
print "После require t=$t \n";
$b="beta"; # $a и $b -специальные переменные, используемые в sort,
           # поэтому они не требуют явного объявления
our $k=5;
$a=umn(2,4);
my $z=5;

{
#******** Блок, в котором действует пакет  alfa
	package alfa;
	our $z=9;
	print "a=$main::a, z=$z \n";
#********* 
}

$a=umn(2,4);
print "a=$a, my z=$z \$alfa::z=$alfa::z\n";
__END__
******* Результаты выполнения программы ******
Мой модуль работает
ISA=Exporter
alfa=fa
@INC=E:/Perl/site/lib E:/Perl/lib . 
До require
Переменная  $X=10 объявлена в главной программе
После require t=2 
umn t=8 $b=beta
a=8, z=9 
umn t=8 $b=beta
a=8, my z=5 $alfa::z=9
#******
#*****Файл my_var1.pl #use strict ; #Запрет неявного объявления переменных и подпрограмм # и использования символических ссылок #use strict 'vars';Запрет неявного объявления только переменных print "Переменная \$X=$X объявлена в главной программе\n"; sub umn {my($x,$y)=@_; my $t; $z=7; $t=$x*$y; print "umn t=$t \$b=$b\n"; return $t }

Пример 15. Передача файла с компьютера клиента на Веб-сервер

   В примере рассматривается двухстраничный сайт. На первой странице пользователь выбирает на своём компьютере файл. Для этого служит элемент
      <INPUT type=file name=fil>
   Для передачи данных на Веб-сервер нужно использовать метод <POST> и атрибут enctype="multipart/form-data.
   Вторая страница формируется скриптом. Вместо функции
        open(F1,"< $fil")
служащей для открытия обычного файла,хранящегося на сервере, связь с полученным с компьютера клиента файлом устанавливается так:
      $fi=upload("fil");
где
    upload - функция(метод), хранящаяся в модуле CGI,
    fil - имя элемента INPUT,
    $fi - переменная, содержащая дескриптор файла.

   В скрипте читаются только файлы с расширениями .txt, .jpg, .gif и .png. Полученный текстовый файл читается и отсылается в HTML-документе. Графические файлы сохраняются на Веб-сервере и также отсылаются в HTML-документе обратно клиенту.
   Следует отметить, что в скрипте не делается никаких проверок передаваемой информации.

Первая страница

<HTML>
<HEAD><TITLE>Посылка файла</title>
</head>
<BODY>
<H2>ПЕРЕДАЧА ФАЙЛА НА ВЕБ-сервер</h2>
<FORM METHOD=POST ACTION="cgi/filIzForm.pl" enctype="multipart/form-data">
<TABLE>
<TR><TD>
Выберите файл
<TD>
<INPUT type=file name=fil>
<TR><TD><TD>
<INPUT type=submit value="Послать">
</table>
</form>
</body>
</html>

Скипт, формирующий вторую страницу

#!\usr\bin\perl
use CGI qw(param upload);
$fil=param("fil");
$fi=upload("fil");#переменная $fi содержит дескриптор полученного файла
#Объектный стиль
#$query=new CGI ;
#$fil=$query->param("fil");
#$fi=$query->upload("fil");
print <<EOT;
Content-type: text/html

<HTML>
<HEAD><TITLE>Посылка файла</title>
</head>
<BODY>
<H2>ПЕРЕДАЧА ФАЙЛА НА ВЕБ-сервер</h2>
Передаётся файл <i>$fil</i><P>
EOT
$fil=~m/.*(\..*)$/; # Выделенте расширения файла
if($1 eq '.txt')
{	print 'Вот текст переданного файла:<P>';
	while(<$fi>)
	{	print"$_<BR>";}
}
elsif($1 eq '.jpg' || $1 eq '.gif' || $1 eq '.png')
{	@a=split(/\\/,$fil);
	$imjifile=$a[$#a];
	chdir "..\\www" 	;#Переход из каталога по умолчанию ..\cgi в каталог ..\www 
	open(FOUT,">$imjifile");
	binmode FOUT;
	while(<$fi>){print FOUT;}
	close FOUT;
	print "<img src=http:../$imjifile>";
}
else
{print "Можно передавать только файлы с расширениями <i>.txt, .jpg, .gif и .png</i>"	
} 
print "</body></html>";

Пример 16. Методы модуля CGI для автоматического формирования HTML-документа

#!\usr\bin\perl
use CGI;                             # load CGI routines
   $q = new CGI;                        # create new CGI object
   print $q->header,                    # create the HTTP header
         $q->start_html('hello world'), # start the HTML
#         $q->h1('hello world'),         # level 1 header
         $q->h1('Здравствуй! Мир.'),         
         $q->end_html;                  # end the HTML
__END__
*** Р Е З У Л Ь Т А Т Ы ***
Content-Type: text/html; charset=ISO-8859-1

<!DOCTYPE html
	PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
	 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" lang="en-US" xml:lang="en-US">
<head>
<title>hello world</title>
<meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />
</head>
<body>

Пример 17. Пакеты

$a11=5;
{	package pack1;
	print "a11=$a11\n";
	 our	 $a11=10;
	print "a11=$a11 main::a11=$main::a11\n";
}
print "a11=$a11\n";
__END__
****Р Е З У Л Ь Т А Т Ы *********
a11=
a11=10 main::a11=5
a11=5
******** ВАРИАНТ С ЯВНЫМ ОБЪЯВЛЕНИЕМ  ПЕРЕМЕННЫХ *****
use strict "vars";
our $a11=5;
{	package pack1;
	print "a11=$a11\n";
	 our	 $a11=10;
	print "a11=$a11 main::a11=$main::a11\n";
}
print "a11=$a11\n";
****Р Е З У Л Ь Т А Т Ы *********
a11=5
a11=10 main::a11=5
a11=5

Пример 18. Рекурсивная функция для вычисления n!

=c
Рекурсивная функция n!
Рекурсивные функции сложны для понимания и требуют больших затрат ресурсов компьютера,
поэтому применять рекурсию целесообразно только к таким задачам, для решения которых 
другого метода нет, например, к древовидным графам.
=cut
$n=5;
$f=fac($n);
print "n!=$f\n";
sub fac
{	my($n)=@_;
	my $f;
	if($n==1){$f=1;}
	else { $f=$n*fac($n-1);}
	return $f;
}
#Проще факториал вычислить так:
$f=1;
for($i=1;$i<=$n;$i++) {$f*=$i;}
print "n!=$f\n";
__END__
Результат
n!=120
n!=120