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