]>
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>, 2001-06-11 #
8 # Frank Schoenmann <fs@tower.de>, 2001-06-04 #
10 # Description: Message access interface, time format routines #
12 ################################################################################
20 use Encode
::Plain
; $Encode::Plain
::utf8
= 1;
25 ################################################################################
29 $VERSION = do { my @r =(q
$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x
$#r, @r };
31 ################################################################################
35 use constant SORT_ASCENT
=> 0; # (latest postings first)
36 use constant SORT_DESCENT
=> 1;
37 use constant KEEP_DELETED
=> 1;
38 use constant KILL_DELETED
=> 0;
40 use base
qw(Exporter);
58 create_forum_xml_string
68 ################################################################################
73 ### sub create_message ($$) ####################################################
75 # create the 'Message' subtree
77 # Params: $xml - XML::DOM::Document object
78 # $par - hash reference
79 # (msg, ip, name, email, home, image, category, subject, time)
81 # Return: XML::DOM::Element object
83 sub create_message
($$) {
86 my $message = $xml -> createElement
('Message');
87 $message -> setAttribute
('id' => $par -> {msg
});
88 $message -> setAttribute
('ip' => $par -> {ip
});
90 my $header = $xml -> createElement
('Header');
91 my $author = $xml -> createElement
('Author');
92 $header -> appendChild
($author);
95 ['name' => 'Name' => $author],
96 ['email' => 'Email' => $author],
97 ['home' => 'HomepageUrl' => $author],
98 ['image' => 'ImageUrl' => $author],
99 ['category' => 'Category' => $header],
100 ['subject' => 'Subject' => $header]
101 );# key => element name => superior
106 my $obj = $xml -> createElement
($_->[1]);
110 defined $par -> {$_->[0]}
115 # link to superior element
116 $_ -> [2] -> appendChild
($obj);
119 my $date = $xml -> createElement
('Date');
120 $date -> setAttribute
('longSec'=> $par -> {time});
122 $header -> appendChild
($date);
123 $message -> appendChild
($header);
130 ### sub create_new_thread ($) ##################################################
132 # create a XML::DOM::Document object of a thread containing one posting
134 # Params: hash reference
135 # (dtd, thread, msg, body, ip, name, email, home,
136 # image, category, subject, time)
138 # Return: XML::DOM::Document object
140 sub create_new_thread
($) {
145 my $xml = new XML
::DOM
::Document
;
149 my $decl = new XML
::DOM
::XMLDecl
;
150 $decl -> setVersion
('1.0');
151 $decl -> setEncoding
('UTF-8');
152 $xml -> setXMLDecl
($decl);
156 my $dtd = $xml -> createDocumentType
('Forum' => $par -> {dtd
});
157 $xml -> setDoctype
($dtd);
159 # create root element 'Forum'
160 # create element 'Thread'
161 # create 'Message' subtree
162 # create element 'ContentList'
163 # create 'MessageContent' subtree
165 my $forum = $xml -> createElement
('Forum');
166 my $thread = $xml -> createElement
('Thread');
167 $thread -> setAttribute
('id' => $par -> {thread
});
168 my $message = create_message
($xml,$par);
169 my $content = $xml -> createElement
('ContentList');
170 my $mcontent = $xml -> createElement
('MessageContent');
171 $mcontent -> setAttribute
('mid' => $par -> {msg
});
172 $mcontent -> appendChild
(
173 $xml -> createCDATASection
(${$par -> {body
}})
176 # link all the nodes to
177 # their superior elements
179 $thread -> appendChild
($message);
180 $forum -> appendChild
($thread);
181 $content -> appendChild
($mcontent);
182 $forum -> appendChild
($content);
183 $xml -> appendChild
($forum);
190 ### get_message_header () ######################################################
192 # Read message header, return as a hash
194 # Params: $node - XML message node
195 # Return: hash reference (name, category, subject, email, home, image, time)
197 sub get_message_header
($)
202 my $header = $node -> getElementsByTagName
('Header' , 0) -> item
(0);
203 my $author = $header -> getElementsByTagName
('Author' , 0) -> item
(0);
204 my $name = $author -> getElementsByTagName
('Name' , 0) -> item
(0);
205 my $email = $author -> getElementsByTagName
('Email' , 0) -> item
(0);
206 my $home = $author -> getElementsByTagName
('HomepageUrl', 0) -> item
(0);
207 my $image = $author -> getElementsByTagName
('ImageUrl' , 0) -> item
(0);
208 my $cat = $header -> getElementsByTagName
('Category' , 0) -> item
(0);
209 my $subject = $header -> getElementsByTagName
('Subject' , 0) -> item
(0);
210 my $date = $header -> getElementsByTagName
('Date' , 0) -> item
(0);
213 name
=> ($name -> hasChildNodes
)?
$name -> getFirstChild
-> getData
:undef,
214 category
=> ($cat -> hasChildNodes
)?
$cat -> getFirstChild
-> getData
:undef,
215 subject
=> ($subject -> hasChildNodes
)?
$subject -> getFirstChild
-> getData
:undef,
216 email
=> (defined ($email) and $email -> hasChildNodes
)?
$email -> getFirstChild
-> getData
:undef,
217 home
=> (defined ($home) and $home -> hasChildNodes
)?
$home -> getFirstChild
-> getData
:undef,
218 image
=> (defined ($image) and $image -> hasChildNodes
)?
$image -> getFirstChild
-> getData
:undef,
219 time => $date -> getAttribute
('longSec')
225 ### get_body_node () ########################################################
227 # Search a specific message body in a XML tree
229 # Params: $xml XML::DOM::Document Object (Document Node)
232 # Return: MessageContent XML node (or -none-)
234 sub get_body_node
($$)
236 my ($xml, $mid) = @_;
238 for ($xml -> getElementsByTagName
('ContentList', 1) -> item
(0) -> getElementsByTagName
('MessageContent', 0)) {
239 return $_ if ($_ -> getAttribute
('mid') eq $mid);
245 ### get_message_body () ########################################################
249 # Params: $xml XML::DOM::Document Object (Document Node)
252 # Return: Scalar reference
254 sub get_message_body
($$)
256 my $cnode = get_body_node
($_[0], $_[1]);
259 $body = ($cnode -> hasChildNodes
)?
$cnode -> getFirstChild
-> getData
:'' if $cnode;
264 ### get_message_node () ########################################################
266 # Search a specific message in a XML tree
268 # Params: $xml XML::DOM::Document Object (Document Node)
272 # Return: Message XML node, Thread XML node (or -none-)
274 sub get_message_node
($$$)
276 my ($xml, $tid, $mid) = @_;
279 for ($xml->getElementsByTagName ('Thread')) {
280 if ($_->getAttribute ('id') eq $tid) {
283 for ($tnode -> getElementsByTagName
('Message')) {
284 if ($_ -> getAttribute
('id') eq $mid) {
298 ### sub parse_xml_file ($) #####################################################
300 # load the specified XML-File and create the DOM tree
301 # this sub is only to avoid errors and to centralize the parse process
303 # Params: $file filename
305 # Return: XML::DOM::Document Object (Document Node) or false
307 sub parse_xml_file
($) {
311 local $SIG{__DIE__
}; # CGI::Carp works unreliable ;-(
312 new XML
::DOM
::Parser
(KeepCDATA
=> 1)->parsefile ($file);
320 ### parse_single_thread () #####################################################
322 # parse a thread file
324 # Params: $tnode - Thread element node
325 # $deleted - keep deleted (boolean)
326 # $sorted - sorting order
330 sub parse_single_thread
($$;$) {
331 my ($tnode, $deleted, $sorted) = @_;
332 my ($header, @msg, %mno);
334 for ($tnode -> getElementsByTagName
('Message')) {
335 $header = get_message_header
($_);
338 mid
=> ($_ -> getAttribute
('id') =~ /(\d+)/)[0],
339 ip
=> $_ -> getAttribute
('ip'),
340 kids
=> [$_ -> getElementsByTagName
('Message', 0)],
341 answers
=> $_ -> getElementsByTagName
('Message') -> getLength
,
342 deleted
=> $_ -> getAttribute
('invisible'),
343 archive
=> $_ -> getAttribute
('archive'),
344 name
=> plain
($header -> {name
}),
345 cat
=> plain
($header -> {category
} or ''),
346 subject
=> plain
($header -> {subject
}),
347 time => plain
($header -> {time})
353 $msg[0] -> {level
} = 0;
355 $level = $_ -> {level
} + 1;
356 @
{$_ -> {kids
}} = map {$msg[$mno{$_}] -> {level
} = $level; $mno{$_}} @
{$_ -> {kids
}};
359 # sort and process deleted files
361 my $smsg = sort_thread
(\
@msg, $sorted);
362 delete_messages
($smsg) unless ($deleted);
367 ################################################################################
369 # Access via regexps and native perl ;)
372 ### sort_thread () #############################################################
374 # sort the message array
376 # Params: $msg - arrayref
377 # $sorted - sorting order
379 # Return: sorted arrayref
381 sub sort_thread
($$) {
382 my ($msg, $sorted) = @_;
384 my ($z, %mhash) = (0);
386 if ($sorted) { # oldest first
388 @
$msg[@
{$_ -> {kids
}}] = sort {$a -> {mid
} <=> $b -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
389 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
391 else { # latest first
393 @
$msg[@
{$_ -> {kids
}}] = sort {$b -> {mid
} <=> $a -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
394 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
398 my @smsg = ($msg -> [0]);
401 splice @smsg,$z,0,@
{$mhash{$_ -> {mid
}}} if ($_ -> {answers
});
402 delete $_ -> {kids
};}
408 ### delete_messages () #########################################################
410 # Filter out deleted messages
412 # Params: $smsg Reference of array of references of hashs
415 sub delete_messages
($) {
417 my ($z, $oldlevel, @path) = (0,0,0);
419 while ($z <= $#{$smsg}) {
421 if ($smsg -> [$z] -> {level
} > $oldlevel) {
423 $oldlevel = $smsg -> [$z] -> {level
};
425 elsif ($smsg -> [$z] -> {level
} < $oldlevel) {
426 splice @path, $smsg -> [$z] -> {level
};
428 $oldlevel = $smsg -> [$z] -> {'level'};
434 if ($smsg -> [$z] -> {deleted
}) {
435 my $n = $smsg -> [$z] -> {answers
} + 1;
436 $smsg -> [$_] -> {answers
} -= $n for (@path);
437 splice @
$smsg, $z, $n;
447 ### get_all_threads () #########################################################
449 # Read and Parse the main file (without any XML-module, they are too slow)
451 # Params: $file - /path/to/filename of the main file
452 # $deleted - hold deleted (invisible) messages in result (1) oder not (0)
453 # $sorted - direction of message sort: descending (0) (default) or ascending (1)
455 # Return: scalar context: hash reference (\%threads)
456 # list context: list (\%threads, $last_thread, $last_message, $dtd, \@unids)
458 sub get_all_threads
($$;$) {
459 my ($file, $deleted, $sorted) = @_;
460 my ($last_thread, $last_message, $dtd, @unids, %threads);
463 open FILE
,"< $file" or return;
464 my $xml = join '', <FILE
>;
465 close(FILE
) or return;
468 ($dtd) = $xml =~ /<!DOCTYPE\s+\S+\s+SYSTEM\s+"([^"]+)">/;
469 ($last_thread) = map {/(\d+)/} $xml =~ /<Forum.+?lastThread="([^"]+)"[^>]*>/;
470 ($last_message) = map {/(\d+)/} $xml =~ /<Forum.+?lastMessage="([^"]+)"[^>]*>/;
473 my $reg_msg = qr
~(?
:</Message
>
474 |<Message\s
+id
="m(\d+)"\s
+unid
="([^"]*)"(?:\s+invisible="([^"]*)")?
(?
:\s
+archive
="([^"]*)")?[^>]*>\s*
475 <Header>[^<]*(?:<(?!Name>)[^<]*)*
476 <Name>([^<]+)</Name>[^<]*(?:<(?!Category>)[^<]*)*
477 <Category>([^<]*)</Category>\s*
478 <Subject>([^<]+)</Subject>\s*
479 <Date\s+longSec="(\d
+)"[^>]*>\s*
480 </Header>\s*(?:(<)/Message>|(?=(<)Message\s*)))~sx;
482 while ($xml =~ /<Thread id="t
(\d
+)">([^<]*(?:<(?!\/Thread>)[^<]*)*)<\/Thread>/g)
484 my ($tid, $thread) = ($1, $2);
485 my ($level, $cmno, @msg, @stack) = (0);
487 while ($thread =~ m;$reg_msg;g)
491 push @stack,$cmno if (defined $cmno);
509 push @{$msg[$cmno] -> {kids}} => $#msg;
510 push @{$msg[$cmno] -> {unids}} => $2;
517 $msg[$_] -> {answers}++ for (@stack);
521 $msg[-1] -> {name} =~ s/&/&/g;
522 $msg[-1] -> {cat} =~ s/&/&/g;
523 $msg[-1] -> {subject} =~ s/&/&/g;
545 push @{$msg[$cmno] -> {kids}} => $#msg;
546 push @{$msg[$cmno] -> {unids}} => $2;
547 $msg[$cmno] -> {answers}++;
554 $msg[$_] -> {answers}++ for (@stack);
556 $msg[-1] -> {name} =~ s/&/&/g;
557 $msg[-1] -> {cat} =~ s/&/&/g;
558 $msg[-1] -> {subject} =~ s/&/&/g;
562 $cmno = pop @stack; $level--;
566 my $smsg = sort_thread (\@msg, $sorted); # sort messages
567 delete_messages ($smsg) unless ($deleted); # remove invisible messages
569 $threads{$tid} = $smsg if (@$smsg);
573 ? (\%threads, $last_thread, $last_message, $dtd, \@unids)
577 ### create_forum_xml_string () #################################################
579 # compose main file xml string
581 # Params: $threads - parsed threads (see also 'get_all_threads')
582 # $params - hashref (see doc for details)
584 # Return: scalarref of the xml string
586 sub create_forum_xml_string ($$) {
587 my ($threads, $param) = @_;
588 my ($level, $thread, $msg);
591 '<?xml version="1.0" encoding="UTF
-8"?>'."\n"
592 . '<!DOCTYPE Forum SYSTEM "'.$param -> {dtd}.'">'."\n"
593 . '<Forum lastMessage="'.$param -> {lastMessage}.'" lastThread="'.$param -> {lastThread}.'">';
595 for $thread (sort {$b <=> $a} keys %$threads) {
596 $xml .= '<Thread id="t
'.$thread.'">';
599 for $msg (@{$threads -> {$thread}}) {
600 $xml .= '</Message>' x ($level - $msg -> {level} + 1) if ($msg -> {level} <= $level);
602 $level = $msg -> {level};
604 '<Message id="m
'.$msg -> {mid}.'"'
605 . ' unid="'.$msg -> {unid}.'"'
606 . (($msg -> {deleted})?' invisible="1"':'')
607 . (($msg -> {archive})?' archive="1"':'')
612 . plain($msg -> {name})
617 . ((length $msg -> {cat})?plain($msg -> {cat}):'')
620 . plain($msg -> {subject})
628 $xml .= '</Message>' x ($level + 1);
629 $xml .= '</Thread>';}
636 ### save_file () ###############################################################
640 # Params: $filename Filename
641 # $content File content as scalar reference
642 # Return: Status (1 - ok, 0 - error)
646 my ($filename, $content) = @_;
649 open FILE, ">$filename.temp
" or return;
651 unless (print FILE $$content)
657 close FILE or return;
659 rename "$filename.temp
", $filename or return;
664 ################################################################################
666 # several time formatting routines
669 # 02. Januar 2001, 12:02 Uhr
672 # 02. 01. 2001, 12:02 Uhr
675 # Dienstag, 02. Januar 2001, 12:02:01 Uhr
681 (qw(Januar Februar), "M\303\244rz", qw(April Mai Juni Juli August September Oktober November Dezember))[shift (@_) - 1];
686 my (undef, $min, $hour, $day, $mon, $year) = germantime
(shift);
688 sprintf ('%02d. %s %04d, %02d:%02d Uhr', $day, month
($mon+1), $year+1900, $hour, $min);
691 sub short_hr_time
($) {
692 my (undef, $min, $hour, $day, $mon, $year) = germantime
(shift);
694 sprintf ('%02d. %02d. %04d, %02d:%02d Uhr', $day, $mon+1, $year+1900, $hour, $min);
697 sub long_hr_time
($) {
698 my @wday = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
699 my ($sek, $min, $hour, $day, $mon, $year, $wday) = germantime
(shift);
701 sprintf ('%s, %02d. %s %04d, %02d:%02d:%02d Uhr', $wday[$wday], $day, month
($mon+1), $year+1900, $hour, $min, $sek);
704 sub very_short_hr_time
($) {
705 my (undef, $min, $hour, $day, $mon, $year) = germantime
(shift);
707 sprintf ('%02d. %02d. %04d', $day, $mon+1, $year+1900);
710 # keep 'require' happy
715 ### end of Posting::_lib #######################################################
patrick-canterino.de