selfforum-cgi/shared/Arc/Archive.pm

   1 package Arc::Archive;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/Arc/Archive.pm                                           #
   6 #                                                                              #
   7 # Authors:     Andre Malo       <nd@o3media.de>, 2001-06-16                    #
   8 #                                                                              #
   9 # Description: Severance of Threads and archiving                              #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   @EXPORT
  16   $VERSION
  17 );
  18
  19 use Arc::Test;
  20 use Lock;
  21 use Posting::_lib qw(
  22   get_all_threads
  23   create_forum_xml_string
  24   parse_xml_file
  25   parse_single_thread
  26   get_message_node
  27   get_body_node
  28   save_file
  29   KEEP_DELETED
  30 );
  31 use Posting::Cache;
  32 use Time::German 'localtime';
  33
  34 use XML::DOM;
  35
  36 ################################################################################
  37 #
  38 # Version check
  39 #
  40 $VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  41
  42 ################################################################################
  43 #
  44 # Export
  45 #
  46 use base qw(Exporter);
  47 @EXPORT = qw(cut_tail);
  48
  49 ### delete_no_archived () ######################################################
  50 #
  51 # remove no archived branches vom thread
  52 #
  53 # Params: $xml     - XML::DOM::Document node
  54 #         $msg     - arrayref - messages
  55 #         $percent - voting limit (percent)
  56 #
  57 # Return: ~none~
  58 #
  59 sub delete_no_archived ($) {
  60   my $par = shift;
  61
  62   my ($xml, $sum, $tid, $msg, $percent) = map {$par->{$_}}
  63    qw( xml   sum   tid   msg   percent);
  64
  65   # $oldlevel: contains the level of last checked msg
  66   # @path    : contains the current branch
  67   # %archive : contains the mids, that will be archived
  68   # %hidden  : contains the invisible mids
  69   #
  70   my ($oldlevel, @path, %archive, %hidden) = (0, 0);
  71
  72   # check all messages of thread
  73   #
  74   for my $z (0..$#{$msg}) {
  75
  76     if ($msg -> [$z] -> {level} > $oldlevel) {
  77       # this msg is a child of the last one
  78       #
  79       push @path => $z;
  80       $oldlevel = $msg -> [$z] -> {level};
  81     }
  82
  83     elsif ($msg -> [$z] -> {level} < $oldlevel) {
  84       # this starts a new subbranch (-1+ level(s))
  85       #
  86
  87       # remove last msg (incl. kids), that is on same level
  88       #
  89       splice @path, $msg -> [$z] -> {level};
  90       push @path => $z;
  91       $oldlevel = $msg -> [$z] -> {level};
  92     }
  93
  94     else {
  95       # the msg is a sister of the last one
  96       #
  97       $path[-1] = $z;
  98     }
  99
 100     # 'archive' is an admin flag
 101     # if set, the message (incl. branch) MUST be archived
 102     #
 103     if (defined $msg->[$z]->{archive} and $msg->[$z]->{archive}) {
 104       $archive{$msg->[$_]->{mid}} = 1 for (@path);
 105     }
 106
 107     # notice invisble messages
 108     # while they are in @path and archive flag is not set,
 109     # they and their kids WON'T be archived
 110     #
 111     $hidden{$z} = 1 if ($msg->[$z]->{deleted});
 112
 113     # if 'archive' is NOT set and message not deleted,
 114     #
 115     unless ($msg->[$z]->{archive} or $msg->[$z]->{deleted}) {
 116       my $key = $sum->{$tid}->{$msg->[$z]->{mid}};
 117
 118       # ...and they've voted enough, it will be archived
 119       #
 120       if ($percent == 0 or ($key->{views} and ($key->{votings} * 100 / $key->{views}) >= $percent)) {
 121         my $hidden_in_path;
 122
 123         # check on hidden messages in @path
 124         #
 125         for (@path) {
 126           if ($hidden{$_}) {
 127             $hidden_in_path = 1;
 128             last;
 129           }
 130         }
 131
 132         # set archive-flag for messages in @path,
 133         # unless a parent message is hidden
 134         #
 135         unless ($hidden_in_path) {
 136           $archive{$msg->[$_]->{mid}} = 1 for (@path);
 137         }
 138       }
 139     }
 140   }
 141
 142   # now remove messages without 'archive'-flag
 143   # from thread xml
 144   #
 145   for (reverse grep {!$archive{$_->{mid}}} @$msg) {
 146     my $h = get_message_node($xml, "t$tid", 'm'.$_->{mid});
 147
 148     # remove message entry
 149     #
 150     $h -> getParentNode -> removeChild ($h);
 151
 152     # remove message text
 153     #
 154     $h = get_body_node($xml, 'm'.$_->{mid});
 155     $h -> getParentNode -> removeChild ($h);
 156   }
 157 }
 158
 159 ### create_arcdir () ###########################################################
 160 #
 161 # check, if specific directories for year and month exist, create
 162 # it, if necessary
 163 #
 164 # Params: $path - archive root
 165 #         $time - Thread time (GMT)
 166 #
 167 # Return: List: $path  - /path/to/ to archived thread file
 168 #               $error - error or undef
 169 #
 170 sub create_arcdir ($$) {
 171   my ($path, $time) = @_;
 172
 173   my ($month, $year) = (localtime ($time))[4,5];
 174
 175   # use the 'real' values for directory names
 176   #
 177   $month++; $year+=1900;
 178
 179   my $yeardir   = $path     . $year;
 180   my $monthdir  = $yeardir  . '/' . $month;
 181   my $monthpath = $monthdir . '/';
 182
 183   mkdir $yeardir, 0777 unless (-d $yeardir);
 184   return ('', "could not create directory '$yeardir'") unless (-d $yeardir);
 185
 186   mkdir $monthdir, 0777 unless (-d $monthdir);
 187   return ('', "could not create directory '$monthdir'") unless (-d $monthdir);
 188
 189   # return path, successfully created
 190   #
 191   $monthpath;
 192 }
 193
 194 ### process_threads () #########################################################
 195 #
 196 # process obsolete threads
 197 # (transmit views/votings from cache, do archive, if necessary)
 198 #
 199 # Params: $par - hash reference
 200 #                (opt, cache, failed, obsolete, messagePath,
 201 #                 archivePath, adminDefault)
 202 #
 203 # Return: ~none~
 204 #
 205 sub process_threads ($) {
 206   my $par = shift;
 207
 208   my ($opt, $failed, $obsolete, $cache) = map {$par->{$_}} qw
 209      ( opt   failed   obsolete   cache);
 210
 211   if ($opt->{exArchiving}) {
 212
 213     # yes, we do archive
 214     #
 215     my $sum = $cache -> summary;
 216     if ($sum) {
 217
 218       # iterate over all obsolete threads, that are not failed yet
 219       #
 220       for my $tid (grep {not exists ($failed->{$_})} @$obsolete) {
 221         my $xml = parse_xml_file ($par->{messagePath}."t$tid.xml");
 222
 223         unless ($xml) {
 224           # xml parse error
 225           #
 226           $failed->{$tid} = 'could not parse thread file.';
 227         }
 228         else {
 229           # ok, parse thread
 230           #
 231           my $tnode = $xml -> getElementsByTagName ('Thread') -> item(0);
 232           my $msg = parse_single_thread ($tnode, KEEP_DELETED);
 233
 234           if ($opt->{archiving} eq 'UserVotings') {
 235
 236             # filter out the bad stuff
 237             #
 238             delete_no_archived ({
 239               xml     => $xml,
 240               sum     => $sum,
 241               tid     => $tid,
 242               msg     => $msg,
 243               percent => $par->{adminDefault}->{Voting}->{Limit}
 244             });
 245           }
 246
 247           # save back xml file (into archive)
 248           #
 249           if ($tnode -> hasChildNodes) {
 250
 251             # insert views and votings counter
 252             #
 253             for ($tnode -> getElementsByTagName ('Message')) {
 254               my ($id) = $_ -> getAttribute ('id') =~ /(\d+)/;
 255               $_ -> setAttribute ('views'   => $sum->{$tid}->{$id}->{views});
 256               $_ -> setAttribute ('votings' => $sum->{$tid}->{$id}->{votings});
 257             }
 258
 259             # create archive dir, unless exists
 260             #
 261             my ($path, $error) = create_arcdir ($par -> {archivePath}, $msg->[0]->{time});
 262
 263             if ($error) {
 264               $failed->{$tid} = $error;
 265             }
 266             else {
 267               # save thread file
 268               #
 269               my $file = "${path}t$tid.xml";
 270               save_file ($file => \($xml -> toString)) or $failed->{$tid} = "could not save '$file'";
 271             }
 272           }
 273         }
 274       }
 275     }
 276     else {
 277       @$failed{@$obsolete} = 'could not load summary';
 278     }
 279   }
 280 }
 281
 282 ### cut_tail () ################################################################
 283 #
 284 # shorten the main file and archive, if necessary
 285 #
 286 # Params: $param - hash reference
 287 #                  (forumFile, messagePath, archivePath, lockFile, adminDefault,
 288 #                   cachePath)
 289 #
 290 # Return: hash reference - empty if all right done
 291 #
 292 sub cut_tail ($) {
 293   my $param = shift;
 294   my %failed;
 295
 296   if (
 297     $param->{adminDefault}->{Severance}->{severance} ne 'instant' or
 298     $param->{adminDefault}->{Instant}->{execute}
 299   ) {
 300     # run only one instance at the same time
 301     # (exlusive lock on sev_lock)
 302     #
 303     my $sev = new Lock ($param->{lockFile});
 304     if ($sev -> lock(LH_EXCL)) {
 305
 306       # lock and parse forum main file
 307       #
 308       my $forum = new Lock ($param->{forumFile});
 309       if ($forum -> lock (LH_EXCL)) {
 310         my (
 311           $threads,
 312           $last_thread,
 313           $last_message,
 314           $dtd
 315         ) = get_all_threads ($forum->filename, KEEP_DELETED);
 316
 317         # get obsolete threads...
 318         #
 319         my $obsolete = get_obsolete_threads ({
 320           parsedThreads => $threads,
 321           adminDefault  => $param->{adminDefault}
 322         });
 323
 324         unless (@$obsolete) {
 325           # nothing to cut - we're ready
 326           #
 327           $forum -> unlock;
 328         }
 329         else {
 330           # ...and delete them from main
 331           #
 332           my %obsolete;
 333           for (@$obsolete) {
 334             $obsolete{$_} = $threads->{$_};
 335             delete $threads->{$_};
 336           }
 337
 338           # save it back...
 339           #
 340           my $saved = save_file (
 341             $param -> {forumFile},
 342             create_forum_xml_string (
 343               $threads,
 344               {
 345                 dtd         => $dtd,
 346                 lastMessage => $last_message,
 347                 lastThread  => $last_thread
 348               }
 349             )
 350           );
 351
 352           # ...and masterlock the obsolete thread files
 353           #
 354           if ($saved) {
 355             for (@$obsolete) {
 356               new Lock($param->{messagePath}."t$_.xml")->lock(LH_MASTER) or $failed{$_} = 'could not set master lock';
 357             }
 358           }
 359
 360           # release forum main file...
 361           #
 362           $forum -> unlock;
 363
 364           if ($saved) {
 365             # ...and now process thread files
 366             #
 367             my $sev_opt = ($param -> {adminDefault} -> {Severance} -> {severance} eq 'instant')
 368                ? $param -> {adminDefault} -> {Instant} -> {Severance}
 369                : ($param -> {adminDefault} -> {Severance});
 370
 371             my $cache = new Posting::Cache ($param->{cachePath});
 372
 373             process_threads ({
 374               opt          => $sev_opt,
 375               cache        => $cache,
 376               failed       => \%failed,
 377               obsolete     => $obsolete,
 378               messagePath  => $param->{messagePath},
 379               archivePath  => $param->{archivePath},
 380               adminDefault => $param->{adminDefault}
 381             });
 382
 383
 384             # delete processed files, that are not failed
 385             #
 386             for (grep {not exists($failed{$_})} @$obsolete) {
 387               unlink ($param->{messagePath}."t$_.xml") or $failed{$_} = 'could not delete thread file';
 388               #file_removed ($param->{messagePath}."t$_.xml");
 389             }
 390             $cache -> delete_threads (@$obsolete);
 391             $cache -> garbage_collection;
 392           }
 393         }
 394         # we're ready, tell this other instances
 395         #
 396         $sev -> unlock;
 397       }
 398     }
 399   }
 400
 401   # return
 402   \%failed;
 403 }
 404
 405 # keep 'require' happy
 406 1;
 407
 408 #
 409 #
 410 ### end of Arc::Archive ########################################################