<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package Arc::Archive;

################################################################################
#                                                                              #
# File:        shared/Arc/Archive.pm                                           #
#                                                                              #
# Authors:     André Malo &lt;nd@o3media.de&gt;                                      #
#                                                                              #
# Description: Severance of Threads and archiving                              #
#                                                                              #
################################################################################

use strict;
use vars qw(
  @EXPORT
);

use Arc::Test;
use Lock;
use Posting::_lib qw(
  get_all_threads
  create_forum_xml_string
  parse_xml_file
  parse_single_thread
  get_message_node
  get_body_node
  save_file
  KEEP_DELETED
);
use Posting::Cache;
use Time::German 'localtime';

use XML::DOM;

################################################################################
#
# Version check
#
# last modified:
#    $Date$ (GMT)
# by $Author$
#
sub VERSION {(q$Revision$ =~ /([\d.]+)\s*$/)[0] or '0.0'}

################################################################################
#
# Export
#
use base qw(Exporter);
@EXPORT = qw(cut_tail);

### delete_no_archived () ######################################################
#
# remove no archived branches vom thread
#
# Params: $xml     - XML::DOM::Document node
#         $msg     - arrayref - messages
#         $percent - voting limit (percent)
#
# Return: ~none~
#
sub delete_no_archived ($) {
  my $par = shift;

  my ($xml, $sum, $tid, $msg, $percent) = map {$par-&gt;{$_}}
   qw( xml   sum   tid   msg   percent);

  # $oldlevel: contains the level of last checked msg
  # @path    : contains the current branch
  # %archive : contains the mids, that will be archived
  # %hidden  : contains the invisible mids
  #
  my ($oldlevel, @path, %archive, %hidden) = (0, 0);

  # check all messages of thread
  #
  for my $z (0..$#{$msg}) {

    if ($msg -&gt; [$z] -&gt; {level} &gt; $oldlevel) {
      # this msg is a child of the last one
      #
      push @path =&gt; $z;
      $oldlevel = $msg -&gt; [$z] -&gt; {level};
    }

    elsif ($msg -&gt; [$z] -&gt; {level} &lt; $oldlevel) {
      # this starts a new subbranch (-1+ level(s))
      #

      # remove last msg (incl. kids), that is on same level
      #
      splice @path, $msg -&gt; [$z] -&gt; {level};
      push @path =&gt; $z;
      $oldlevel = $msg -&gt; [$z] -&gt; {level};
    }

    else {
      # the msg is a sister of the last one
      #
      $path[-1] = $z;
    }

    # 'archive' is an admin flag
    # if set, the message (incl. branch) MUST be archived
    #
    if (defined $msg-&gt;[$z]-&gt;{archive} and $msg-&gt;[$z]-&gt;{archive}) {
      $archive{$msg-&gt;[$_]-&gt;{mid}} = 1 for (@path);
    }

    # notice invisble messages
    # while they are in @path and archive flag is not set,
    # they and their kids WON'T be archived
    #
    $hidden{$z} = 1 if ($msg-&gt;[$z]-&gt;{deleted});

    # if 'archive' is NOT set and message not deleted,
    #
    unless ($msg-&gt;[$z]-&gt;{archive} or $msg-&gt;[$z]-&gt;{deleted}) {
      my $key = $sum-&gt;{$tid}-&gt;{$msg-&gt;[$z]-&gt;{mid}};

      # ...and they've voted enough, it will be archived
      #
      if ($percent == 0 or ($key-&gt;{views} and ($key-&gt;{votings} * 100 / $key-&gt;{views}) &gt;= $percent)) {
        my $hidden_in_path;

        # check on hidden messages in @path
        #
        for (@path) {
          if ($hidden{$_}) {
            $hidden_in_path = 1;
            last;
          }
        }

        # set archive-flag for messages in @path,
        # unless a parent message is hidden
        #
        unless ($hidden_in_path) {
          $archive{$msg-&gt;[$_]-&gt;{mid}} = 1 for (@path);
        }
      }
    }
  }

  # now remove messages without 'archive'-flag
  # from thread xml
  #
  for (reverse grep {!$archive{$_-&gt;{mid}}} @$msg) {
    my $h = get_message_node($xml, "t$tid", 'm'.$_-&gt;{mid});

    # remove message entry
    #
    $h -&gt; getParentNode -&gt; removeChild ($h);

    # remove message text
    #
    $h = get_body_node($xml, 'm'.$_-&gt;{mid});
    $h -&gt; getParentNode -&gt; removeChild ($h);

    # 'remove' from $msg
    #
    $_-&gt;{deleted} = 1;
  }
}

### create_arcdir () ###########################################################
#
# check, if specific directories for year and month exist, create
# it, if necessary
#
# Params: $path - archive root
#         $time - Thread time (GMT)
#
# Return: List: $path  - /path/to/ to archived thread file
#               $error - error or undef
#
sub create_arcdir ($$) {
  my ($path, $time) = @_;

  my ($month, $year) = (localtime ($time))[4,5];

  # use the 'real' values for directory names
  #
  $month++; $year+=1900;

  my $yeardir   = $path     . $year;
  my $monthdir  = $yeardir  . '/' . $month;
  my $monthpath = $monthdir . '/';

  mkdir $yeardir, 0777 unless (-d $yeardir);
  return ('', "could not create directory '$yeardir'") unless (-d $yeardir);

  mkdir $monthdir, 0777 unless (-d $monthdir);
  return ('', "could not create directory '$monthdir'") unless (-d $monthdir);

  # return path, successfully created
  #
  $monthpath;
}

