]>
git.p6c8.net - selfforum.git/blob - selfforum-cgi/shared/Posting/_lib.pm
05a0285c2a2cef36a1590a88086f519d09341a99
3 ################################################################################
5 # File: shared/Posting/_lib.pm #
7 # Authors: André Malo <nd@o3media.de>, 2001-03-03 #
8 # Frank Schoenmann <fs@tower.de>, 2001-03-13 #
10 # Description: Message access interface, time format routines #
12 ################################################################################
16 use vars
qw(@EXPORT_OK);
17 use base qw(Exporter);
19 use Encode
::Plain
; $Encode::Plain
::utf8
= 1;
23 # ====================================================
25 # ====================================================
27 @EXPORT_OK = qw(get_message_header get_message_body get_message_node get_body_node parse_single_thread
28 hr_time short_hr_time long_hr_time
29 get_all_threads create_forum_xml_string
32 # ====================================================
34 # ====================================================
36 ### get_message_header () ######################################################
38 # Read message header, return as a hash
40 # Params: $node XML message node
41 # Return: Hash reference (name, category, subject, email, home, image, time)
43 sub get_message_header
($)
48 my $header = $node -> getElementsByTagName
('Header', 0) -> item
(0);
49 my $author = $header -> getElementsByTagName
('Author', 0) -> item
(0);
50 my $name = $author -> getElementsByTagName
('Name', 0) -> item
(0);
51 my $email = $author -> getElementsByTagName
('Email', 0) -> item
(0);
52 my $home = $author -> getElementsByTagName
('HomepageUrl', 0) -> item
(0);
53 my $image = $author -> getElementsByTagName
('ImageUrl', 0) -> item
(0);
54 my $cat = $header -> getElementsByTagName
('Category', 0) -> item
(0);
55 my $subject = $header -> getElementsByTagName
('Subject', 0) -> item
(0);
56 my $date = $header -> getElementsByTagName
('Date', 0) -> item
(0);
59 name
=> ($name -> hasChildNodes
)?
$name -> getFirstChild
-> getData
:undef,
60 category
=> ($cat -> hasChildNodes
)?
$cat -> getFirstChild
-> getData
:undef,
61 subject
=> ($subject -> hasChildNodes
)?
$subject -> getFirstChild
-> getData
:undef,
62 email
=> (defined ($email) and $email -> hasChildNodes
)?
$email -> getFirstChild
-> getData
:undef,
63 home
=> (defined ($home) and $home -> hasChildNodes
)?
$home -> getFirstChild
-> getData
:undef,
64 image
=> (defined ($image) and $image -> hasChildNodes
)?
$image -> getFirstChild
-> getData
:undef,
65 time => $date -> getAttribute
('longSec')
71 ### get_body_node () ########################################################
73 # Search a specific message body in a XML tree
75 # Params: $xml XML::DOM::Document Object (Document Node)
77 # Return: MessageContent XML node (or -none-)
79 sub get_body_node
($$)
83 for ($xml->getElementsByTagName ('ContentList', 1)->item (0)->getElementsByTagName ('MessageContent', 0))
85 return $_ if ($_ -> getAttribute
('mid') eq $mid);
91 ### get_message_body () ########################################################
95 # Params: $xml XML::DOM::Document Object (Document Node)
97 # Return: Scalar reference
99 sub get_message_body
($$)
101 my $cnode = get_body_node
($_[0], $_[1]);
104 $body = ($cnode -> hasChildNodes
)?
$cnode -> getFirstChild
-> getData
:'' if $cnode;
109 ### get_message_node () ########################################################
111 # Search a specific message in a XML tree
113 # Params: $xml XML::DOM::Document Object (Document Node)
116 # Return: Message XML node, Thread XML node (or -none-)
118 sub get_message_node
($$$)
120 my ($xml, $tid, $mid) = @_;
123 for ($xml->getElementsByTagName ('Thread'))
125 if ($_->getAttribute ('id') eq $tid)
128 for ($tnode -> getElementsByTagName
('Message'))
130 if ($_ -> getAttribute
('id') eq $mid)
140 wantarray ?
($mnode, $tnode) : $mnode;
143 ###########################
144 # sub parse_single_thread
146 # einzelne Threaddatei
148 ###########################
150 sub parse_single_thread
($$;$) {
151 my ($tnode, $deleted, $sorted) = @_;
152 my ($header, @msg, %mno);
154 for ($tnode -> getElementsByTagName
('Message')) {
155 $header = get_message_header
($_);
157 push @msg,{mid
=> ($_ -> getAttribute
('id') =~ /(\d+)/)[0],
158 ip
=> $_ -> getAttribute
('ip'),
159 kids
=> [$_ -> getElementsByTagName
('Message', 0)],
160 answers
=> $_ -> getElementsByTagName
('Message') -> getLength
,
161 deleted
=> $_ -> getAttribute
('invisible'),
162 archive
=> $_ -> getAttribute
('archive'),
163 name
=> plain
($header -> {name
}),
164 cat
=> plain
($header -> {category
} or ''),
165 subject
=> plain
($header -> {subject
}),
166 time => plain
($header -> {time})};
169 # Eintraege ergaenzen und korrigieren
171 $msg[0] -> {level
} = 0;
173 $level = $_ -> {level
} + 1;
174 @
{$_ -> {kids
}} = map {$msg[$mno{$_}] -> {level
} = $level; $mno{$_}} @
{$_ -> {kids
}};}
177 # Sortieren und bei Bedarf
178 # geloeschte Messages entfernen
180 my $smsg = sort_thread
(\
@msg, $sorted);
181 delete_messages
($smsg) unless ($deleted);
186 ###########################
187 # sub create_message_xml
191 ###########################
193 sub create_message_xml
($$$) {
194 my ($xml, $msges, $num) = @_;
196 my $msg = $msges -> [$num];
198 my $message = $xml -> createElement
('Message');
199 $message -> setAttribute
('id', 'm'.$msg -> {mid
});
200 $message -> setAttribute
('invisible', '1') if ($msg -> {deleted
});
201 $message -> setAttribute
('archive', '1') if ($msg -> {archive
});
204 my $header = $xml -> createElement
('Header');
206 # alles inside of 'Header'
207 my $author = $xml -> createElement
('Author');
209 my $name = $xml -> createElement
('Name');
210 $name -> addText
(toUTF8
($msg -> {name
}));
212 my $email = $xml -> createElement
('Email');
214 my $category = $xml -> createElement
('Category');
215 $category -> addText
(toUTF8
($msg -> {cat
}));
217 my $subject = $xml -> createElement
('Subject');
218 $subject -> addText
(toUTF8
($msg -> {subject
}));
220 my $date = $xml -> createElement
('Date');
221 $date -> setAttribute
('longSec', $msg -> {time});
223 $author -> appendChild
($name);
224 $author -> appendChild
($email);
225 $header -> appendChild
($author);
226 $header -> appendChild
($category);
227 $header -> appendChild
($subject);
228 $header -> appendChild
($date);
229 $message -> appendChild
($header);
231 if ($msg -> {kids
}) {
232 for (@
{$msg -> {kids
}}) {
233 $message -> appendChild
(&create_message_xml
($xml, $msges, $_));
240 # ====================================================
241 # XML-Parsen von Hand
242 # ====================================================
244 ###########################
249 ###########################
251 sub sort_thread
($$) {
252 my ($msg, $sorted) = @_;
254 my ($z, %mhash) = (0);
256 if ($sorted) { # aelteste zuerst
258 @
$msg[@
{$_ -> {kids
}}] = sort {$a -> {mid
} <=> $b -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
259 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
261 else { # juengste zuerst
263 @
$msg[@
{$_ -> {kids
}}] = sort {$b -> {mid
} <=> $a -> {mid
}} @
$msg[@
{$_ -> {kids
}}] if (@
{$_ -> {kids
}} > 1);
264 $mhash{$_ -> {mid
}} = [@
$msg[@
{$_ -> {kids
}}]];}}
266 # Kinder wieder richtig einsortieren
267 my @smsg = ($msg -> [0]);
270 splice @smsg,$z,0,@
{$mhash{$_ -> {mid
}}} if ($_ -> {answers
});
271 delete $_ -> {kids
};}
276 ### delete_messages () #########################################################
278 # Filter out deleted messages
280 # Params: $smsg Reference of array of references of hashs
283 sub delete_messages
($)
287 my ($z, $oldlevel, @path) = (0,0,0);
291 if ($_ -> {'deleted'})
293 my $n = $_ -> {'answers'} + 1;
294 $smsg -> [$_] -> {'answers'} -= $n for (@path);
299 if ($_ -> {'level'} > $oldlevel)
302 $oldlevel = $_ -> {'level'};
304 elsif ($_ -> {'level'} < $oldlevel)
306 splice @path,$_ -> {'level'} - $oldlevel;
307 $oldlevel = $_ -> {'level'};
321 ### get_all_threads () #########################################################
323 # Read and Parse the main file (without any XML-module, they are too slow)
325 # Params: $file /path/to/filename of the main file
326 # $deleted hold deleted (invisible) messages in result (1) oder not (0)
327 # $sorted direction of message sort: descending (0) (default) or ascending (1)
328 # Return: scalar context: hash reference
329 # list context: list (\%threads, $last_thread, $last_message, $dtd, \@unids)
331 sub get_all_threads
($$;$)
333 my ($file, $deleted, $sorted) = @_;
334 my ($last_thread, $last_message, $dtd, @unids, %threads);
337 open FILE
, $file or return undef;
338 my $xml = join '', <FILE
>;
339 close(FILE
) or return undef;
343 ($dtd) = $xml =~ /<!DOCTYPE\s+\S+\s+SYSTEM\s+"([^"]+)">/;
344 ($last_thread) = map {/(\d+)/} $xml =~ /<Forum.+?lastThread="([^"]+)"[^>]*>/;
345 ($last_message) = map {/(\d+)/} $xml =~ /<Forum.+?lastMessage="([^"]+)"[^>]*>/;
348 my $reg_msg = qr
~(?
:</Message
>
349 |<Message\s
+id
="m(\d+)"\s
+unid
="([^"]*)"(?:\s+invisible="([^"]*)")?
(?
:\s
+archive
="([^"]*)")?[^>]*>\s*
350 <Header>[^<]*(?:<(?!Name>)[^<]*)*
351 <Name>([^<]+)</Name>[^<]*(?:<(?!Category>)[^<]*)*
352 <Category>([^<]*)</Category>\s*
353 <Subject>([^<]+)</Subject>\s*
354 <Date\s+longSec="(\d
+)"[^>]*>\s*
355 </Header>\s*(?:(<)/Message>|(?=(<)Message\s*)))~sx;
357 while ($xml =~ /<Thread id="t
(\d
+)">([^<]*(?:<(?!\/Thread>)[^<]*)*)<\/Thread>/g)
359 my ($tid, $thread) = ($1, $2);
360 my ($level, $cmno, @msg, @stack) = (0);
362 while ($thread =~ m;$reg_msg;g)
366 push @stack,$cmno if (defined $cmno);
367 push @msg, {mid => $1,
382 push @{$msg[$cmno] -> {kids}} => $#msg;
383 push @{$msg[$cmno] -> {unids}} => $2;
390 $msg[$_] -> {answers}++ for (@stack);
394 $msg[-1] -> {name} =~ s/&/&/g;
395 $msg[-1] -> {cat} =~ s/&/&/g;
396 $msg[-1] -> {subject} =~ s/&/&/g;
401 push @msg, {mid => $1,
416 push @{$msg[$cmno] -> {kids}} => $#msg;
417 push @{$msg[$cmno] -> {unids}} => $2;
418 $msg[$cmno] -> {answers}++;
425 $msg[$_] -> {answers}++ for (@stack);
427 $msg[-1] -> {name} =~ s/&/&/g;
428 $msg[-1] -> {cat} =~ s/&/&/g;
429 $msg[-1] -> {subject} =~ s/&/&/g;
433 $cmno = pop @stack; $level--;
437 my $smsg = sort_thread (\@msg, $sorted); # sort messages
438 delete_messages ($smsg) unless ($deleted); # remove invisible messages
440 $threads{$tid} = $smsg if (@$smsg);
444 ? (\%threads, $last_thread, $last_message, $dtd, \@unids)
448 ###########################
449 # sub create_forum_xml_string
451 # Forumshauptdatei erzeugen
452 ###########################
454 sub create_forum_xml_string ($$) {
455 my ($threads, $param) = @_;
456 my ($level, $thread, $msg);
458 my $xml = '<?xml version="1.0" encoding="UTF
-8"?>'."\n"
459 .'<!DOCTYPE Forum SYSTEM "'.$param -> {dtd}.'">'."\n"
460 .'<Forum lastMessage="'.$param -> {lastMessage}.'" lastThread="'.$param -> {lastThread}.'">';
462 foreach $thread (sort {$b <=> $a} keys %$threads) {
463 $xml .= '<Thread id="t
'.$thread.'">';
466 foreach $msg (@{$threads -> {$thread}}) {
467 $xml .= '</Message>' x ($level - $msg -> {level} + 1) if ($msg -> {level} <= $level);
468 $level = $msg -> {level};
469 $xml .= '<Message id="m
'.$msg -> {mid}.'"'
470 .' unid="'.$msg -> {unid}.'"'
471 .(($msg -> {deleted})?' invisible="1"':'')
472 .(($msg -> {archive})?' archive="1"':'')
477 .plain($msg -> {name})
482 .((length $msg -> {cat})?plain($msg -> {cat}):'')
485 .plain($msg -> {subject})
492 $xml .= '</Message>' x ($level + 1);
493 $xml .= '</Thread>';}
500 ### save_file () ###############################################################
504 # Params: $filename Filename
505 # $content File content as scalar reference
506 # Return: Status (1 - ok, 0 - error)
510 my ($filename, $content) = @_;
513 open FILE, ">$filename.temp
" or return;
515 unless (print FILE $$content)
521 close FILE or return;
523 rename "$filename.temp
", $filename or return;
528 # ====================================================
530 # ====================================================
532 ###########################
534 # 02. Januar 2001, 12:02 Uhr
537 # 02. 01. 2001, 12:02 Uhr
540 # Dienstag, 02. Januar 2001, 12:02:01 Uhr
542 # formatierte Zeitangabe
543 ###########################
546 my @month = (qw(Januar Februar), "M\303\244rz", qw(April Mail Juni Juli August September Oktober November Dezember));
549 my (undef, $min, $hour, $day, $mon, $year) = localtime ($_[0]);
551 sprintf ('%02d. %s %04d, %02d:%02d Uhr', $day, $month[$mon], $year+1900, $hour, $min);
554 sub short_hr_time
($) {
555 my (undef, $min, $hour, $day, $mon, $year) = localtime ($_[0]);
557 sprintf ('%02d. %02d. %04d, %02d:%02d Uhr', $day, $mon+1, $year+1900, $hour, $min);
560 sub long_hr_time
($) {
561 my @month = (qw(Januar Februar), "M\303\244rz", qw(April Mail Juni Juli August September Oktober November Dezember));
564 my @wday = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
565 my ($sek, $min, $hour, $day, $mon, $year, $wday) = localtime ($_[0]);
567 sprintf ('%s, %02d. %s %04d, %02d:%02d:%02d Uhr', $wday[$wday], $day, $month[$mon], $year+1900, $hour, $min, $sek);
570 # ====================================================
571 # Modulinitialisierung
572 # ====================================================
574 # making require happy
patrick-canterino.de