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