]> git.p6c8.net - selfforum.git/blob - selfforum-cgi/shared/Posting/_lib.pm
added purge method
[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> #
8 # Frank Schönmann <fs@tower.de> #
9 # #
10 # Description: Message access interface, time format routines #
11 # #
12 ################################################################################
13
14 use strict;
15 use vars qw(
16 @EXPORT_OK
17 );
18
19 use Encode::Plain; $Encode::Plain::utf8 = 1;
20
21 use Time::German ':overwrite_internal_localtime';
22 use XML::DOM;
23
24 ################################################################################
25 #
26 # Version check
27 #
28 # last modified:
29 # $Date$ (GMT)
30 # by $Author$
31 #
32 sub VERSION {(q$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'}
33
34 ################################################################################
35 #
36 # Export
37 #
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;
42
43 use base qw(Exporter);
44 @EXPORT_OK = qw(
45 get_message_header
46 get_message_body
47 get_message_node
48 get_body_node
49 parse_single_thread
50 parse_xml_file
51 create_new_thread
52 create_message
53
54 hr_time
55 short_hr_time
56 long_hr_time
57 very_short_hr_time
58 month
59
60 get_all_threads
61 create_forum_xml_string
62
63 save_file
64
65 SORT_ASCENT
66 SORT_DESCENT
67 KEEP_DELETED
68 KILL_DELETED
69 );
70
71 ################################################################################
72 #
73 # Access via XML::DOM
74 #
75
76 ### sub create_message ($$) ####################################################
77 #
78 # create the 'Message' subtree
79 #
80 # Params: $xml - XML::DOM::Document object
81 # $par - hash reference
82 # (msg, ip, name, email, home, image, category, subject, time)
83 #
84 # Return: XML::DOM::Element object
85 #
86 sub create_message ($$) {
87 my ($xml,$par) = @_;
88
89 my $message = $xml -> createElement ('Message');
90 $message -> setAttribute ('id' => $par -> {msg});
91 $message -> setAttribute ('ip' => $par -> {ip});
92
93 my $header = $xml -> createElement ('Header');
94 my $author = $xml -> createElement ('Author');
95 $header -> appendChild ($author);
96
97 my @may = (
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
105
106 for (@may) {
107
108 # create element
109 my $obj = $xml -> createElement ($_->[1]);
110
111 # insert content
112 $obj -> addText (
113 defined $par -> {$_->[0]}
114 ? $par -> {$_->[0]}
115 : ''
116 );
117
118 # link to superior element
119 $_ -> [2] -> appendChild ($obj);
120 }
121
122 my $date = $xml -> createElement ('Date');
123 $date -> setAttribute ('longSec'=> $par -> {time});
124
125 $header -> appendChild ($date);
126 $message -> appendChild ($header);
127
128 # return
129 #
130 $message;
131 }
132
133 ### sub create_new_thread ($) ##################################################
134 #
135 # create a XML::DOM::Document object of a thread containing one posting
136 #
137 # Params: hash reference
138 # (dtd, thread, msg, body, ip, name, email, home,
139 # image, category, subject, time)
140 #
141 # Return: XML::DOM::Document object
142 #
143 sub create_new_thread ($) {
144 my $par = shift;
145
146 # new document
147 #
148 my $xml = new XML::DOM::Document;
149
150 # xml declaration
151 #
152 my $decl = new XML::DOM::XMLDecl;
153 $decl -> setVersion ('1.0');
154 $decl -> setEncoding ('UTF-8');
155 $xml -> setXMLDecl ($decl);
156
157 # set doctype
158 #
159 my $dtd = $xml -> createDocumentType ('Forum' => $par -> {dtd});
160 $xml -> setDoctype ($dtd);
161
162 # create root element 'Forum'
163 # create element 'Thread'
164 # create 'Message' subtree
165 # create element 'ContentList'
166 # create 'MessageContent' subtree
167 #
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}})
177 );
178
179 # link all the nodes to
180 # their superior elements
181 #
182 $thread -> appendChild ($message);
183 $forum -> appendChild ($thread);
184 $content -> appendChild ($mcontent);
185 $forum -> appendChild ($content);
186 $xml -> appendChild ($forum);
187
188 # return
189 #
190 $xml;
191 }
192
193 ### get_message_header () ######################################################
194 #
195 # Read message header, return as a hash
196 #
197 # Params: $node - XML message node
198 # Return: hash reference (name, category, subject, email, home, image, time)
199 #
200 sub get_message_header ($)
201 {
202 my $node = shift;
203 my %conf;
204
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);
214
215 %conf = (
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')
223 );
224
225 \%conf;
226 }
227
228 ### get_body_node () ########################################################
229 #
230 # Search a specific message body in a XML tree
231 #
232 # Params: $xml XML::DOM::Document Object (Document Node)
233 # $mid Message ID
234 #
235 # Return: MessageContent XML node (or -none-)
236 #
237 sub get_body_node ($$)
238 {
239 my ($xml, $mid) = @_;
240
241 for ($xml -> getElementsByTagName ('ContentList', 1) -> item (0) -> getElementsByTagName ('MessageContent', 0)) {
242 return $_ if ($_ -> getAttribute ('mid') eq $mid);
243 }
244
245 return;
246 }
247
248 ### get_message_body () ########################################################
249 #
250 # Read message body
251 #
252 # Params: $xml XML::DOM::Document Object (Document Node)
253 # $mid Message ID
254 #
255 # Return: Scalar reference
256 #
257 sub get_message_body ($$)
258 {
259 my $cnode = get_body_node ($_[0], $_[1]);
260 my $body;
261
262 $body = ($cnode -> hasChildNodes)?$cnode -> getFirstChild -> getData:'' if $cnode;
263
264 \$body;
265 }
266
267 ### get_message_node () ########################################################
268 #
269 # Search a specific message in a XML tree
270 #
271 # Params: $xml XML::DOM::Document Object (Document Node)
272 # $tid Thread ID
273 # $mid Message ID
274 #
275 # Return: Message XML node, Thread XML node (or -none-)
276 #
277 sub get_message_node ($$$)
278 {
279 my ($xml, $tid, $mid) = @_;
280 my ($mnode, $tnode);
281
282 for ($xml->getElementsByTagName ('Thread')) {
283 if ($_->getAttribute ('id') eq $tid) {
284 $tnode = $_;
285
286 for ($tnode -> getElementsByTagName ('Message')) {
287 if ($_ -> getAttribute ('id') eq $mid) {
288 $mnode = $_;
289 last;
290 }
291 }
292 last;
293 }
294 }
295
296 wantarray
297 ? ($mnode, $tnode)
298 : $mnode;
299 }
300
301 ### sub parse_xml_file ($) #####################################################
302 #
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
305 #
306 # Params: $file filename
307 #
308 # Return: XML::DOM::Document Object (Document Node) or false
309 #
310 sub parse_xml_file ($) {
311 my $file = shift;
312
313 my $xml = eval {
314 local $SIG{__DIE__}; # CGI::Carp works unreliable ;-(
315 new XML::DOM::Parser(KeepCDATA => 1)->parsefile ($file);
316 };
317
318 return if ($@);
319
320 $xml;
321 }
322
323 ### parse_single_thread () #####################################################
324 #
325 # parse a thread file
326 #
327 # Params: $tnode - Thread element node
328 # $deleted - keep deleted (boolean)
329 # $sorted - sorting order
330 #
331 # Return: arrayref
332 #
333 sub parse_single_thread ($$;$) {
334 my ($tnode, $deleted, $sorted) = @_;
335 my ($header, @msg, %mno);
336
337 for ($tnode -> getElementsByTagName ('Message')) {
338 $header = get_message_header ($_);
339
340 push @msg => {
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})
351 };
352 $mno{$_} = $#msg;
353 }
354
355 my $level;
356 $msg[0] -> {level} = 0;
357 for (@msg) {
358 $level = $_ -> {level} + 1;
359 @{$_ -> {kids}} = map {$msg[$mno{$_}] -> {level} = $level; $mno{$_}} @{$_ -> {kids}};
360 }
361
362 # sort and process deleted files
363 #
364 my $smsg = sort_thread (\@msg, $sorted);
365 delete_messages ($smsg) unless ($deleted);
366
367 $smsg;
368 }
369
370 ################################################################################
371 #
372 # Access via regexps and native perl ;)
373 #
374
375 ### sort_thread () #############################################################
376 #
377 # sort the message array
378 #
379 # Params: $msg - arrayref
380 # $sorted - sorting order
381 #
382 # Return: sorted arrayref
383 #
384 sub sort_thread ($$) {
385 my ($msg, $sorted) = @_;
386
387 my ($z, %mhash) = (0);
388
389 if ($sorted) { # oldest first
390 for (@$msg) {
391 @$msg[@{$_ -> {kids}}] = sort {$a -> {mid} <=> $b -> {mid}} @$msg[@{$_ -> {kids}}] if (@{$_ -> {kids}} > 1);
392 $mhash{$_ -> {mid}} = [@$msg[@{$_ -> {kids}}]];}}
393
394 else { # latest first
395 for (@$msg) {
396 @$msg[@{$_ -> {kids}}] = sort {$b -> {mid} <=> $a -> {mid}} @$msg[@{$_ -> {kids}}] if (@{$_ -> {kids}} > 1);
397 $mhash{$_ -> {mid}} = [@$msg[@{$_ -> {kids}}]];}}
398
399 # sort the children
400 #
401 my @smsg = ($msg -> [0]);
402 for (@smsg) {
403 ++$z;
404 splice @smsg,$z,0,@{$mhash{$_ -> {mid}}} if ($_ -> {answers});
405 delete $_ -> {kids};
406 }
407
408 # return
409 \@smsg;
410 }
411
412 ### delete_messages () #########################################################
413 #
414 # Filter out deleted messages
415 #
416 # Params: $smsg Reference of array of references of hashs
417 # Return: -none-
418 #
419 sub delete_messages ($) {
420 my $smsg = shift;
421 my ($z, $oldlevel, @path) = (0,0,0);
422
423 while ($z <= $#{$smsg}) {
424
425 if ($smsg -> [$z] -> {level} > $oldlevel) {
426 push @path => $z;
427 $oldlevel = $smsg -> [$z] -> {level};
428 }
429 elsif ($smsg -> [$z] -> {level} < $oldlevel) {
430 splice @path, $smsg -> [$z] -> {level};
431 push @path => $z;
432 $oldlevel = $smsg -> [$z] -> {'level'};
433 }
434 else {
435 $path[-1] = $z;
436 }
437
438 if ($smsg -> [$z] -> {deleted}) {
439 my $n = $smsg -> [$z] -> {answers} + 1;
440 $smsg -> [$_] -> {answers} -= $n for (@path);
441 splice @$smsg, $z, $n;
442 }
443 else {
444 $z++;
445 }
446 }
447
448 return;
449 }
450
451 ### get_all_threads () #########################################################
452 #
453 # Read and Parse the main file (without any XML-module, they are too slow)
454 #
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)
458 #
459 # Return: scalar context: hash reference (\%threads)
460 # list context: list (\%threads, $last_thread, $last_message, $dtd, \@unids)
461 #
462 sub get_all_threads ($$;$) {
463 my ($file, $deleted, $sorted) = @_;
464 my ($last_thread, $last_message, $dtd, @unids, %threads);
465 local (*FILE, $/);
466
467 open FILE,"< $file" or return;
468 my $xml = join '', <FILE>;
469 close(FILE) or return;
470
471 if (wantarray) {
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="([^"]+)"[^>]*>/;
475 }
476
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;
485
486 while ($xml =~ /<Thread id="t(\d+)">([^<]*(?:<(?!\/Thread>)[^<]*)*)<\/Thread>/g)
487 {
488 my ($tid, $thread) = ($1, $2);
489 my ($level, $cmno, @msg, @stack) = (0);
490
491 while ($thread =~ m;$reg_msg;g)
492 {
493 if (defined($10))
494 {
495 push @stack,$cmno if (defined $cmno);
496 push @msg, {
497 mid => $1,
498 unid => $2,
499 deleted => $3 || 0,
500 archive => $4 || 0,
501 name => $5,
502 cat => $6,
503 subject => $7,
504 time => $8,
505 level => $level++,
506 unids => [],
507 kids => [],
508 answers => 0
509 };
510
511 if (defined $cmno)
512 {
513 push @{$msg[$cmno] -> {kids}} => $#msg;
514 push @{$msg[$cmno] -> {unids}} => $2;
515 }
516 else
517 {
518 push @unids => $2;
519 }
520
521 $msg[$_] -> {answers}++ for (@stack);
522
523 $cmno=$#msg;
524
525 $msg[-1] -> {name} =~ s/&amp;/&/g;
526 $msg[-1] -> {cat} =~ s/&amp;/&/g;
527 $msg[-1] -> {subject} =~ s/&amp;/&/g;
528
529 }
530 elsif (defined ($9))
531 {
532 push @msg, {
533 mid => $1,
534 unid => $2,
535 deleted => $3 || 0,
536 archive => $4 || 0,
537 name => $5,
538 cat => $6,
539 subject => $7,
540 time => $8,
541 level => $level,
542 unids => [],
543 kids => [],
544 answers => 0
545 };
546
547 if (defined $cmno)
548 {
549 push @{$msg[$cmno] -> {kids}} => $#msg;
550 push @{$msg[$cmno] -> {unids}} => $2;
551 $msg[$cmno] -> {answers}++;
552 }
553 else
554 {
555 push @unids => $2;
556 }
557
558 $msg[$_] -> {answers}++ for (@stack);
559
560 $msg[-1] -> {name} =~ s/&amp;/&/g;
561 $msg[-1] -> {cat} =~ s/&amp;/&/g;
562 $msg[-1] -> {subject} =~ s/&amp;/&/g;
563 }
564 else
565 {
566 $cmno = pop @stack; $level--;
567 }
568 }
569
570 my $smsg = sort_thread (\@msg, $sorted); # sort messages
571 delete_messages ($smsg) unless ($deleted); # remove invisible messages
572
573 $threads{$tid} = $smsg if (@$smsg);
574 }
575
576 wantarray
577 ? (\%threads, $last_thread, $last_message, $dtd, \@unids)
578 : \%threads;
579 }
580
581 ### create_forum_xml_string () #################################################
582 #
583 # compose main file xml string
584 #
585 # Params: $threads - parsed threads (see also 'get_all_threads')
586 # $params - hashref (see doc for details)
587 #
588 # Return: scalarref of the xml string
589 #
590 sub create_forum_xml_string ($$) {
591 my ($threads, $param) = @_;
592 my ($level, $thread, $msg);
593
594 my $xml =
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}.'">';
598
599 for $thread (sort {$b <=> $a} keys %$threads) {
600 $xml .= '<Thread id="t'.$thread.'">';
601 $level = -1;
602
603 for $msg (@{$threads -> {$thread}}) {
604 $xml .= '</Message>' x ($level - $msg -> {level} + 1) if ($msg -> {level} <= $level);
605
606 $level = $msg -> {level};
607 $xml .=
608 '<Message id="m'.$msg -> {mid}.'"'
609 . ' unid="'.$msg -> {unid}.'"'
610 . (($msg -> {deleted})?' invisible="1"':'')
611 . (($msg -> {archive})?' archive="1"':'')
612 . '>'
613 . '<Header>'
614 . '<Author>'
615 . '<Name>'
616 . plain($msg -> {name})
617 . '</Name>'
618 . '<Email />'
619 . '</Author>'
620 . '<Category>'
621 . ((length $msg -> {cat})?plain($msg -> {cat}):'')
622 . '</Category>'
623 . '<Subject>'
624 . plain($msg -> {subject})
625 . '</Subject>'
626 . '<Date longSec="'
627 . $msg -> {time}
628 . '"/>'
629 . '</Header>';
630 }
631
632 $xml .= '</Message>' x ($level + 1);
633 $xml .= '</Thread>';}
634
635 $xml.='</Forum>';
636
637 \$xml;
638 }
639
640 ### save_file () ###############################################################
641 #
642 # Save a file
643 #
644 # Params: $filename Filename
645 # $content File content as scalar reference
646 # Return: Status (1 - ok, 0 - error)
647 #
648 sub save_file ($$)
649 {
650 my ($filename, $content) = @_;
651 local *FILE;
652
653 open FILE, ">$filename.temp" or return;
654
655 unless (print FILE $$content)
656 {
657 close FILE;
658 return;
659 }
660
661 close FILE or return;
662
663 rename "$filename.temp", $filename or return;
664
665 1;
666 }
667
668 ################################################################################
669 #
670 # several time formatting routines
671 #
672 # hr_time
673 # 02. Januar 2001, 12:02 Uhr
674 #
675 # short_hr_time
676 # 02. 01. 2001, 12:02 Uhr
677 #
678 # long_hr_time
679 # Dienstag, 02. Januar 2001, 12:02:01 Uhr
680 #
681 # very_short_hr_time
682 # 02. 01. 2001
683 #
684 sub month($) {
685 (qw(Januar Februar), "M\303\244rz", qw(April Mai Juni Juli August September Oktober November Dezember))[shift (@_) - 1];
686 # ^^^^^^^^ - UTF8 #
687 }
688
689 sub hr_time ($) {
690 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
691
692 sprintf ('%02d. %s %04d, %02d:%02d Uhr', $day, month($mon+1), $year+1900, $hour, $min);
693 }
694
695 sub short_hr_time ($) {
696 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
697
698 sprintf ('%02d. %02d. %04d, %02d:%02d Uhr', $day, $mon+1, $year+1900, $hour, $min);
699 }
700
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);
704
705 sprintf ('%s, %02d. %s %04d, %02d:%02d:%02d Uhr', $wday[$wday], $day, month($mon+1), $year+1900, $hour, $min, $sek);
706 }
707
708 sub very_short_hr_time($) {
709 my (undef, $min, $hour, $day, $mon, $year) = localtime (shift);
710
711 sprintf ('%02d. %02d. %04d', $day, $mon+1, $year+1900);
712 }
713
714 # keep 'require' happy
715 1;
716
717 #
718 #
719 ### end of Posting::_lib #######################################################

patrick-canterino.de