Xpoint
   [напомнить пароль]

Программирование::Perl::Разное - F.A.Q.

Полезные ссылки
Ссылки на F.A.Q. Perl-форумов
Как сделать аутентификацию на Perl, а не средствами веб-сервера?

Для того, чтобы браузер выдал запрос логина и пароля, скрипт должен выдать следующие заголовки:

print "WWW-Authenticate: Basic realm=\"что то там\"\n";
print "Status: 401 Unauthorized\n\n";
print "Ошибка авторизации!\n";

При этом "что то там" — это имя области авторизации, по правилам для области с одним именем должен всегда срабарывать один и тот же пароль. Проблема заключается в том, что ответ пользователя сидит в заголовке HTTP-запроса, в поле Authorization, которое скрипту через переменные окружения не передаётся. Для сервера Апаче эта проблема решается прописыванием в файле конфигурации следующих строк:

RewriteEngine on
RewriteCond %{HTTP:Authorization} ^(.*)
RewriteRule ^(.*) - [E=HTTP_CGI_AUTHORIZATION:%1]

Всё что он делает — это добавляет в переменную окружения HTTP_CGI_AUTHORIZATION, в которую пишется содержимое HTTP заголовка Authorization, таким образом означенное поле становится доступным для анализа внутри скрипта. Формат этого поля следующий: "login:password", причём эта строка закодирована в Base64, получить эти составляющие можно так:

use MIME::Base64;
$ENV{HTTP_CGI_AUTHORIZATION} =~ s/basic\s+//i;
($REMOTE_USER,$REMOTE_PASSWD) =
  split(/:/,decode_base64($ENV{HTTP_CGI_AUTHORIZATION}));

Вот простейший скрипт, проверяющий авторизацию. В качестве "правильных значений" используются:

  • Login: "user"
  • Password: "userpas"
use MIME::Base64;
$ENV{HTTP_CGI_AUTHORIZATION} =~ s/basic\s+//i;
($REMOTE_USER,$REMOTE_PASSWD) =
  split(/:/,decode_base64($ENV{HTTP_CGI_AUTHORIZATION}));

# проверяем значения $REMOTE_USER и $REMOTE_PASSWD
if (!UserAccess($REMOTE_USER,$REMOTE_PASSWD)) { 
  print "WWW-Authenticate: Basic realm=\"что то там\"\n";
  print "Status: 401 Unauthorized\n\n";
  print "Ошибка авторизации!\n";
  exit; 
} 

# код, который выполняется при успешной авторизации
print "Content-type: text/html\n\n"; 
print "Привет, $REMOTE_USER!";
exit; 

# простейшая проверка: 
# совпадают ли введенные значения с "user" и "userpas"
sub UserAccess { 
  my $aUser = $_[0]; 
  my $aPass = $_[1]; 

  $res = ( $aUser eq "user" && $aPass eq "userpas" ? 1 : 0); 
  return $res; 
} 
Примечание

Если Вы работаете под ОС Windows и используете Apache для Windows, Вам нужно, для загрузки модуля Rewrite, раскомментировать в файле httpd.conf строку:

LoadModule rewrite_module modules/ApacheModuleRewrite.dll
Я пытаюсть скриптом вывести картинку, а мне вместо нее выдается стандартная битая картинка браузера.

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

print "Content-Type: image/gif\n"; 
# Для JPEG будет image/jpeg
print "Content-Length: 7256\n\n";
open (IMG,"image.gif");
binmode IMG;
binmode STDOUT;
print <IMG>;
close (IMG);

Заголовок Content-Length в принципе необязателен, но желателен. Он должен содержать реальный размер файла в байтах. Его можно получить, воспользовавшись конструкцией -s или функцией stat().

Как сделать upload картинки через форму?

В случае, если вам не претит воспользоваться модулем CGI, это будет выглядеть примерно так:

use CGI qw/:standard/; 

# Код для HTML-формы 
print "Content-Type: text/html\n\n"; 
print "<form method=\"post\" enctype=\"multipart/form-data\" action=\"upload.cgi\">";
print "<input type=\"file\" name=\"picture\">";
print "<input type=\"submit\" name=\"Submit\" value=\"Submit\">";
print "</form>";

#end of print form

insert_image() if (param()); 

sub insert_image { 
  # путь к директории для закачки директория 
  # должна иметь право на запись для 
  # пользователя, под которым работает веб-сервер 
  my $downpath = "tmp/"; 

  my $in=param('picture'); 

  # выделяем имя файла из параметра 
  my ($name) = $in =~ m#([^\\/:]+)$#; 

  open(OUT,">$downpath$name"); 
  binmode(OUT); 
  # читаем входной поток и пишем в файл 
  while (<$in>) { 
    print OUT $_; 
  } 
  close(OUT); 

  # выводим надпись о закачке файла <$name> 
  print "Upload file: $name"; 
} 
Примечание

