3 # Stil Life forum. Copyright (c) by Victor B. Wagner, 2008
4 # This program distributed under GNU Affero General Public License v3 or
6 # http://www.gnu.org/licenses/agpl.html
8 # Вкратце: Если вы используете этот скрипт на своем сайте, Вы обязаны
9 # сделать доступным его исходный текст. В частности, если Вы внесли
10 # какие-либо изменения, вы должны эти изменения опубликовать.
12 # Home site of this program http://vitus.wagner.pp.ru/stilllife
16 use Fcntl qw(:DEFAULT :flock);
18 use HTML::TreeBuilder;
19 use Storable qw(freeze thaw);
26 use Net::OpenID::Consumer;
28 # Набор поддерживаемых действий. Хэш вида
29 # "имя поля в запросе" => "функция обработчик"
33 edit => \&edit_comment,
34 delete => \&delete_comment,
35 move => \&move_comment,
36 newtopic=> \&new_topic,
37 newforum=> \&new_forum,
41 setrights=>\&set_rights,
42 openidlogin=>\&openid_login,
43 openidvfy =>\&openid_verify
46 # Уровень прав, которые необходимо иметь пользователю для совершения
47 # определенного действия
48 # иерархия вида undef < banned < normal < author < moderator <admin
49 # Если операция не упомянута в данном массив, то значит можно всем, в
50 # том числе и анониму.
51 # Слово login означает, что вообще-то это normal, но пользователь может
52 # логиниться непосредственно в процессе выполнения операции.
59 newforum => "moderator",
63 our $path_translated; # Untainted value of PATH_TRANSLATED env var
65 print STDERR "--------------------\n";
66 my $forum=get_forum_config();
68 authorize_user($cgi,$forum);
69 if ($cgi->request_method ne "POST") {
70 # Запрос к скрипту методом GET. Надо показать форму, если только это не
71 # редирект от OpenId-сервера
72 if ($cgi->param('openidvfy')) {
73 openid_verify($cgi,$forum);
74 } elsif ($cgi->param("logout")) {
75 logout('logout',$cgi,$forum);
76 } elsif ($cgi->param("profile")) {
77 show_profile("profile",$cgi,$forum);
79 for my $param ($cgi->param) {
80 # Среди параметров, указанных в URL ищем тот, который задает
82 if (exists $actions{$param}) {
83 # Мы, конечно уже проверили, что в названии параметра
84 # нехороших символов нет, но чтобы perl в taint mode не
86 if (allow_operation($param,$cgi,$forum)) {
87 print STDERR "Allow_operation completed\n";
88 show_template($1,$cgi,$forum) if $param=~/^(\w+)$/;
91 if (!$forum->{"authenticated"}) {
92 $cgi->param("returnto",$cgi->url(-full=>1));
93 show_template("login",$cgi,$forum);
97 show_error($forum,"У Вас нет прав на выполнение этой
103 if (index($path_translated,$forum->{userdir})==0) {
104 show_user_page($cgi,$forum);
106 show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр
110 # Запрос методом POST. Вызываем обработчик
111 for my $param ($cgi->param) {
112 if (exists $actions{$param}) {
113 if (allow_operation($param,$cgi,$forum)) {
114 $actions{$param}->($param,$cgi,$forum);
117 show_error($forum,"У Вас нет прав на выполнение этой
123 print STDERR "Получены параметры ",join(" ",$cgi->param),"\n";
124 show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия");
127 #--------------------------------------------------------------
128 #-------- Чтение конфигурационного файла и связанные с этим действия
129 #------------------------------------------------------------------
132 # Преобразование пути в файловой системе сервера в путь в URL
137 my $pos=rindex $ENV{'PATH_TRANSLATED'},$ENV{'PATH_INFO'};
138 if ($pos <0 && $ENV{'PATH_INFO'}=~m!(/\~\w+)/!) {
141 rindex($ENV{'PATH_TRANSLATED'},substr($ENV{'PATH_INFO'},length($1)));
144 show_error({},"Ошибка конфигурации форума. Не удается определить
145 алгоритм преобразования директори в URL\n".
146 "PATH_INFO=$ENV{PATH_INFO}\n".
147 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
149 my $root = substr($ENV{'PATH_TRANSLATED'},0,$pos);
150 if (substr($dir,0,length($root)) ne $root) {
151 show_error({},"Ошибка конфигурации форума. Не удается преобразовать
152 имя директории $dir в url\n".
153 "PATH_INFO=$ENV{PATH_INFO}\n".
154 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
156 return $prefix.substr($dir,length($root));
159 # Поиск файла .forum вверх по дереву от $path_translated
160 # Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не
162 # Возвращает список имя,значение, имя, значение который прививается в
165 sub get_forum_config {
166 $path_translated = $1 if $ENV{PATH_TRANSLATED}=~/^(.+)$/;
167 $path_translated=~s/\/+$//;
168 my @path=split("/",$path_translated);
170 print STDERR "Searching for config in ",join("/",@path),"\n";
171 if (-r (my $config=join("/",@path,".forum")) ) {
175 s/#.*$//; #Drop comments;
176 $config{$1}=$2 if /(\w+)\s*=\s*(\S.*)$/;
180 # Переменная forumtop - это URL того места, где находится
183 $config{"forumtop"} = dir2url($cgi,join("/",@path));
184 $config{"forumroot"} = join("/",@path);
185 # Если в конфиге отсутствует переменная templates, но
186 # рядом с конфигом присутствует директория templates,
189 if (! exists $config{"templates"}
190 && -d (my $filename = join("/",@path,"templates"))) {
191 $config{"templates"} = $filename;
193 $config{"templatesurl"} = dir2url($cgi,$config{"templates"})
194 unless exists $config{"templatesurl"};
196 # То же самое - параметр userdir и директория users
198 if (! exists $config{"userdir"}
199 && -d (my $filename = join("/",@path,"users"))) {
200 $config{"userdir"} = $filename;
204 $config{"userurl"} = dir2url($cgi,$config{"userdir"});
206 # Если нет ссылки в конфиге на файл паролей или он не
207 # существует, выдаем ошибку. С офоромлением, так как шаблоны
209 if (!exists $config{"datadir"}) {
210 show_error(\%config,"В конфигурации форума не указана
211 директория данных ");
214 if (!-d $config{"datadir"}) {
215 show_error(\%config,"В конфигурации форума указана несуществующая директория данных ");
219 # Некоторые умолчания
221 $config{"authperiod"}="+1M" if (! exists $config{"authperiod"});
222 $config{"renewtime"} = "86000" if (!exists $config{"renewtime"});
223 $config{"replies_per_page"} = 50 if (!exists $config{"replies_per_page"});
224 $config{"indexfile"} = "index.html" if (!exists $config{"indexfile"});
230 # Выводим ошибку 404 без осмысленного оформления, так как данных форума
232 print "Status: 404\nContent-Type: text/html; charset=utf-8\n\n",
233 "<HTML><HEAD><TITLE>Форум не обнаружен</TITLE></HEAD><BODY>",
234 "<H!>Форум не найден</H!>",
235 "<p>Хвост URL, указанный при вызове скрипта показывает не на
237 # To make IE think this page is user friendly
238 "<!--",("X" x 512),"--></body></html>\n";
242 # Вывод сообщения об ошибке по шаблону форума
243 # Шаблон должен содержать элемент с классом error.
247 if ( -r $cfg->{"templates"}."/error.html") {
248 my $tree = treefromfile($cfg->{"templates"}."/error.html");
249 my $node= $tree->find_by_attribute('class','error');
252 $body = $tree->find_by_tagname('body');
253 $body->push_content($node = new
254 HTML::Element('div','class'=>'error'));
256 $node->delete_content;
257 $node->push_content($msg);
258 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
259 print output_html($tree);
261 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
262 print "<html><head><title>Ошибка конфигурации форума</title></head>",
263 "<body><h1>Ошибка конфигурации форума</h1><p>",
264 $cgi->escapeHTML($msg),"</p>",
265 "<p>При обработке этой ошибки не обнаружен шаблон сообщения об ошибке</p></body></html>";
271 # Вывод шаблона формы. В шаблоне должна присутстовать форма с
272 # именем, совпадающим с именем form. Если в $cgi есть параметры, имена
273 # которых совпадают с именами полей этой формы, их значения
277 my $tree = prepare_template(@_);
278 send_to_user($tree,@_);
282 my ($tree,$form,$cgi,$forum) = @_;
284 $cgi->header(-type=>"text/html",-charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
287 sub prepare_template {
288 my ($form,$cgi,$forum) = @_;
289 my $tree = gettemplate($forum,$form,$ENV{'PATH_INFO'});
291 # Находим форму с классом $form
292 my $f = $tree->look_down("_tag","form",
295 # Если не нашли - ругаемся
296 show_error($forum,"Шаблон для операции $form не содержит формы с
300 $cgi->delete('password');
301 if (!$cgi->param("returnto")) {
302 $cgi->param("returnto", $cgi->referer||$cgi->url(-absolute=>1,-path_info=>1));
305 if (!$cgi->param($form)) {
306 $cgi->param($form,1);
309 # Если ранее была выставлена ошибка с помощью set_error, подставляем
310 # сообщение в элемент с классом error
312 if ($forum->{error_message}) {
313 my $errormsg = $tree->look_down("class"=>"error");
315 $errormsg->delete_content();
316 $errormsg->push_content($forum->{error_message});
319 if ($forum->{"authenticated"}) {
321 # Подставляем информацию о текущем пользователе если в шаблоне
323 substitute_user_info($tree,$forum);
324 $cgi->param("user",$forum->{"authenticated"}{"user"}) if (!defined $cgi->param("user"))
328 for my $element ($f->find_by_tag_name("textarea","input","select")) {
329 my $name = $element->attr("name");
330 #print STDERR "Found element <".$element->tag()." name=\"$name\">\n" ;
331 #print STDERR "Corresponding \$cgi->param($name)=\"",$cgi->param($name),"\"\n";
332 $substituted{$name} = 1;
333 if (defined $cgi->param($name)) {
334 if ($element->tag eq "input") {
335 my $type=$element->attr('type') || "text";
336 next ELEMENT if grep($type eq $_,
337 "button","submit","reset");
338 if ($type eq "check") {
339 if (grep($element->attr("value") eq $_,$cgi->param($name))) {
340 $element->attr("checked","");
342 $element->attr("checked",undef);
347 if ($element->attr("value") eq $cgi->param($name)) {
348 $element->attr("checked","");
350 $element->attr("checked",undef);
353 $element->attr("value",$cgi->param($name));
355 } elsif ($element->tag eq "textarea") {
356 $element->delete_content;
357 $element->push_content($cgi->param($name));
358 } elsif ($element->tag eq "select") {
359 for my $option ($element->find_by_tag_name("option")) {
360 my $value = $option->attr("value") ||
362 if (grep($value eq $_, $cgi->param($name))) {
363 $option->attr("selected","");
365 $option->attr("selected",undef);
373 $f->attr("method","POST");
374 for my $required ($form,"returnto") {
375 if (!$substituted{$required}) {
376 my $element = new HTML::Element('input',
377 'type' => 'hidden', 'name' => $required,
378 'value'=> $cgi->param($required));
379 $f->push_content($element);
385 # Поправляет ссылки на служебные файлы и скрипты форума
387 sub fix_forum_links {
388 my ($forum,$tree,$path_info) = @_;
389 if (!defined $path_info) {
390 $path_info = $ENV{PATH_INFO};
391 $path_info =~ s/\/+/\//g;
393 my $script_with_path = $ENV{SCRIPT_NAME}.$path_info;
395 for my $element ($tree->find_by_tag_name("form","img","link","script","a")) {
397 if ($element->tag eq "form") {
399 } elsif ($element->tag eq "a"|| $element->tag eq "link") {
405 # Обрабатываем наши специальные link rel=""
406 my $userlist = $cgi->url(-absolute=>1,
407 -path_info=>0,-query_string=>0).$forum->{userurl};
408 if ($element->tag eq "link") {
409 if ($element->attr("rel") eq "forum-user-list") {
410 $element->attr("href" => $userlist);
412 } elsif ($element->attr("rel") eq "forum-script") {
413 $element->attr("href" => $script_with_path);
417 my $link = $element->attr($attr);
418 # Абсолютная ссылка - оставляем как есть.
419 next ELEMENT if (! defined $link || $link=~/^\w+:/ || $link
420 eq"."||$link eq "..");
421 # Ссылка от корня сайта.
422 if (substr($link,0,1) eq "/") {
423 # Если там два слэша, заменяем их на forumtop
424 if (substr($link,0,2) eq '//') {
425 $element->attr($attr, $forum->{forumtop}.substr($link,1));
428 # Если она не ведет на наш скрипт, не обрабатываем
429 next ELEMENT if substr($link,0,length($ENV{SCRIPT_NAME}) ne
431 # Иначе пишем туда слово forum вместо реального имени
432 # скрипта чтобы потом единообразно обработать
433 $link =~ s/^[^\?]+/forum/;
435 if (!($link =~ s!^templates/!$forum->{templatesurl}/!) &&
436 !($link =~ s!^users/!$userlist/!) &&
437 !($link =~ s!^forum\b!$script_with_path!)) {
438 $link = $forum->{"forumtop"}."/".$link
440 $element->attr($attr,$link);
444 # Подставляет в заданное поддерево информацию о пользователе
447 sub substitute_user_info {
449 my ($tree,$forum,$user) = @_;
454 # Если не сказано, какой юзер, то текущий.
455 %userinfo = %{$forum->{"authenticated"}}
459 # Специально обрабатываем поля user (должна быть ссылка) и avatar
462 if ($userinfo{"openiduser"}) {
463 $userpage = "http://".$userinfo{"user"};
466 $cgi->url(-absolute=>1).$forum->{"userurl"}."/".$cgi->escape($userinfo{"user"});
468 substinfo($tree,["_tag"=>"a","class"=>"author"],
469 href=>$userpage,_content=>$userinfo{"user"});
470 delete $userinfo{"user"};
471 if (ref $userinfo{"avatar"} eq "HASH") {
472 substinfo($tree,["_tag"=>"img","class"=>"avatar"],
473 %{$userinfo{'avatar'}});
474 } elsif ($userinfo{'avatar'}) {
475 substinfo($tree,["_tag"=>"img","class"=>"avatar"],
476 src=>$userinfo{"avatar"});
478 substinfo($tree,["_tag"=>"img","class"=>"avatar"],
479 src=>$forum->{templatesurl}."/1x1.gif",
482 delete $userinfo{"avatar"};
484 for my $element ( $tree->look_down("class",qr/^ap-/)) {
485 my $field=$1 if $element->attr("class")=~/^ap-(.*)$/;
486 $element->delete_content();
488 $userinfo{$field} = 0 if (!exists $userinfo{$field} && grep ($field eq
489 $_,"forums","messages","topics"));
490 if (exists $userinfo{$field}) {
493 if ($field eq "registered" || substr($field,0,5) eq "last_") {
494 $data = strftime("%d.%m.%Y %H:%M",localtime($userinfo{$field}))
495 } elsif ($field=~/^<\w+/) {
496 $data = str2tree($userinfo{$field});
498 $data = $userinfo{$field}
500 $element->push_content($data);
504 $element->attr(href=>"mailto:$userinfo{$field}")
505 if ($element->tag eq "a" && $field eq "email");
512 # Авторизует зарегистрированного пользователя.
513 # 1. Проверяет куку если есть
518 if (my $session=$cgi->cookie("slsession")) {
519 # Пользователь имеет куку
521 dbmopen %sessbase,datafile($forum,"session"),0644;
522 if ($sessbase{$session}) {
523 my ($user,$expires,$ip)=split(";", $sessbase{$session});
524 my $user_cookie = $cgi->cookie("sluser");
525 if ($user_cookie ne $user && $user_cookie ne
527 clear_user_cookies($cgi,$forum);
528 show_error($forum,"Некорректная пользовательская сессия");
531 if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) {
533 dbmopen %userbase,datafile($forum,"passwd"),0644;
534 if ( $userbase{$user}) {
535 my $userinfo = thaw($userbase{$user});
536 delete $userinfo->{"passwd"};
537 $userinfo->{"user"} = $user;
538 if ($expires-time()< $forum->{"renewtime" }) {
539 delete $sessbase{$session};
540 newsession(\%sessbase,$forum,$user,$ip);
542 print STDERR "user $user restored session $session\n";
543 $forum->{"authenticated"}=$userinfo;
544 print STDERR "authorize_user: ",$forum->{authenticated}{user},
545 $forum->{authenticated},"\n";
550 clear_user_cookies($cgi,$forum);
551 show_error($forum,"Некорректная пользовательская сессия");
558 # Возвращает путь к файлу в директории
561 my ($forum,$filename) = @_;
562 return $forum->{"datadir"}."/".$filename;
566 # Создает новую сессию для пользователя и подготавливает куку которую
567 # сохраняет в хэше конфигурации форума
570 my ($base,$forum,$user,$bindip) = @_;
571 if (!defined $base) {
573 dbmopen %$base,datafile($forum,"session"),0644;
577 my ($u,$expires,$ip);
579 $sessname = sprintf("%08x",rand(0xffffffff));
580 if ($base->{"sessname"}) {
581 ($u,$expires,$ip) = split ";", $base->{$sessname};
582 delete $base->{$sessname} if $expires < $t;
584 } while ($base->{$sessname});
585 my $cookie = $cgi->cookie(-name=>"slsession",
586 -expires => $forum->{"authperiod"},-value=> $sessname);
587 my $username = $user;
588 $username =~ s/^http:\/\///; #Remoove http:// from OpenID user names
589 $base->{$sessname}=$username.";".str2time($cookie->expires()).
590 ($ip?";$ENV{'REMOTE_ADDR'}":"");
592 $forum->{'cookies'}=[ $cookie,
593 $cgi->cookie(-name=>"sluser",-value=>$user,-expires =>
594 $forum->{authperiod})];
597 # Выполняет аутентикацию пользователя по логину и паролю и
598 # создает для него сессию.
601 my ($cgi,$forum) = @_;
602 if ($cgi->param("openidsite")) {
603 my $openid_url = sprintf($cgi->param("openidsite"),$cgi->param("user"));
604 openidstart($cgi,$forum,$openid_url);
607 dbmopen %userbase,datafile($forum,"passwd"),0644;
608 my $user = $cgi->param("user");
609 my $password = $cgi->param("password");
610 $cgi->delete("password");
611 if (! $userbase{$user}) {
612 set_error($forum,"Неверное имя пользователя или пароль");
615 my $userinfo = thaw($userbase{$user}) ;
617 #while (my ($key,$val)=each %$userinfo) { print STDERR "$key => '$val'\n";}
618 if (defined $forum->{denied_status} && $userinfo->{status} eq
619 $forum->{denied_status}) {
620 set_error($forum,"Вход пользователя $user в систему заблокирован");
623 if (crypt($password,$userinfo->{passwd}) eq $userinfo->{passwd}) {
624 delete $userinfo->{"passwd"};
625 $cgi->delete("password");
626 $userinfo->{"user"} = $user;
627 newsession(undef,$forum,$user);
628 $forum->{"authenticated"} = $userinfo;
629 print STDERR "User $user authenticated successfully\n";
632 set_error($forum,"Неверное имя пользователя или пароль");
637 # Запоминает сообщение об ошибке для последующего вывода show_template
640 my ($forum,$message) = @_;
641 print STDERR "set_error: $message\n";
642 $forum->{error_message} = $message;
645 # Выводит текущий шаблон с сообщением об ошибке
648 my ($form_name,$cgi,$forum,$msg) = @_;
649 set_error($forum,$msg);
650 show_template($form_name,$cgi,$forum);
654 # Выполняет редирект (возможно, с установкой куков) на страницу,
655 # указанную # третьем параметре функции или в параметре CGI-запроса
657 # Если и то, и другое не определено, пытается сконструировать URL для
658 # возврата из PATH_INFO.
662 my ($cgi,$forum,$url) = @_;
664 $url = $cgi->param("returnto");
666 $cgi->url(-base=>1).($cgi->path_info()||$forum->{forumtop}) if !$url ;
668 print $cgi->redirect(-url=>$url,
669 ($forum->{cookies}?(-cookie=>$forum->{cookies}):()));
673 # Заполнение формы редактирования профиля данными пользователя
676 my ($formname,$cgi,$forum) = @_;
677 my $rights = getrights($cgi,$forum);
678 my $user = $cgi->param("user");
679 if (!$user && substr($path_translated,length($forum->{userdir}) eq
680 $forum->{userdir})) {
681 $user = substr($path_translated,length($forum->{userdir})+1);
683 $user = $forum->{authenticated}{user} unless $user;
684 show_error($forum,"Чей профиль вы хотите редактировать?")
687 dbmopen %base,datafile($forum,"passwd"),0664;
688 show_error($forum,"Нет такого пользователя $user")
690 my $userinfo = thaw($base{$user});
692 delete $userinfo->{passwd};
693 $userinfo->{user}=$user;
694 print STDERR "Substituting userinfo for $user\n";
695 while(my ($field,$value) = each %$userinfo) {
696 $value = $value->{src} if ($field eq 'avatar' && ref($value));
697 $cgi->param($field,$value);
699 my $tree = prepare_template(@_);
700 # Запрещаем редактирование полей, входящих в restricted_user_info
701 my $form = $tree->look_down(_tag=>"form",name=>"profile");
702 if ($rights ne "admin" && $forum->{restricted_user_info}) {
703 for my $field (split /\s*,\s*/,$forum->{restricted_user_info}) {
705 for my $element ($form->look_down(name=>$field)) {
706 my $tag= $element->tag;
707 if ($tag eq 'input') {
708 my $newel=new HTML::Element("span",
709 "class"=>"restricted-field");
711 $newel->push_content($element->attr("value"));
712 $element->replace_with($newel)->delete();
713 } elsif ($tag eq 'textarea') {
714 $element->replace_with_content(new HTML::Element("div",
715 class=>"restricted-field"))->delete();
716 } elsif ($tag eq 'select') {
717 my $newel = new HTML::Element("span",
718 class=>"restricted-field");
720 for my $option ($element->content_list) {
721 if (ref $option eq "HTML::Element" &&
722 $option->attr("selected")) {
723 $newel->push_content($option->detach_content());
727 if (!$newel->content_list) {
728 $newel->push_content(($element->content_list)[0]);
730 $element->replace_with($newel)->delete;
735 # Подставляем аватарку
736 print STDERR "avatar=",$userinfo->{avatar},"\n";
737 substinfo($tree,[_tag=>'img',class=>'avatar'],(ref($userinfo->{avatar})?(%{$userinfo->{avatar}}):(src=>$userinfo->{avatar})));
738 for my $userlink ($tree->look_down(_tag => "a",class=>"author")) {
739 $userlink->delete_content;
740 $userlink->push_content($user);
741 if ($forum->{authenticated}{openiduser}) {
742 $userlink->attr('href'=>"http://$user");
744 $userlink->attr('href'=>undef);
745 $userlink->tag('span');
748 send_to_user($tree,@_);
750 # Обработка результатов редактирования профиля пользвателя
753 my ($formname,$cgi,$forum) = @_;
754 if (!$cgi->param("user")) {
755 show_error($forum,"В форме нет имени пользователя");
757 my $user = $cgi->param('user');
758 my $rights = getrights($cgi,$forum);
759 if ($user ne $forum->{authenticated}{user} &&
760 $rights ne "admin") {
761 show_error($forum,"У вас нет прав на изменение профиля этого
765 dbmopen %base,datafile($forum,"passwd"),0644;
767 show_error($forum,"Несуществующий пользователь $user");
769 my $userinfo = thaw $base{$user};
770 $userinfo->{user}=$user;
772 # If password fields are filled, change password
774 if ($cgi->param('pass1')) {
775 if ($cgi->param('pass1') eq $cgi->param('pass2')) {
776 $userinfo->{passwd}=crypt_password($cgi->param('pass1'));
778 form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
781 make_profile($formname,$cgi,$forum,$userinfo,$rights eq "admin");
782 delete $userinfo->{user};
783 $base{$user} = freeze $userinfo;
785 show_profile($formname,$cgi,$forum);
788 # Обработка результатов заполнения формы регистрации.
792 my ($formname,$cgi,$forum) = @_;
795 # 1 Такой юзер уже есть
797 # не заполнено поле user
798 if (!$cgi->param("user")) {
799 form_error($formname,$cgi,$forum, "Не заполнено имя пользователя");
802 if (!$cgi->param("pass1")) {
803 form_error($formname,$cgi,$forum,"Не указан пароль");
805 # Копии пароля не совпали
806 if ($cgi->param("pass2") ne $cgi->param("pass1")) {
807 form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
809 my $user = $cgi->param("user");
810 # Не указаны поля, перечисленные в скрытом поле required
811 if ($cgi->param("required")) {
812 foreach my $field (split(/\s*,\s*/,$cgi->param('required'))) {
813 if (!$cgi->param($field)) {
814 form_error($formname,$cgi,$forum,"Не заполнено обязательное поле $field");
818 $cgi->delete("required");
820 dbmopen %userbase,datafile($forum,"passwd"),0644
821 or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!");
822 if ($userbase{$cgi->param("user")}) {
824 form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято");
826 my $userinfo = {passwd=>crypt_password($cgi->param('pass1'))};
827 make_profile($formname,$cgi,$forum,$userinfo,0);
828 $userinfo->{registered} = time;
829 set_default_user_attrs($forum,$userinfo);
830 print STDERR "stilllife forum: registering user $user\n";
831 $userbase{$user} = freeze($userinfo);
833 if (!defined $forum->{denied_status} || $userinfo->{status} ne
834 $forum->{denied_status}) {
835 newsession(undef,$forum,$user);
836 forum_redirect($cgi,$forum,$cgi->param("returnto"));
838 # FIXME Email validation
840 show_template("newuser",$cgi,$forum);
844 my ($formname,$cgi,$forum,$userinfo,$isadmin) =@_;
845 # Удаляем лишние поля
846 foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) {
847 if (!$cgi->param($field)) {
848 $cgi->delete($field);
851 if ($cgi->param("email") && ! Email::Valid->address($cgi->param("email"))) {
852 form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес");
854 my $user = $userinfo->{user};
855 my $userprefix=$user;
856 $userprefix=~tr!\\/: !_!;
857 # Если есть аватар в файле, то сохраняем этот файл и формируем URL
859 $cgi->delete($formname);
860 $cgi->delete("user");
861 $cgi->delete("pass1");
862 $cgi->delete("pass2");
863 if ($cgi->param("avatarfile" )) {
864 my $f = $cgi->upload("avatarfile");
867 my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/;
868 my $path = $forum->{"userdir"}."/".$userprefix."_".$filename;
870 binmode $out,":bytes";
872 while (my $bytes = read($f,$buffer,4096)) {
877 my ($w,$h) = imgsize($path);
878 $userinfo->{'avatar'}= {src=>$forum->{"userurl"}."/".$userprefix."_".$filename,
879 width=>$w,height=>$h};
880 } elsif ($cgi->param('avatar')) {
881 if (!ref($userinfo->{'avatar'}) ||
882 $userinfo->{avatar}{'src'} ne $cgi->param('avatar')) {
883 $userinfo->{avatar}=get_avatar_info($cgi->param('avatar'));
887 @restrict = split /\s*,\s*/, $forum->{restricted_user_info}
890 foreach my $param ($cgi->param) {
891 next if (grep $_ eq $param,@restrict);
892 next if $param eq 'avatar';
893 next if $param eq 'avatarfile';
894 next if $param eq 'returnto';
895 next if $param =~ /_format$/;
896 if (defined $cgi->param("${param}_format")) {
897 my $tree = input2tree($cgi,$forum,$param);
898 $userinfo->{$param} = tree2str($tree);
901 $userinfo->{$param} = $cgi->param($param);
906 my $open_password=shift;
907 my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./';
908 my $salt = substr($saltstring,int(rand(64)),1).
909 substr($saltstring,int(rand(64)),1);
910 my $password=crypt($open_password,$salt);
914 sub set_default_user_attrs {
915 my ($forum,$userinfo) = @_;
916 while (my($key,$val) = each %$forum) {
917 next unless $key =~ /^default_(.*)$/;
918 $userinfo->{$1} = $val;
923 my ($cgi,$forum) = @_;
925 $rights=getrights($cgi,$forum) if ($forum->{authenticated});
928 dbmopen %base,datafile($forum,"passwd"),0664;
929 if ($path_translated eq $forum->{userdir}) {
930 # показать список пользователей
931 $tree = gettemplate($forum,"userlist");
932 my $usertpl = $tree->look_down(class=>"userinfo");
933 my $userlist = $usertpl->parent;
935 for my $user (sort keys %base) {
936 my $block = $usertpl->clone;
937 $userlist->push_content($block);
938 my $userinfo =thaw($base{$user});
939 $userinfo->{"user"} = $user;
940 substitute_user_info($block,$forum,$userinfo);
941 profile_links($block,$user,$rights,$cgi,$forum);
945 my $user = substr($path_translated,length($forum->{userdir})+1);
947 print $cgi->header(-status=>"404 NOT FOUND");
950 my $userinfo = thaw($base{$user});
951 $userinfo->{"user"} = $user;
952 $tree = gettemplate($forum,"user");
953 substinfo($tree,[_tag=>"title"],_content=>"Stilllife user: $user");
954 substitute_user_info($tree,$forum,$userinfo);
955 profile_links($tree,$user,$rights,$cgi,$forum);
956 unless ($userinfo->{openiduser}) {
957 for my $userlink ($tree->look_down(_tag => "a",class=>"author")) {
958 $userlink->attr("href",undef);
959 $userlink->tag("span");
963 my $page = output_html($tree);
964 my $length = do {use bytes; length($page);};
965 print $cgi->header(-type=>"text/html",-content_length=>$length,
966 -charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
970 my ($tree,$user,$rights,$cgi,$forum)=@_;
971 foreach my $profile_link ($tree->look_down(_tag=>"a",
972 href=>qr/profile=/)) {
973 if ((defined $rights && $rights eq "admin")||
974 (defined $forum->{authenticated}{user} &&
975 $forum->{authenticated}{user} eq $user)) {
977 $profile_link->attr("href",
978 $cgi->url(-absolute=>1,-path_info=>0).$forum->{userurl}.
979 "/".$user."?profile=1");
981 $profile_link->delete();
985 sub clear_user_cookies {
986 my ($cgi,$forum) = @_;
987 $forum->{cookies}=[ $cgi->cookie(-name=>"sluser", -value=>"0",
988 -expires=>"-1m"),$cgi->cookie(-name=>"slsession", -value=>"0",
992 # Обработчик формы логина. Сводится к вызову функции authenticate,
993 # поскольку мы поддерживаем логин одновременный с отправкой реплики.
996 my ($form,$cgi,$forum)=@_;
997 if (authenticate($cgi,$forum)) {
998 forum_redirect($cgi,$forum);
1004 # Обработчик формы logout. В отличие от большинства обработчиков форм,
1005 # поддерживает обработку методом GET
1008 my ($form,$cgi,$forum) = @_;
1009 clear_user_cookies($cgi,$forum);
1010 if (defined (my $session_id = $cgi->cookie("slsession"))) {
1012 dbmopen %sessiondb,datafile($forum,"session"),0644;
1013 delete $sessiondb{$session_id};
1014 dbmclose %sessiondb;
1016 forum_redirect($cgi,$forum);
1018 sub allow_operation {
1019 my ($operation,$cgi,$forum) = @_;
1020 return 1 if (!exists($permissions{$operation}));
1021 if (!$forum->{authenticated}) {
1022 return 1 if ($permissions{$operation} eq "login");
1025 my $user = $forum->{authenticated}{user} ;
1026 my $accesslevel=getrights($cgi,$forum);
1027 # Если permissions{$operation} равны author, нам нужно извлечь
1028 # текст из соответствующего файла и положить его в
1029 # cgi->param("text"); Заодно определим и автора
1030 my ($itemauthor,$itemtext)=get_message_by_id($cgi->param("id")) if
1031 $permissions{$operation} eq "author";
1033 return 1 if ($accesslevel eq "admin");
1034 return 0 if ($permissions{$operation} eq "admin");
1035 return 1 if ($accesslevel eq "moderator");
1036 return 0 if $accesslevel eq "banned";
1037 return 0 if $permissions{$operation} eq "author" && $user ne $itemauthor;
1042 my ($form,$cgi,$forum) = @_;
1043 if (! exists $forum->{authenticated} ) {
1044 form_error($form,$cgi,$forum,"Вы не зарегистрировались") if (!authenticate($cgi,$forum));
1047 # Находим файл дискуссии, в который надо поместить реплику
1049 my ($tree,$lockfd)=gettree($path_translated);
1050 my $newmsg = newlistelement($tree,"message","messagelist");
1052 show_error($forum,"Шаблон темы не содержит элемента с классом
1058 # Генерируем идентификатор записи.
1060 my $id = "m".get_uid($forum);
1064 # Сохраняем приаттаченные картинки, если есть.
1066 my $dir = $path_translated;
1068 $dir=~ s/[^\/]+$// if (-f $dir);
1070 for (my $i=1;$cgi->param("image$i"); $i++) {
1071 my $userpath=$cgi->param("image$i");
1072 my $filename=lc($1) if $userpath =~ /([^\/\\]+)$/;
1073 $attached{$filename} = $id."_".$filename;
1074 my $in = $cgi->upload("image$i");
1076 show_error($forum,"Ошибка при загрузке картинки $filename");
1080 open $out,">$dir/$attached{$filename}";
1081 binmode $out,":bytes";
1089 # Преобразуем текст записи в html и чистим его
1091 my $txtree = input2tree($cgi,$forum,"text");
1093 # Находим в тексте URL на приаттаченные картинки и меняем на те
1094 # имена, под которыми мы их сохранили.
1096 for my $image ($txtree->find_by_tag_name("img")) {
1097 my $file=lc($image->attr("src"));
1098 if ( exists $attached{$file}) {
1099 $image->attr("src" => $attached{$file});
1100 my ($width,$height) = imgsize($dir ."/".$attached{$file});
1101 $image->attr("width" =>$width);
1102 $image->attr("height" => $height);
1106 # Подставляем данные сообщения
1108 $newmsg->attr("id"=>$id);
1109 substinfo($newmsg,[class=>"subject"],_content=>$cgi->param("subject"));
1110 my $textnode=$newmsg->look_down("class"=>"mtext");
1112 show_error($forum,"В шаблоне реплики нет места для текста");
1114 $textnode->delete_content();
1115 $textnode->push_content($txtree);
1116 if ($forum->{authenticated}{signature}) {
1117 $textnode->push_content(new HTML::Element("br"),"--",
1118 new HTML::Element("br"),str2tree($forum->{authenticated}{signature}));
1120 substitute_user_info($newmsg,$forum);
1122 # Подставляем данные в форму msginfo
1124 my $editform=$newmsg->look_down(_tag=>"form","class"=>"msginfo");
1126 substinfo($editform,[_tag=>"input",name=>"id"],value=>$id) ||
1127 show_error($forum,"В форме управления сообщением нет поля id");
1128 substinfo($editform,[_tag=>"input",name=>"author"],value=>
1129 $forum->{authenticated}{user}) ||
1130 show_error($forum,"В форме управления сообщением нет поля author");
1133 my $posted = strftime("%d.%m.%Y %H:%M",localtime());
1134 substinfo($newmsg,["class"=>"mdate"],
1135 _content =>$posted);
1136 # Подставляем mreply
1137 substinfo($newmsg,[_tag=>"a","class"=>"mreply"],"href" =>
1138 $cgi->url(-absolute=>1,-path_info=>1)."?reply=1&id=$id");
1139 # Подставляем manchor
1140 substinfo($newmsg,[_tag=>"a","class"=>"manchor"],
1141 "name"=>"#$id","href"=>undef) or
1142 show_error($forum,"В шаблоне сообщения отсутствует якорь для ссылок на него");
1144 substinfo($newmsg,[_tag=>"a","class"=>"mlink"],
1145 href=>$cgi->path_info."#$id");
1146 # подставляем mparent
1147 my $parent_id=$cgi->param("id");
1149 substinfo($newmsg,[_tag => "a",class=>"mparent"],
1150 "href"=>$cgi->path_info."#$parent_id",style=>undef);
1152 substinfo($newmsg,[_tag => "a",class=>"mparent"],
1153 style=>"display: none;");
1156 for my $msg ($newmsg->parent->look_down("class"=>"message")) {
1161 # Делаем Уфф и сохраняем то, что получилось
1163 record_as_recent($forum,$newmsg->clone);
1164 savetree($path_translated,$tree,$lockfd);
1165 record_statistics($forum,"message"),
1166 update_topic_list($forum,$path_translated,$msgcount,$posted);
1167 forum_redirect($cgi,$forum,$cgi->path_info."#$id");
1169 sub update_topic_list {
1170 my ($forum,$topic,$count,$date) = @_;
1171 my ($tree,$lockfd,$block,$index);
1172 if (!ref ($topic)) {
1173 # Если $topic - имя файла, найдем соответствующий индекс и в нем
1174 # элемент с соответствующим id;
1175 my ($dir,$id)=($1,$2) if $topic =~/(.+)\/([^\/]+).html/;
1176 $index = $dir."/".$forum->{indexfile};
1177 ($tree,$lockfd) = gettree($index);
1178 $block = $tree->look_down("id"=>$id);
1179 return unless $block;
1181 # Иначе нам передали кусок готового распарсенного дерева
1184 substinfo($block,[class=>"msgcount"],_content=>$count);
1185 substinfo($block,[class=>"last-updated"],_content=>$date);
1186 # и если мы парсили дерево, то мы его и сохраняем
1187 savetree($index,$tree,$lockfd);
1190 sub record_as_recent {
1191 my ($forum,$msg) = @_;
1192 my ($tree,$lockfd) = gettree($forum->{forumroot}."/recent.html");
1193 my $msglist = $tree->look_down("class"=>"messagelist");
1195 my $style = $msglist->attr("style");
1196 if ($style && $style =~ s/display: none;//) {
1197 $msglist->attr("style",$style);
1198 $msglist->look_down(class=>"message")->replace_with($msg);
1200 my @msgs = $msglist->look_down("class"=>"message");
1201 if (@msgs > $forum->{replies_per_page}) {
1202 for (my $i=$#msgs;$i>=$forum->{replies_per_page};$i--) {
1206 $msgs[0]->preinsert($msg);
1209 savetree($forum->{forumroot}."/recent.html",$tree,$lockfd);
1212 # Обработка операции создания новой темы.
1216 my ($form,$cgi,$forum) = @_;
1218 # Проверяем корректность urlname и прочих полей
1221 if (!$cgi->param("urlname")) {
1222 $urlname = get_uid($forum);
1224 $urlname=$1 if $cgi->param("urlname") =~ /^([-\w]+)$/;
1225 form_error($form,$cgi,$forum,"Некорректные символы в urlname.
1226 Допустимы только латинские буквы, цифры и минус") unless $urlname;
1228 if (!-d $path_translated) {
1229 show_error($forum,"Операция $form может быть вызвана только со
1232 my $filename = "$path_translated/$urlname.html";
1234 form_error($form,$cgi,$forum,"Тема с urlname $urlname уже
1237 my $url = $cgi->path_info."/$urlname.html";
1239 if (!$cgi->param("title")) {
1240 form_error($form,$cgi,$forum,"Тема должна иметь непустое название");
1243 # Создаем собственно тему
1245 my $tree = gettemplate($forum,"topic",$url);
1246 # Заполнить название и аннотацию
1247 my $abstract = input2tree($cgi,$forum,"abstract");
1248 substinfo($tree,[_tag=>"meta","name"=>"description"],content=>$abstract->as_trimmed_text);
1249 substinfo($tree,[_tag=>"title"],_content=>$cgi->param("title"));
1250 my $subtree = $tree->look_down("class"=>"topic");
1251 my $creation_time=strftime("%d.%m.%Y %H:%M",localtime());
1253 substinfo($subtree,["class"=>"title"],
1254 _content=>$cgi->param("title"));
1255 substinfo($subtree,["class"=>"date"],
1256 _content=>$creation_time);
1257 # Вставляем в страницу КОПИЮ аннотации, поскольку аннотация
1258 # нам еще понадобится в списке тем.
1259 substinfo($subtree,["class"=>"abstract"],_content=>$abstract->clone);
1260 substitute_user_info($subtree,$forum);
1262 substinfo($tree,["class"=>"title"],
1263 _content=>$cgi->param("title"));
1265 # Скрыть список сообщений.
1266 hide_list($tree,"messagelist");
1267 savetree($filename,$tree,undef);
1270 # Добавляем элемент в список тем текущего форума
1274 ($tree,$lockfd)=gettree($path_translated."/".$forum->{"indexfile"});
1275 my $newtopic = newlistelement($tree,"topic","topiclist");
1276 substinfo($newtopic,[_tag=>"a","class"=>"title"],
1277 _content=>$cgi->param("title"), href=>"$urlname.html");
1278 substinfo($newtopic,["class"=>"date"], _content=>$creation_time);
1279 substinfo($newtopic,["class"=>"abstract"],_content=>$abstract);
1280 substitute_user_info($newtopic,$forum);
1281 $newtopic->attr("id",$urlname);
1282 my $controlform = $newtopic->look_down(_tag=>"form",class=>"topicinfo");
1284 $controlform->attr("action"=>$cgi->url(-absolute=>1,-path_info=>0,
1285 -query_string=>0).$url);
1286 substinfo($controlform,[_tag=>"input",name=>"author"],value=>
1287 $forum->{authenticated}{user});
1289 update_topic_list($forum,$newtopic,0,$creation_time);
1290 savetree($path_translated."/".$forum->{"indexfile"},$tree,$lockfd);
1291 record_statistics($forum,"topic");
1292 forum_redirect($cgi,$forum,$cgi->url(-base=>1).$url);
1296 my ($form,$cgi,$forum) = @_;
1298 # Проверяем корректность urlname и прочих полей
1301 if (!$cgi->param("urlname")) {
1302 form_error($form,$cgi,$forum,"Форуму необходимо задать непустое urlname");
1304 if ($cgi->param("urlname") eq ".") {
1307 $urlname=$1 if $cgi->param("urlname") =~ /^([-\w]+)$/ ;
1308 form_error($form,$cgi,$forum,"Некорректные символы в urlname.
1309 Допустимы только латинские буквы, цифры и минус") unless $urlname;
1311 if (!-d $path_translated) {
1312 show_error($forum,"Операция $form может быть вызвана только со
1315 my $newname = "$path_translated/$urlname";
1316 $newname=$path_translated if ($urlname eq ".");
1317 my $filename = "$newname/$forum->{indexfile}";
1319 form_error($form,$cgi,$forum,"Форум $urlname уже существует");
1321 if (!$cgi->param("title")) {
1322 form_error($form,$cgi,$forum,"Форум должен иметь непустое название");
1324 mkdir $newname unless -d $newname;
1328 my ($logo_name,$logo_width,$logo_height);
1329 if ($cgi->param("logo")) {
1330 my $userpath = $cgi->param("logo");
1331 $logo_name="logo.".lc($1) if $userpath=~/\.([^.]+)$/;
1332 my $in = $cgi->upload("logo");
1334 show_error($forum,"Ошибка при загрузке картинки $userpath");
1338 open $out,">$newname/$logo_name";
1339 binmode $out,":bytes";
1345 ($logo_width,$logo_height) = imgsize("$newname/$logo_name");
1347 $logo_name = $forum->{"templatesurl"}."/1x1.gif";
1354 # Создаем собственно оглавление форума
1357 my $url = $cgi->path_info."/$urlname";
1358 $url= $cgi->path_info if $urlname eq ".";
1360 my $tree = gettemplate($forum,"forum",$url);
1361 # Удалить элементы, который присутствуют только на главной странице
1362 if ($urlname ne ".") {
1363 for my $element ($tree->look_down("class"=>"top-page")) {
1367 # Заполнить название и аннотацию
1368 my $abstract = input2tree($cgi,$forum,"abstract");
1369 substinfo($tree,[_tag=>"meta","name"=>"description"],content=>$abstract->as_trimmed_text);
1370 substinfo($tree,[_tag=>"title"],_content=>$cgi->param("title"));
1371 my $subtree = $tree->look_down("class"=>"annotation")
1372 or show_error($forum,"В шаблоне форума отсутствует класс annotation");
1373 my $creation_time=strftime("%d.%m.%Y %H:%M",localtime());
1374 substinfo($subtree,["class"=>"title"],
1375 _content=>$cgi->param("title"));
1376 substinfo($subtree,["class"=>"date"],
1377 _content=>$creation_time);
1378 # Вставляем в страницу КОПИЮ аннотации, поскольку аннотация
1379 # нам еще понадобится в списке тем.
1380 substinfo($subtree,["class"=>"abstract"],_content=>$abstract->clone);
1381 substitute_user_info($subtree,$forum);
1382 substinfo($subtree,[_tag=>"img","class"=>"logo"],
1383 src=> $logo_name, width=>$logo_width, height=>$logo_height);
1384 # Скрыть списки подфорумов и тем .
1385 hide_list($tree,"forumlist");
1386 hide_list($tree,"topiclist");
1387 if ($urlname eq ".") {
1388 for my $link_up ($tree->look_down(_tag=>"a",href=>"..")) {
1392 savetree($filename,$tree,undef);
1395 # Добавляем элемент в список тем текущего форума
1397 if ($urlname ne ".") {
1399 ($tree,$lockfd)=gettree($path_translated."/".$forum->{"indexfile"});
1400 my $newforum = newlistelement($tree,"forum","forumlist");
1401 substinfo($newforum,[_tag=>"a","class"=>"title"],
1402 _content=>$cgi->param("title"), href=>"$urlname/");
1403 substinfo($newforum,["class"=>"date"], _content=>$creation_time);
1404 substinfo($newforum,["class"=>"abstract"],_content=>$abstract);
1405 substinfo($newforum,[_tag=>"img","class"=>"logo"],src=>"$urlname/$logo_name",
1406 width=>$logo_width,height=>$logo_height);
1407 substitute_user_info($newforum,$forum);
1408 $newforum->attr("id",$urlname);
1409 my $controlform = $newforum->look_down(_tag=>"form",class=>"foruminfo");
1411 $controlform->attr("action"=>$cgi->url(-absolute=>1,-path_info=>0).
1413 substinfo($controlform,[_tag=>"input",name=>"author"],value=>
1414 $forum->{authenticated}{user});
1416 savetree($path_translated."/".$forum->{"indexfile"},$tree,$lockfd);
1417 record_statistics($forum,"forum");
1419 # Создаем тему для "свежих реплик"
1420 my $recent = gettemplate($forum,"topic",$url."/recent.html");
1421 # remove reply link from page itself
1422 for my $link ($recent->look_down(_tag =>"a", href=>qr/reply=/)) {
1425 substinfo($recent,["_tag"=>"title"],$cgi->param("title").": Свежие сообщения");
1426 substinfo($recent,["class"=>"title"],
1427 _content=>$cgi->param("title"). ": Свежие сообщения");
1428 hide_list($recent,"messagelist");
1429 savetree($path_translated."/recent.html",$recent,undef);
1433 forum_redirect($cgi,$forum,$cgi->url(-base=>1).$url);
1436 #----------------------------------------------------------
1437 # База пользователей и права доступа
1438 #----------------------------------------------------------
1440 # Записывает в базу данных пользователей, сколько каких объектов
1441 # создал текущий пользователь
1443 sub record_statistics {
1444 my ($forum,$type) = @_;
1445 my $user = $forum->{authenticated}{user};
1447 dbmopen %base,datafile($forum,"passwd"),0664;
1448 my $userinfo = thaw($base{$user});
1449 $userinfo->{$type."s"}++;
1450 $userinfo->{"last_$type"}=time;
1451 $base{$user} = freeze($userinfo);
1455 # читает файлы прав доступа в дереве форума, и возвращает
1456 # статус текущего пользователя (undef - аноним, banned, normal,
1457 # moderator или admin
1460 my ($cgi,$forum) = @_;
1461 if (!$forum->{authenticated}) {
1464 return $forum->{authenticated}{rights} if
1465 exists $forum->{authenticated}{rights};
1466 my $user = $forum->{authenticated}{user};
1467 my $dir = $path_translated;
1469 $dir =~s/\/[^\/]+$// if (!-d $dir);
1471 my $user_status = "normal";
1473 while (length($dir)) {
1474 if (-f "$dir/perms.txt") {
1475 open $f,"<","$dir/perms.txt";
1478 if (/^\[\s*(admins|moderators|banned)\s*\]/) {
1482 if ($user eq $_ && defined $status) {
1483 if ($status eq "banned") {
1484 return $forum->{authenticated}{rights}=$status;
1486 if ($status eq "admins" ) {
1487 return $forum->{authenticated}{rights}="admin";
1489 $user_status = "moderator";
1494 last LEVEL if -f "$dir/.forum";
1496 # Strip last path component.
1497 $dir =~s/\/[^\/]+$//
1499 return $forum->{authenticated}{rights}=$user_status;
1505 #------------------------------------------------------------------
1506 # Работа с файлами и идентификторами
1507 #------------------------------------------------------------------
1510 # Залочить файл и получить его распрасенное представление.
1511 # Возвращает пару ($tree,$lockfd)
1514 my $filename = shift;
1516 open $f,"<",$filename or return undef;
1518 my $tree = treefromfile($f);
1519 $tree->parse_file($f);
1523 # Сохранить дерево и закрыть lockfd.
1528 my ($filename,$tree,$lockfd) = @_;
1530 open $f,">",$filename . ".new" or return undef;
1531 print $f output_html($tree);
1533 # FIXME - только для POSIX.
1535 rename $filename.".new",$filename;
1536 close $lockfd if defined($lockfd);
1539 # Cериализовать HTML-документ с DOCTYPE (workaround вокруг баги в
1540 # HTML::TreeBuilder)
1544 return '<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "http://www.w3.org/TR/html4/loose.dtd">'.
1545 $tree->as_HTML("<>&");
1548 # Читает шаблон и подготавливает его к размещению по указанной URL.
1549 # Если url не указана, считается что шаблон будет показан как результат
1550 # текущего http-запроса.
1553 my ($forum, $template,$url) = @_;
1554 $url =~ s/\/+/\//g if defined $url;
1555 my $filename=$forum->{"templates"}."/$template.html";
1556 if (! -r $filename) {
1557 show_error($forum,"Нет шаблона $template");
1560 my $tree = treefromfile($filename);
1561 fix_forum_links($forum,$tree,$url);
1566 # Создает объект HTML::TreeBuilder и выставляет ряд опций.
1570 my $tree = HTML::TreeBuilder->new;
1571 # Set some options for treebuilder
1572 # Comments are neccessary to convert HTML back to BBCode
1573 $tree->store_comments(1);
1574 # Avoid converting html into one long-long string
1575 $tree->ignore_ignorable_whitespace(0);
1576 $tree->no_space_compacting(1);
1583 my $tree = make_tree();
1584 $tree->parse_file($f);
1588 # Получает уникальный числовой идентификатор.
1593 open $f,"+<",datafile($forum,"sequence") or
1598 printf $f "%8s\n",$id;
1601 return sprintf ("%08s",$1);
1603 # --------------------------------------------------------------------
1604 # OpenID registration
1605 # -------------------------------------------------------------------
1606 sub create_openid_consumer {
1607 my ($cgi,$forum) = @_;
1608 return Net::OpenID::Consumer ->new(
1609 ua => LWP::UserAgent->new( agent => "Stilllife/1.0"),
1611 consumer_secret=>"X9RWPo0rBE7yLja6VB3d",
1612 required_root => $cgi->url(-base=>1));
1616 # openidstart - вызывается когда обнаружено что текущее имя
1617 # пользователя, пытающегося аутентифицироваться, содержит http://
1622 my ($cgi,$forum,$openidurl) = @_;
1624 # Fix duplicated http:// which can be produced by our sprintf based
1627 $openidurl=~s!^http://http://!http://!;
1628 my $csr = create_openid_consumer($cgi,$forum);
1629 my $claimed_identity=$csr->claimed_identity($openidurl);
1630 if (!defined $claimed_identity) {
1631 show_error($forum,"Указанная URL $openidurl не является OpenId");
1634 $cgi->param("openidvfy",1);
1635 $cgi->delete("user");
1636 $cgi->delete("openidsite");
1637 $cgi->delete("password");
1638 my $check_url = $claimed_identity->check_url(
1639 return_to=> $cgi->url(-full=>1,-path_info=>1,-query=>1),
1640 trust_root=> $cgi->url(-base=>1));
1641 print $cgi->redirect(-location=>$check_url);
1645 # Вызывается при редиректе от openid producer-а. Проверяет, что
1646 # удаленный сервер подтвердил openid и вызывает операцию для которой
1647 # (либо возврат на исходную страницу при операции login, либо постинг
1651 my ($cgi,$forum) = @_;
1652 my $csr = create_openid_consumer($cgi,$forum);
1653 if (my $setup_url = $csr->user_setup_url) {
1654 print $cgi->redirect(-location=>$setup_url);
1656 } elsif ($csr->user_cancel) {
1657 show_error($forum,"Ваш openid-сервер отказался подтвержать вашу
1660 } elsif (my $vident = $csr->verified_identity) {
1661 #Успешная аутентификация.
1663 my $user = $vident->url;
1664 # Remove trailing slash from URL if any
1667 dbmopen %userbase,datafile($forum,"passwd"),0664;
1668 my $username = $user;
1669 $username =~ s/^http:\/\///;
1670 if (!$userbase{$username}) {
1671 # Тащим foaf, если получится
1672 my %info=get_foaf($csr->ua,$vident->declared_foaf);
1673 if (ref($info{'avatar'}) eq "HASH" ) {
1674 delete $info{'avatar'}{'type'};
1676 $info{"openiduser"}=1;
1677 $info{"registered"}=time;
1678 print STDERR "forum $forum info ".\%info."\n";
1679 set_default_user_attrs($forum,\%info);
1680 $info{'status'} = $forum->{openid_status} if $forum->{openid_status};
1681 $forum->{authenticated}=\%info;
1682 $userbase{$username} = freeze(\%info);
1684 $forum->{authenticated} = thaw ($userbase{$username});
1687 if (defined $forum->{denied_status} &&
1688 ($forum->{authenticated}{status} eq $forum->{denied_status})) {
1689 show_error($forum,"Вход пользователя $username в систему заблокирован");
1691 $forum->{"authenticated"}{"user"} = $username;
1692 newsession(undef,$forum,$user);
1693 # Если указан параметр reply, вызываем обработку реплики
1694 if ($cgi->param("reply")) {
1695 reply("reply",$cgi,$forum);
1698 #Иначе, возвращаемся на исходную страницу
1699 forum_redirect($cgi,$forum,undef);
1701 show_error($forum,"Ошибка OpenId аутентификации");
1706 sub get_avatar_info {
1708 $ua = LWP::UserAgent->new( agent => "Stilllife/1.0") unless $ua;
1709 my $response = $ua->get($url);
1710 if ($response->is_success) {
1711 my $image = $response->content;
1712 my ($w,$h,$type) = imgsize(\$image);
1713 return {width=>$w,height=>$h,type=>$type,src=>$url};
1715 print STDERR "Error getting $url: ".$response->status_line,"\n";
1721 my ($ua,$foaf_url) = @_;
1722 my $response = $ua->get($foaf_url);
1723 unless ($response->is_success) {
1724 print STDERR "Error geting foaf from $foaf_url\n";
1727 my $foaf = $response->content;
1728 my %info = foaf_parse($foaf);
1729 if ($info{avatar}) {
1730 $info{avatar} = get_avatar_info($info{avatar},$ua);
1737 my ($starttag) = $foaf =~ /<(\w+(:\w+)?[^>]+)>/sg;
1738 my %ns = reverse ($starttag =~ /xmlns:(\w+)="([^"]+)"/sg);
1739 my $foaf_prefix = $ns{"http://xmlns.com/foaf/0.1/"};
1740 my $rdf_prefix = $ns{"http://www.w3.org/1999/02/22-rdf-syntax-ns#"};
1741 my ($userpic) = $foaf=~/<$foaf_prefix:img[^>]* $rdf_prefix:resource="([^"]+)"/s;
1743 push @info, avatar =>$userpic if $userpic;
1744 my ($icq) = $foaf =~/<$foaf_prefix:icqChatID>([^<]*)<\/$foaf_prefix:icqChatID>/s;
1745 push @info, icq => $icq if ($icq);
1746 my ($jabber) = $foaf =~/<$foaf_prefix:jabberID>([^<]*)<\/$foaf_prefix:jabberID>/s;
1747 push @info, jabber => $jabber if ($jabber);
1750 #-----------------------------------------------------------------
1751 # Обработка форматированных текстовых полей
1752 #-----------------------------------------------------------------
1755 my ($cgi,$forum,$field_name) = @_;
1756 my $format = $cgi->param($field_name."_format");
1757 my $text = $cgi->param($field_name);
1758 if ($format eq "bbcode") {
1759 my $parser = HTML::BBReverse->new();
1760 $text="<div class=\"bbcode\">".$parser->parse($text)."</div>";
1761 } elsif ($format eq "text") {
1762 $text=~s/\r?\n\r?\n/<\/p><p class=\"text\">/;
1763 $text=~s/\r?\n/<br>/;
1764 $text = "<div><p class=\"text\">".$text."</p></div>";
1766 my $txtree = str2tree($text);
1768 ("script","style","head","html","object","embed","iframe","frameset","frame",
1769 ($forum->{forbid_tags}?split(/\s*,\s*/,$forum->{forbid_tags}):())) {
1770 for my $element ($txtree->find_by_tag_name($badtag)) {
1771 $element->delete() if defined $element;
1774 # Проверяем на наличие URL-ок не оформленных ссылками.
1782 my $tree = make_tree();
1783 # Set parser options here
1784 $tree->parse("<html><body><div>$data</div></body></html>");
1786 my $element=$tree->find("body");
1787 while (($element =($element->content_list)[0])->tag ne "div") {
1796 return $tree->as_HTML("<>&");
1799 #------------------------------------------------------------------------
1800 # Подстановка в дереве
1801 #------------------------------------------------------------------------
1803 # элемент указанного класса и удаляет display: none из его атрибута
1804 # style. Возвращает 1, если элемент был раскрыт, и 0, если он и до этого
1807 my ($tree,$class) = @_;
1808 my $msglist = $tree->look_down("class"=>$class);
1810 my $style = $msglist->attr("style");
1811 if ($style && $style =~ s/display: none;//) {
1812 $msglist->attr("style",$style);
1820 # Находит первый элемент указанного класса, и приписывает ему display:
1824 my ($tree,$class)=@_;
1825 my $msglist = $tree->look_down("class"=>$class);
1826 return undef unless $msglist;
1827 if (!$msglist->attr("style")) {
1828 $msglist->attr("style","display: none;");
1830 my $style = $msglist->attr("style");
1831 unless ($style=~ s/\bdisplay:\s+\w+\s*;/display: none;/) {
1832 $style .= "display: none;";
1834 $msglist->attr("style",$style);
1839 # Найти все элементы, удоволетворяющие заданному критерию и подставить в
1840 # них указанные атрибуты
1842 # Параметры 1. Дерево (класса HTML::Element)
1843 # 2. Запрос - ссылка на список вида атрибут=>значение.
1844 # Этот список будет непосредственно передан в
1845 # HTML::Element::look_down
1846 # 3. Далее пары имя-атрибута, значение. Если вместо имени атрибута
1847 # использовать слово _content, заменено будет содержимое элемента.
1848 # Значение для _content - ссылка на HTML::Element. Если там строка,
1849 # она будет вставлена как одиночный текстовый узел.
1850 # 4. Возвращает число выполненных подстановок (0, если искомых элементов
1854 my ($tree,$query,@attrs) = @_;
1856 foreach my $element ($tree->look_down(@$query)) {
1859 my $attr = shift @attrs;
1860 my $value = shift @attrs;
1861 if ($attr eq "_content") {
1862 $element->delete_content;
1863 $element->push_content($value);
1865 $element->attr($attr,$value);
1872 # newlistelement($tree,$elementclass,$listclass)
1874 # Если список с указанным классом скрыт, раскрывает его и возвращает
1875 # (единственный) элемент
1876 sub newlistelement {
1877 my ($tree,$element,$list) =@_;
1878 my $msglist = $tree->look_down("class"=>$list);
1880 my $style = $msglist->attr("style");
1881 if ($style && $style =~ s/display: none;//) {
1882 $msglist->attr("style",$style);
1883 return $msglist->look_down(class=>$element);
1885 my $template = $msglist->look_down("class"=>$element);
1886 return undef unless $template;
1887 my $newitem=$template->clone;
1888 $template->parent->push_content($newitem);