]>
git.p6c8.net - selfforum.git/blob - selfforum-cgi/shared/Posting/_lib.pm
3 ################################################################################
5 # File: shared/Posting/_lib.pm #
7 # Authors: André Malo <nd@o3media.de> #
8 # Frank Schönmann <fs@tower.de> #
10 # Description: Message access interface, time format routines #
12 ################################################################################
19 use Encode
::Plain
; $Encode::Plain
::utf8
= 1;
21 use Time
::German
qw(localtime);
24 ################################################################################
32 sub VERSION
{(q
$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'}
34 ################################################################################
38 use constant SORT_ASCENT
=> 0; # (latest postings first)
39 use constant SORT_DESCENT
=> 1;
40 use constant KEEP_DELETED
=> 1;
41 use constant KILL_DELETED
=> 0;
43 use constant FORUM_DTD
=> 'http://selfforum.sourceforge.net/dtd/forum.dtd';
45 use base
qw(Exporter);
63 create_forum_xml_string
73 ################################################################################
78 ### sub create_message ($$) ####################################################
80 # create the 'Message' subtree
82 # Params: $xml - XML::DOM::Document object
83 # $par - hash reference
84 # (msg, ip, name, email, home, image, category, subject, time)
86 # Return: XML::DOM::Element object
88 sub create_message
($$) {
91 my $message = $xml -> createElement
('Message');
92 $message -> setAttribute
('id' => $par -> {msg
});
93 $message -> setAttribute
('ip' => $par -> {ip
});
95 my $header = $xml -> createElement
('Header');
96 my $author = $xml -> createElement
('Author');
97 $header -> appendChild
($author);
100 ['name' => 'Name' => $author],
101 ['email' => 'Email' => $author],
102 ['home' => 'HomepageUrl' => $author],
103 ['image' => 'ImageUrl' => $author],
104 ['category' => 'Category' => $header],
105 ['subject' => 'Subject' => $header]
106 );# key => element name => superior
111 my $obj = $xml -> createElement
($_->[1]);
115 defined $par -> {$_->[0]}
120 # link to superior element
121 $_ -> [2] -> appendChild
($obj);
124 my $date = $xml -> createElement
('Date');
125 $date -> setAttribute
('longSec'=> $par -> {time});
127 $header -> appendChild
($date);
128 $message -> appendChild
($header);
135 ### sub create_new_thread ($) ##################################################
137 # create a XML::DOM::Document object of a thread containing one posting
139 # Params: hash reference
140 # (thread, msg, body, ip, name, email, home,
141 # image, category, subject, time)
143 # Return: XML::DOM::Document object
145 sub create_new_thread
($) {
150 my $xml = new XML
::DOM
::Document
;
154 my $decl = new XML
::DOM
::XMLDecl
;
155 $decl -> setVersion
('1.0');
156 $decl -> setEncoding
('UTF-8');
157 $xml -> setXMLDecl
($decl);
161 my $dtd = $xml -> createDocumentType
('Forum' => FORUM_DTD
);
162 $xml -> setDoctype
($dtd);
164 # create root element 'Forum'
165 # create element 'Thread'
166 # create 'Message' subtree
167 # create element 'ContentList'
168 # create 'MessageContent' subtree
170 my $forum = $xml -> createElement
('Forum');
171 my $thread = $xml -> createElement
('Thread');
172 $thread -> setAttribute
('id' => $par -> {thread
});
173 my $message = create_message
($xml,$par);
174 my $content = $xml -> createElement
('ContentList');
175 my $mcontent = $xml -> createElement
('MessageContent');
176 $mcontent -> setAttribute
('mid' => $par -> {msg
});
177 $mcontent -> appendChild
(
178 $xml -> createCDATASection
(${$par -> {body
}})
181 # link all the nodes to
182 # their superior elements
184 $thread -> appendChild
($message);
185 $forum -> appendChild
($thread);
186 $content -> appendChild
($mcontent);
187 $forum -> appendChild
($content);
188 $xml -> appendChild
($forum);
195 ### get_message_header () ######################################################
197 # Read message header, return as a hash
199 # Params: $node - XML message node
200 # Return: hash reference (name, category, subject, email, home, image, time)
202 sub get_message_header
($)
207 my $header = $node -> getElementsByTagName
('Header' , 0) -> item
(0);
208 my $author = $header -> getElementsByTagName
('Author' , 0) -> item
(0);
209 my $name = $author -> getElementsByTagName
('Name' , 0) -> item
(0);
210 my $email = $author -> getElementsByTagName
('Email' , 0) -> item
(0);
211 my $home = $author -> getElementsByTagName
('HomepageUrl', 0) -> item
(0);
212 my $image = $author -> getElementsByTagName
('ImageUrl' , 0) -> item
(0);
213 my $cat = $header -> getElementsByTagName
('Category' , 0) -> item
(0);
214 my $subject = $header -> getElementsByTagName
('Subject' , 0) -> item
(0);
215 my $date = $header -> getElementsByTagName
('Date' , 0) -> item
(0);
218 name
=> ($name -> hasChildNodes
)?
$name -> getFirstChild
-> getData
:undef,
219 category
=> ($cat -> hasChildNodes
)?
$cat -> getFirstChild
-> getData
:undef,
220 subject
=> ($subject -> hasChildNodes
)?
$subject -> getFirstChild
-> getData
:undef,
221 email
=> (defined ($email) and $email -> hasChildNodes
)?
$email -> getFirstChild
-> getData
:undef,
222 home
=> (defined ($home) and $home -> hasChildNodes
)?
$home -> getFirstChild
-> getData
:undef,
223 image
=> (defined ($image) and $image -> hasChildNodes
)?
$image -> getFirstChild
-> getData
:undef,
224 time => $date -> getAttribute
('longSec')
230 ### get_body_node () ########################################################
232 # Search a specific message body in a XML tree
234 # Params: $xml XML::DOM::Document Object (Document Node)
237 # Return: MessageContent XML node (or -none-)
239 sub get_body_node
($$)
241 my ($xml, $mid) = @_;
243 for ($xml -> getElementsByTagName
('ContentList', 1) -> item
(0) -> getElementsByTagName
('MessageContent', 0)) {
244 return $_ if ($_ -> getAttribute
('mid') eq $mid);
250 ### get_message_body () ########################################################
254 # Params: $xml XML::DOM::Document Object (Document Node)
257 # Return: Scalar reference
259 sub get_message_body
($$)
261 my $cnode = get_body_node
($_[0], $_[1]);
264 $body = ($cnode -> hasChildNodes
)?
$cnode -> getFirstChild
-> getData
:'' if $cnode;
269 ### get_message_node () ########################################################
271 # Search a specific message in a XML tree
273 # Params: $xml XML::DOM::Document Object (Document Node)
277 # Return: Message XML node, Thread XML node (or -none-)
279 sub get_message_node
($$$)
281 my ($xml, $tid, $mid) = @_;
284 for ($xml->getElementsByTagName ('Thread')) {
285 if ($_->getAttribute ('id') eq $tid) {
288 for ($tnode -> getElementsByTagName
('Message')) {
289 if ($_ -> getAttribute
('id') eq $mid) {
303 ### sub parse_xml_file ($) #####################################################
305 # load the specified XML-File and create the DOM tree
306 # this sub is only to avoid errors and to centralize the parse process
308 # Params: $file filename
310 # Return: XML::DOM::Document Object (Document Node) or false
312 sub parse_xml_file
($) {
316 local $SIG{__DIE__
}; # CGI::Carp works unreliable ;-(
317 new XML
::DOM
::Parser
(KeepCDATA
=> 1)->parsefile ($file);
325 ### parse_single_thread () #####################################################
327 # parse a thread file
329 # Params: $tnode - Thread element node
330 # $deleted - keep deleted (boolean)
331 # $sorted - sorting order
335 sub parse_single_thread
($$;$) {
336 my ($tnode, $deleted, $sorted) = @_;
337 my ($header, @msg, %mno);
339 for ($tnode -> getElementsByTagName
('Message')) {
340 $header = get_message_header
($_);
343 mid
=> ($_ -> getAttribute
('id') =~ /(\d+)/)[0],
344 ip
=> $_ -> getAttribute
('ip'),
345 kids
=> [$_ -> getElementsByTagName
('Message', 0)],
346 answers
=> $_ -> getElementsByTagName
('Message') -> getLength
,
347 deleted
=> $_ -> getAttribute
('invisible'),
348 archive
=> $_ -> getAttribute
('archive'),
349 name
=> plain
($header -> {name
}),
350 cat
=> plain
($header -> {category
} or ''),
351 subject
=> plain
($header -> {subject
}),
352 time => plain
($header -> {time})
358 $msg[0] -> {level
} = 0;
360 $level = $_ -> {level
} + 1;
361 @
{$_ -> {kids
}} = map {$msg[$mno{$_}] -> {level
} = $level; $mno{$_}} @
{$_ -> {kids
}};
364 # sort and process deleted files
366 my $smsg = sort_thread
(\
@msg, $sorted);
367 delete_messages
($smsg) unless ($deleted);
372 ################################################################################
374 # Access via regexps and native perl ;)
377 ### sort_thread () #############################################################
379 # sort the message array
381 # Params: $msg - arrayref
382 # $sorted - sorting order
384 # Return: sorted arrayref
386 sub sort_thread
($$) {
387 my ($msg, $sorted) = @_;
389 my ($z, %mhash) = (0);
391 if ($sorted) { # oldest first
393 @
$msg[@
{$_ -> {kids
}}] = sort {$a -> {mid
} <=> $b -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
394 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
396 else { # latest first
398 @
$msg[@
{$_ -> {kids
}}] = sort {$b -> {mid
} <=> $a -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
399 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
403 my @smsg = ($msg -> [0]);
406 splice @smsg,$z,0,@
{$mhash{$_ -> {mid
}}} if ($_ -> {answers
});
414 ### delete_messages () #########################################################
416 # Filter out deleted messages
418 # Params: $smsg Reference of array of references of hashs
421 sub delete_messages
($) {
423 my ($z, $oldlevel, @path) = (0,0,0);
425 while ($z <= $#{$smsg}) {
427 if ($smsg -> [$z] -> {level
} > $oldlevel) {
429 $oldlevel = $smsg -> [$z] -> {level
};
431 elsif ($smsg -> [$z] -> {level
} < $oldlevel) {
432 splice @path, $smsg -> [$z] -> {level
};
434 $oldlevel = $smsg -> [$z] -> {'level'};
440 if ($smsg -> [$z] -> {deleted
}) {
441 my $n = $smsg -> [$z] -> {answers
} + 1;
442 $smsg -> [$_] -> {answers
} -= $n for (@path);
443 splice @
$smsg, $z, $n;
453 ### get_all_threads () #########################################################
455 # Read and Parse the main file (without any XML-module, they are too slow)
457 # Params: $file - /path/to/filename of the main file
458 # $deleted - hold deleted (invisible) messages in result (1) oder not (0)
459 # $sorted - direction of message sort: descending (0) (default) or ascending (1)
461 # Return: scalar context: hash reference (\%threads)
462 # list context: list (\%threads, $last_thread, $last_message, $dtd, \@unids)
464 sub get_all_threads
($$;$) {
465 my ($file, $deleted, $sorted) = @_;
466 my ($last_thread, $last_message, $dtd, @unids, %threads);
469 open FILE
,"< $file" or return;
470 my $xml = join '', <FILE
>;
471 close(FILE
) or return;
475 ($last_thread) = map {/(\d+)/} $xml =~ /<Forum.+?lastThread="([^"]+)"[^>]*>/;
476 ($last_message) = map {/(\d+)/} $xml =~ /<Forum.+?lastMessage="([^"]+)"[^>]*>/;
479 my $reg_msg = qr
~(?
:</Message
>
480 |<Message\s
+id
="m(\d+)"(?
:\s
+unid
="([^"]*)")?(?:\s+invisible="([^"]*)")?
(?
:\s
+archive
="([^"]*)")?[^>]*>\s*
481 <Header>[^<]*(?:<(?!Name>)[^<]*)*
482 <Name>([^<]+)</Name>[^<]*(?:<(?!Category>)[^<]*)*
483 <Category>([^<]*)</Category>\s*
484 <Subject>([^<]+)</Subject>\s*
485 <Date\s+longSec="(\d
+)"[^>]*>\s*
486 </Header>\s*(?:(<)/Message>|(?=(<)Message\s*)))~sx;
488 while ($xml =~ /<Thread id="t
(\d
+)">([^<]*(?:<(?!\/Thread>)[^<]*)*)<\/Thread>/g)
490 my ($tid, $thread) = ($1, $2);
491 my ($level, $cmno, @msg, @stack) = (0);
493 while ($thread =~ m;$reg_msg;g)
497 push @stack,$cmno if (defined $cmno);
500 unid => (defined $2) ? $2 : '',
515 push @{$msg[$cmno] -> {kids}} => $#msg;
516 push @{$msg[$cmno] -> {unids}} => (defined $2) ? $2 : '#';
520 push @unids => (defined $2) ? $2 : '';
523 $msg[$_] -> {answers}++ for (@stack);
527 $msg[-1] -> {name} =~ s/&/&/g;
528 $msg[-1] -> {cat} =~ s/&/&/g;
529 $msg[-1] -> {subject} =~ s/&/&/g;
536 unid => (defined $2) ? $2 : '',
551 push @{$msg[$cmno] -> {kids}} => $#msg;
552 push @{$msg[$cmno] -> {unids}} => (defined $2) ? $2 : '';
553 $msg[$cmno] -> {answers}++;
557 push @unids => (defined $2) ? $2 : '';
560 $msg[$_] -> {answers}++ for (@stack);
562 $msg[-1] -> {name} =~ s/&/&/g;
563 $msg[-1] -> {cat} =~ s/&/&/g;
564 $msg[-1] -> {subject} =~ s/&/&/g;
568 $cmno = pop @stack; $level--;
572 my $smsg = sort_thread (\@msg, $sorted); # sort messages
573 delete_messages ($smsg) unless ($deleted); # remove invisible messages
575 $threads{$tid} = $smsg if (@$smsg);
579 ? (\%threads, $last_thread, $last_message, $dtd, \@unids)
583 ### create_forum_xml_string () #################################################
585 # compose main file xml string
587 # Params: $threads - parsed threads (see also 'get_all_threads')
588 # $params - hashref (see doc for details)
590 # Return: scalarref of the xml string
592 sub create_forum_xml_string ($$) {
593 my ($threads, $param) = @_;
594 my ($level, $thread, $msg);
597 '<?xml version="1.0"?>'."\n"
598 . '<!DOCTYPE Forum SYSTEM "'.FORUM_DTD.'">'."\n"
599 . '<Forum lastMessage="m
'.($param->{lastMessage} =~ /(\d+)/)[0].'" lastThread="t
'.($param->{lastThread} =~ /(\d+)/)[0].'">';
601 for $thread (sort {$b <=> $a} keys %$threads) {
602 $xml .= '<Thread id="t
'.$thread.'">';
605 for $msg (@{$threads -> {$thread}}) {
606 $xml .= '</Message>' x ($level - $msg -> {level} + 1) if ($msg -> {level} <= $level);
608 $level = $msg -> {level};
610 '<Message id="m
'.$msg -> {mid}.'"'
611 . (($msg -> {unid}) ?' unid="'.$msg -> {unid}.'"':'')
612 . (($msg -> {deleted})?' invisible="1"':'')
613 . (($msg -> {archive})?' archive="1"':'')
618 . plain($msg -> {name})
623 . ((length $msg -> {cat})?plain($msg -> {cat}):'')
626 . plain($msg -> {subject})
634 $xml .= '</Message>' x ($level + 1);
635 $xml .= '</Thread>';}
642 ### save_file () ###############################################################
646 # Params: $filename Filename
647 # $content File content as scalar reference
648 # Return: Status (1 - ok, 0 - error)
652 my ($filename, $content) = @_;
655 open FILE, ">$filename.temp
" or return;
657 unless (print FILE $$content)
663 close FILE or return;
665 rename "$filename.temp
", $filename or return;
670 ################################################################################
672 # several time formatting routines
675 # 02. Januar 2001, 12:02 Uhr
678 # 02. 01. 2001, 12:02 Uhr
681 # Dienstag, 02. Januar 2001, 12:02:01 Uhr
687 (qw(Januar Februar), "M\303\244rz", qw(April Mai Juni Juli August September Oktober November Dezember))[shift (@_) - 1];
692 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
694 sprintf ('%02d. %s %04d, %02d:%02d Uhr', $day, month
($mon+1), $year+1900, $hour, $min);
697 sub short_hr_time
($) {
698 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
700 sprintf ('%02d. %02d. %04d, %02d:%02d Uhr', $day, $mon+1, $year+1900, $hour, $min);
703 sub long_hr_time
($) {
704 my @wday = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
705 my ($sek, $min, $hour, $day, $mon, $year, $wday) = localtime (shift);
707 sprintf ('%s, %02d. %s %04d, %02d:%02d:%02d Uhr', $wday[$wday], $day, month
($mon+1), $year+1900, $hour, $min, $sek);
710 sub very_short_hr_time
($) {
711 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
713 sprintf ('%02d. %02d. %04d', $day, $mon+1, $year+1900);
716 # keep 'require' happy
721 ### end of Posting::_lib #######################################################
patrick-canterino.de