X-Git-Url: http://www.wagner.pp.ru/gitweb/?a=blobdiff_plain;f=forum%2Fforum;h=7cb882b48c9c9234da43ab5d6d0ec89cd5dadeb5;hb=394bfadb608997e0366304e916f97e5ceb898161;hp=5ece800ea5750a442beddde87169e3247657a177;hpb=56743ec1613ddf1a16a5e2ada00704b6037589df;p=oss%2Fstilllife.git diff --git a/forum/forum b/forum/forum index 5ece800..7cb882b 100755 --- a/forum/forum +++ b/forum/forum @@ -31,7 +31,7 @@ use Net::OpenID::Consumer; my %actions = ( reply => \&reply, edit => \&edit_comment, - delete => \&delete_comment, + delete => \&delete_item, move => \&move_comment, newtopic=> \&new_topic, newforum=> \&new_forum, @@ -65,7 +65,6 @@ my $cgi = new CGI; print STDERR "--------------------\n"; my $forum=get_forum_config(); - authorize_user($cgi,$forum); if ($cgi->request_method ne "POST") { # Запрос к скрипту методом GET. Надо показать форму, если только это не @@ -74,6 +73,10 @@ if ($cgi->request_method ne "POST") { openid_verify($cgi,$forum); } elsif ($cgi->param("logout")) { logout('logout',$cgi,$forum); + } elsif ($cgi->param("profile")) { + show_profile("profile",$cgi,$forum); + } elsif ($cgi->param('delete')) { + delete_item("delete",$cgi,$forum); } else { for my $param ($cgi->param) { # Среди параметров, указанных в URL ищем тот, который задает @@ -83,6 +86,7 @@ if ($cgi->request_method ne "POST") { # нехороших символов нет, но чтобы perl в taint mode не # ругался... if (allow_operation($param,$cgi,$forum)) { + print STDERR "Allow_operation completed\n"; show_template($1,$cgi,$forum) if $param=~/^(\w+)$/; exit; } else { @@ -98,6 +102,9 @@ if ($cgi->request_method ne "POST") { } } } + if (index($path_translated,$forum->{userdir})==0) { + show_user_page($cgi,$forum); + } show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия"); } @@ -119,6 +126,13 @@ if ($cgi->request_method ne "POST") { show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия"); } +#-------------------------------------------------------------- +#-------- Чтение конфигурационного файла и связанные с этим действия +#------------------------------------------------------------------ + +# +# Преобразование пути в файловой системе сервера в путь в URL +# sub dir2url { my ($cgi,$dir) = @_; my $prefix=""; @@ -149,9 +163,10 @@ sub dir2url { # враг. # Возвращает список имя,значение, имя, значение который прививается в # хэш - +# sub get_forum_config { - $path_translated = $1 if $ENV{PATH_TRANSLATED}=~/^(\S+)$/; + $path_translated = $1 if $ENV{PATH_TRANSLATED}=~/^(.+)$/; + $path_translated=~s/\/+$//; my @path=split("/",$path_translated); while (@path>1) { if (-r (my $config=join("/",@path,".forum")) ) { @@ -167,6 +182,7 @@ sub get_forum_config { # файл .forum $config{"forumtop"} = dir2url($cgi,join("/",@path)); + $config{"forumroot"} = join("/",@path); # Если в конфиге отсутствует переменная templates, но # рядом с конфигом присутствует директория templates, # то шаблоны там. @@ -200,6 +216,9 @@ sub get_forum_config { show_error(\%config,"В конфигурации форума указана несуществующая директория данных "); exit; } + # + # Некоторые умолчания + # $config{"authperiod"}="+1M" if (! exists $config{"authperiod"}); $config{"renewtime"} = "86000" if (!exists $config{"renewtime"}); $config{"replies_per_page"} = 50 if (!exists $config{"replies_per_page"}); @@ -227,7 +246,7 @@ sub get_forum_config { sub show_error { my ($cfg,$msg) = @_; if ( -r $cfg->{"templates"}."/error.html") { - my $tree = HTML::TreeBuilder->new_from_file($cfg->{"templates"}."/error.html"); + my $tree = treefromfile($cfg->{"templates"}."/error.html"); my $node= $tree->find_by_attribute('class','error'); my $body; if (!$node) { @@ -238,7 +257,7 @@ sub show_error { $node->delete_content; $node->push_content($msg); print $cgi->header(-type=>'text/html',-charset=>'utf-8'); - print $tree->as_HTML("<>&"); + print output_html($tree); } else { print $cgi->header(-type=>'text/html',-charset=>'utf-8'); print "Ошибка конфигурации форума", @@ -256,6 +275,17 @@ sub show_error { # подставляются # sub show_template { + my $tree = prepare_template(@_); + send_to_user($tree,@_); + exit; +} +sub send_to_user { + my ($tree,$form,$cgi,$forum) = @_; + print + $cgi->header(-type=>"text/html",-charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())), + output_html($tree); +} +sub prepare_template { my ($form,$cgi,$forum) = @_; my $tree = gettemplate($forum,$form,$ENV{'PATH_INFO'}); @@ -299,20 +329,19 @@ sub show_template { for my $element ($f->find_by_tag_name("textarea","input","select")) { my $name = $element->attr("name"); $substituted{$name} = 1; - #print STDERR "substituting form element name $name tag ",$element->tag, - # "value='",$cgi->param($name),"'\n"; if (defined $cgi->param($name)) { if ($element->tag eq "input") { - next ELEMENT if grep ($element->attr("type") eq - $_,"button","submit","reset"); - if ($element->attr("type") eq "check") { + my $type=$element->attr('type') || "text"; + next ELEMENT if grep($type eq $_, + "button","submit","reset"); + if ($type eq "check") { if (grep($element->attr("value") eq $_,$cgi->param($name))) { $element->attr("checked",""); } else { $element->attr("checked",undef); } - } elsif ($element->attr("type") eq + } elsif ($type eq "radio") { if ($element->attr("value") eq $cgi->param($name)) { $element->attr("checked",""); @@ -323,12 +352,26 @@ sub show_template { $element->attr("value",$cgi->param($name)); } } elsif ($element->tag eq "textarea") { + my $data=$cgi->param($name); + if ($data=~/^<(div|p)\b/ && !defined($cgi->param($name."_format"))) { + if ($data=~/^
(.*)<\/div>$/) { + $cgi->param($name."_format","bbcode"); + my $parser = HTML::BBReverse->new(); + $data = $parser->reverse($1); + # FIXME elsif ($data=~/

) + } else { + $cgi->param($name."_format","html"); + } + + } $element->delete_content; $element->push_content($cgi->param($name)); } elsif ($element->tag eq "select") { for my $option ($element->find_by_tag_name("option")) { - if (grep($option->attr("value") eq $_, $cgi->param($name))) { - $option->attr("selected",""); + my $value = $option->attr("value") || + $option->as_text(); + if (grep($value eq $_, $cgi->param($name))) { + $option->attr("selected","selected"); } else { $option->attr("selected",undef); } @@ -347,18 +390,17 @@ sub show_template { $f->push_content($element); } } - - - print - $cgi->header(-type=>"text/html",-charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())), - $tree->as_HTML("<>&"); -} + return $tree; +} # # Поправляет ссылки на служебные файлы и скрипты форума # sub fix_forum_links { my ($forum,$tree,$path_info) = @_; - $path_info=$ENV{'PATH_INFO'} if (!defined $path_info); + if (!defined $path_info) { + $path_info = $ENV{PATH_INFO}; + $path_info =~ s/\/+/\//g; + } my $script_with_path = $ENV{SCRIPT_NAME}.$path_info; ELEMENT: for my $element ($tree->find_by_tag_name("form","img","link","script","a")) { @@ -372,10 +414,11 @@ sub fix_forum_links { } # Обрабатываем наши специальные link rel="" + my $userlist = $cgi->url(-absolute=>1, + -path_info=>0,-query_string=>0).$forum->{userurl}; if ($element->tag eq "link") { if ($element->attr("rel") eq "forum-user-list") { - $element->attr("href" => $cgi->url(-absolute=>1, - -path_info=>0,-query_string=>0).$forum->{userurl}); + $element->attr("href" => $userlist); next ELEMENT; } elsif ($element->attr("rel") eq "forum-script") { $element->attr("href" => $script_with_path); @@ -384,9 +427,15 @@ sub fix_forum_links { } my $link = $element->attr($attr); # Абсолютная ссылка - оставляем как есть. - next ELEMENT if (! defined $link || $link=~/^\w+:/); + next ELEMENT if (! defined $link || $link=~/^\w+:/ || $link + eq"."||$link eq ".."); # Ссылка от корня сайта. if (substr($link,0,1) eq "/") { + # Если там два слэша, заменяем их на forumtop + if (substr($link,0,2) eq '//') { + $element->attr($attr, $forum->{forumtop}.substr($link,1)); + next ELEMENT; + } # Если она не ведет на наш скрипт, не обрабатываем next ELEMENT if substr($link,0,length($ENV{SCRIPT_NAME}) ne $ENV{SCRIPT_NAME}) ; @@ -395,7 +444,7 @@ sub fix_forum_links { $link =~ s/^[^\?]+/forum/; } if (!($link =~ s!^templates/!$forum->{templatesurl}/!) && - !($link =~ s!^users/!$forum->{usersurl}/!) && + !($link =~ s!^users/!$userlist/!) && !($link =~ s!^forum\b!$script_with_path!)) { $link = $forum->{"forumtop"}."/".$link } @@ -411,14 +460,7 @@ sub substitute_user_info { my ($tree,$forum,$user) = @_; my %userinfo; if (defined $user) { - my %users; - dbmopen %users,datafile($forum,"passwd"),0644; - if (!$users{$user}) { - show_error($forum,"Неизвестный пользователь $user"); - } - my $record = thaw($users{$user}); - %userinfo = %$record; - $userinfo{"user"} = $user; + %userinfo=%$user; } else { # Если не сказано, какой юзер, то текущий. %userinfo = %{$forum->{"authenticated"}} @@ -437,18 +479,39 @@ if (defined $user) { substinfo($tree,["_tag"=>"a","class"=>"author"], href=>$userpage,_content=>$userinfo{"user"}); delete $userinfo{"user"}; - substinfo($tree,["_tag"=>"img","class"=>"avatar"], - src=>$userinfo{"avatar"}||$forum->{templatesurl}."/1x1.gif"); - delete $userinfo{"avatar"}; + if (ref $userinfo{"avatar"} eq "HASH") { + substinfo($tree,["_tag"=>"img","class"=>"avatar"], + %{$userinfo{'avatar'}}); + } elsif ($userinfo{'avatar'}) { + substinfo($tree,["_tag"=>"img","class"=>"avatar"], + src=>$userinfo{"avatar"}); + } else { + substinfo($tree,["_tag"=>"img","class"=>"avatar"], + src=>$forum->{templatesurl}."/1x1.gif", + width=>1,height=>1); + } for my $element ( $tree->look_down("class",qr/^ap-/)) { my $field=$1 if $element->attr("class")=~/^ap-(.*)$/; $element->delete_content(); - $element->push_content(str2tree($userinfo{$field})) - if $userinfo{$field}; - $element->attr(href=>"mailto:$userinfo{$field}") - if ($element->tag eq "a" && $field eq "email"); - } + $field =~ tr/-/_/; + $userinfo{$field} = 0 if (!exists $userinfo{$field} && grep ($field eq + $_,"forums","messages","topics")); + if (exists $userinfo{$field}) { + + my $data; + if ($field eq "registered" || substr($field,0,5) eq "last_") { + $data = strftime("%d.%m.%Y %H:%M",localtime($userinfo{$field})) + } elsif ($userinfo{$field}=~/^<\w+/) { + $data = str2tree($userinfo{$field}); + } else { + $data = $userinfo{$field} + } + $element->push_content($data); + $element->attr(href=>"mailto:$userinfo{$field}") + if ($element->tag eq "a" && $field eq "email"); + } + } } @@ -476,7 +539,6 @@ sub authorize_user { my %userbase; dbmopen %userbase,datafile($forum,"passwd"),0644; if ( $userbase{$user}) { - print STDERR "getting user info for $user\n"; my $userinfo = thaw($userbase{$user}); delete $userinfo->{"passwd"}; $userinfo->{"user"} = $user; @@ -560,6 +622,11 @@ sub authenticate { my $userinfo = thaw($userbase{$user}) ; dbmclose %userbase; #while (my ($key,$val)=each %$userinfo) { print STDERR "$key => '$val'\n";} + if (defined $forum->{denied_status} && $userinfo->{status} eq + $forum->{denied_status}) { + set_error($forum,"Вход пользователя $user в систему заблокирован"); + return undef; + } if (crypt($password,$userinfo->{passwd}) eq $userinfo->{passwd}) { delete $userinfo->{"passwd"}; $cgi->delete("password"); @@ -605,11 +672,125 @@ sub forum_redirect { $url = $cgi->url(-base=>1).($cgi->path_info()||$forum->{forumtop}) if !$url ; } + $url = $cgi->url(-base=>1).$url if substr($url,0,1) eq "/"; print $cgi->redirect(-url=>$url, ($forum->{cookies}?(-cookie=>$forum->{cookies}):())); exit; } # +# Заполнение формы редактирования профиля данными пользователя + +sub show_profile { + my ($formname,$cgi,$forum) = @_; + my $rights = getrights($cgi,$forum); + my $user = $cgi->param("user"); + if (!$user && substr($path_translated,length($forum->{userdir}) eq + $forum->{userdir})) { + $user = substr($path_translated,length($forum->{userdir})+1); + } + $user = $forum->{authenticated}{user} unless $user; + show_error($forum,"Чей профиль вы хотите редактировать?") + unless $user; + my %base; + dbmopen %base,datafile($forum,"passwd"),0664; + show_error($forum,"Нет такого пользователя $user") + unless $base{$user}; + my $userinfo = thaw($base{$user}); + dbmclose(%base); + delete $userinfo->{passwd}; + $userinfo->{user}=$user; + while(my ($field,$value) = each %$userinfo) { + $value = $value->{src} if ($field eq 'avatar' && ref($value)); + $cgi->param($field,$value); + } + my $tree = prepare_template(@_); + # Запрещаем редактирование полей, входящих в restricted_user_info + my $form = $tree->look_down(_tag=>"form",name=>"profile"); + if ($rights ne "admin" && $forum->{restricted_user_info}) { + for my $field (split /\s*,\s*/,$forum->{restricted_user_info}) { + ELEMENT: + for my $element ($form->look_down(name=>$field)) { + my $tag= $element->tag; + if ($tag eq 'input') { + my $newel=new HTML::Element("span", + "class"=>"restricted-field"); + + $newel->push_content($element->attr("value")); + $element->replace_with($newel)->delete(); + } elsif ($tag eq 'textarea') { + $element->replace_with_content(new HTML::Element("div", + class=>"restricted-field"))->delete(); + } elsif ($tag eq 'select') { + my $newel = new HTML::Element("span", + class=>"restricted-field"); + OPTION: + for my $option ($element->content_list) { + if (ref $option eq "HTML::Element" && + $option->attr("selected")) { + $newel->push_content($option->detach_content()); + last OPTION; + } + } + if (!$newel->content_list) { + $newel->push_content(($element->content_list)[0]); + } + $element->replace_with($newel)->delete; + } + } + } + } + # Подставляем аватарку + substinfo($tree,[_tag=>'img',class=>'avatar'],(ref($userinfo->{avatar})?(%{$userinfo->{avatar}}):(src=>$userinfo->{avatar}))); + for my $userlink ($tree->look_down(_tag => "a",class=>"author")) { + $userlink->delete_content; + $userlink->push_content($user); + if ($forum->{authenticated}{openiduser}) { + $userlink->attr('href'=>"http://$user"); + } else { + $userlink->attr('href'=>undef); + $userlink->tag('span'); + } + } + send_to_user($tree,@_); +} +# Обработка результатов редактирования профиля пользвателя +# +sub profile { + my ($formname,$cgi,$forum) = @_; + if (!$cgi->param("user")) { + show_error($forum,"В форме нет имени пользователя"); + } + my $user = $cgi->param('user'); + my $rights = getrights($cgi,$forum); + if ($user ne $forum->{authenticated}{user} && + $rights ne "admin") { + show_error($forum,"У вас нет прав на изменение профиля этого + пользователя"); + } + my %base; + dbmopen %base,datafile($forum,"passwd"),0644; + if (!$base{$user}) { + show_error($forum,"Несуществующий пользователь $user"); + } + my $userinfo = thaw $base{$user}; + $userinfo->{user}=$user; + # + # If password fields are filled, change password + # + if ($cgi->param('pass1')) { + if ($cgi->param('pass1') eq $cgi->param('pass2')) { + $userinfo->{passwd}=crypt_password($cgi->param('pass1')); + } else { + form_error($formname,$cgi,$forum,"Ошибка при вводе пароля"); + } + } + make_profile($formname,$cgi,$forum,$userinfo,$rights eq "admin"); + delete $userinfo->{user}; + $base{$user} = freeze $userinfo; + dbmclose %base; + show_profile($formname,$cgi,$forum); +} +# # Обработка результатов заполнения формы регистрации. # # @@ -640,6 +821,7 @@ sub register { } } } + $cgi->delete("required"); my %userbase; dbmopen %userbase,datafile($forum,"passwd"),0644 or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!"); @@ -647,35 +829,50 @@ sub register { dbmclose %userbase; form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято"); } - if ($cgi->param("email") && ! Email::Valid->address($cgi->param("email"))) { - form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес"); + my $userinfo = {passwd=>crypt_password($cgi->param('pass1'))}; + make_profile($formname,$cgi,$forum,$userinfo,0); + $userinfo->{registered} = time; + set_default_user_attrs($forum,$userinfo); + print STDERR "stilllife forum: registering user $user\n"; + $userbase{$user} = freeze($userinfo); + dbmclose %userbase; + if (!defined $forum->{denied_status} || $userinfo->{status} ne + $forum->{denied_status}) { + newsession(undef,$forum,$user); + forum_redirect($cgi,$forum,$cgi->param("returnto")); + } else { + # FIXME Email validation + # Email to admin + show_template("newuser",$cgi,$forum); } - my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./'; - my $salt = substr($saltstring,int(rand(64)),1). - substr($saltstring,int(rand(64)),1); - my $password=crypt($cgi->param("pass1"),$salt); - my $userinfo = {passwd=>$password}; +} +sub make_profile { + my ($formname,$cgi,$forum,$userinfo,$isadmin) =@_; # Удаляем лишние поля - $cgi->delete("required"); - $cgi->delete("register"); - $cgi->delete("user"); - $cgi->delete("pass1"); - $cgi->delete("pass2"); foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) { if (!$cgi->param($field)) { $cgi->delete($field); } } - my $returnto = $cgi->param("returnto"); - $cgi->delete("returnto"); + if ($cgi->param("email") && ! Email::Valid->address($cgi->param("email"))) { + form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес"); + } + my $user = $userinfo->{user}; + my $userprefix=$user; + $userprefix=~tr!\\/: !_!; # Если есть аватар в файле, то сохраняем этот файл и формируем URL # на него. + $cgi->delete($formname); + $cgi->delete("user"); + $cgi->delete("pass1"); + $cgi->delete("pass2"); if ($cgi->param("avatarfile" )) { my $f = $cgi->upload("avatarfile"); binmode $f,":bytes"; my $out; my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/; - open $out,">",$forum->{"userdir"}."/".$filename; + my $path = $forum->{"userdir"}."/".$userprefix."_".$filename; + open $out,">",$path; binmode $out,":bytes"; my $buffer; while (my $bytes = read($f,$buffer,4096)) { @@ -683,24 +880,114 @@ sub register { } close $f; close $out; - $userinfo->{'avatar'}= $forum->{"userurl"}."/".$filename; - $cgi->delete("avatar"); - $cgi->delete("avatarfile"); + my ($w,$h) = imgsize($path); + $userinfo->{'avatar'}= {src=>$forum->{"userurl"}."/".$userprefix."_".$filename, + width=>$w,height=>$h}; + } elsif ($cgi->param('avatar')) { + if (!ref($userinfo->{'avatar'}) || + $userinfo->{avatar}{'src'} ne $cgi->param('avatar')) { + $userinfo->{avatar}=get_avatar_info($cgi->param('avatar')); + } } - + my @restrict=(); + @restrict = split /\s*,\s*/, $forum->{restricted_user_info} + unless $isadmin; + foreach my $param ($cgi->param) { - $userinfo->{$param} = $cgi->param($param); - } - $userinfo->{registered} = time; - if (exists $forum->{default_status}) { - $userinfo->{status} = $forum->{default_status}; + next if (grep $_ eq $param,@restrict); + next if $param eq 'avatar'; + next if $param eq 'avatarfile'; + next if $param eq 'returnto'; + next if $param =~ /_format$/; + if (defined $cgi->param("${param}_format")) { + my $tree = input2tree($cgi,$forum,$param); + $userinfo->{$param} = tree2str($tree); + $tree->delete(); + } else { + $userinfo->{$param} = $cgi->param($param); + } } - print STDERR "stilllife forum: registering user $user\n"; - $userbase{$user} = freeze($userinfo); - dbmclose %userbase; - newsession(undef,$forum,$user); - forum_redirect($cgi,$forum,$returnto) +} +sub crypt_password { + my $open_password=shift; + my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./'; + my $salt = substr($saltstring,int(rand(64)),1). + substr($saltstring,int(rand(64)),1); + my $password=crypt($open_password,$salt); + return $password; } + +sub set_default_user_attrs { + my ($forum,$userinfo) = @_; + while (my($key,$val) = each %$forum) { + next unless $key =~ /^default_(.*)$/; + $userinfo->{$1} = $val; + } +} + +sub show_user_page { + my ($cgi,$forum) = @_; + my $rights; + $rights=getrights($cgi,$forum) if ($forum->{authenticated}); + my %base; + my $tree; + dbmopen %base,datafile($forum,"passwd"),0664; + if ($path_translated eq $forum->{userdir}) { + # показать список пользователей + $tree = gettemplate($forum,"userlist"); + my $usertpl = $tree->look_down(class=>"userinfo"); + my $userlist = $usertpl->parent; + $usertpl->detach; + for my $user (sort keys %base) { + my $block = $usertpl->clone; + $userlist->push_content($block); + my $userinfo =thaw($base{$user}); + $userinfo->{"user"} = $user; + substitute_user_info($block,$forum,$userinfo); + profile_links($block,$user,$rights,$cgi,$forum); + } + $usertpl->delete; + } else { + my $user = substr($path_translated,length($forum->{userdir})+1); + if (!$base{$user}) { + print $cgi->header(-status=>"404 NOT FOUND"); + exit; + } + my $userinfo = thaw($base{$user}); + $userinfo->{"user"} = $user; + $tree = gettemplate($forum,"user"); + substinfo($tree,[_tag=>"title"],_content=>"Stilllife user: $user"); + substitute_user_info($tree,$forum,$userinfo); + profile_links($tree,$user,$rights,$cgi,$forum); + unless ($userinfo->{openiduser}) { + for my $userlink ($tree->look_down(_tag => "a",class=>"author")) { + $userlink->attr("href",undef); + $userlink->tag("span"); + } + } + } + my $page = output_html($tree); + my $length = do {use bytes; length($page);}; + print $cgi->header(-type=>"text/html",-content_length=>$length, + -charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())), + $page; +} +sub profile_links { + my ($tree,$user,$rights,$cgi,$forum)=@_; + foreach my $profile_link ($tree->look_down(_tag=>"a", + href=>qr/profile=/)) { + if ((defined $rights && $rights eq "admin")|| + (defined $forum->{authenticated}{user} && + $forum->{authenticated}{user} eq $user)) { + + $profile_link->attr("href", + $ENV{'SCRIPT_NAME'}.$forum->{userurl}. + "/".$user."?profile=1"); + } else { + $profile_link->delete(); + } + } +} sub clear_user_cookies { my ($cgi,$forum) = @_; $forum->{cookies}=[ $cgi->cookie(-name=>"sluser", -value=>"0", @@ -743,17 +1030,11 @@ sub allow_operation { } my $user = $forum->{authenticated}{user} ; my $accesslevel=getrights($cgi,$forum); - # Если permissions{$operation} равны author, нам нужно извлечь - # текст из соответствующего файла и положить его в - # cgi->param("text"); Заодно определим и автора - my ($itemauthor,$itemtext)=get_message_by_id($cgi->param("id")) if - $permissions{$operation} eq "author"; return 1 if ($accesslevel eq "admin"); return 0 if ($permissions{$operation} eq "admin"); return 1 if ($accesslevel eq "moderator"); return 0 if $accesslevel eq "banned"; - return 0 if $permissions{$operation} eq "author" && $user ne $itemauthor; return 1; } @@ -776,7 +1057,7 @@ sub reply { # # Генерируем идентификатор записи. # - my $id = get_uid($forum); + my $id = "m".get_uid($forum); # @@ -849,8 +1130,9 @@ sub reply { show_error($forum,"В форме управления сообщением нет поля author"); } # Подставляем mdate + my $posted = strftime("%d.%m.%Y %H:%M",localtime()); substinfo($newmsg,["class"=>"mdate"], - _content =>strftime("%d.%m.%Y %H:%M",localtime())); + _content =>$posted); # Подставляем mreply substinfo($newmsg,[_tag=>"a","class"=>"mreply"],"href" => $cgi->url(-absolute=>1,-path_info=>1)."?reply=1&id=$id"); @@ -860,7 +1142,7 @@ sub reply { show_error($forum,"В шаблоне сообщения отсутствует якорь для ссылок на него"); # подставляем mlink substinfo($newmsg,[_tag=>"a","class"=>"mlink"], - href=>$cgi->path_info."#id"); + href=>$cgi->path_info."#$id"); # подставляем mparent my $parent_id=$cgi->param("id"); if ($parent_id) { @@ -870,14 +1152,62 @@ sub reply { substinfo($newmsg,[_tag => "a",class=>"mparent"], style=>"display: none;"); } - + my $msgcount=0; + for my $msg ($newmsg->parent->look_down("class"=>"message")) { + $msgcount ++; + } + # # Делаем Уфф и сохраняем то, что получилось # + $newmsg = $newmsg->clone; savetree($path_translated,$tree,$lockfd); + record_as_recent($forum,$newmsg); record_statistics($forum,"message"), - forum_redirect($cgi,$forum); - + update_topic_list($forum,$path_translated,$msgcount,$posted); + forum_redirect($cgi,$forum,$cgi->path_info."#$id"); +} +sub update_topic_list { + my ($forum,$topic,$count,$date) = @_; + my ($tree,$lockfd,$block,$index); + if (!ref ($topic)) { + # Если $topic - имя файла, найдем соответствующий индекс и в нем + # элемент с соответствующим id; + my ($dir,$id)=($1,$2) if $topic =~/(.+)\/([^\/]+).html/; + $index = $dir."/".$forum->{indexfile}; + ($tree,$lockfd) = gettree($index); + $block = $tree->look_down("id"=>$id); + return unless $block; + } else { + # Иначе нам передали кусок готового распарсенного дерева + $block = $topic; + } + substinfo($block,[class=>"msgcount"],_content=>$count); + substinfo($block,[class=>"last-updated"],_content=>$date); + # и если мы парсили дерево, то мы его и сохраняем + savetree($index,$tree,$lockfd); +} + +sub record_as_recent { + my ($forum,$msg) = @_; + my ($tree,$lockfd) = gettree($forum->{forumroot}."/recent.html"); + my $msglist = $tree->look_down("class"=>"messagelist"); + if ($msglist) { + my $style = $msglist->attr("style"); + if ($style && $style =~ s/display: none;//) { + $msglist->attr("style",$style); + $msglist->look_down(class=>"message")->replace_with($msg); + } else { + my @msgs = $msglist->look_down("class"=>"message"); + if (@msgs >= $forum->{replies_per_page}) { + for (my $i=$#msgs;$i>=$forum->{replies_per_page}-1;$i--) { + $msgs[$i]->delete; + } + } + $msgs[0]->preinsert($msg); + } + } + savetree($forum->{forumroot}."/recent.html",$tree,$lockfd); } # # Обработка операции создания новой темы. @@ -905,13 +1235,15 @@ sub new_topic { form_error($form,$cgi,$forum,"Тема с urlname $urlname уже существует"); } + my $url = $cgi->path_info."/$urlname.html"; + $url =~ s/\/+/\//g; if (!$cgi->param("title")) { form_error($form,$cgi,$forum,"Тема должна иметь непустое название"); } # # Создаем собственно тему # - my $tree = gettemplate($forum,"topic",$cgi->path_info."/$urlname.html"); + my $tree = gettemplate($forum,"topic",$url); # Заполнить название и аннотацию my $abstract = input2tree($cgi,$forum,"abstract"); substinfo($tree,[_tag=>"meta","name"=>"description"],content=>$abstract->as_trimmed_text); @@ -934,10 +1266,10 @@ sub new_topic { # Скрыть список сообщений. hide_list($tree,"messagelist"); savetree($filename,$tree,undef); + $tree->destroy; # # Добавляем элемент в список тем текущего форума # - $tree->destroy; my $lockfd; ($tree,$lockfd)=gettree($path_translated."/".$forum->{"indexfile"}); @@ -950,15 +1282,300 @@ sub new_topic { $newtopic->attr("id",$urlname); my $controlform = $newtopic->look_down(_tag=>"form",class=>"topicinfo"); if ($controlform) { - $controlform->attr("action"=>$cgi->url(-absolute=>1,-path_info=>1). - "/$urlname.html"); + $controlform->attr("action"=>$cgi->url(-absolute=>1,-path_info=>0, + -query_string=>0).$url); substinfo($controlform,[_tag=>"input",name=>"author"],value=> $forum->{authenticated}{user}); } + update_topic_list($forum,$newtopic,0,$creation_time); savetree($path_translated."/".$forum->{"indexfile"},$tree,$lockfd); record_statistics($forum,"topic"); - forum_redirect($cgi,$forum,$cgi->path_info."/$urlname.html"); + forum_redirect($cgi,$forum,$cgi->url(-base=>1).$url); } + +sub new_forum { + my ($form,$cgi,$forum) = @_; + # + # Проверяем корректность urlname и прочих полей + # + my $urlname; + if (!$cgi->param("urlname")) { + form_error($form,$cgi,$forum,"Форуму необходимо задать непустое urlname"); + } + if ($cgi->param("urlname") eq ".") { + $urlname = "." + } else { + $urlname=$1 if $cgi->param("urlname") =~ /^([-\w]+)$/ ; + form_error($form,$cgi,$forum,"Некорректные символы в urlname. + Допустимы только латинские буквы, цифры и минус") unless $urlname; + } + if (!-d $path_translated) { + show_error($forum,"Операция $form может быть вызвана только со + страницы форума"); + } + my $newname = "$path_translated/$urlname"; + $newname=$path_translated if ($urlname eq "."); + my $filename = "$newname/$forum->{indexfile}"; + if (-f $filename) { + form_error($form,$cgi,$forum,"Форум $urlname уже существует"); + } + if (!$cgi->param("title")) { + form_error($form,$cgi,$forum,"Форум должен иметь непустое название"); + } + mkdir $newname unless -d $newname; + # + # Сохраняем логотип + # + my ($logo_name,$logo_width,$logo_height); + if ($cgi->param("logo")) { + my $userpath = $cgi->param("logo"); + $logo_name="logo.".lc($1) if $userpath=~/\.([^.]+)$/; + my $in = $cgi->upload("logo"); + if (!$in) { + show_error($forum,"Ошибка при загрузке картинки $userpath"); + exit; + } + my $out; + open $out,">$newname/$logo_name"; + binmode $out,":bytes"; + local $/=undef; + my $data = <$in>; + print $out $data; + close $in; + close $out; + ($logo_width,$logo_height) = imgsize("$newname/$logo_name"); + } else { + $logo_name = $forum->{"templatesurl"}."/1x1.gif"; + $logo_width = 1; + $logo_height=1; + } + + + # + # Создаем собственно оглавление форума + # + + my $url = $cgi->path_info."/$urlname"; + $url= $cgi->path_info if $urlname eq "."; + $url =~ s/\/+/\//g; + my $tree = gettemplate($forum,"forum",$url); + # Удалить элементы, который присутствуют только на главной странице + if ($urlname ne ".") { + for my $element ($tree->look_down("class"=>"top-page")) { + $element->delete; + } + } + # Заполнить название и аннотацию + my $abstract = input2tree($cgi,$forum,"abstract"); + substinfo($tree,[_tag=>"meta","name"=>"description"],content=>$abstract->as_trimmed_text); + substinfo($tree,[_tag=>"title"],_content=>$cgi->param("title")); + my $subtree = $tree->look_down("class"=>"annotation") + or show_error($forum,"В шаблоне форума отсутствует класс annotation"); + my $creation_time=strftime("%d.%m.%Y %H:%M",localtime()); + substinfo($subtree,["class"=>"title"], + _content=>$cgi->param("title")); + substinfo($subtree,["class"=>"date"], + _content=>$creation_time); + # Вставляем в страницу КОПИЮ аннотации, поскольку аннотация + # нам еще понадобится в списке тем. + substinfo($subtree,["class"=>"abstract"],_content=>$abstract->clone); + substitute_user_info($subtree,$forum); + substinfo($subtree,[_tag=>"img","class"=>"logo"], + src=> $logo_name, width=>$logo_width, height=>$logo_height); + # Скрыть списки подфорумов и тем . + hide_list($tree,"forumlist"); + hide_list($tree,"topiclist"); + if ($urlname eq ".") { + for my $link_up ($tree->look_down(_tag=>"a",href=>"..")) { + $link_up->delete; + } + } + savetree($filename,$tree,undef); + $tree->destroy; + # + # Добавляем элемент в список тем текущего форума + # + if ($urlname ne ".") { + my $lockfd; + ($tree,$lockfd)=gettree($path_translated."/".$forum->{"indexfile"}); + my $newforum = newlistelement($tree,"forum","forumlist"); + substinfo($newforum,[_tag=>"a","class"=>"title"], + _content=>$cgi->param("title"), href=>"$urlname/"); + substinfo($newforum,["class"=>"date"], _content=>$creation_time); + substinfo($newforum,["class"=>"abstract"],_content=>$abstract); + substinfo($newforum,[_tag=>"img","class"=>"logo"],src=>"$urlname/$logo_name", + width=>$logo_width,height=>$logo_height); + substitute_user_info($newforum,$forum); + $newforum->attr("id",$urlname); + my $controlform = $newforum->look_down(_tag=>"form",class=>"foruminfo"); + if ($controlform) { + $controlform->attr("action"=>$cgi->url(-absolute=>1,-path_info=>0). + $url); + substinfo($controlform,[_tag=>"input",name=>"author"],value=> + $forum->{authenticated}{user}); + } + savetree($path_translated."/".$forum->{"indexfile"},$tree,$lockfd); + record_statistics($forum,"forum"); + } else { + # Создаем тему для "свежих реплик" + my $recent = gettemplate($forum,"topic",$url."/recent.html"); + # remove reply link from page itself + for my $link ($recent->look_down(_tag =>"a", href=>qr/reply=/)) { + $link->delete; + } + substinfo($recent,["_tag"=>"title"],$cgi->param("title").": Свежие сообщения"); + substinfo($recent,["class"=>"title"], + _content=>$cgi->param("title"). ": Свежие сообщения"); + hide_list($recent,"messagelist"); + savetree($path_translated."/recent.html",$recent,undef); + + } + + forum_redirect($cgi,$forum,$cgi->url(-base=>1).$url); +} + +# +# Обработка операции удаления всего на свете +# +sub delete_item { + my ($formname,$cgi,$forum) = @_; + # + # Сначала разберемся, что мы собственно удаляем + # + if ($cgi->param("user")) { + delete_user($cgi,$forum,$cgi->param("user")); + } elsif (-f $path_translated) { + if ($cgi->param("id")) { + delete_comment($cgi,$forum,$path_translated,$cgi->param("id")); + } else { + delete_topic($cgi,$forum,$path_translated); + } + } elsif (-d $path_translated && -f $path_translated ."/". $forum->{indexfile}) { + delete_forum($cgi,$forum,$path_translated); + } else { + show_error($forum,"Невозможно удалить неопознанный объект"); + } +} +# +# Удаление пользователя +# +sub delete_user { + my ($cgi,$forum,$user) = @_; + if ($forum->{authenticated}{user} ne $user && + getrights($cgi,$forum) ne "admin") { + show_error($forum,"У вас недостаточно прав для удаления + пользователя $user"); + } + my %base; + dbmopen %base,datafile($forum,"passwd"),0644; + delete $base{$user}; + dbmclose %base; + forum_redirect($cgi,$forum,$forum->{forumtop}); +} +# +# Удаление реплики +# +sub delete_comment { + my ($cgi,$forum,$topic,$id) = @_; + my ($tree,$lockfd) = gettree($topic); + my ($msg) = $tree->look_down(id => $id); + show_error("В данной теме нет реплики с id=$id") if (!$msg); + if (getrights($cgi,$forum) ne "moderator" + && getrights($cgi,$forum) ne "admin") { + my $author= $msg->look_down(_tag=>"input",name=>"author"); + if ($author->attr("value") ne $forum->{authenticated}{user}) { + show_error($forum,"У вас нет прав на удаление этого сообщения"); + } + } + delete_from_list($tree,"messagelist","message",$msg); + savetree($topic,$tree,$lockfd); + $tree->delete; + ($tree,$lockfd) = gettree($forum->{forumroot}."/recent.html"); + ($msg) = $tree->look_down(id => $id); + if ($msg) { + delete_from_list($tree,"messagelist","message",$msg); + savetree($forum->{forumroot}."/recent.html",$tree,$lockfd); + } else { + discardtree($tree,$lockfd); + } + # Если у реплики были картинки, то их тоже надо грохнуть + for my $pic (<$id."_*.*">) { + unlink $pic; + } + forum_redirect($cgi,$forum,$cgi->path_info); +} +# +# Удаление темы +# +sub delete_topic { + my ($cgi,$forum,$topic) = @_; + # Если модератор, то в тему и не заглядываем + my ($dir,$id) = ($1,$2) if $topic=~/^(.*)\/([^\/]+).html$/; + show_error($forum,"Неверное имя темы $topic") unless ($dir && $id); + if (getrights($cgi,$forum) ne "moderator" && + getrights($cgi,$forum) ne "admin") { + # Проверяем авторство темы и наличие в ней сообщений + my ($tree,$lockfd) = gettree($topic); + my $info = $tree->look_down(class=>"topic"); + my $author = $tree->look_down(class=>"author"); + if ($author->as_text() ne $forum->{authenticated}{user}) { + show_error($forum,"У вас нет права удалять эту тему"); + } + $info = $tree->look_down(class=>"messagelist"); + if ($info->attr("style") !~ /display: none;/) { + show_error($forum,"Невозможно удалить тему, содержащую сообщения"); + } + discardtree($tree,$lockfd); + } # FIXME при удалении непустой темы модератором почистить recent.html + my ($tree,$lockfd) = gettree($dir . "/".$forum->{indexfile}); + delete_from_list($tree,"topiclist","topic",$id); + savetree($tree,$dir ."/".$forum->{indexfile}); + unlink $topic; + my $redirect_url = $cgi->path_info; + $redirect_url =~ s/\/[^\/]*$//; + forum_redirect($cgi,$forum,$redirect_url); +} +# +# Удаление форума +# +sub delete_forum { + my ($cgi,$forum,$dir) = @_; + if (getrights($cgi,$forum) ne "moderator" && getrights($cgi,$forum) + ne "admin") { + show_error($forum,"У вас нет права удалять форумы"); + } + opendir DIR,$dir; + my $count = 0; + while ( my $entry=readdir DIR) { + next if $entry eq $forum->{indexfile}; + next if $entry eq "perms.txt"; + next if $entry =~ /^logo.[^.]+/; + show_error($forum,"Нельзя удалять корень форума" ) + if $entry eq ".forum"; + $count ++; + } + closedir DIR; + show_error("Нельзя удалять непустой форум") if $count; + # Находим родительский форум + my $upper = $dir; + $upper=~s/([\/]+)$/$forum->{indexfile}/; + my $id = $1 if $dir =~ /\/([\/]+)$/; + # Удаляем форум из списка. + my ($tree,$lockfd) = gettree($upper); + delete_from_list($tree,"forumlist","forum",$id); + savetree($upper,$tree,$lockfd); + # Удаляем из файловой системы + opendir DIR,$dir; + for my $entry ( readdir DIR) { + unlink "$dir/$entry"; + } + rmdir $dir; + my $redirect_url = $cgi->path_info; + $redirect_url =~s/\/$//; + $redirect_url =~ s/\/[^\/]*$//; + forum_redirect($cgi,$forum,$redirect_url); +} + #---------------------------------------------------------- # База пользователей и права доступа #---------------------------------------------------------- @@ -987,8 +1604,11 @@ sub getrights { if (!$forum->{authenticated}) { return undef; } + return $forum->{authenticated}{rights} if + exists $forum->{authenticated}{rights}; my $user = $forum->{authenticated}{user}; - my $dir = $ENV{'PATH_TRANSLATED'}; + my $dir = $path_translated; + $dir =~s/\/$//; $dir =~s/\/[^\/]+$// if (!-d $dir); my $f; my $user_status = "normal"; @@ -1004,10 +1624,10 @@ sub getrights { chomp; if ($user eq $_ && defined $status) { if ($status eq "banned") { - return $status; + return $forum->{authenticated}{rights}=$status; } if ($status eq "admins" ) { - return "admin"; + return $forum->{authenticated}{rights}="admin"; } $user_status = "moderator"; } @@ -1015,11 +1635,11 @@ sub getrights { } close $f; last LEVEL if -f "$dir/.forum"; - # Strip last path component. - $dir =~s/\/[^\/]+$// } + # Strip last path component. + $dir =~s/\/[^\/]+$// } - return $user_status; + return $forum->{authenticated}{rights}=$user_status; } @@ -1038,7 +1658,8 @@ sub gettree { my $f; open $f,"<",$filename or return undef; flock $f, LOCK_EX; - my $tree = HTML::TreeBuilder->new_from_file($f); + my $tree = treefromfile($f); + $tree->parse_file($f); return ($tree,$f); } # @@ -1050,13 +1671,29 @@ sub savetree { my ($filename,$tree,$lockfd) = @_; my $f; open $f,">",$filename . ".new" or return undef; - print $f $tree->as_HTML("<>&"); + print $f output_html($tree); close $f; # FIXME - только для POSIX. unlink $filename; rename $filename.".new",$filename; close $lockfd if defined($lockfd); } + +sub discardtree { + my ($tree,$lockfd) = @_; + flock $lockfd,LOCK_UN; + close $lockfd; + $tree->delete; +} +# +# Cериализовать HTML-документ с DOCTYPE (workaround вокруг баги в +# HTML::TreeBuilder) +# +sub output_html { + my $tree=shift; + return ''. + $tree->as_HTML("<>&"); +} # # Читает шаблон и подготавливает его к размещению по указанной URL. # Если url не указана, считается что шаблон будет показан как результат @@ -1064,17 +1701,39 @@ sub savetree { sub gettemplate { my ($forum, $template,$url) = @_; + $url =~ s/\/+/\//g if defined $url; my $filename=$forum->{"templates"}."/$template.html"; if (! -r $filename) { show_error($forum,"Нет шаблона $template"); exit; } - my $tree = HTML::TreeBuilder->new_from_file($filename); + my $tree = treefromfile($filename); fix_forum_links($forum,$tree,$url); return $tree; } +# +# Создает объект HTML::TreeBuilder и выставляет ряд опций. +# + +sub make_tree { + my $tree = HTML::TreeBuilder->new; + # Set some options for treebuilder + # Comments are neccessary to convert HTML back to BBCode + $tree->store_comments(1); + # Avoid converting html into one long-long string + $tree->ignore_ignorable_whitespace(0); + $tree->no_space_compacting(1); + $tree->p_strict(1); + return $tree; +} +sub treefromfile { + my ($f) = shift; + my $tree = make_tree(); + $tree->parse_file($f); + return $tree; +} # # Получает уникальный числовой идентификатор. # @@ -1097,12 +1756,13 @@ sub get_uid { sub create_openid_consumer { my ($cgi,$forum) = @_; return Net::OpenID::Consumer ->new( - ua => LWP::UserAgent->new(), + ua => LWP::UserAgent->new( agent => "Stilllife/1.0"), args => $cgi, consumer_secret=>"X9RWPo0rBE7yLja6VB3d", required_root => $cgi->url(-base=>1)); } + # openidstart - вызывается когда обнаружено что текущее имя # пользователя, пытающегося аутентифицироваться, содержит http:// # @@ -1158,11 +1818,25 @@ sub openid_verify { my $username = $user; $username =~ s/^http:\/\///; if (!$userbase{$username}) { - $userbase{$username} = freeze($forum->{authenticated}={"openiduser"=>1}); + # Тащим foaf, если получится + my %info=get_foaf($csr->ua,$vident->declared_foaf); + if (ref($info{'avatar'}) eq "HASH" ) { + delete $info{'avatar'}{'type'}; + } + $info{"openiduser"}=1; + $info{"registered"}=time; + set_default_user_attrs($forum,\%info); + $info{'status'} = $forum->{openid_status} if $forum->{openid_status}; + $forum->{authenticated}=\%info; + $userbase{$username} = freeze(\%info); } else { $forum->{authenticated} = thaw ($userbase{$username}); } dbmclose %userbase; + if (defined $forum->{denied_status} && + ($forum->{authenticated}{status} eq $forum->{denied_status})) { + show_error($forum,"Вход пользователя $username в систему заблокирован"); + } $forum->{"authenticated"}{"user"} = $username; newsession(undef,$forum,$user); # Если указан параметр reply, вызываем обработку реплики @@ -1177,6 +1851,51 @@ sub openid_verify { exit; } } + +sub get_avatar_info { + my ($url,$ua) = @_; + $ua = LWP::UserAgent->new( agent => "Stilllife/1.0") unless $ua; + my $response = $ua->get($url); + if ($response->is_success) { + my $image = $response->content; + my ($w,$h,$type) = imgsize(\$image); + return {width=>$w,height=>$h,type=>$type,src=>$url}; + } else { + print STDERR "Error getting $url: ".$response->status_line,"\n"; + return undef; + } +} + +sub get_foaf { + my ($ua,$foaf_url) = @_; + my $response = $ua->get($foaf_url); + unless ($response->is_success) { + print STDERR "Error geting foaf from $foaf_url\n"; + return (); + } + my $foaf = $response->content; + my %info = foaf_parse($foaf); + if ($info{avatar}) { + $info{avatar} = get_avatar_info($info{avatar},$ua); + } + return %info; +} + +sub foaf_parse { + my $foaf = shift; + my ($starttag) = $foaf =~ /<(\w+(:\w+)?[^>]+)>/sg; + my %ns = reverse ($starttag =~ /xmlns:(\w+)="([^"]+)"/sg); + my $foaf_prefix = $ns{"http://xmlns.com/foaf/0.1/"}; + my $rdf_prefix = $ns{"http://www.w3.org/1999/02/22-rdf-syntax-ns#"}; + my ($userpic) = $foaf=~/<$foaf_prefix:img[^>]* $rdf_prefix:resource="([^"]+)"/s; + my @info; + push @info, avatar =>$userpic if $userpic; + my ($icq) = $foaf =~/<$foaf_prefix:icqChatID>([^<]*)<\/$foaf_prefix:icqChatID>/s; + push @info, icq => $icq if ($icq); + my ($jabber) = $foaf =~/<$foaf_prefix:jabberID>([^<]*)<\/$foaf_prefix:jabberID>/s; + push @info, jabber => $jabber if ($jabber); + return @info; +} #----------------------------------------------------------------- # Обработка форматированных текстовых полей #----------------------------------------------------------------- @@ -1209,13 +1928,18 @@ sub input2tree { sub str2tree { my ($data)=@_; - my $tree = HTML::TreeBuilder->new(); + my $tree = make_tree(); + $tree->ignore_ignorable_whitespace(1); # Set parser options here $tree->parse("

$data
"); $tree->eof; my $element=$tree->find("body"); while (($element =($element->content_list)[0])->tag ne "div") { } + while ($element->content_list==1&& $element->tag eq "div" && + !defined $element->attr("style")) { + $element = ($element->content_list)[0] + } $element->detach; $tree->destroy; return $element; @@ -1266,6 +1990,24 @@ sub hide_list { return 1; } # +# Удаляет из списка элемент, если он не последий. Если последний - +# скрывает весь список. Элемент можно указывать как ссылкой на объект +# HTML::Element, так и значением атрибута id +# +sub delete_from_list { + my ($tree,$listclass,$itemclass,$item) = @_; + my $list = $tree->look_down(class =>$listclass); + ($item) = $list->look_down(id =>$item) unless ref($item); + return undef unless $item; + my (@items)=$tree->look_down(class=>$itemclass); + if (@items == 1) { + hide_list($tree,$listclass); + } else { + $item->delete; + } + return 1; +} +# # Найти все элементы, удоволетворяющие заданному критерию и подставить в # них указанные атрибуты # @@ -1322,3 +2064,4 @@ sub newlistelement { return undef; } } +