forum/forum

   1 #!/usr/bin/perl -T
   2 #
   3 # Stil Life forum. Copyright (c) by Victor B. Wagner, 2008
   4 # This program distributed under GNU Affero General Public License v3 or
   5 # above
   6 # http://www.gnu.org/licenses/agpl.html
   7 #
   8 # Вкратце: Если вы используете этот скрипт на своем сайте, Вы обязаны
   9 # сделать доступным его исходный текст. В частности, если Вы внесли
  10 # какие-либо изменения, вы должны эти изменения опубликовать.
  11 #
  12 # Home site of this program http://vitus.wagner.pp.ru/stilllife
  13 #
  14 use strict;
  15 use warnings;
  16 use CGI;
  17 use HTML::TreeBuilder;
  18 use Storable qw(freeze thaw);
  19 use Date::Parse;
  20 use Email::Valid;
  21 #
  22 # Набор поддерживаемых действий. Хэш вида
  23 # "имя поля в запросе" =>  "функция обработчик"
  24 #
  25 my %actions = (
  26         reply => \&reply,
  27         edit => \&edit_comment,
  28         delete => \&delete_comment,
  29         move => \&move_comment,
  30         newtopic=> \&new_topic,
  31         newforum=> \&new_forum,
  32         login => \&login,
  33         register=>\&register,
  34         profile=>\&profile,
  35         setrights=>\&set_rights,
  36         openidlogin=>\&openid_login,
  37         openidvfy =>\&openid_verify
  38 );
  39
  40
  41
  42 my $cgi = new CGI;
  43 print STDERR "--------------------\n";
  44 my $forum=get_forum_config();
  45
  46
  47 authorize_user($cgi,$forum);
  48 if ($cgi->request_method ne "POST") {
  49 # Запрос к скрипту методом GET. Надо показать форму, если только это не
  50 # редирект от OpenId-сервера
  51         if ($cgi->param('openidvfy')) {
  52                 openid_verify($cgi);
  53         } elsif ($cgi->param("logout")) {
  54                 logout('logout',$cgi,$forum);
  55         } else {
  56                 for my $param ($cgi->param) {
  57 # Среди параметров, указанных в URL ищем тот, который задает
  58 # действие
  59                         if (exists $actions{$param}) {
  60 # Мы, конечно уже проверили, что в названии параметра
  61 # нехороших символов нет, но чтобы perl в taint mode не
  62 # ругался...
  63                                 if (allow_operation($param,$cgi,$forum)) {
  64                                         show_template($1,$cgi,$forum) if $param=~/^(\w+)$/;
  65                                         exit;
  66                                 } else {
  67                                         if (!$forum->{"authenticated"}) {
  68                                                 $cgi->param("returnto",$cgi->uri(-full=>1));
  69                                                 show_template("login",$cgi,$forum);
  70                                                 exit;
  71
  72                                         } else {
  73                                                 show_error($forum,"У Вас нет прав на  выполнение этой
  74                                                 операции")
  75                                         }
  76                                 }
  77                         }
  78                 }
  79                 show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр
  80                                 действия");
  81         }
  82 } else {
  83         # Запрос методом POST. Вызываем обработчик
  84         for my $param ($cgi->param) {
  85                 if (exists $actions{$param}) {
  86                         $actions{$param}->($param,$cgi,$forum);
  87                         exit;
  88                 }
  89         }
  90         print STDERR "Получены параметры ",join(" ",$cgi->param),"\n";
  91         show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия");
  92 }
  93
  94 sub dir2url {
  95         my ($cgi,$dir) = @_;
  96         my $prefix=$cgi->url(-base=>1);
  97         my $pos=rindex $ENV{'PATH_TRANSLATED'},$ENV{'PATH_INFO'};
  98         if ($pos <0 && $ENV{'PATH_INFO'}=~m!(/\~\w+)/!) {
  99                 $prefix .=$1;
 100                 $pos =
 101                 rindex($ENV{'PATH_TRANSLATED'},substr($ENV{'PATH_INFO'},length($1)));
 102         }
 103         if ($pos <0) {
 104                 show_error({},"Ошибка конфигурации форума. Не удается определить
 105                 алгоритм преобразования директори в URL\n".
 106                 "PATH_INFO=$ENV{PATH_INFO}\n".
 107                 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
 108         }
 109         my $root = substr($ENV{'PATH_TRANSLATED'},0,$pos);
 110         if (substr($dir,0,length($root)) ne $root) {
 111                 show_error({},"Ошибка конфигурации форума. Не удается преобразовать
 112                 имя директории $dir в url\n".
 113                 "PATH_INFO=$ENV{PATH_INFO}\n".
 114                 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
 115         }
 116         return $prefix.substr($dir,length($root));
 117 }
 118 #
 119 # Поиск файла .forum вверх по дереву от $ENV{PATH_TRANSLATED}
 120 # Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не
 121 # враг.
 122 # Возвращает список имя,значение, имя, значение который прививается в
 123 # хэш
 124
 125 sub get_forum_config {
 126         my @path=split("/",$1) if $ENV{PATH_TRANSLATED}=~/^(\S+)$/;
 127         while (@path>1) {
 128                 if (-r (my $config=join("/",@path,".forum")) ) {
 129                         open F,"<",$config;
 130                         my %config;
 131                         while (<F>) {
 132                                 s/#.*$//; #Drop comments;
 133                                 $config{$1}=$2 if /(\w+)\s*=\s*(\S.*)$/;
 134                         }
 135                         close F;
 136                         #
 137                         # Переменная forumtop - это URL того места, где находится
 138                         # файл .forum
 139
 140                         $config{"forumtop"} = dir2url($cgi,join("/",@path));
 141                         # Если в конфиге отсутствует переменная templates, но
 142                         # рядом с конфигом присутствует директория templates,
 143                         # то шаблоны там.
 144                         #
 145                         if (! exists $config{"templates"}
 146                                 && -d (my $filename = join("/",@path,"templates"))) {
 147                                         $config{"templates"} = $filename;
 148                         }
 149                         $config{"templatesurl"} = dir2url($cgi,$config{"templates"})
 150                                 unless exists $config{"templatesurl"};
 151                         #
 152                         # То же самое - параметр userdir и директория users
 153                         #
 154                         if (! exists $config{"userdir"}
 155                                 && -d (my $filename = join("/",@path,"users"))) {
 156                                         $config{"userdir"} = $filename;
 157
 158
 159                         }
 160                         $config{"userurl"} = dir2url($cgi,$config{"userdir"});
 161
 162                         #
 163                         # Если нет ссылки в конфиге на файл паролей или он не
 164                         # существует, выдаем ошибку. С офоромлением, так как шаблоны
 165                         #  у нас уже есть
 166                         if (!exists $config{"datadir"}) {
 167                                 show_error(\%config,"В конфигурации форума не указана
 168                                 директория данных ");
 169                                 exit;
 170                         }
 171                         if (!-d $config{"datadir"}) {
 172                                 show_error(\%config,"В конфигурации форума указана несуществующая директория данных ");
 173                                 exit;
 174                         }
 175                         $config{"authperiod"}="+1M" if (! exists $config{"authperiod"});
 176                         $config{"renewtime"} = "86000" if (!exists $config{"renewtime"});
 177                         $config{"replies_per_page"} = 50 if (!exists $config{"replies_per_page"});
 178                         return \%config;
 179                 }
 180                 pop @path;
 181         }
 182         #
 183         # Выводим ошибку 404 без осмысленного оформления, так как данных форума
 184         # мы не нашли
 185         print "Status: 404\nContent-Type: text/html; charset=utf-8\n\n",
 186         "<HTML><HEAD><TITLE>Форум не обнаружен</TITLE></HEAD><BODY>",
 187         "<H!>Форум не найден</H!>",
 188         "<p>Хвост URL, указанный при вызове скрипта  показывает не на
 189         форум</p>",
 190         # To make IE think this page is user friendly
 191         "<!--",("X" x 512),"--></body></html>\n";
 192         exit;
 193 }
 194 #
 195 # Вывод сообщения об ошибке по шаблону форума
 196 # Шаблон должен содержать элемент с классом error.
 197 #
 198 sub show_error {
 199         my ($cfg,$msg) = @_;
 200         if ( -r $cfg->{"templates"}."/error.html") {
 201                 my $tree = HTML::TreeBuilder->new_from_file($cfg->{"templates"}."/error.html");
 202                 my $node= $tree->find_by_attribute('class','error');
 203                 my $body;
 204                 if (!$node) {
 205                         $body = $tree->find_by_tagname('body');
 206                         $body->push_content($node = new
 207                         HTML::Element('div','class'=>'error'));
 208                 }
 209                 $node->delete_content;
 210                 $node->push_content($msg);
 211                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
 212                 print $tree->as_HTML("<>&");
 213         } else {
 214                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
 215                 print "<html><head><title>Ошибка конфигурации форума</title></head>",
 216                 "<body><h1>Ошибка конфигурации форума</h1><p>",
 217                 $cgi->escapeHTML($msg),"</p>",
 218                 "<p>При обработке этой ошибки не обнаружен шаблон сообщения об ошибке</p></body></html>";
 219         }
 220         exit;
 221 }
 222 #
 223 # Вывод шаблона формы. В шаблоне должна присутстовать форма с
 224 # именем, совпадающим с именем form. Если в $cgi есть параметры, имена
 225 # которых совпадают с именами полей этой формы, их значения
 226 # подставляются
 227 #
 228 sub show_template {
 229         my ($form,$cgi,$forum) = @_;
 230         my $filename=$forum->{"templates"}."/$form.html";
 231         if (! -r $filename) {
 232                 show_error($forum,"Нет шаблона для операции $form");
 233                 exit;
 234         }
 235         my $tree = HTML::TreeBuilder->new_from_file($filename);
 236         fix_forum_links($forum,$tree);
 237         # Находим форму с классом $form
 238         my $f = $tree->look_down("_tag","form",
 239                 "name",$form);
 240         if (! defined $f) {
 241                 # Если не нашли - ругаемся
 242                 show_error($forum,"Шаблон для операции $form не содержит формы с
 243                 именем $form");
 244                 exit;
 245         }
 246         $cgi->delete('password');
 247         if (!$cgi->param("returnto")) {
 248                 $cgi->param("returnto", $cgi->referer||$cgi->url(-absolute=>1,-path_info=>1));
 249
 250         }
 251         if (!$cgi->param($form)) {
 252                 $cgi->param($form,1);
 253         }
 254         #
 255         # Если ранее была выставлена ошибка с помощью set_error, подставляем
 256         # сообщение в элемент с классом error
 257         #
 258         if ($forum->{error_message}) {
 259                 my $errormsg = $tree->look_down("class"=>"error");
 260                 if ($errormsg) {
 261                         $errormsg->delete_content();
 262                         $errormsg->push_content($forum->{error_message});
 263                 }
 264         }
 265         if ($forum->{"authenticated"}) {
 266
 267                 # Подставляем информацию о текущем пользователе если в шаблоне
 268                 # это предусмотрено
 269                 substitute_user_info($tree,$forum);
 270                 $cgi->param("user",$forum->{"authenticated"}{"user"}) if (!defined $cgi->param("user"))
 271         }
 272         my %substituted;
 273         ELEMENT:
 274         for my $element ($f->find_by_tag_name("textarea","input","select")) {
 275                 my $name = $element->attr("name");
 276                 $substituted{$name} = 1;
 277                 #print STDERR "substituting form element name $name tag ",$element->tag,
 278             #           "value='",$cgi->param($name),"'\n";
 279                 if (defined  $cgi->param($name)) {
 280                         if ($element->tag eq "input") {
 281                                 next ELEMENT if grep ($element->attr("type") eq
 282                                 $_,"button","submit","reset");
 283                                 if ($element->attr("type") eq "check") {
 284                                         if (grep($element->attr("value") eq $_,$cgi->param($name))) {
 285                                                 $element->attr("checked","");
 286                                         } else {
 287                                                 $element->attr("checked",undef);
 288                                         }
 289
 290                                 } elsif ($element->attr("type") eq
 291                                 "radio") {
 292                                         if ($element->attr("value") eq $cgi->param($name)) {
 293                                                 $element->attr("checked","");
 294                                         } else {
 295                                                 $element->attr("checked",undef);
 296                                         }
 297                                 } else {
 298                                 $element->attr("value",$cgi->param($name));
 299                                 }
 300                         } elsif ($f->tag eq "textarea") {
 301                                 $f->delete_content;
 302                                 $f->push_content($cgi->param("name"));
 303                         } elsif ($f->tag eq "select") {
 304                                 for my $option ($f->find_by_tag_name("option")) {
 305                                         if (grep($option->attr("value") eq $_, $cgi-param("name"))) {
 306                                                 $option->attr("selected","");
 307                                         } else {
 308                                                 $option->attr("selected",undef);
 309                                         }
 310                                 }
 311
 312                         }
 313                 }
 314
 315         }
 316         $f->attr("type","POST");
 317         for my $required ($form,"returnto") {
 318                 if (!$substituted{$required}) {
 319                         my $element = new HTML::Element('input',
 320                                 'type' => 'hidden', 'name' => $required,
 321                                 'value'=> $cgi->param($required));
 322                         $f->push_content($element);
 323                 }
 324         }
 325
 326
 327         print
 328         $cgi->header(-type=>"text/html",-charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
 329         $tree->as_HTML("<>&");
 330 }
 331 #
 332 # Поправляет ссылки на служебные файлы и скрипты форума
 333 #
 334 sub fix_forum_links {
 335         my ($forum,$tree,$path_info) = @_;
 336         $path_info=$ENV{'PATH_INFO'} if (!defined $path_info);
 337         my $script_with_path = $ENV{SCRIPT_NAME}.$path_info;
 338         ELEMENT:
 339         for my $element ($tree->find_by_tag_name("form","img","link","script","a")) {
 340                 my $attr;
 341                 if ($element->tag eq "form")  {
 342                         $attr = "action";
 343                 } elsif ($element->tag eq "a"|| $element->tag eq "link") {
 344                         $attr = "href";
 345                 } else {
 346                         $attr ="src";
 347                 }
 348                 my $link = $element->attr($attr);
 349                 print STDERR "Fixing link $link\n";
 350                 # Абсолютная ссылка - оставляем как есть.
 351                 next ELEMENT if (! defined $link || $link=~/^\w+:/);
 352                 # Ссылка от корня сайта.
 353                 if (substr($link,0,1) eq "/") {
 354                         # Если она не ведет на наш скрипт, не обрабатываем
 355                         next ELEMENT if substr($link,0,length($ENV{SCRIPT_NAME}) ne
 356                         $ENV{SCRIPT_NAME}) ;
 357                         # Иначе пишем туда слово forum вместо реального имени
 358                         # скрипта чтобы потом единообразно обработать
 359                         $link =~ s/^[^\?]+/forum/;
 360                 }
 361                 if (!($link =~ s!^templates/!$forum->{templatesurl}/!) &&
 362                     !($link =~ s!^users/!$forum->{usersurl}/!) &&
 363                     !($link =~ s!^forum\b!$script_with_path!)) {
 364                         $link = $forum->{"forumtop"}."/".$link
 365                 }
 366                 print STDERR "Fixed to $link\n";
 367                 $element->attr($attr,$link);
 368         }
 369 }
 370 #
 371 # Подставляет в заданное поддерево информацию о пользователе
 372 #
 373
 374 sub substitute_user_info {
 375
 376 my ($tree,$forum) = @_;
 377 my %userinfo = %{$forum->{"authenticated"}};
 378
 379 #
 380 # Специально обрабатываем поля user (должна быть ссылка) и avatar
 381 # (должен быть img).
 382 my @userlink = $tree->look_down("_tag"=>"a","class"=>"author");
 383 if (@userlink) {
 384         my $userpage;
 385         if ($userinfo{"user"}=~/^http:/) {
 386                 $userpage = $userinfo{"user"};
 387         } else {
 388                 $userpage =
 389                 $cgi->url(-absolute=>1,-path_info=>1)."?profile=1&user=".$cgi->escape($userinfo{"user"});
 390         }
 391         for my $element (@userlink) {
 392                 $element->attr(href=>$userpage);
 393                 $element->delete_content();
 394                 $element->push_content($userinfo{"user"});
 395         }
 396 }
 397 delete $userinfo{"userpage"};
 398 delete $userinfo{"user"};
 399 my $avatar = $tree->look_down("_tag"=>"img","class"=>"avatar");
 400 if ($avatar) {
 401         $avatar->attr(src=>$userinfo{"avatar"});
 402 }
 403 delete $userinfo{"avatar"};
 404
 405 while (my ($field,$value)=each %userinfo) {
 406         my $element = $tree->look_down("class","a".$field);
 407         if ($element) {
 408                 $element->delete_content();
 409                 #
 410                 # FixME - allow HTML in author attributes
 411                 $element->push_content($value);
 412         }
 413
 414 }
 415
 416 }
 417 #
 418 # Авторизует зарегистрированного пользователя.
 419 # 1. Проверяет куку если есть
 420 #
 421
 422 sub authorize_user      {
 423         ($cgi,$forum) = @_;
 424         if (my $session=$cgi->cookie("slsession")) {
 425         # Пользователь имеет куку
 426                 my %sessbase;
 427                 dbmopen %sessbase,datafile($forum,"session"),0644;
 428                         if ($sessbase{$session})  {
 429                                 my ($user,$expires,$ip)=split(";", $sessbase{$session});
 430                                 if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) {
 431                                         my %userbase;
 432                                         dbmopen %userbase,datafile($forum,"passwd"),0644;
 433                                         if ( $userbase{$user}) {
 434                                                 my $userinfo = thaw($userbase{$user});
 435                                                 delete $userinfo->{"passwd"};
 436                                                 $userinfo->{"user"} = $user;
 437                                                 if ($expires-time()< $forum->{"renewtime" }) {
 438                                                         delete $sessbase{$session};
 439                                                         newsession(\%sessbase,$forum,$user,$ip);
 440                                                 }
 441                                                 print STDERR "user $user restored session $session\n";
 442                                                 $forum->{"authenticated"}=$userinfo;
 443                                                 print STDERR "authorize_user:
 444                                                 ",$forum->{authenticated}{user},
 445                                                 $forum->{authenticated},"\n";
 446                                         }
 447                                         dbmclose %userbase;
 448                                 }
 449                         }
 450                 dbmclose %sessbase;
 451         }
 452 }
 453 #
 454 # Возвращает путь к файлу в директории
 455 #
 456 sub datafile {
 457         my ($forum,$filename) = @_;
 458         return $forum->{"datadir"}."/".$filename;
 459 }
 460
 461 #
 462 # Создает новую сессию для пользователя и подготавливает куку которую
 463 # сохраняет в хэше конфигурации форума
 464 #
 465 sub newsession {
 466         my ($base,$forum,$user,$bindip) = @_;
 467         if (!defined $base) {
 468                 $base = {};
 469                 dbmopen %$base,datafile($forum,"session"),0644;
 470         }
 471         my $sessname;
 472         my $t = time();
 473         my ($u,$expires,$ip);
 474         do {
 475                 $sessname = sprintf("%08x",rand(0xffffffff));
 476                 if ($base->{"sessname"}) {
 477                         ($u,$expires,$ip) = split ";", $base->{$sessname};
 478                         delete $base->{$sessname} if $expires < $t;
 479                 }
 480         } while ($base->{$sessname});
 481         my $cookie = $cgi->cookie(-name=>"slsession",
 482                 -expires => $forum->{"authperiod"},-value=> $sessname);
 483         $base->{$sessname}=$user.";".str2time($cookie->expires()).
 484                 ($ip?";$ENV{'REMOTE_ADDR'}":"");
 485
 486         $forum->{'cookies'}=[ $cookie,
 487         $cgi->cookie(-name=>"sluser",-value=>$user,-expires =>
 488         $forum->{authperiod})];
 489 }
 490 #
 491 # Выполняет аутентикацию пользователя по логину и паролю и
 492 # создает для него сессию.
 493 #
 494 sub authenticate {
 495         my ($cgi,$forum) = @_;
 496         if ($cgi->param("openidsite")) {
 497                 my $openid_url = sprintf($cgi->param("openidsite",$cgi->param("user")));
 498                 openidstart($cgi,$openid_url);
 499         }
 500         my %userbase;
 501         dbmopen %userbase,datafile($forum,"passwd"),0644;
 502         my $user = $cgi->param("user");
 503         my $password = $cgi->param("password");
 504         print STDERR "user=>'$user'\npassword=>'$password'\n";
 505         $cgi->delete("password");
 506         if (! $userbase{$user}) {
 507           set_error($forum,"Неверное имя пользователя или пароль");
 508           return undef;
 509         }
 510         my $userinfo = thaw($userbase{$user}) ;
 511         dbmclose %userbase;
 512         while (my ($key,$val)=each %$userinfo) { print STDERR "$key => '$val'\n";}
 513         if (crypt($password,$userinfo->{passwd}) eq $userinfo->{passwd}) {
 514                 delete $userinfo->{"passwd"};
 515                 $cgi->delete("password");
 516                 $userinfo->{"user"} = $user;
 517                 newsession(undef,$forum,$user);
 518                 $forum->{"authenticated"} = $userinfo;
 519                 print STDERR "User $user authenticated successfully\n";
 520                 return 1;
 521         } else {
 522                 set_error($forum,"Неверное имя пользователя или пароль");
 523                 return undef;
 524         }
 525 }
 526 #
 527 # Запоминает сообщение об ошибке для последующего вывода show_template
 528 #
 529 sub set_error {
 530         my  ($forum,$message) = @_;
 531         print STDERR "set_error: $message\n";
 532         $forum->{error_message} = $message;
 533 }
 534 #
 535 # Выводит текущий шаблон с сообщением об ошибке
 536 #
 537 sub form_error {
 538         my ($form_name,$cgi,$forum,$msg) = @_;
 539         set_error($forum,$msg);
 540         show_template($form_name,$cgi,$forum);
 541         exit;
 542 }
 543 #
 544 # Выполняет редирект (возможно, с установкой куков) на страницу,
 545 # указанную # третьем параметре функции или в параметре CGI-запроса
 546 # returnto
 547 # Если и то, и другое не определено, пытается сконструировать URL для
 548 # возврата из PATH_INFO.
 549 #
 550
 551 sub forum_redirect {
 552         my ($cgi,$forum,$url) = @_;
 553         if (!defined $url) {
 554                 $url = $cgi->param("returnto");
 555                 $url = $cgi->url(-base=>1).$cgi->path_info() if (!$url);
 556         }
 557         print $cgi->redirect(-url=>$url,
 558                 ($forum->{cookies}?(-cookie=>$forum->{cookies}):()));
 559         exit;
 560 }
 561 #
 562 # Обработка результатов заполнения формы регистрации.
 563 #
 564 #
 565 sub register {
 566         my ($formname,$cgi,$forum) = @_;
 567         #
 568         # Возможные ошибки:
 569         # 1 Такой юзер уже есть
 570         #
 571         #  не заполнено поле user
 572         if (!$cgi->param("user")) {
 573                 form_error($formname,$cgi,$forum, "Не заполнено имя пользователя");
 574         }
 575         #  или поле password
 576         if (!$cgi->param("pass1"))  {
 577                 form_error($formname,$cgi,$forum,"Не указан пароль");
 578         }
 579         #  Копии пароля не совпали
 580         if ($cgi->param("pass2") ne $cgi->param("pass1")) {
 581                 form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
 582         }
 583         my $user = $cgi->param("user");
 584         # Не указаны поля, перечисленные в скрытом поле required
 585         if ($cgi->param("required")) {
 586                 foreach my $field (split(/\s*,\s*/,$cgi->param('required'))) {
 587                         if (!$cgi->param($field)) {
 588                                 form_error($formname,$cgi,$forum,"Не заполнено обязательное поле $field");
 589                         }
 590                 }
 591         }
 592         my %userbase;
 593         dbmopen %userbase,datafile($forum,"passwd"),0644
 594                 or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!");
 595         if ($userbase{$cgi->param("user")}) {
 596                 dbmclose %userbase;
 597                 form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято");
 598         }
 599         if ($cgi->param("email") && !  Email::Valid->address($cgi->param("email"))) {
 600                 form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес");
 601         }
 602         my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./';
 603         my $salt = substr($saltstring,int(rand(64)),1).
 604                                 substr($saltstring,int(rand(64)),1);
 605         my $password=crypt($cgi->param("pass1"),$salt);
 606         my $userinfo = {passwd=>$password};
 607         # Удаляем лишние поля
 608         $cgi->delete("required");
 609         $cgi->delete("register");
 610         $cgi->delete("user");
 611         $cgi->delete("pass1");
 612         $cgi->delete("pass2");
 613         foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) {
 614                 if (!$cgi->param($field)) {
 615                         $cgi->delete($field);
 616                 }
 617         }
 618         my $returnto = $cgi->param("returnto");
 619         $cgi->delete("returnto");
 620         # Если есть аватар в файле, то сохраняем этот файл и формируем URL
 621         # на него.
 622         if ($cgi->param("avatarfile" )) {
 623                 my $f = $cgi->upload("avatarfile");
 624                 binmode $f,":bytes";
 625                 my $out;
 626                 my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/;
 627                 open $out,">",$forum->{"userdir"}."/".$filename;
 628                 binmode $out,":bytes";
 629                 my $buffer;
 630                 while (my $bytes = read($f,$buffer,4096)) {
 631                         print $out $buffer;
 632                 }
 633                 close $f;
 634                 close $out;
 635                 $userinfo->{'avatar'}= $forum->{"userurl"}."/".$filename;
 636                 $cgi->delete("avatar");
 637                 $cgi->delete("avatarfile");
 638         }
 639
 640         foreach my $param       ($cgi->param) {
 641                 $userinfo->{$param} = $cgi->param($param);
 642         }
 643         $userinfo->{registered} = time;
 644         if (exists $forum->{default_status}) {
 645                 $userinfo->{status} = $forum->{default_status};
 646         }
 647         print STDERR "stilllife forum: registering user $user\n";
 648         $userbase{$user} = freeze($userinfo);
 649         dbmclose %userbase;
 650         newsession(undef,$forum,$user);
 651         forum_redirect($cgi,$forum,$returnto)
 652 }
 653 #
 654 # Обработчик формы логина. Сводится к вызову функции authenticate,
 655 # поскольку мы поддерживаем логин одновременный с отправкой реплики.
 656 #
 657 sub login {
 658         my ($form,$cgi,$forum)=@_;
 659         if (authenticate($cgi,$forum)) {
 660                 forum_redirect($cgi,$forum);
 661         } else {
 662                 show_template(@_);
 663         }
 664 }
 665 #
 666 # Обработчик формы logout. В отличие от большинства обработчиков форм,
 667 # поддерживает обработку методом GET
 668 #
 669 sub logout {
 670         my ($form,$cgi,$forum) = @_;
 671         $forum->{cookies}=[ $cgi->cookie(-name=>"sluser", -value=>"0",
 672         -expires=>"-1m"),$cgi->cookie(-name=>"slsession", -value=>"0",
 673                         -expires => "-1m")];
 674         if (defined (my $session_id = $cgi->cookie("slsession"))) {
 675                 my %sessiondb;
 676                 dbmopen %sessiondb,datafile($forum,"session"),0644;
 677                 delete $sessiondb{$session_id};
 678                 dbmclose %sessiondb;
 679         }
 680         forum_redirect($cgi,$forum);
 681 }
 682 sub allow_operation {
 683         my ($operation,$cgi,$forum) = @_;
 684         return 1 if (grep $operation eq $_,"register","login","reply");
 685
 686         return 1;
 687 }
 688
 689 sub reply {
 690         my ($form,$cgi,$forum) = @_;
 691         if (! exists $forum->{authenticated} ) {
 692                 form_error($form,$cgi,$forum,"Вы не зарегистрировались") if (!authenticate($cgi,$forum));
 693         }
 694         #
 695         # Находим файл дискуссии, в который надо поместить реплику
 696         #
 697
 698         #
 699         # Сохраняем приаттаченную картинку, если есть.
 700         #
 701
 702         # Генерируем идентификатор записи.
 703         #
 704
 705         #
 706         # Преобразуем текст записи в html и чистим его
 707         #
 708         my $txtree = undef;
 709         if ($cgi->param("format") eq "bbcode") {
 710
 711         } elsif ($cgi->param("format") eq "text") {
 712                 my $text = $cgi->escapeHTML($cgi->param("text"));
 713                 $text=~s/\r?\n\r?\n/<p>/;
 714                 $text=~s/\n/<br>/;
 715                 $txtree =
 716                 HTML::TreeBuilder->new_from_content("<div>$text</div>");
 717         } else { # Default - html
 718                 $txtree =
 719                 HTML::TreeBuilder->new_from_content("<div>".$cgi->param("text")."</div>");
 720                 for my $badtag
 721                 ("script","style","head","html","object","embed","iframe","frameset","frame",
 722                 ($forum->{forbid_tags}?split(/\s*,\s*/,$forum->{forbid_tags}):())) {
 723                         for my $element ($txtree->find_by_tag_name($badtag)) {
 724                                 $element->delete() if defined $element;
 725                         }
 726                 }
 727         }
 728 }
 729