]> git.p6c8.net - selfforum.git/blob - selfforum-cgi/shared/Posting/_lib.pm
05a0285c2a2cef36a1590a88086f519d09341a99
[selfforum.git] / selfforum-cgi / shared / Posting / _lib.pm
1 package Posting::_lib;
2
3 ################################################################################
4 # #
5 # File: shared/Posting/_lib.pm #
6 # #
7 # Authors: André Malo <nd@o3media.de>, 2001-03-03 #
8 # Frank Schoenmann <fs@tower.de>, 2001-03-13 #
9 # #
10 # Description: Message access interface, time format routines #
11 # #
12 ################################################################################
13
14 use strict;
15
16 use vars qw(@EXPORT_OK);
17 use base qw(Exporter);
18
19 use Encode::Plain; $Encode::Plain::utf8 = 1;
20
21 use XML::DOM;
22
23 # ====================================================
24 # Export
25 # ====================================================
26
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
30 save_file);
31
32 # ====================================================
33 # Access via XML::DOM
34 # ====================================================
35
36 ### get_message_header () ######################################################
37 #
38 # Read message header, return as a hash
39 #
40 # Params: $node XML message node
41 # Return: Hash reference (name, category, subject, email, home, image, time)
42 #
43 sub get_message_header ($)
44 {
45 my $node = shift;
46 my %conf;
47
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);
57
58 %conf = (
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')
66 );
67
68 \%conf;
69 }
70
71 ### get_body_node () ########################################################
72 #
73 # Search a specific message body in a XML tree
74 #
75 # Params: $xml XML::DOM::Document Object (Document Node)
76 # $mid Message ID
77 # Return: MessageContent XML node (or -none-)
78 #
79 sub get_body_node ($$)
80 {
81 my ($xml, $mid) = @_;
82
83 for ($xml->getElementsByTagName ('ContentList', 1)->item (0)->getElementsByTagName ('MessageContent', 0))
84 {
85 return $_ if ($_ -> getAttribute ('mid') eq $mid);
86 }
87
88 return;
89 }
90
91 ### get_message_body () ########################################################
92 #
93 # Read message body
94 #
95 # Params: $xml XML::DOM::Document Object (Document Node)
96 # $mid Message ID
97 # Return: Scalar reference
98 #
99 sub get_message_body ($$)
100 {
101 my $cnode = get_body_node ($_[0], $_[1]);
102 my $body;
103
104 $body = ($cnode -> hasChildNodes)?$cnode -> getFirstChild -> getData:'' if $cnode;
105
106 \$body;
107 }
108
109 ### get_message_node () ########################################################
110 #
111 # Search a specific message in a XML tree
112 #
113 # Params: $xml XML::DOM::Document Object (Document Node)
114 # $tid Thread ID
115 # $mid Message ID
116 # Return: Message XML node, Thread XML node (or -none-)
117 #
118 sub get_message_node ($$$)
119 {
120 my ($xml, $tid, $mid) = @_;
121 my ($mnode, $tnode);
122
123 for ($xml->getElementsByTagName ('Thread'))
124 {
125 if ($_->getAttribute ('id') eq $tid)
126 {
127 $tnode = $_;
128 for ($tnode -> getElementsByTagName ('Message'))
129 {
130 if ($_ -> getAttribute ('id') eq $mid)
131 {
132 $mnode = $_;
133 last;
134 }
135 }
136 last;
137 }
138 }
139
140 wantarray ? ($mnode, $tnode) : $mnode;
141 }
142
143 ###########################
144 # sub parse_single_thread
145 #
146 # einzelne Threaddatei
147 # parsen
148 ###########################
149
150 sub parse_single_thread ($$;$) {
151 my ($tnode, $deleted, $sorted) = @_;
152 my ($header, @msg, %mno);
153
154 for ($tnode -> getElementsByTagName ('Message')) {
155 $header = get_message_header ($_);
156
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})};
167 $mno{$_} = $#msg;}
168
169 # Eintraege ergaenzen und korrigieren
170 my $level;
171 $msg[0] -> {level} = 0;
172 for (@msg) {
173 $level = $_ -> {level} + 1;
174 @{$_ -> {kids}} = map {$msg[$mno{$_}] -> {level} = $level; $mno{$_}} @{$_ -> {kids}};}
175
176 # ============
177 # Sortieren und bei Bedarf
178 # geloeschte Messages entfernen
179
180 my $smsg = sort_thread (\@msg, $sorted);
181 delete_messages ($smsg) unless ($deleted);
182
183 $smsg;
184 }
185
186 ###########################
187 # sub create_message_xml
188 #
189 # Message-XML-String
190 # erzeugen
191 ###########################
192
193 sub create_message_xml ($$$) {
194 my ($xml, $msges, $num) = @_;
195
196 my $msg = $msges -> [$num];
197
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});
202
203 # Header erzeugen
204 my $header = $xml -> createElement ('Header');
205
206 # alles inside of 'Header'
207 my $author = $xml -> createElement ('Author');
208
209 my $name = $xml -> createElement ('Name');
210 $name -> addText (toUTF8($msg -> {name}));
211
212 my $email = $xml -> createElement ('Email');
213
214 my $category = $xml -> createElement ('Category');
215 $category -> addText (toUTF8($msg -> {cat}));
216
217 my $subject = $xml -> createElement ('Subject');
218 $subject -> addText (toUTF8($msg -> {subject}));
219
220 my $date = $xml -> createElement ('Date');
221 $date -> setAttribute ('longSec', $msg -> {time});
222
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);
230
231 if ($msg -> {kids}) {
232 for (@{$msg -> {kids}}) {
233 $message -> appendChild (&create_message_xml ($xml, $msges, $_));
234 }
235 }
236
237 $message;
238 }
239
240 # ====================================================
241 # XML-Parsen von Hand
242 # ====================================================
243
244 ###########################
245 # sub sort_thread
246 #
247 # Messages eines
248 # Threads sortieren
249 ###########################
250
251 sub sort_thread ($$) {
252 my ($msg, $sorted) = @_;
253
254 my ($z, %mhash) = (0);
255
256 if ($sorted) { # aelteste zuerst
257 for (@$msg) {
258 @$msg[@{$_ -> {kids}}] = sort {$a -> {mid} <=> $b -> {mid}} @$msg[@{$_ -> {kids}}] if (@{$_ -> {kids}} > 1);
259 $mhash{$_ -> {mid}} = [@$msg[@{$_ -> {kids}}]];}}
260
261 else { # juengste zuerst
262 for (@$msg) {
263 @$msg[@{$_ -> {kids}}] = sort {$b -> {mid} <=> $a -> {mid}} @$msg[@{$_ -> {kids}}] if (@{$_ -> {kids}} > 1);
264 $mhash{$_ -> {mid}} = [@$msg[@{$_ -> {kids}}]];}}
265
266 # Kinder wieder richtig einsortieren
267 my @smsg = ($msg -> [0]);
268 for (@smsg) {
269 ++$z;
270 splice @smsg,$z,0,@{$mhash{$_ -> {mid}}} if ($_ -> {answers});
271 delete $_ -> {kids};}
272
273 \@smsg;
274 }
275
276 ### delete_messages () #########################################################
277 #
278 # Filter out deleted messages
279 #
280 # Params: $smsg Reference of array of references of hashs
281 # Return: -none-
282 #
283 sub delete_messages ($)
284 {
285 my $smsg = shift;
286
287 my ($z, $oldlevel, @path) = (0,0,0);
288
289 for (@$smsg)
290 {
291 if ($_ -> {'deleted'})
292 {
293 my $n = $_ -> {'answers'} + 1;
294 $smsg -> [$_] -> {'answers'} -= $n for (@path);
295 splice @$smsg,$z,$n;
296 }
297 else
298 {
299 if ($_ -> {'level'} > $oldlevel)
300 {
301 push @path,$z;
302 $oldlevel = $_ -> {'level'};
303 }
304 elsif ($_ -> {'level'} < $oldlevel)
305 {
306 splice @path,$_ -> {'level'} - $oldlevel;
307 $oldlevel = $_ -> {'level'};
308 }
309 else
310 {
311 $path[-1] = $z;
312 }
313
314 $z++;
315 }
316 }
317
318 return;
319 }
320
321 ### get_all_threads () #########################################################
322 #
323 # Read and Parse the main file (without any XML-module, they are too slow)
324 #
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)
330 #
331 sub get_all_threads ($$;$)
332 {
333 my ($file, $deleted, $sorted) = @_;
334 my ($last_thread, $last_message, $dtd, @unids, %threads);
335 local (*FILE, $/);
336
337 open FILE, $file or return undef;
338 my $xml = join '', <FILE>;
339 close(FILE) or return undef;
340
341 if (wantarray)
342 {
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="([^"]+)"[^>]*>/;
346 }
347
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;
356
357 while ($xml =~ /<Thread id="t(\d+)">([^<]*(?:<(?!\/Thread>)[^<]*)*)<\/Thread>/g)
358 {
359 my ($tid, $thread) = ($1, $2);
360 my ($level, $cmno, @msg, @stack) = (0);
361
362 while ($thread =~ m;$reg_msg;g)
363 {
364 if (defined($10))
365 {
366 push @stack,$cmno if (defined $cmno);
367 push @msg, {mid => $1,
368 unid => $2,
369 deleted => $3,
370 archive => $4,
371 name => $5,
372 cat => $6,
373 subject => $7,
374 time => $8,
375 level => $level++,
376 unids => [],
377 kids => [],
378 answers => 0};
379
380 if (defined $cmno)
381 {
382 push @{$msg[$cmno] -> {kids}} => $#msg;
383 push @{$msg[$cmno] -> {unids}} => $2;
384 }
385 else
386 {
387 push @unids => $2;
388 }
389
390 $msg[$_] -> {answers}++ for (@stack);
391
392 $cmno=$#msg;
393
394 $msg[-1] -> {name} =~ s/&amp;/&/g;
395 $msg[-1] -> {cat} =~ s/&amp;/&/g;
396 $msg[-1] -> {subject} =~ s/&amp;/&/g;
397
398 }
399 elsif (defined ($9))
400 {
401 push @msg, {mid => $1,
402 unid => $2,
403 deleted => $3,
404 archive => $4,
405 name => $5,
406 cat => $6,
407 subject => $7,
408 time => $8,
409 level => $level,
410 unids => [],
411 kids => [],
412 answers => 0};
413
414 if (defined $cmno)
415 {
416 push @{$msg[$cmno] -> {kids}} => $#msg;
417 push @{$msg[$cmno] -> {unids}} => $2;
418 $msg[$cmno] -> {answers}++;
419 }
420 else
421 {
422 push @unids => $2;
423 }
424
425 $msg[$_] -> {answers}++ for (@stack);
426
427 $msg[-1] -> {name} =~ s/&amp;/&/g;
428 $msg[-1] -> {cat} =~ s/&amp;/&/g;
429 $msg[-1] -> {subject} =~ s/&amp;/&/g;
430 }
431 else
432 {
433 $cmno = pop @stack; $level--;
434 }
435 }
436
437 my $smsg = sort_thread (\@msg, $sorted); # sort messages
438 delete_messages ($smsg) unless ($deleted); # remove invisible messages
439
440 $threads{$tid} = $smsg if (@$smsg);
441 }
442
443 wantarray
444 ? (\%threads, $last_thread, $last_message, $dtd, \@unids)
445 : \%threads;
446 }
447
448 ###########################
449 # sub create_forum_xml_string
450 #
451 # Forumshauptdatei erzeugen
452 ###########################
453
454 sub create_forum_xml_string ($$) {
455 my ($threads, $param) = @_;
456 my ($level, $thread, $msg);
457
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}.'">';
461
462 foreach $thread (sort {$b <=> $a} keys %$threads) {
463 $xml .= '<Thread id="t'.$thread.'">';
464 $level = -1;
465
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"':'')
473 .'>'
474 .'<Header>'
475 .'<Author>'
476 .'<Name>'
477 .plain($msg -> {name})
478 .'</Name>'
479 .'<Email></Email>'
480 .'</Author>'
481 .'<Category>'
482 .((length $msg -> {cat})?plain($msg -> {cat}):'')
483 .'</Category>'
484 .'<Subject>'
485 .plain($msg -> {subject})
486 .'</Subject>'
487 .'<Date longSec="'
488 .$msg -> {time}
489 .'"/>'
490 .'</Header>';}
491
492 $xml .= '</Message>' x ($level + 1);
493 $xml .= '</Thread>';}
494
495 $xml.='</Forum>';
496
497 \$xml;
498 }
499
500 ### save_file () ###############################################################
501 #
502 # Save a file
503 #
504 # Params: $filename Filename
505 # $content File content as scalar reference
506 # Return: Status (1 - ok, 0 - error)
507 #
508 sub save_file ($$)
509 {
510 my ($filename, $content) = @_;
511 local *FILE;
512
513 open FILE, ">$filename.temp" or return;
514
515 unless (print FILE $$content)
516 {
517 close FILE;
518 return;
519 }
520
521 close FILE or return;
522
523 rename "$filename.temp", $filename or return;
524
525 1;
526 }
527
528 # ====================================================
529 # Zeitdarstellung
530 # ====================================================
531
532 ###########################
533 # sub hr_time
534 # 02. Januar 2001, 12:02 Uhr
535 #
536 # sub short_hr_time
537 # 02. 01. 2001, 12:02 Uhr
538 #
539 # sub long_hr_time
540 # Dienstag, 02. Januar 2001, 12:02:01 Uhr
541 #
542 # formatierte Zeitangabe
543 ###########################
544
545 sub hr_time ($) {
546 my @month = (qw(Januar Februar), "M\303\244rz", qw(April Mail Juni Juli August September Oktober November Dezember));
547 # ^^^^^^^^ - UTF8 #
548
549 my (undef, $min, $hour, $day, $mon, $year) = localtime ($_[0]);
550
551 sprintf ('%02d. %s %04d, %02d:%02d Uhr', $day, $month[$mon], $year+1900, $hour, $min);
552 }
553
554 sub short_hr_time ($) {
555 my (undef, $min, $hour, $day, $mon, $year) = localtime ($_[0]);
556
557 sprintf ('%02d. %02d. %04d, %02d:%02d Uhr', $day, $mon+1, $year+1900, $hour, $min);
558 }
559
560 sub long_hr_time ($) {
561 my @month = (qw(Januar Februar), "M\303\244rz", qw(April Mail Juni Juli August September Oktober November Dezember));
562 # ^^^^^^^^ - UTF8 #
563
564 my @wday = qw(Sonntag Montag Dienstag Mittwoch Donnerstag Freitag Samstag);
565 my ($sek, $min, $hour, $day, $mon, $year, $wday) = localtime ($_[0]);
566
567 sprintf ('%s, %02d. %s %04d, %02d:%02d:%02d Uhr', $wday[$wday], $day, $month[$mon], $year+1900, $hour, $min, $sek);
568 }
569
570 # ====================================================
571 # Modulinitialisierung
572 # ====================================================
573
574 # making require happy
575 1;

patrick-canterino.de