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