]> www.wagner.pp.ru Git - oss/stilllife.git/blob - forum/forum
posting into existing topic more or less works
[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 Fcntl qw(:DEFAULT :flock);
17 use CGI;
18 use HTML::TreeBuilder;
19 use Storable qw(freeze thaw);
20 use Date::Parse;
21 use Email::Valid;
22 use Image::Size;
23 use HTML::BBReverse;
24 use POSIX;
25 use LWP::UserAgent;
26 use Net::OpenID::Consumer;
27 #
28 # Набор поддерживаемых действий. Хэш вида 
29 # "имя поля в запросе" =>  "функция обработчик"
30 #
31 my %actions = (
32         reply => \&reply,
33         edit => \&edit_comment,
34         delete => \&delete_comment,
35         move => \&move_comment,
36         newtopic=> \&new_topic,
37         newforum=> \&new_forum,
38         login => \&login,
39         register=>\&register,
40         profile=>\&profile,
41         setrights=>\&set_rights,
42         openidlogin=>\&openid_login,
43         openidvfy =>\&openid_verify
44 );      
45 #
46 #  Уровень прав, которые необходимо иметь пользователю для совершения
47 #  определенного действия
48 #  иерархия вида undef < banned < normal < author < moderator <admin
49 #  Если операция не упомянута в данном массив, то значит можно всем, в
50 #  том числе  и анониму.
51 # Слово login означает, что вообще-то это normal, но пользователь может
52 # логиниться непосредственно в процессе выполнения операции.
53 my %permissions = (
54         reply => "login",
55         edit => "author",
56         delete => "author",
57         newtopic => "normal",
58         move => "moderator",
59         newforum => "moderator",
60         profile => "normal",
61         setrights => "admin",
62 );      
63
64 my $cgi = new CGI;
65 print STDERR "--------------------\n";
66 my $forum=get_forum_config();
67
68
69 authorize_user($cgi,$forum);
70 if ($cgi->request_method ne "POST") {
71 # Запрос к скрипту методом GET. Надо показать форму, если только это не
72 # редирект от OpenId-сервера 
73         if ($cgi->param('openidvfy')) { 
74                 openid_verify($cgi,$forum);
75         } elsif ($cgi->param("logout")) {
76                 logout('logout',$cgi,$forum);
77         } else {
78                 for my $param ($cgi->param) {
79 # Среди параметров, указанных в URL ищем тот, который задает
80 # действие 
81                         if (exists $actions{$param}) {
82 # Мы, конечно уже проверили, что в названии параметра
83 # нехороших символов нет, но чтобы perl в taint mode не
84 # ругался... 
85                                 if (allow_operation($param,$cgi,$forum)) {
86                                         show_template($1,$cgi,$forum) if $param=~/^(\w+)$/;     
87                                         exit;
88                                 } else {
89                                         if (!$forum->{"authenticated"}) { 
90                                                 $cgi->param("returnto",$cgi->url(-full=>1));
91                                                 show_template("login",$cgi,$forum);
92                                                 exit;
93
94                                         } else {
95                                                 show_error($forum,"У Вас нет прав на  выполнение этой
96                                                 операции")
97                                         }
98                                 }       
99                         }
100                 }
101                 show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр
102                                 действия");
103         }       
104 } else {
105         # Запрос методом POST. Вызываем обработчик
106         for my $param ($cgi->param) {
107                 if (exists $actions{$param}) {
108                         if (allow_operation($param,$cgi,$forum)) {
109                                 $actions{$param}->($param,$cgi,$forum);
110                                 exit;
111                         } else {
112                                 show_error($forum,"У Вас нет прав на  выполнение этой
113                                 операции")
114                         }
115
116                 }
117         }
118         print STDERR "Получены параметры ",join(" ",$cgi->param),"\n";
119         show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия");
120 }       
121
122 sub dir2url {
123         my ($cgi,$dir) = @_;
124         my $prefix="";
125         my $pos=rindex $ENV{'PATH_TRANSLATED'},$ENV{'PATH_INFO'};
126         if ($pos <0 && $ENV{'PATH_INFO'}=~m!(/\~\w+)/!) {
127                 $prefix .=$1;
128                 $pos =
129                 rindex($ENV{'PATH_TRANSLATED'},substr($ENV{'PATH_INFO'},length($1)));
130         }
131         if ($pos <0) {
132                 show_error({},"Ошибка конфигурации форума. Не удается определить
133                 алгоритм преобразования директори в URL\n".
134                 "PATH_INFO=$ENV{PATH_INFO}\n".
135                 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
136         }       
137         my $root = substr($ENV{'PATH_TRANSLATED'},0,$pos);
138         if (substr($dir,0,length($root)) ne $root) {
139                 show_error({},"Ошибка конфигурации форума. Не удается преобразовать
140                 имя директории $dir в url\n".
141                 "PATH_INFO=$ENV{PATH_INFO}\n".
142                 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
143         }
144         return $prefix.substr($dir,length($root));
145 }
146 #
147 # Поиск файла .forum вверх по дереву от $ENV{PATH_TRANSLATED}  
148 # Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не
149 # враг.
150 # Возвращает список имя,значение, имя, значение который прививается в
151 # хэш
152
153 sub get_forum_config {
154         my @path=split("/",$1) if $ENV{PATH_TRANSLATED}=~/^(\S+)$/;
155         while (@path>1) {
156                 if (-r (my $config=join("/",@path,".forum")) ) {
157                         open F,"<",$config;
158                         my %config;
159                         while (<F>) {
160                                 s/#.*$//; #Drop comments;
161                                 $config{$1}=$2 if /(\w+)\s*=\s*(\S.*)$/;
162                         }       
163                         close F;
164                         #
165                         # Переменная forumtop - это URL того места, где находится
166                         # файл .forum
167                          
168                         $config{"forumtop"} = dir2url($cgi,join("/",@path));
169                         # Если в конфиге отсутствует переменная templates, но
170                         # рядом с конфигом присутствует директория templates,
171                         # то шаблоны там.
172                         #
173                         if (! exists $config{"templates"} 
174                                 && -d (my $filename = join("/",@path,"templates"))) {
175                                         $config{"templates"} = $filename;
176                         }               
177                         $config{"templatesurl"} = dir2url($cgi,$config{"templates"})
178                                 unless exists $config{"templatesurl"};
179                         # 
180                         # То же самое - параметр userdir и директория users
181                         #
182                         if (! exists $config{"userdir"} 
183                                 && -d (my $filename = join("/",@path,"users"))) {
184                                         $config{"userdir"} = $filename;
185
186
187                         }       
188                         $config{"userurl"} = dir2url($cgi,$config{"userdir"});
189
190                         #
191                         # Если нет ссылки в конфиге на файл паролей или он не 
192                         # существует, выдаем ошибку. С офоромлением, так как шаблоны
193                         #  у нас уже есть
194                         if (!exists $config{"datadir"}) {
195                                 show_error(\%config,"В конфигурации форума не указана
196                                 директория данных "); 
197                                 exit;
198                         }
199                         if (!-d $config{"datadir"}) {
200                                 show_error(\%config,"В конфигурации форума указана несуществующая директория данных "); 
201                                 exit;
202                         }
203                         $config{"authperiod"}="+1M" if (! exists $config{"authperiod"}); 
204                         $config{"renewtime"} = "86000" if (!exists $config{"renewtime"});
205                         $config{"replies_per_page"} = 50 if (!exists $config{"replies_per_page"});
206                         return \%config;
207                 }
208                 pop @path;
209         }
210         #
211         # Выводим ошибку 404 без осмысленного оформления, так как данных форума
212         # мы не нашли
213         print "Status: 404\nContent-Type: text/html; charset=utf-8\n\n",
214         "<HTML><HEAD><TITLE>Форум не обнаружен</TITLE></HEAD><BODY>",
215         "<H!>Форум не найден</H!>",
216         "<p>Хвост URL, указанный при вызове скрипта  показывает не на
217         форум</p>",
218         # To make IE think this page is user friendly
219         "<!--",("X" x 512),"--></body></html>\n"; 
220         exit;
221 }
222 #
223 # Вывод сообщения об ошибке по шаблону форума
224 # Шаблон должен содержать элемент с классом error.
225 #
226 sub show_error {
227         my ($cfg,$msg) = @_;
228         if ( -r $cfg->{"templates"}."/error.html") {
229                 my $tree = HTML::TreeBuilder->new_from_file($cfg->{"templates"}."/error.html");
230                 my $node= $tree->find_by_attribute('class','error');
231                 my $body;
232                 if (!$node) {
233                         $body = $tree->find_by_tagname('body');
234                         $body->push_content($node = new
235                         HTML::Element('div','class'=>'error'));
236                 }
237                 $node->delete_content;
238                 $node->push_content($msg);
239                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
240                 print $tree->as_HTML("<>&");
241         } else {
242                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
243                 print "<html><head><title>Ошибка конфигурации форума</title></head>",
244                 "<body><h1>Ошибка конфигурации форума</h1><p>",
245                 $cgi->escapeHTML($msg),"</p>",
246                 "<p>При обработке этой ошибки не обнаружен шаблон сообщения об ошибке</p></body></html>";  
247         }
248         exit;
249 }       
250
251 sub gettemplate {
252         my ($forum, $template,$url) = @_;
253         my $filename=$forum->{"templates"}."/$template.html";
254         if (! -r $filename) {
255                 show_error($forum,"Нет шаблона $template");
256                 exit;
257         }
258         my $tree = HTML::TreeBuilder->new_from_file($filename);
259         fix_forum_links($forum,$tree,$url);
260         return $tree;
261 }       
262 #
263 # Вывод шаблона формы. В шаблоне должна присутстовать форма с  
264 # именем, совпадающим с именем form. Если в $cgi есть параметры, имена
265 # которых совпадают с именами полей этой формы, их значения
266 # подставляются
267 #
268 sub show_template {
269         my ($form,$cgi,$forum) = @_;
270         my $tree = gettemplate($forum,$form,$ENV{'PATH_INFO'});
271
272         # Находим форму с классом $form
273         my $f = $tree->look_down("_tag","form",
274                 "name",$form);
275         if (! defined $f) {
276                 # Если не нашли - ругаемся
277                 show_error($forum,"Шаблон для операции $form не содержит формы с
278                 именем $form");
279                 exit;
280         }
281         $cgi->delete('password');
282         if (!$cgi->param("returnto")) {
283                 $cgi->param("returnto", $cgi->referer||$cgi->url(-absolute=>1,-path_info=>1));
284
285         }       
286         if (!$cgi->param($form)) {
287                 $cgi->param($form,1);
288         }       
289         # 
290         # Если ранее была выставлена ошибка с помощью set_error, подставляем
291         # сообщение в элемент с классом error
292         #
293         if ($forum->{error_message}) {
294                 my $errormsg = $tree->look_down("class"=>"error");
295                 if ($errormsg) {
296                         $errormsg->delete_content();
297                         $errormsg->push_content($forum->{error_message});
298                 }
299         }       
300         if ($forum->{"authenticated"}) {
301                  
302                 # Подставляем информацию о текущем пользователе если в шаблоне
303                 # это предусмотрено 
304                 substitute_user_info($tree,$forum);
305                 $cgi->param("user",$forum->{"authenticated"}{"user"}) if (!defined $cgi->param("user"))
306         }
307         my %substituted;
308         ELEMENT:
309         for my $element ($f->find_by_tag_name("textarea","input","select")) {
310                 my $name = $element->attr("name");
311                 $substituted{$name} = 1;
312                 #print STDERR "substituting form element name $name tag ",$element->tag,
313             #           "value='",$cgi->param($name),"'\n";  
314                 if (defined  $cgi->param($name)) {
315                         if ($element->tag eq "input") {
316                                 next ELEMENT if grep ($element->attr("type") eq
317                                 $_,"button","submit","reset");  
318                                 if ($element->attr("type") eq "check") {
319                                         if (grep($element->attr("value") eq $_,$cgi->param($name))) {
320                                                 $element->attr("checked","");
321                                         } else {
322                                                 $element->attr("checked",undef);
323                                         }
324                                 
325                                 } elsif ($element->attr("type") eq
326                                 "radio") {
327                                         if ($element->attr("value") eq $cgi->param($name)) {
328                                                 $element->attr("checked","");
329                                         } else {
330                                                 $element->attr("checked",undef);
331                                         }
332                                 } else {        
333                                 $element->attr("value",$cgi->param($name));
334                                 }
335                         } elsif ($f->tag eq "textarea") {
336                                 $f->delete_content;
337                                 $f->push_content($cgi->param("name"));
338                         } elsif ($f->tag eq "select") {
339                                 for my $option ($f->find_by_tag_name("option")) {
340                                         if (grep($option->attr("value") eq $_, $cgi-param("name"))) {
341                                                 $option->attr("selected","");
342                                         } else {        
343                                                 $option->attr("selected",undef);
344                                         }       
345                                 }
346
347                         }
348                 }
349
350         }
351         $f->attr("method","POST");
352         for my $required ($form,"returnto") {
353                 if (!$substituted{$required}) {
354                         my $element = new HTML::Element('input',
355                                 'type' => 'hidden', 'name' => $required,
356                                 'value'=> $cgi->param($required));
357                         $f->push_content($element);
358                 }
359         }       
360                                 
361                 
362         print
363         $cgi->header(-type=>"text/html",-charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
364         $tree->as_HTML("<>&");
365 }
366 #
367 # Поправляет ссылки на служебные файлы и скрипты форума
368 #
369 sub fix_forum_links {
370         my ($forum,$tree,$path_info) = @_;
371         $path_info=$ENV{'PATH_INFO'} if (!defined $path_info);
372         my $script_with_path = $ENV{SCRIPT_NAME}.$path_info;
373         ELEMENT:
374         for my $element ($tree->find_by_tag_name("form","img","link","script","a")) {
375                 my $attr;
376                 if ($element->tag eq "form")  {
377                         $attr = "action";
378                 } elsif ($element->tag eq "a"|| $element->tag eq "link") {
379                         $attr = "href";
380                 } else {
381                         $attr ="src";
382                 }
383                 
384                 # Обрабатываем наши специальные link rel=""
385                 if ($element->tag eq "link") {
386                         if ($element->attr("rel") eq "forum-user-list") {
387                                 $element->attr("href" => $cgi->url(-absolute=>1,
388                                         -path_info=>0,-query_string=>0).$forum->{userurl});
389                                 next ELEMENT;   
390                         } elsif ($element->attr("rel") eq "forum-script")  {
391                                 $element->attr("href" => $script_with_path);
392                                 next ELEMENT;
393                         }       
394                 }
395                 my $link = $element->attr($attr);
396                 # Абсолютная ссылка - оставляем как есть. 
397                 next ELEMENT if (! defined $link || $link=~/^\w+:/); 
398                 # Ссылка от корня сайта. 
399                 if (substr($link,0,1) eq "/") {
400                         # Если она не ведет на наш скрипт, не обрабатываем
401                         next ELEMENT if substr($link,0,length($ENV{SCRIPT_NAME}) ne
402                         $ENV{SCRIPT_NAME}) ;
403                         # Иначе пишем туда слово forum вместо реального имени
404                         # скрипта чтобы потом единообразно обработать
405                         $link =~ s/^[^\?]+/forum/;
406                 }
407                 if (!($link =~ s!^templates/!$forum->{templatesurl}/!) &&
408                     !($link =~ s!^users/!$forum->{usersurl}/!) &&
409                     !($link =~ s!^forum\b!$script_with_path!)) {
410                         $link = $forum->{"forumtop"}."/".$link 
411                 }       
412                 $element->attr($attr,$link);
413         }
414 }               
415 #
416 # Подставляет в заданное поддерево информацию о пользователе
417 #
418
419 sub substitute_user_info {
420
421 my ($tree,$forum) = @_;
422 my %userinfo = %{$forum->{"authenticated"}};
423
424 #
425 # Специально обрабатываем поля user (должна быть ссылка) и avatar  
426 # (должен быть img).
427 my @userlink = $tree->look_down("_tag"=>"a","class"=>"author");
428 if (@userlink) {
429         my $userpage;
430         if ($userinfo{"user"}=~/^http:/) {
431                 $userpage = $userinfo{"user"};
432         } else {
433                 $userpage =
434                 $cgi->url(-absolute=>1).$forum->{"userurl"}."/".$cgi->escape($userinfo{"user"});
435         }       
436         for my $element (@userlink) {
437                 $element->attr(href=>$userpage);
438                 $element->delete_content();
439                 $element->push_content($userinfo{"user"});
440         }
441 }       
442 delete $userinfo{"userpage"};
443 delete $userinfo{"user"};
444 my $avatar = $tree->look_down("_tag"=>"img","class"=>"avatar");
445 if ($avatar) {
446         $avatar->attr(src=>$userinfo{"avatar"});
447 }
448 delete $userinfo{"avatar"};
449
450 while (my ($field,$value)=each %userinfo) {
451         my $element = $tree->look_down("class","a".$field);
452         if ($element) {
453                 $element->delete_content();
454                 # 
455                 # FixME - allow HTML in author attributes
456                 $element->push_content($value);
457         }
458
459 }
460
461 }
462 #
463 # Авторизует зарегистрированного пользователя.
464 # 1. Проверяет куку если есть
465 #
466
467 sub authorize_user      {
468         ($cgi,$forum) = @_;
469         if (my $session=$cgi->cookie("slsession")) {
470         # Пользователь имеет куку
471                 my %sessbase;   
472                 dbmopen %sessbase,datafile($forum,"session"),0644;
473                         if ($sessbase{$session})  {
474                                 my ($user,$expires,$ip)=split(";", $sessbase{$session});
475                                 my $user_cookie = $cgi->cookie("sluser");
476                                 if ($user_cookie ne $user && $user_cookie ne
477                                 "http://".$user) {
478                                         clear_user_cookies($cgi,$forum);
479                                         show_error($forum,"Некорректная пользовательская сессия");
480                                         exit;
481                                 }       
482                                 if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) {
483                                         my %userbase;
484                                         dbmopen %userbase,datafile($forum,"passwd"),0644;
485                                         if ( $userbase{$user}) {
486                                                 print STDERR "getting user info for $user\n";
487                                                 my $userinfo = thaw($userbase{$user});
488                                                 delete $userinfo->{"passwd"};
489                                                 $userinfo->{"user"} = $user;
490                                                 if ($expires-time()< $forum->{"renewtime" }) {
491                                                         delete $sessbase{$session};
492                                                         newsession(\%sessbase,$forum,$user,$ip);
493                                                 }
494                                                 print STDERR "user $user restored session $session\n";
495                                                 $forum->{"authenticated"}=$userinfo;
496                                                 print STDERR "authorize_user: ",$forum->{authenticated}{user},
497                                                 $forum->{authenticated},"\n";
498                                         }       
499                                         dbmclose %userbase; 
500                                 }       
501                         } else {
502                                 clear_user_cookies($cgi,$forum);
503                                 show_error($forum,"Некорректная пользовательская сессия");
504                                 exit;
505                         }
506                 dbmclose %sessbase;
507         }
508 }
509 #
510 # Возвращает путь к файлу в директории 
511 #
512 sub datafile {
513         my ($forum,$filename) = @_;
514         return $forum->{"datadir"}."/".$filename;
515 }       
516
517 #
518 # Создает новую сессию для пользователя и подготавливает куку которую
519 # сохраняет в хэше конфигурации форума
520
521 sub newsession {
522         my ($base,$forum,$user,$bindip) = @_;
523         if (!defined $base) {
524                 $base = {};
525                 dbmopen %$base,datafile($forum,"session"),0644;
526         }       
527         my $sessname;
528         my $t = time();
529         my ($u,$expires,$ip);
530         do {
531                 $sessname = sprintf("%08x",rand(0xffffffff));
532                 if ($base->{"sessname"}) {
533                         ($u,$expires,$ip) = split ";", $base->{$sessname};
534                         delete $base->{$sessname} if $expires < $t;
535                 }
536         } while ($base->{$sessname});
537         my $cookie = $cgi->cookie(-name=>"slsession",
538                 -expires => $forum->{"authperiod"},-value=> $sessname);
539         my $username = $user;
540         $username =~ s/^http:\/\///; #Remoove http:// from OpenID user names 
541         $base->{$sessname}=$username.";".str2time($cookie->expires()).
542                 ($ip?";$ENV{'REMOTE_ADDR'}":"");
543                 
544         $forum->{'cookies'}=[ $cookie,
545         $cgi->cookie(-name=>"sluser",-value=>$user,-expires =>
546         $forum->{authperiod})];                         
547 }
548 #
549 # Выполняет аутентикацию пользователя по логину и паролю и 
550 # создает для него сессию.
551 #
552 sub authenticate {
553         my ($cgi,$forum) = @_;  
554         if ($cgi->param("openidsite")) {
555                 my $openid_url = sprintf($cgi->param("openidsite"),$cgi->param("user"));
556                 openidstart($cgi,$forum,$openid_url);
557         }       
558         my %userbase;
559         dbmopen %userbase,datafile($forum,"passwd"),0644;
560         my $user = $cgi->param("user");
561         my $password = $cgi->param("password");
562         $cgi->delete("password");
563         if (! $userbase{$user}) {
564           set_error($forum,"Неверное имя пользователя или пароль");
565           return undef;
566         }   
567         my $userinfo = thaw($userbase{$user}) ;
568         dbmclose %userbase;
569         #while (my ($key,$val)=each %$userinfo) { print STDERR "$key => '$val'\n";}
570         if (crypt($password,$userinfo->{passwd}) eq $userinfo->{passwd}) {
571                 delete $userinfo->{"passwd"};
572                 $cgi->delete("password");
573                 $userinfo->{"user"} = $user;
574                 newsession(undef,$forum,$user);
575                 $forum->{"authenticated"} = $userinfo;          
576                 print STDERR "User $user authenticated successfully\n";
577                 return 1;
578         } else {
579                 set_error($forum,"Неверное имя пользователя или пароль");
580                 return undef;
581         }       
582 }
583 #
584 # Запоминает сообщение об ошибке для последующего вывода show_template
585 #
586 sub set_error {
587         my  ($forum,$message) = @_;
588         print STDERR "set_error: $message\n";
589         $forum->{error_message} = $message;
590 }       
591 #
592 # Выводит текущий шаблон с сообщением об ошибке
593 #
594 sub form_error {
595         my ($form_name,$cgi,$forum,$msg) = @_;
596         set_error($forum,$msg);
597         show_template($form_name,$cgi,$forum);
598         exit;
599 }       
600 #
601 # Выполняет редирект (возможно, с установкой куков) на страницу,
602 # указанную # третьем параметре функции или в параметре CGI-запроса
603 # returnto
604 # Если и то, и другое не определено, пытается сконструировать URL для
605 # возврата из PATH_INFO.
606 #
607
608 sub forum_redirect {
609         my ($cgi,$forum,$url) = @_;
610         if (!defined $url) {
611                 $url = $cgi->param("returnto");
612                 $url =
613                 $cgi->url(-base=>1).($cgi->path_info()||$forum->{forumtop}) if !$url ;
614         }
615         print $cgi->redirect(-url=>$url,
616                 ($forum->{cookies}?(-cookie=>$forum->{cookies}):()));
617         exit;   
618 }
619 #
620 # Обработка результатов заполнения формы регистрации.
621 #
622 #
623 sub register {
624         my ($formname,$cgi,$forum) = @_; 
625         #
626         # Возможные ошибки: 
627         # 1 Такой юзер уже есть
628         #
629         #  не заполнено поле user 
630         if (!$cgi->param("user")) {
631                 form_error($formname,$cgi,$forum, "Не заполнено имя пользователя");
632         }       
633         #  или поле password 
634         if (!$cgi->param("pass1"))  {
635                 form_error($formname,$cgi,$forum,"Не указан пароль");
636         }       
637         #  Копии пароля не совпали
638         if ($cgi->param("pass2") ne $cgi->param("pass1")) {
639                 form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
640         }               
641         my $user = $cgi->param("user");
642         # Не указаны поля, перечисленные в скрытом поле required 
643         if ($cgi->param("required")) { 
644                 foreach my $field (split(/\s*,\s*/,$cgi->param('required'))) {
645                         if (!$cgi->param($field)) {
646                                 form_error($formname,$cgi,$forum,"Не заполнено обязательное поле $field");
647                         }
648                 }       
649         }
650         my %userbase;
651         dbmopen %userbase,datafile($forum,"passwd"),0644 
652                 or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!");
653         if ($userbase{$cgi->param("user")}) {
654                 dbmclose %userbase;
655                 form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято");
656         }
657         if ($cgi->param("email") && !  Email::Valid->address($cgi->param("email"))) {
658                 form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес");
659         }
660         my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./';
661         my $salt = substr($saltstring,int(rand(64)),1).
662                                 substr($saltstring,int(rand(64)),1);
663         my $password=crypt($cgi->param("pass1"),$salt);                 
664         my $userinfo = {passwd=>$password};
665         # Удаляем лишние поля
666         $cgi->delete("required");
667         $cgi->delete("register");
668         $cgi->delete("user");
669         $cgi->delete("pass1");
670         $cgi->delete("pass2");
671         foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) {
672                 if (!$cgi->param($field)) {
673                         $cgi->delete($field);
674                 }
675         }       
676         my $returnto = $cgi->param("returnto");
677         $cgi->delete("returnto");
678         # Если есть аватар в файле, то сохраняем этот файл и формируем URL
679         # на него.
680         if ($cgi->param("avatarfile" )) {
681                 my $f = $cgi->upload("avatarfile");
682                 binmode $f,":bytes";
683                 my $out;
684                 my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/;
685                 open $out,">",$forum->{"userdir"}."/".$filename;
686                 binmode $out,":bytes";
687                 my $buffer;
688                 while (my $bytes = read($f,$buffer,4096)) {
689                         print $out $buffer;
690                 }       
691                 close $f;
692                 close $out;
693                 $userinfo->{'avatar'}= $forum->{"userurl"}."/".$filename;
694                 $cgi->delete("avatar");
695                 $cgi->delete("avatarfile");
696         }
697         
698         foreach my $param       ($cgi->param) {
699                 $userinfo->{$param} = $cgi->param($param);
700         }
701         $userinfo->{registered} = time;
702         if (exists $forum->{default_status}) {
703                 $userinfo->{status} = $forum->{default_status};
704         }
705         print STDERR "stilllife forum: registering user $user\n";
706         $userbase{$user} = freeze($userinfo);
707         dbmclose %userbase;
708         newsession(undef,$forum,$user);
709         forum_redirect($cgi,$forum,$returnto) 
710 }       
711 #
712 # Обработчик формы логина. Сводится к вызову функции authenticate,
713 # поскольку мы поддерживаем логин одновременный с отправкой реплики. 
714 #
715 sub login {
716         my ($form,$cgi,$forum)=@_;
717         if (authenticate($cgi,$forum)) {
718                 forum_redirect($cgi,$forum);
719         } else {
720                 show_template(@_);
721         }       
722 }       
723 sub clear_user_cookies {
724         my ($cgi,$forum) = @_;
725         $forum->{cookies}=[ $cgi->cookie(-name=>"sluser", -value=>"0",
726         -expires=>"-1m"),$cgi->cookie(-name=>"slsession", -value=>"0",
727                         -expires => "-1m")];
728 }                       
729 #
730 # Обработчик формы logout. В отличие от большинства обработчиков форм,
731 # поддерживает обработку методом GET
732 #
733 sub logout {
734         my ($form,$cgi,$forum) = @_;
735         clear_user_cookies($cgi,$forum);
736         if (defined (my $session_id = $cgi->cookie("slsession"))) {
737                 my %sessiondb;
738                 dbmopen %sessiondb,datafile($forum,"session"),0644;
739                 delete $sessiondb{$session_id};
740                 dbmclose %sessiondb;
741         }
742         forum_redirect($cgi,$forum);
743 }       
744 sub allow_operation {
745         my ($operation,$cgi,$forum) = @_;
746         return 1 if (!exists($permissions{$operation})); 
747         if (!$forum->{authenticated}) {
748                 return 1 if ($permissions{$operation} eq "login");
749                 return 0;
750         }       
751         my $user = $forum->{authenticated}{user} ;
752         my $accesslevel=getrights($cgi,$forum);
753         # Если permissions{$operation} равны author, нам нужно извлечь
754         # текст из соответствующего файла и положить его в
755         # cgi->param("text"); Заодно определим и автора
756         my ($itemauthor,$itemtext)=get_message_by_id($cgi->param("id")) if
757                 $permissions{$operation} eq "author";
758         
759         return 1 if ($accesslevel eq "admin");
760         return 0 if ($permissions{$operation} eq "admin");      
761         return 1 if ($accesslevel eq "moderator");
762         return 0 if $accesslevel eq "banned";   
763         return 0 if $permissions{$operation} eq "author" && $user ne $itemauthor;
764         return 1;
765 }
766
767 sub reply {
768         my ($form,$cgi,$forum) = @_;
769         if (! exists $forum->{authenticated} ) {
770                 form_error($form,$cgi,$forum,"Вы не зарегистрировались") if (!authenticate($cgi,$forum)); 
771         }
772         #
773         # Находим файл дискуссии, в который надо поместить реплику
774         #
775         my ($tree,$lockfd)=gettree($ENV{'PATH_TRANSLATED'}); 
776         my $messagetpl = $tree->look_down(class=>"message");
777         if (!$messagetpl) {
778                 show_error($forum,"Шаблон темы не содержит элемента с классом
779                 message");
780                 exit;
781         }       
782         
783         #       
784         # Генерируем идентификатор записи.
785         #
786         my $id = get_uid($forum);
787
788
789         #
790         # Сохраняем приаттаченные картинки, если есть.
791         #
792         my $dir = $1 if $ENV{PATH_TRANSLATED}=~/^(.*)$/;
793         $dir=~ s/[^\/]+$// if (-f $dir);
794         my %attached;
795         for (my $i=1;$cgi->param("image$i"); $i++) {
796                 my $userpath=$cgi->param("image$i");
797                 my $filename=lc($1) if $userpath =~ /([^\/\\]+)$/;
798                 $attached{$filename} = $id."_".$filename;
799                 my $in = $cgi->upload("image$i");
800                 if (!$in) {
801                         show_error($forum,"Ошибка при загрузке картинки $filename");
802                         exit;
803                 }       
804                 my $out;
805                 open $out,">$dir/$attached{$filename}";
806                 binmode $out,":bytes";
807                 local $/=undef;
808                 my $data = <$in>;
809                 print $out $data;
810                 close $in;
811                 close $out;
812         }
813         #
814         # Преобразуем текст записи в html и чистим его
815         #
816         my $txtree = input2tree($cgi,$forum,"text");
817         #
818         # Находим в тексте URL на приаттаченные картинки и меняем на те
819         # имена, под которыми мы их сохранили.
820         #
821         for my $image ($txtree->find_by_tag_name("img")) {
822                 my $file=lc($image->attr("src"));
823                 if ( exists $attached{$file}) {
824                         $image->attr("src" => $attached{$file});
825                         my ($width,$height) = imgsize($dir ."/".$attached{$file});              
826                         $image->attr("width" =>$width);
827                         $image->attr("height" => $height);
828                 }       
829         }       
830         #
831         # Копируем элемент с классом message
832         #
833         my $newmsg = $messagetpl->clone;
834         my $parent = $messagetpl->parent;
835         $parent->push_content($newmsg);
836         #
837         # Подставляем данные сообщения 
838         #
839         $newmsg->attr("id"=>$id);
840         if ((my $subj=$newmsg->look_down("class"=>"subject")) &&
841                 $cgi->param("subject")) {
842                 $subj->delete_content;
843                 $subj->push_content($cgi->param("subject"));
844         }
845         my $textnode=$newmsg->look_down("class"=>"mtext");
846         if (!$textnode) {
847                 show_error($forum,"В шаблоне реплики нет места для текста"); 
848         }       
849         $textnode->delete_content();
850         $textnode->push_content($txtree);
851         if ($forum->{authenticated}{signature}) {
852                 $textnode->push_content(new HTML::Element("br"),"--",
853                 new HTML::Element("br"),str2tree($forum->{authenticated}{signature}));
854         }
855         substitute_user_info($newmsg,$forum);
856         #
857         # Подставляем данные в форму msginfo
858         #
859         my $editform=$newmsg->look_down(_tag=>"form","class"=>"msginfo");
860         if ($editform) {
861                 my $idfield = $editform->look_down(_tag=>"input","name"=>"id");
862                 if (!$idfield) {
863                         show_error($forum,"В форме управления сообщением нет поля
864                         id");
865                 }
866                 $idfield->attr("value" => $id);
867                 my $authorfield = $editform->look_down(_tag=>"input","name"=>"author");
868                 if (!$authorfield) {
869                         show_error($forum,"В форме управления сообщением нет поля author");
870                 }
871                 $authorfield->attr("value"=>$forum->{authenticated}{user});
872         }
873         # Подставляем mdate
874         my $date = $newmsg->look_down("class"=>"mdate");
875         if ($date) {
876                 $date->delete_content;
877                 $date->push_content(strftime("%d.%m.%Y %H:%M",localtime()));
878
879         }       
880         # Подставляем mreply
881         my $reply_link = $newmsg->look_down(_tag=>"a","class"=>"mreply");
882         $reply_link->attr("href"=> $cgi->url(-absolute=>1,-path_info=>1).
883                 "?reply=1&id=$id") if ($reply_link);
884         # Подставляем manchor
885         my $anchor = $newmsg->look_down(_tag=>"a","class"=>"manchor");
886         if (! $anchor) {
887                 show_error($forum,"В шаблоне сообщения отсутствует якорь для
888                 ссылок на него");
889                 exit;
890         }       
891         $anchor->attr(href=>undef);
892         $anchor->attr(name=>"#$id");
893         # подставляем mlink
894         my $link = $newmsg->look_down(_tag=>"a","class"=>"mlink");
895         $link->attr(href=>$cgi->path_info."#id") if $link; 
896         # подставляем mparent
897         my $parent_id=$cgi->param("id");
898         my $parent_link=$newmsg->look_down(_tag => "a",class=>"mparent");
899         if ($parent_link) {
900                 if ($parent_id) {
901                         $parent_link->attr("href"=>$cgi->path_info."#$parent_id");
902                 } else {
903                         # Если parent_id отсутствует, т.е. это начало нового треда
904                         # просто делаем ссылку невидимой.
905                         $parent_link->delete_content();
906                 }
907         }       
908
909         #
910         # Проверяем видимость списка сообщений 
911         #
912         my $msglist = $tree->look_down("class"=>"messagelist");
913         if ($msglist) {
914                 my $style = $msglist->attr("style");
915                 $msglist->attr("style",$style) if $style && $style =~ s/display: none;//;
916         }       
917         #
918         # Делаем Уфф и сохраняем то, что получилось 
919         #
920         savetree($ENV{PATH_TRANSLATED},$tree,$lockfd);
921         forum_redirect($cgi,$forum);
922          
923 }       
924 #
925 # читает файлы прав доступа в дереве форума, и возвращает
926 # статус текущего пользователя (undef - аноним, banned, normal,
927 # moderator или admin
928
929 sub getrights {
930         my ($cgi,$forum) = @_;
931         if (!$forum->{authenticated}) {
932                 return undef;
933         }       
934         my $user = $forum->{authenticated}{user};
935         my $dir = $ENV{'PATH_TRANSLATED'};
936         $dir =~s/\/[^\/]+$// if (!-d $dir);
937         my $f;
938         my $user_status = "normal";
939         LEVEL:
940         while (length($dir)) {  
941                 if (-f "$dir/perms.txt") {
942                         open $f,"<","$dir/perms.txt";
943                         my $status = undef;
944                         while (<$f>) {
945                                 if (/^\[\s*(admins|moderators|banned)\s*\]/) {
946                                         $status = $1;
947                                 } else {
948                                         chomp;
949                                         if  ($user eq $_ && defined $status) {
950                                                 if ($status eq "banned") {
951                                                         return $status;
952                                                 } 
953                                                 if ($status eq "admins" ) {
954                                                         return "admin";
955                                                 }
956                                                 $user_status = "moderator";
957                                         }
958                                 }       
959                         }
960                         close $f;
961                         last LEVEL if  -f "$dir/.forum";
962                         # Strip last path component.
963                         $dir =~s/\/[^\/]+$// 
964                 }       
965         }               
966         return $user_status;
967
968 }               
969
970
971 #
972 # Залочить файл и получить его распрасенное представление.
973 # Возвращает пару ($tree,$lockfd)
974
975 sub gettree {
976         my $filename = shift;
977         my $f;
978         open $f,"<",$filename or return undef;
979         flock $f, LOCK_EX;
980         my $tree = HTML::TreeBuilder->new_from_file($f);
981         return ($tree,$f);
982 }       
983 #
984 # Сохранить дерево и закрыть lockfd.
985 #
986 #
987
988 sub savetree {
989         my ($filename,$tree,$lockfd) = @_;
990         my $f;
991         $filename = $1 if $filename =~ /^(.*)$/;
992         open $f,">",$filename . ".new" or return undef;
993         print $f $tree->as_HTML("<>&");
994         close $f;
995         # FIXME - только для POSIX.
996         unlink $filename;
997         rename $filename.".new",$filename;
998         close $lockfd if defined($lockfd);
999 }       
1000
1001
1002
1003 #
1004 # Получает уникальный числовой идентификатор.
1005
1006 sub get_uid {
1007         my $forum = shift;
1008         my $f;
1009         open $f,"+<",datafile($forum,"sequence") or 
1010         flock $f,LOCK_EX;
1011         my $id=<$f> || "0";
1012         $id++;
1013         seek $f,0,0;
1014         printf $f "%8s\n",$id;
1015         close $f;
1016         $id=~/(\d+)/;
1017         return sprintf ("%08s",$1);
1018 }
1019 # --------------------------------------------------------------------
1020 #  OpenID registration
1021 # -------------------------------------------------------------------
1022 sub create_openid_consumer {
1023         my ($cgi,$forum) = @_;
1024         return Net::OpenID::Consumer ->new(
1025                 ua => LWP::UserAgent->new(),
1026                 args => $cgi,
1027                 consumer_secret=>"X9RWPo0rBE7yLja6VB3d",
1028                 required_root => $cgi->url(-base=>1));
1029 }               
1030
1031 # openidstart - вызывается когда обнаружено что текущее имя
1032 # пользователя, пытающегося аутентифицироваться, содержит http://
1033 #  
1034 #
1035
1036 sub openidstart {
1037         my ($cgi,$forum,$openidurl) = @_;
1038         #
1039         # Fix duplicated http:// which can be produced by our sprintf based
1040         # login system
1041         #
1042         $openidurl=~s!^http://http://!http://!;
1043         my $csr = create_openid_consumer($cgi,$forum);
1044         my $claimed_identity=$csr->claimed_identity($openidurl);
1045         if (!defined $claimed_identity) {
1046                 show_error($forum,"Указанная URL $openidurl не является OpenId");            
1047                 exit;
1048         }
1049         $cgi->param("openidvfy",1);
1050         $cgi->delete("user");
1051         $cgi->delete("openidsite");
1052         $cgi->delete("password");
1053         my $check_url = $claimed_identity->check_url(
1054                 return_to=> $cgi->url(-full=>1,-path_info=>1,-query=>1),
1055                 trust_root=> $cgi->url(-base=>1));
1056         print $cgi->redirect(-location=>$check_url);
1057         exit;
1058 }       
1059 #
1060 # Вызывается при редиректе от openid producer-а. Проверяет, что
1061 # удаленный сервер подтвердил openid и вызывает операцию для которой
1062 # (либо возврат на исходную страницу при операции login, либо постинг
1063 # реплики) 
1064 #
1065 sub openid_verify {
1066         my ($cgi,$forum) = @_;
1067         my $csr  = create_openid_consumer($cgi,$forum);
1068         if (my $setup_url = $csr->user_setup_url) {
1069                 print $cgi->redirect(-location=>$setup_url);
1070                 exit;
1071         } elsif ($csr->user_cancel) {
1072                 show_error($forum,"Ваш openid-сервер отказался подтвержать вашу
1073                 идентичность");
1074                 exit;
1075         } elsif (my $vident = $csr->verified_identity) {
1076                 #Успешная аутентификация.         
1077                 #Создаем сессию
1078                 my $user = $vident->url; 
1079                 # Remove trailing slash from URL if any
1080                 $user=~s/\/$//;
1081                 my %userbase;
1082                 dbmopen %userbase,datafile($forum,"passwd"),0664;
1083                 my $username = $user; 
1084                 $username =~ s/^http:\/\///;
1085                 if (!$userbase{$username}) {
1086                         $userbase{$username} = freeze($forum->{authenticated}={"openiduser"=>1});
1087                 } else {
1088                         $forum->{authenticated} = thaw ($userbase{$username});
1089                 }
1090                 dbmclose %userbase;
1091                 $forum->{"authenticated"}{"user"} = $username;
1092                 newsession(undef,$forum,$user);
1093                 # Если указан параметр reply, вызываем обработку реплики
1094                 if ($cgi->param("reply")) {     
1095                         reply("reply",$cgi,$forum);
1096                         exit;
1097                 }       
1098                 #Иначе, возвращаемся на исходную страницу
1099                 forum_redirect($cgi,$forum,undef);
1100         }       else {
1101                 show_error($forum,"Ошибка OpenId аутентификации");
1102                 exit;
1103         }       
1104 }
1105 #-----------------------------------------------------------------
1106 # Обработка форматированных текстовых полей
1107 #-----------------------------------------------------------------
1108
1109 sub input2tree {
1110         my ($cgi,$forum,$field_name) = @_;
1111         my $format = $cgi->param($field_name."_format");
1112         my $text = $cgi->param($field_name);
1113         if ($format eq "bbcode") {
1114                 my $parser = HTML::BBReverse->new(); 
1115                 $text="<div class=\"bbcode\">".$parser->parse($text)."</div>";
1116         } elsif ($format eq "text") {
1117                 $text=~s/\r?\n\r?\n/<\/p><p class=\"text\">/;
1118                 $text=~s/\r?\n/<br>/;
1119                 $text = "<div><p class=\"text\">".$text."</p></div>";
1120         } 
1121         my $txtree = str2tree($text);
1122         for my $badtag
1123         ("script","style","head","html","object","embed","iframe","frameset","frame",
1124         ($forum->{forbid_tags}?split(/\s*,\s*/,$forum->{forbid_tags}):())) {
1125                 for my $element ($txtree->find_by_tag_name($badtag)) {
1126                         $element->delete() if defined $element;
1127                 }       
1128         }       
1129         # Проверяем на наличие URL-ок не оформленных ссылками.
1130         return $txtree;
1131 }       
1132
1133
1134
1135 sub str2tree {
1136         my ($data)=@_;
1137         my $tree = HTML::TreeBuilder->new();
1138         # Set parser options here
1139         $tree->parse("<html><body><div>$data</div></body></html>");
1140         $tree->eof;
1141         my $element=$tree->find("body");
1142         while (($element =($element->content_list)[0])->tag ne "div") {
1143         }
1144         $element->detach;
1145         $tree->destroy;
1146         return $element;
1147 }       
1148
1149 sub tree2str {
1150         my ($tree)=@_;
1151         return $tree->as_HTML("<>&");
1152 }