Часто возникает проблема: "При закачке картинок 00 меняется на 20(пробел), соответственно картинка не отображается..."

Это следствие перекодирования принимаемых данных http-сервером.

Если у Вас русский Apache, то эта проблема "лечится" выставлением директивы:

CharsetRecodeMultipartForms off
Как хранить пароли на сервере в зашифрованом виде?
Регистрация

При регистрации или изменении пароля новый пароль шифруется функцией crypt со случайным параметром salt (две буквы):

@saltair = ('A'..'Z', 'a'..'z', '0'..'9');
$salt = $saltair[rand(@saltair)] . $saltair[rand(@saltair)];

$crypted_password = crypt($plain_password, $salt);
Авторизация

Когда требуется сравнить пароль, который ввёл пользователь, с сохраненным зашифрованным паролем, надо зашифровать новый пароль с тем же параметром salt и сравнить обе строки. Поскольку salt записывается в первые две буквы шифрованного пароля, это не представляет сложности (лишние буквы crypt обрезает сам):

if (crypt($entered_password, $crypted_password) eq $crypted_password) {
  # правильный пароль
} else {
  # неверный пароль
}
Напоминание пароля

Поскольку системе пароль известен только в зашифрованном виде, напоминания как такового быть не может. Вместо этого можно по требованию пользователя создать случайным образом новый пароль и выслать ему по почте. Возникает, однако, проблема, как не давать людям менять чужие пароли. Поэтому лучше пароль не менять, а послать пользователю по почте случайный код, с которым он сможет один раз войти в систему, чтобы изменить пароль.

Как сделать так, чтобы программа гарантированно работала только в одном экземпляре?
Способ 1: файл с process id (PID)
$pidfile = '/var/run/mydaemon.pid';

if (-e $pidfile) {
  # PID-файл существует, но может быть создавший его процесс уже умер
  unless (open(PIDFILE, $pidfile)) {
    # слишком опасно стартовать, невозможно прочитать старый PID
    exit(1);
  }

  my $oldpid=<PIDFILE>;
  close PIDFILE;
  # проверить, существует ли процесс с таким PID
  if ($oldpid > 1 && kill(0,$oldpid)) {
    # один экземпляр программы уже выполняется
    exit(1);
  } else {
    # процесс, создавший файл, уже умер
  }
}

# создать PID-файл
open(PID, ">$pidfile") or die;
print PID $$;
close(PID);

# выполнение программы
...

# удалить PID-файл
unlink $pidfile;
exit(0);
Способ 2: блокировка файлов
# создать заблокированый файл
$lockfilename="/tmp/mydaemon.lock";
unless (open(LOCKFILE, ">$lockfilename")) {
  # невозможно создать файл для блокирования
  exit(1);
}
unless (flock(LOCKFILE, LOCK_EX|LOCK_NB)) {
  # oдин экземпляр программы уже выполняется
  exit(1);
}

# выполнение программы
...

# разблокировать файл
close(LOCKFILE);
unlink($lockfilename);
exit(0);
Можно ли сделать из программы на Perl выполняемый файл?

Вы можете воспользоваться коммерческой программой Perl2Exe. Это утилита для преобразования Perl-сценариев в выполняемые файлы, которые не требуют интерпретатора языка (на самом деле, интерпретатор просто включается в эти выполняемые файлы). В качестве операционных систем для выполнеемых файлов поддерживаются Win32 и многие клоны Unix. Можно также создавать графические интерфейсы для программ с помощью Tk.

Аналогичная программа PerlApp содержится в пакете Perl Dev Kit от ActiveState. Благодаря графическому интерфейсу, пользоваться ей проще, да и возможности у неё пошире. К сожалению, это отображается и в цене.

Существует также компилятор perlcc, который поставляется в дистрибутиве Perl и пытается перевести программу в язык программирования C. Однако, этот компилятор ненадежен и может перевести только самые простые программы.

Как можно стандартизировать (оформить в виде процедуры) получение выборки из БД, чтобы получать набор записей с именованными полями?

Это можно сделать так:

sub QueryArrayOfHashes
{
  my ($DB, $query) = @_;

  my @items = ();
  my $result = $DB->prepare($query);
  $result->execute or return;
  while (my $data_hash = $result->fetchrow_hashref)
  {
    push @items,{%$data_hash};
  }
  $result->finish;
  return @items;
}
Комментарии
  • $data_hash — ссылка на хэш
  • {%$data_hash} — копирование хеша из ссылки и создание новой ссылки на него (судя по документацие, в будущих версиях DBI ссылка $data_hash будет использоваться более одного раза, поэтому здесь нужно копирование)
