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