selfforum-cgi/shared/Posting/_lib.pm

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