]>
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
':overwrite_internal_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 base
qw(Exporter);
61 create_forum_xml_string
71 ################################################################################
76 ### sub create_message ($$) ####################################################
78 # create the 'Message' subtree
80 # Params: $xml - XML::DOM::Document object
81 # $par - hash reference
82 # (msg, ip, name, email, home, image, category, subject, time)
84 # Return: XML::DOM::Element object
86 sub create_message
($$) {
89 my $message = $xml -> createElement
('Message');
90 $message -> setAttribute
('id' => $par -> {msg
});
91 $message -> setAttribute
('ip' => $par -> {ip
});
93 my $header = $xml -> createElement
('Header');
94 my $author = $xml -> createElement
('Author');
95 $header -> appendChild
($author);
98 ['name' => 'Name' => $author],
99 ['email' => 'Email' => $author],
100 ['home' => 'HomepageUrl' => $author],
101 ['image' => 'ImageUrl' => $author],
102 ['category' => 'Category' => $header],
103 ['subject' => 'Subject' => $header]
104 );# key => element name => superior
109 my $obj = $xml -> createElement
($_->[1]);
113 defined $par -> {$_->[0]}
118 # link to superior element
119 $_ -> [2] -> appendChild
($obj);
122 my $date = $xml -> createElement
('Date');
123 $date -> setAttribute
('longSec'=> $par -> {time});
125 $header -> appendChild
($date);
126 $message -> appendChild
($header);
133 ### sub create_new_thread ($) ##################################################
135 # create a XML::DOM::Document object of a thread containing one posting
137 # Params: hash reference
138 # (dtd, thread, msg, body, ip, name, email, home,
139 # image, category, subject, time)
141 # Return: XML::DOM::Document object
143 sub create_new_thread
($) {
148 my $xml = new XML
::DOM
::Document
;
152 my $decl = new XML
::DOM
::XMLDecl
;
153 $decl -> setVersion
('1.0');
154 $decl -> setEncoding
('UTF-8');
155 $xml -> setXMLDecl
($decl);
159 my $dtd = $xml -> createDocumentType
('Forum' => $par -> {dtd
});
160 $xml -> setDoctype
($dtd);
162 # create root element 'Forum'
163 # create element 'Thread'
164 # create 'Message' subtree
165 # create element 'ContentList'
166 # create 'MessageContent' subtree
168 my $forum = $xml -> createElement
('Forum');
169 my $thread = $xml -> createElement
('Thread');
170 $thread -> setAttribute
('id' => $par -> {thread
});
171 my $message = create_message
($xml,$par);
172 my $content = $xml -> createElement
('ContentList');
173 my $mcontent = $xml -> createElement
('MessageContent');
174 $mcontent -> setAttribute
('mid' => $par -> {msg
});
175 $mcontent -> appendChild
(
176 $xml -> createCDATASection
(${$par -> {body
}})
179 # link all the nodes to
180 # their superior elements
182 $thread -> appendChild
($message);
183 $forum -> appendChild
($thread);
184 $content -> appendChild
($mcontent);
185 $forum -> appendChild
($content);
186 $xml -> appendChild
($forum);
193 ### get_message_header () ######################################################
195 # Read message header, return as a hash
197 # Params: $node - XML message node
198 # Return: hash reference (name, category, subject, email, home, image, time)
200 sub get_message_header
($)
205 my $header = $node -> getElementsByTagName
('Header' , 0) -> item
(0);
206 my $author = $header -> getElementsByTagName
('Author' , 0) -> item
(0);
207 my $name = $author -> getElementsByTagName
('Name' , 0) -> item
(0);
208 my $email = $author -> getElementsByTagName
('Email' , 0) -> item
(0);
209 my $home = $author -> getElementsByTagName
('HomepageUrl', 0) -> item
(0);
210 my $image = $author -> getElementsByTagName
('ImageUrl' , 0) -> item
(0);
211 my $cat = $header -> getElementsByTagName
('Category' , 0) -> item
(0);
212 my $subject = $header -> getElementsByTagName
('Subject' , 0) -> item
(0);
213 my $date = $header -> getElementsByTagName
('Date' , 0) -> item
(0);
216 name
=> ($name -> hasChildNodes
)?
$name -> getFirstChild
-> getData
:undef,
217 category
=> ($cat -> hasChildNodes
)?
$cat -> getFirstChild
-> getData
:undef,
218 subject
=> ($subject -> hasChildNodes
)?
$subject -> getFirstChild
-> getData
:undef,
219 email
=> (defined ($email) and $email -> hasChildNodes
)?
$email -> getFirstChild
-> getData
:undef,
220 home
=> (defined ($home) and $home -> hasChildNodes
)?
$home -> getFirstChild
-> getData
:undef,
221 image
=> (defined ($image) and $image -> hasChildNodes
)?
$image -> getFirstChild
-> getData
:undef,
222 time => $date -> getAttribute
('longSec')
228 ### get_body_node () ########################################################
230 # Search a specific message body in a XML tree
232 # Params: $xml XML::DOM::Document Object (Document Node)
235 # Return: MessageContent XML node (or -none-)
237 sub get_body_node
($$)
239 my ($xml, $mid) = @_;
241 for ($xml -> getElementsByTagName
('ContentList', 1) -> item
(0) -> getElementsByTagName
('MessageContent', 0)) {
242 return $_ if ($_ -> getAttribute
('mid') eq $mid);
248 ### get_message_body () ########################################################
252 # Params: $xml XML::DOM::Document Object (Document Node)
255 # Return: Scalar reference
257 sub get_message_body
($$)
259 my $cnode = get_body_node
($_[0], $_[1]);
262 $body = ($cnode -> hasChildNodes
)?
$cnode -> getFirstChild
-> getData
:'' if $cnode;
267 ### get_message_node () ########################################################
269 # Search a specific message in a XML tree
271 # Params: $xml XML::DOM::Document Object (Document Node)
275 # Return: Message XML node, Thread XML node (or -none-)
277 sub get_message_node
($$$)
279 my ($xml, $tid, $mid) = @_;
282 for ($xml->getElementsByTagName ('Thread')) {
283 if ($_->getAttribute ('id') eq $tid) {
286 for ($tnode -> getElementsByTagName
('Message')) {
287 if ($_ -> getAttribute
('id') eq $mid) {
301 ### sub parse_xml_file ($) #####################################################
303 # load the specified XML-File and create the DOM tree
304 # this sub is only to avoid errors and to centralize the parse process
306 # Params: $file filename
308 # Return: XML::DOM::Document Object (Document Node) or false
310 sub parse_xml_file
($) {
314 local $SIG{__DIE__
}; # CGI::Carp works unreliable ;-(
315 new XML
::DOM
::Parser
(KeepCDATA
=> 1)->parsefile ($file);
323 ### parse_single_thread () #####################################################
325 # parse a thread file
327 # Params: $tnode - Thread element node
328 # $deleted - keep deleted (boolean)
329 # $sorted - sorting order
333 sub parse_single_thread
($$;$) {
334 my ($tnode, $deleted, $sorted) = @_;
335 my ($header, @msg, %mno);
337 for ($tnode -> getElementsByTagName
('Message')) {
338 $header = get_message_header
($_);
341 mid
=> ($_ -> getAttribute
('id') =~ /(\d+)/)[0],
342 ip
=> $_ -> getAttribute
('ip'),
343 kids
=> [$_ -> getElementsByTagName
('Message', 0)],
344 answers
=> $_ -> getElementsByTagName
('Message') -> getLength
,
345 deleted
=> $_ -> getAttribute
('invisible'),
346 archive
=> $_ -> getAttribute
('archive'),
347 name
=> plain
($header -> {name
}),
348 cat
=> plain
($header -> {category
} or ''),
349 subject
=> plain
($header -> {subject
}),
350 time => plain
($header -> {time})
356 $msg[0] -> {level
} = 0;
358 $level = $_ -> {level
} + 1;
359 @
{$_ -> {kids
}} = map {$msg[$mno{$_}] -> {level
} = $level; $mno{$_}} @
{$_ -> {kids
}};
362 # sort and process deleted files
364 my $smsg = sort_thread
(\
@msg, $sorted);
365 delete_messages
($smsg) unless ($deleted);
370 ################################################################################
372 # Access via regexps and native perl ;)
375 ### sort_thread () #############################################################
377 # sort the message array
379 # Params: $msg - arrayref
380 # $sorted - sorting order
382 # Return: sorted arrayref
384 sub sort_thread
($$) {
385 my ($msg, $sorted) = @_;
387 my ($z, %mhash) = (0);
389 if ($sorted) { # oldest first
391 @
$msg[@
{$_ -> {kids
}}] = sort {$a -> {mid
} <=> $b -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
392 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
394 else { # latest first
396 @
$msg[@
{$_ -> {kids
}}] = sort {$b -> {mid
} <=> $a -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
397 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
401 my @smsg = ($msg -> [0]);
404 splice @smsg,$z,0,@
{$mhash{$_ -> {mid
}}} if ($_ -> {answers
});
412 ### delete_messages () #########################################################
414 # Filter out deleted messages
416 # Params: $smsg Reference of array of references of hashs
419 sub delete_messages
($) {
421 my ($z, $oldlevel, @path) = (0,0,0);
423 while ($z <= $#{$smsg}) {
425 if ($smsg -> [$z] -> {level
} > $oldlevel) {
427 $oldlevel = $smsg -> [$z] -> {level
};
429 elsif ($smsg -> [$z] -> {level
} < $oldlevel) {
430 splice @path, $smsg -> [$z] -> {level
};
432 $oldlevel = $smsg -> [$z] -> {'level'};
438 if ($smsg -> [$z] -> {deleted
}) {
439 my $n = $smsg -> [$z] -> {answers
} + 1;
440 $smsg -> [$_] -> {answers
} -= $n for (@path);
441 splice @
$smsg, $z, $n;
451 ### get_all_threads () #########################################################
453 # Read and Parse the main file (without any XML-module, they are too slow)
455 # Params: $file - /path/to/filename of the main file
456 # $deleted - hold deleted (invisible) messages in result (1) oder not (0)
457 # $sorted - direction of message sort: descending (0) (default) or ascending (1)
459 # Return: scalar context: hash reference (\%threads)
460 # list context: list (\%threads, $last_thread, $last_message, $dtd, \@unids)
462 sub get_all_threads
($$;$) {
463 my ($file, $deleted, $sorted) = @_;
464 my ($last_thread, $last_message, $dtd, @unids, %threads);
467 open FILE
,"< $file" or return;
468 my $xml = join '', <FILE
>;
469 close(FILE
) or return;
472 ($dtd) = $xml =~ /<!DOCTYPE\s+\S+\s+SYSTEM\s+"([^"]+)">/;
473 ($last_thread) = map {/(\d+)/} $xml =~ /<Forum.+?lastThread="([^"]+)"[^>]*>/;
474 ($last_message) = map {/(\d+)/} $xml =~ /<Forum.+?lastMessage="([^"]+)"[^>]*>/;
477 my $reg_msg = qr
~(?
:</Message
>
478 |<Message\s
+id
="m(\d+)"\s
+unid
="([^"]*)"(?:\s+invisible="([^"]*)")?
(?
:\s
+archive
="([^"]*)")?[^>]*>\s*
479 <Header>[^<]*(?:<(?!Name>)[^<]*)*
480 <Name>([^<]+)</Name>[^<]*(?:<(?!Category>)[^<]*)*
481 <Category>([^<]*)</Category>\s*
482 <Subject>([^<]+)</Subject>\s*
483 <Date\s+longSec="(\d
+)"[^>]*>\s*
484 </Header>\s*(?:(<)/Message>|(?=(<)Message\s*)))~sx;
486 while ($xml =~ /<Thread id="t
(\d
+)">([^<]*(?:<(?!\/Thread>)[^<]*)*)<\/Thread>/g)
488 my ($tid, $thread) = ($1, $2);
489 my ($level, $cmno, @msg, @stack) = (0);
491 while ($thread =~ m;$reg_msg;g)
495 push @stack,$cmno if (defined $cmno);
513 push @{$msg[$cmno] -> {kids}} => $#msg;
514 push @{$msg[$cmno] -> {unids}} => $2;
521 $msg[$_] -> {answers}++ for (@stack);
525 $msg[-1] -> {name} =~ s/&/&/g;
526 $msg[-1] -> {cat} =~ s/&/&/g;
527 $msg[-1] -> {subject} =~ s/&/&/g;
549 push @{$msg[$cmno] -> {kids}} => $#msg;
550 push @{$msg[$cmno] -> {unids}} => $2;
551 $msg[$cmno] -> {answers}++;
558 $msg[$_] -> {answers}++ for (@stack);
560 $msg[-1] -> {name} =~ s/&/&/g;
561 $msg[-1] -> {cat} =~ s/&/&/g;
562 $msg[-1] -> {subject} =~ s/&/&/g;
566 $cmno = pop @stack; $level--;
570 my $smsg = sort_thread (\@msg, $sorted); # sort messages
571 delete_messages ($smsg) unless ($deleted); # remove invisible messages
573 $threads{$tid} = $smsg if (@$smsg);
577 ? (\%threads, $last_thread, $last_message, $dtd, \@unids)
581 ### create_forum_xml_string () #################################################
583 # compose main file xml string
585 # Params: $threads - parsed threads (see also 'get_all_threads')
586 # $params - hashref (see doc for details)
588 # Return: scalarref of the xml string
590 sub create_forum_xml_string ($$) {
591 my ($threads, $param) = @_;
592 my ($level, $thread, $msg);
595 '<?xml version="1.0" encoding="UTF
-8"?>'."\n"
596 . '<!DOCTYPE Forum SYSTEM "'.$param -> {dtd}.'">'."\n"
597 . '<Forum lastMessage="m
'.$param -> {lastMessage}.'" lastThread="t
'.$param -> {lastThread}.'">';
599 for $thread (sort {$b <=> $a} keys %$threads) {
600 $xml .= '<Thread id="t
'.$thread.'">';
603 for $msg (@{$threads -> {$thread}}) {
604 $xml .= '</Message>' x ($level - $msg -> {level} + 1) if ($msg -> {level} <= $level);
606 $level = $msg -> {level};
608 '<Message id="m
'.$msg -> {mid}.'"'
609 . ' unid="'.$msg -> {unid}.'"'
610 . (($msg -> {deleted})?' invisible="1"':'')
611 . (($msg -> {archive})?' archive="1"':'')
616 . plain($msg -> {name})
621 . ((length $msg -> {cat})?plain($msg -> {cat}):'')
624 . plain($msg -> {subject})
632 $xml .= '</Message>' x ($level + 1);
633 $xml .= '</Thread>';}
640 ### save_file () ###############################################################
644 # Params: $filename Filename
645 # $content File content as scalar reference
646 # Return: Status (1 - ok, 0 - error)
650 my ($filename, $content) = @_;
653 open FILE, ">$filename.temp
" or return;
655 unless (print FILE $$content)
661 close FILE or return;
663 rename "$filename.temp
", $filename or return;
668 ################################################################################
670 # several time formatting routines
673 # 02. Januar 2001, 12:02 Uhr
676 # 02. 01. 2001, 12:02 Uhr
679 # Dienstag, 02. Januar 2001, 12:02:01 Uhr
685 (qw(Januar Februar), "M\303\244rz", qw(April Mai Juni Juli August September Oktober November Dezember))[shift (@_) - 1];
690 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
692 sprintf ('%02d. %s %04d, %02d:%02d Uhr', $day, month
($mon+1), $year+1900, $hour, $min);
695 sub short_hr_time
($) {
696 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
698 sprintf ('%02d. %02d. %04d, %02d:%02d Uhr', $day, $mon+1, $year+1900, $hour, $min);
701 sub long_hr_time
($) {
702 my @wday = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
703 my ($sek, $min, $hour, $day, $mon, $year, $wday) = localtime (shift);
705 sprintf ('%s, %02d. %s %04d, %02d:%02d:%02d Uhr', $wday[$wday], $day, month
($mon+1), $year+1900, $hour, $min, $sek);
708 sub very_short_hr_time
($) {
709 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
711 sprintf ('%02d. %02d. %04d', $day, $mon+1, $year+1900);
714 # keep 'require' happy
719 ### end of Posting::_lib #######################################################
patrick-canterino.de