### process_threads () #########################################################
#
# process obsolete threads
# (transmit views/votings from cache, do archive, if necessary)
#
# Params: $par - hash reference
#                (opt, cache, failed, obsolete, messagePath,
#                 archivePath, adminDefault)
#
# Return: hashref (tid =&gt; $msg)
#
sub process_threads ($) {
  my $par = shift;

  my ($opt, $failed, $obsolete, $cache) = map {$par-&gt;{$_}} qw
     ( opt   failed   obsolete   cache);

  my %archived;

  if ($opt-&gt;{exArchiving}) {

    # yes, we do archive
    #
    my $sum = $cache -&gt; summary;
    if ($sum) {

      # iterate over all obsolete threads, that are not failed yet
      #
      for my $tid (grep {not exists ($failed-&gt;{$_})} @$obsolete) {
        my $xml = parse_xml_file ($par-&gt;{messagePath}."t$tid.xml");

        unless ($xml) {
          # xml parse error
          #
          $failed-&gt;{$tid} = 'could not parse thread file.';
        }
        else {
          # ok, parse thread
          #
          my $tnode = $xml -&gt; getElementsByTagName ('Thread') -&gt; item(0);
          my $msg = parse_single_thread ($tnode, KEEP_DELETED);

          if ($opt-&gt;{archiving} eq 'UserVotings') {

            # filter out the bad stuff
            #
            delete_no_archived ({
              xml     =&gt; $xml,
              sum     =&gt; $sum,
              tid     =&gt; $tid,
              msg     =&gt; $msg,
              percent =&gt; $par-&gt;{adminDefault}-&gt;{Voting}-&gt;{Limit}
            });
          }

          # save back xml file (into archive)
          #
          if ($tnode -&gt; hasChildNodes) {

            # insert views and votings counter
            #
            for ($tnode -&gt; getElementsByTagName ('Message')) {
              my ($id) = $_ -&gt; getAttribute ('id') =~ /(\d+)/;
              $_ -&gt; setAttribute ('views'   =&gt; $sum-&gt;{$tid}-&gt;{$id}-&gt;{views});
              $_ -&gt; setAttribute ('votings' =&gt; $sum-&gt;{$tid}-&gt;{$id}-&gt;{votings});
            }

            # create archive dir, unless exists
            #
            my ($path, $error) = create_arcdir ($par -&gt; {archivePath}, $msg-&gt;[0]-&gt;{time});

            if ($error) {
              $failed-&gt;{$tid} = $error;
            }
            else {
              # save thread file
              #
              my $file = "${path}t$tid.xml";
              unless (save_file ($file =&gt; \($xml -&gt; toString))) {
                $failed-&gt;{$tid} = "could not save '$file'";
              }
              else {
                $archived{$tid} = $msg
              }
            }
          }
        }
      }
    }
    else {
      @$failed{@$obsolete} = 'error: could not load summary';
    }
  }

  \%archived;
}

### append_threads () ##########################################################
#
# open specified index file, append threads, save it back
#
# Params: $file    - /path/to/indexfile
#         $threads - hashref (threads)
#
# Return: success code (boolean)
#
sub append_threads ($$) {
  my ($file, $threads) = @_;
  my $thash={};

  my $index = new Lock ($file);

  return unless ($index -&gt; lock (LH_EXCL));

  if (-f $file) {
    $thash = get_all_threads ($file =&gt; KEEP_DELETED);
    $thash-&gt;{$_} = $threads-&gt;{$_} for (keys %$threads);
  }
  else {
    $thash = $threads;
  }

  # save it back...
  #
  my $saved = save_file (
    $file =&gt; create_forum_xml_string (
      $threads,
      {
        dtd         =&gt; 'forum.dtd',
        lastMessage =&gt; 0,
        lastThread  =&gt; 0
      }
    )
  );

  $index -&gt; unlock;

  return unless $saved;

  1;
}

### indexpath () ###############################################################
#
# compose relative path of archive index file
#
# Params: $param - hash reference
#                  ($msg-&gt;[0])
#
# Return: $string (relative path)
#
sub indexpath ($) {
  my $root = shift;

  my ($month, $year) = (localtime ($root-&gt;{time}))[4,5];

  # use the 'real' values for directory names
  #
  $month++; $year+=1900;

  "$year/$month/";
}