Пример использования
use DBI;
...
$dbh=DBI->connect('DBI:mysql:mysql:localhost', $user, $password,
                    {RaiseError => 1})
            or die "connecting : $DBI::errstr\n";

@res = QueryArrayOfHashes($dbh, "select user, password from user");
for ($i=0; $i<=$#res; $i++)
{
  print "\n[Record #$i]::\n";
  foreach $key (sort keys %{$res[$i]})
  {
    # запись вида $a[1]{b} эквивалентна $a[1]->{b}
    print  $key, "\t", $res[$i]{$key}, "\n";
  }
}

$dbh->disconnect;
Альтернативное решение (автор: Alexander O)

В DBI, начиная с версии 1.14, для этой цели есть встроенное средство: selectall_arrayref

my $ar = $dbh->selectall_arrayref( 'select user, password from user',
                                  { Slice => {},                     # DBI.pm v1.20+
                                    dbi_fetchall_arrayref_attr => {} # DBI.pm v1.14-v1.19
                                  }
                               );

К сожалению, в разных версиях параметр Slice называется по-разному, и для кроссплатформенности необходимо это учесть.

Как из Perl получить документ с другого сервера?
Рекомендуемое решение

Воспользуйтесь модулем LWP (Library for WWW accesss in Perl).

#!/usr/bin/perl
use strict;
use LWP;

my $ua=LWP::UserAgent->new();
$ua->agent("PerlUA/0.1");

my $url="http://xpoint.ru";
my $document=$ua->request(HTTP::Request->new(GET => $url));
if ($document->is_success)
{
  print "Content-Type: text/html\n\n";
  print $document->content;
}
else
{
  print "Content-Type: text/html\n\n";
  print "Couldn't fetch $url\n";
}

Примечание: Чтобы меньше писать, можно использовать модуль HTTP::Request::Common. Кроме того, простые запросы можно делать с помощью модуля LWP::Simple.

Альтернативный вариант

Можно создать соединение с помощью модуля IO::Socket:

#!/usr/bin/perl
use strict;
use IO::Socket;

my $host = "xpoint.ru";
my $port = "80";
my $uri = "/";

my $socket = IO::Socket::INET->new("$host:$port");
unless ($socket) {die "can't connect to HTTP server on $host:$port: $!"}
$socket->autoflush(1);
print $socket "GET $uri HTTP/1.0\nHost: $host\n\n";
while (<$socket>) {print}
close $socket;

Примечание: Учтите, что в этом случае Вы получите ответ сервера полностью, включая заголовки HTTP!

Как отправить из Perl POST-запрос в другую CGI-программу?

Для отправки POST-запроса стоит воспользоваться модулем LWP (Library for WWW accesss in Perl) в комбинации с HTTP::Request::Common. Последний закодирует за Вас данные формы, то есть сделает из [login => 'пользователь', password => 'pass'] строку "login=%EF%EE%EB%FC%E7%EE%E2%E0%F2%E5%EB%FC&password=pass".

#!/usr/bin/perl
use strict;
use LWP;
use HTTP::Request::Common;

my $ua = LWP::UserAgent->new();
$ua->agent("PerlUA/0.1");

my $url = "http://xpoint.ru/user/login.xhtml";
my $request = POST $url, [a => 'пользователь', b => 'pass'];
my $document = $ua->request($request);
if ($document->is_success)
{
  print "Content-Type: text/html\n\n";
  print $document->content;
}
else
{
  print "Content-Type: text/html\n\n";
  print "Couldn't post to $url\n";
}
Дополнительная информация
  • lwpcook — примеры типичного использования библиотеки libwww-perl.
Как отправить письмо из Perl-скрипта?
Способ 1: модуль Mail::Sender

Примеры использования:

  1. Отправка простого письма
    use Mail::Sender; 
    
    # создаем объект с указанием SMTP сервера
    ref ($sender = new Mail::Sender {smtp => 'mail.smtp.host'}) 
    or die "Error($sender) : $Mail::Sender::Error\n"; 
    
    # headers - 
    #   определение дополнительного заголовка письма !!!
    $sender->Open( 
     {from => 'me@smtp.host', 
     to => 'friend@smtp.host', 
     subject => 'Mail::Sender.pm - new module', 
     headers => "MIME-Version: 1.0\r\nContent-type: text/plain; 
     charset=KOI8-R\r\nContent-Transfer-Encoding: 8bit"}) 
    or die $Mail::Sender::Error,"\n"; 
    
    $sender->Send(<<'*END*'); 
    Вот новый модуль Mail::Sender. 
    Он обеспечивает объект, реализующий интерфейс 
    для посылки писем через SMTP сервер. 
    
    Он использует прямую связь через Socket, 
    так что ему не нужна никакая дополнительная программа. 
    
    Author:: Jan Krynicky <jenda@krynicky.cz> http://Jenda.Krynicky.cz 
    *END*
    
    $sender->Close; 
    
    # END
    

    Примечание: не все SMTP-серверы позволяют отправлять письма без авторизации. Возможно, что придется указать в методе Open() еще и параметры authid/authpwd.

  2. Отправка письма с прилагаемым файлом
    use Mail::Sender; 
    
    ref ($sender = new Mail::Sender 
      {from => 'me@smtp.host', 
       smtp => 'mail.smtp.host', 
       boundary => 'This-is-a-mail-boundary-435427'}) 
    or die "Error($sender) : $Mail::Sender::Error\n"; 
    
    $sender->OpenMultipart( 
      {to => 'friend@smtp.host', 
      subject => 'Mail::Sender.pm - new module'}); 
    
    # !!! определяем заколовок тела письма !!!
    $sender->Body("KOI8-R", "8BIT", "text/plain"); 
    $sender->Send(<<'*END*'); 
    Вот новый модуль Mail::Sender. 
    Он обеспечивает объект, реализующий интерфейс 
    для посылки писем через SMTP сервер. 
    
    Он использует прямую связь через Socket, 
    так что ему не нужна никакая дополнительная программа. 
    
    Author:: Jan Krynicky <jenda@krynicky.cz> http://Jenda.Krynicky.cz 
    *END*
    
    # sender.zip - 
    #   прилагаемый файл !!!
    $sender->SendFile( 
      {description => 'Perl module Mail::Sender.pm', 
       ctype => 'application/x-zip-encoded', 
       encoding => 'Base64', 
       disposition => 'attachment; 
       filename="Sender.zip";
       type="ZIP archive"', 
       file => 'sender.zip'}); 
    
    $sender->Close; 
    
    # END
    
Способ 2: использование программы sendmail
  1. Отправка простого письма
    $mail_prog = '/usr/bin/sendmail'; # путь к sendmail
    $from_name = 'Администратор';
    $from_mail = 'admin@host.com';
    $to_name = 'Посетитель';
    $to_mail='user@host.com';
    $subject='test mail from sendmail programm';
    
    $message = <<END;
    To: "$to_name" <$to_mail>
    From: "$from_name" <$from_mail>
    Subject: $subject
    Content-Type: text/plain; charset=koi8-r
    Не отвечайте на это письмо!
    Это тестовое сообщение системы.
    
    С уважением, $from_name
    END
    
    open (MAIL, "| $mail_prog -f $from_mail $to_mail") || die "Mail: $!";
    print MAIL $message;
    close MAIL;
    
  2. Отправка письма с прилагаемым файлом

    Как преобразовать файл см. http://www.perldoc.com/perl5.6.1/lib/MIME/Base64.html

    Потом пишете (подразумевается, что $file это преобразованный файл):

    open(MAIL, '| /usr/sbin/sendmail -t -oi'); 
    
    print MAIL <<EOF; 
    To: $toemail 
    From: $email 
    Subject: $subject 
    Content-Type: multipart/mixed; boundary=boundary123 
    
    --boundary123
    Content-Type: application/zip; name="file.zip"
    Content-Transfer-Encoding: base64 
    Content-Disposition: attachment; filename="file.zip"
    
    $file
    --boundary123--
    EOF
    
    # end of print
    
Способ 3: модуль MIME::Lite
Дополнительная информация
Как сделать так, чтобы скрипт работал в фоновом режиме, как демон?
Варианта два. Первый - воспользоваться модулем Proc::Daemon, второй - сделать все самому, примерно так:
use strict;
require 'sys/syscall.ph';

# Устанавливаем путь по умолчанию
$ENV{PATH} = '/bin:/usr/bin';

# Чисто для прикола
$0='mydaemon';

# Отделяемся от родителя
fork() && exit;

# Отключаемся от терминала
close STDOUT; close STDERR; close STDIN;

# Делаем корень текужим каталогом
chdir '/';

# Создаем новую сессию и становимся лидером
# группы процессов, чтоб нас случайно не прибили
syscall(&SYS_setsid);

# Перехватываем сигналы, для корректного выхода
$SIG{'INT'} = $SIG{'QUIT'} = $SIG{'TERM'} = 'quit';
$SIG{'HUP'} = 'ignore';

# Делаем наши темные дела
...

# Выходим
quit();

sub quit {
  # Помещаем сюда код для корректного
  # прекращения работы
  ...
  exit(0);
}
Если Вы хотите написать демона, реализующего работу через сеть, рекомендуем ознакомиться с модулем Net::Daemon.
Proc::Background - Общий для Unix и Win32 интерфейс управление фоновыми процессами
Proc::Background - http://search.cpan.org/search?dist=Proc-Background

Это общий интерфейс для управления фоновыми процессами как на Unix, так и на Win32 платформах. Модуль позволяет Вам запускать и заверщать фоновые процессы, получать выходные данные и отслеживать состояние фоновых процессов.

P.S. Рекомендую при использовании под Win32 брать архив со CPAN и посмотреть прилагаемые примеры и скрипты.

Вторая cookie не передается, что неправильно я сделал?

Если вы используете библиотеку CGI.pm и функции header() или redirect() из нее, то учтите, что вызов этих функций означает выдачу заголовка HTTP, который заканчивается двойным переносом строки. Все, что идет после этого, интерпретируется уже как содержимое страницы, которую надо показать.

Пример:
my $c_login=cookie(-NAME => "login", -VALUE => 'user');
my $c_passwd=cookie(-NAME => "password",-VALUE => 'pass');

print header(-COOKIE => $c_login);
# вторая кука не поставится - заголовок HTTP уже выдан!
print header(-COOKIE => $c_passwd);
Если уж Вы так хотите писать, используя CGI.pm, то пишите:
print header(-COOKIE=> [$c_login, $c_passwd]);
Результат, выдаваемый сервером, будет таким:
-----------------------
Status: 200 ОК
Set-Cookie: login=user
Set-Cookie: password=pass
Content-Type: text/html

-----------------------
Как добавить строку в начало файла?

В файл нельзя так просто "вставить" строчку, файл это место на диске, чтобы что-то вставить пришлось бы сдвигать все остальное. Если файл небольшой, то его можно прочитать в память и потом записать обратно уже с изменением. Для меньшего расхода памяти надо создать временный файл:

open(FILEIN, "$filename");
open(TEMP,">$filename~");

print TEMP "$newline\n";
while (<FILEIN>)
{
  print TEMP $_;
}

close(FILEIN);
close(TEMP);

rename("$filename~", "$filename");
Больше информации о работе с файлами
Как удалить дерево каталогов или выполнить какую-то другую операцию на всех подкаталогах и файлах?
Способ 1: рекурсия

Самые простые алгоритмы для решения данной проблемы основываются на рекурсии. Вот пример функции для удаления каталога со всем его содержимым:

sub del_folder
{
  my $dir=shift;
  return 0 unless $dir;

  opendir(DIR,$dir) or (warn "Can't rmdir $dir: $!" and return 0);
  my @files=readdir(DIR);
  closedir(DIR);

  foreach (@files)
  {
    # Пропускаем спецфайлы . и ..
    next if /^\.\.?$/;
                
    my $filename="$dir/$_";
    if (-d $filename)
    {
      del_folder($filename);
    }
    else
    {
      unlink $filename or (warn "Can't unlink $filename: $!" and next);
    }
  }

  rmdir $dir or (warn "Can't rmdir $dir: $!" and return 0);
  return 1;
}
Способ 2: использование модулей

В "Perl Cookbook" by Tom Christiansen and Nathan Torkington, O'Reilly ("Библиотека программиста: Perl", издательство "Питер"), приводится два примера рекурсивного удаления каталога вместе с его содержимым. В одном используется функция finddepth из модуля File::Find, во втором — функция rmtree из File::Path.

Как открыть пользователю окошко сохранения файла?

Чтобы в браузере открылся диалог "Сохранить файл" с названием файла file.dat, скрипт должен послать соответствующие заголовки Content-Disposition и Content-Type:

#!/usr/bin/perl
use strict;

print "Content-Disposition: attachment; filename=file.dat\n";
print "Content-Type: application/x-force-download; name=\"file.dat\"\n\n";

open(F, "/etc/passwd");
print while (<F>);
close(F);

Не мешало бы также ссылаться на скрипт как http://.../download.pl?file.dat, иначе браузеры семейства Mozilla могут попытаться записать файл как file.dat.pl.

Примечание

Не используйте заголовок Cache-Control: no-cache в таких скриптах, большинство версий Internet Explorer не смогут скачать файл.

Powered by POEM™ Engine Copyright © 2002-2005