]> www.wagner.pp.ru Git - oss/stilllife.git/blob - forum/forum
*** empty log message ***
[oss/stilllife.git] / 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