### index_threads () ###########################################################
#
# add threads to their specific archive index file
#
# Params: $param - hash reference
#                  (threads, archivePath, archiveIndex, failed)
#
# Return: ~none~
#
sub index_threads ($) {
  my $par = shift;

  my ($threads, $failed) = map {$par-&gt;{$_}} qw
     ( threads   failed);

  # indexfile =&gt; hashref of threads
  # for more efficiency (open each index file *once*)
  #
  my %index;

  # iterate over all archived threads,
  # prepare indexing and assign threads to indexfiles
  #
  for my $thread (keys %$threads) {

    # index only, if the root is visible
    #
    unless ($threads-&gt;{$thread}-&gt;[0]-&gt;{deleted}) {
      my $file = $par-&gt;{archivePath} . indexpath ($threads-&gt;{$thread}-&gt;[0]) . $par-&gt;{archiveIndex};
      $index{$file} = {} unless exists($index{$file});

      $index{$file} -&gt; {$thread} = [$threads-&gt;{$thread}-&gt;[0]];
    }
  }

  # now append threads to index files
  #
  for my $file (keys %index) {
    unless (append_threads ($file =&gt; $index{$file})) {
      $failed-&gt;{$_} = "error: could not list in '$file'" for (keys %{$index{$file}});
    }
  }
}

### cut_tail () ################################################################
#
# shorten the main file and archive, if necessary
#
# Params: $param - hash reference
#                  (forumFile, messagePath, archivePath, lockFile, adminDefault,
#                   cachePath, archiveIndex)
#
# Return: hash reference - empty if all right done
#
sub cut_tail ($) {
  my $param = shift;
  my %failed;

  if (
    $param-&gt;{adminDefault}-&gt;{Severance}-&gt;{severance} ne 'instant' or
    $param-&gt;{adminDefault}-&gt;{Instant}-&gt;{execute}
  ) {
    # run only one instance at the same time
    # (exlusive lock on sev_lock)
    #
    my $sev = new Lock ($param-&gt;{lockFile});
    if ($sev -&gt; lock(LH_EXCL)) {

      # lock and parse forum main file
      #
      my $forum = new Lock ($param-&gt;{forumFile});
      if ($forum -&gt; lock (LH_EXCL)) {
        my (
          $threads,
          $last_thread,
          $last_message,
          $dtd
        ) = get_all_threads ($forum-&gt;filename, KEEP_DELETED);

        # get obsolete threads...
        #
        my $obsolete = get_obsolete_threads ({
          parsedThreads =&gt; $threads,
          adminDefault  =&gt; $param-&gt;{adminDefault}
        });

        unless (@$obsolete) {
          # nothing to cut - we're ready
          #
          $forum -&gt; unlock;
        }
        else {
          # ...and delete them from main
          #
          my %obsolete;
          for (@$obsolete) {
            $obsolete{$_} = $threads-&gt;{$_};
            delete $threads-&gt;{$_};
          }

          # save it back...
          #
          my $saved = save_file (
            $param -&gt; {forumFile},
            create_forum_xml_string (
              $threads,
              {
                dtd         =&gt; $dtd,
                lastMessage =&gt; $last_message,
                lastThread  =&gt; $last_thread
              }
            )
          );

          # ...and masterlock the obsolete thread files
          #
          if ($saved) {
            for (@$obsolete) {
              new Lock($param-&gt;{messagePath}."t$_.xml")-&gt;lock(LH_MASTER) or $failed{$_} = 'error: could not set master lock';
            }
          }

          # release forum main file...
          #
          $forum -&gt; unlock;

          if ($saved) {
            # ...and now process thread files
            #
            my $sev_opt = ($param -&gt; {adminDefault} -&gt; {Severance} -&gt; {severance} eq 'instant')
               ? $param -&gt; {adminDefault} -&gt; {Instant} -&gt; {Severance}
               : ($param -&gt; {adminDefault} -&gt; {Severance});

            my $cache = new Posting::Cache ($param-&gt;{cachePath});

            process_threads ({
              opt          =&gt; $sev_opt,
              cache        =&gt; $cache,
              failed       =&gt; \%failed,
              obsolete     =&gt; $obsolete,
              messagePath  =&gt; $param-&gt;{messagePath},
              archivePath  =&gt; $param-&gt;{archivePath},
              adminDefault =&gt; $param-&gt;{adminDefault}
            });

            # delete processed files, that are not failed
            #
            my @removed;

            for (grep {not exists($failed{$_})} @$obsolete) {
              if (exists($failed{$_})) {
                delete $obsolete{$_};
              }
              else {
                unless (unlink ($param-&gt;{messagePath}."t$_.xml")) {
                  $failed{$_} = 'warning: could not delete thread file';
                }
                else {
                  push @removed =&gt; $_;
                  #file_removed ($param-&gt;{messagePath}."t$_.xml");
                }
              }
            }

            if (@removed) {
              $cache -&gt; delete_threads (@removed);
              $cache -&gt; garbage_collection;
            }

            # add archived threads to archive index
            #
            index_threads ({
              threads      =&gt; \%obsolete,
              archivePath  =&gt; $param-&gt;{archivePath},
              archiveIndex =&gt; $param-&gt;{archiveIndex},
              failed       =&gt; \%failed
            });
          }
        }

        # we're ready, tell this other (waiting?) instances
        #
        $sev -&gt; unlock;
      }
    }
  }

  # return
  \%failed;
}

# keep 'require' happy
1;

#
#
### end of Arc::Archive ########################################################</pre></body></html>