cvs2cl.pl

RAM Defragmentation tools

  my ($common_dir, $qunkrefs) =
    $self->_pretty_file_list(\(%unanimous_tags, %non_unanimous_tags, %all_branches),
      $qunksref);

  my @qunkrefs = @$qunkrefs;

  # If outputting XML, then our task is pretty simple, because we
  # don't have to detect common dir, common tags, branch prefixing,
  # etc.  We just output exactly what we have, and don't worry about
  # redundancy or readability.

  foreach my $qunkref (@qunkrefs)
  {
    my $filename    = $qunkref->filename;
    my $state       = $qunkref->state;
    my $revision    = $qunkref->revision;
    my $tags        = $qunkref->tags;
    my $branch      = $qunkref->branch;
    my $branchroots = $qunkref->roots;
    my $lines       = $qunkref->lines;

    $filename = $self->escape($filename);   # probably paranoia
    $revision = $self->escape($revision);   # definitely paranoia

    $beauty .= "<file>\n";
    $beauty .= "<name>${filename}</name>\n";
    $beauty .= "<cvsstate>${state}</cvsstate>\n";
    $beauty .= "<revision>${revision}</revision>\n";

    if ($Show_Lines_Modified
        && $lines && $lines =~ m/\+(\d+)\s+-(\d+)/) {
        $beauty .= "<linesadded>$1</linesadded>\n";
        $beauty .= "<linesremoved>$2</linesremoved>\n";
    }

    if ($branch) {
      $branch   = $self->escape($branch);     # more paranoia
      $beauty .= "<branch>${branch}</branch>\n";
    }
    foreach my $tag (@$tags) {
      $tag = $self->escape($tag);  # by now you're used to the paranoia
      $beauty .= "<tag>${tag}</tag>\n";
    }
    foreach my $root (@$branchroots) {
      $root = $self->escape($root);  # which is good, because it will continue
      $beauty .= "<branchroot>${root}</branchroot>\n";
    }
    $beauty .= "</file>\n";
  }

  # Theoretically, we could go home now.  But as long as we're here,
  # let's print out the common_dir and utags, as a convenience to
  # the receiver (after all, earlier code calculated that stuff
  # anyway, so we might as well take advantage of it).

  if ((scalar (keys (%unanimous_tags))) > 1) {
    foreach my $utag ((keys (%unanimous_tags))) {
      $utag = $self->escape($utag);   # the usual paranoia
      $beauty .= "<utag>${utag}</utag>\n";
    }
  }
  if ($common_dir) {
    $common_dir = $self->escape($common_dir);
    $beauty .= "<commondir>${common_dir}</commondir>\n";
  }

  # That's enough for XML, time to go home:
  return $beauty;
}

# -------------------------------------

sub output_tagdate {
  # NOT YET DONE
}

# -------------------------------------

sub output_entry {
  my $self = shift;
  my ($fh, $entry) = @_;
  print $fh "<entry>\n$entry</entry>\n\n";
}

# -------------------------------------

sub format_body {
  my $self = shift;
  my ($msg, $files, $qunklist) = @_;

  $msg = $self->preprocess_msg_text($msg);
  return $files . $msg;
}

# ----------------------------------------------------------------------------

package CVS::Utils::ChangeLog::EntrySet::Output;

use Carp           qw( croak );
use File::Basename qw( fileparse );

# Class Utility Functions -------------

{ # form closure

my @weekdays = (qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday));
sub weekday_en {
  my $class = shift;
  return $weekdays[$_[0]];
}

}

# -------------------------------------

sub new {
  my ($proto, %args) = @_;
  my $class = ref $proto || $proto;

  my $follow_branches = delete $args{follow_branches};
  my $follow_only     = delete $args{follow_only};
  my $ignore_tags     = delete $args{ignore_tags};
  my $show_tags       = delete $args{show_tags};
  die "Unrecognized arg to EntrySet::Output::new: '$_'\n"
    for keys %args;

  bless +{follow_branches => $follow_branches,
          follow_only     => $follow_only,
          show_tags       => $show_tags,
          ignore_tags     => $ignore_tags,
         }, $class;
}

# Abstract Subrs ----------------------

sub wday               { croak "Whoops.  Abtract method call (wday).\n" }
sub pretty_file_list   { croak "Whoops.  Abtract method call (pretty_file_list).\n" }
sub output_tagdate     { croak "Whoops.  Abtract method call (output_tagdate).\n" }
sub header_line        { croak "Whoops.  Abtract method call (header_line).\n" }

# Instance Subrs ----------------------

sub output_header { }

# -------------------------------------

sub output_entry {
  my $self = shift;
  my ($fh, $entry) = @_;
  print $fh "$entry\n";
}

# -------------------------------------

sub output_footer { }

# -------------------------------------

sub escape { return $_[1] }

# -------------------------------------

sub _revision_is_wanted {
  my ($self, $qunk) = @_;

  my ($revision, $branch_numbers) = @{$qunk}{qw( revision branch_numbers )};
  my $follow_branches = $self->{follow_branches};
  my $follow_only     = $self->{follow_only};

#print STDERR "IG: ", join(',', keys %{$self->{ignore_tags}}), "\n";
#print STDERR "IX: ", join(',', @{$qunk->{tags}}), "\n" if defined $qunk->{tags};
#print STDERR "IQ: ", join(',', keys %{$qunk->{branch_numbers}}), "\n" if defined $qunk->{branch_numbers};
#use Data::Dumper; print STDERR Dumper $qunk;

  for my $ignore_tag (keys %{$self->{ignore_tags}}) {
    return
      if defined $qunk->{tags} and grep $_ eq $ignore_tag, @{$qunk->{tags}};
  }

  if ( keys %{$self->{show_tags}} ) {
    for my $show_tag (keys %{$self->{show_tags}}) {
      return
        if ! defined $qunk->{tags} or ! grep $_ eq $show_tag, @{$qunk->{tags}};
    }
  }

  return 1
    unless @$follow_branches + @$follow_only; # no follow is follow all

  for my $x (map([$_, 1], @$follow_branches),
             map([$_, 0], @$follow_only    )) {
    my ($branch, $followsub) = @$x;

    # Special case for following trunk revisions
    return 1
      if $branch =~ /^trunk$/i and $revision =~ /^[0-9]+\.[0-9]+$/;

    if ( my $branch_number = $branch_numbers->{$branch} ) {
      # Are we on one of the follow branches or an ancestor of same?

      # If this revision is a prefix of the branch number, or possibly is less
      # in the minormost number, OR if this branch number is a prefix of the
      # revision, then yes.  Otherwise, no.

      # So below, we determine if any of those conditions are met.

      # Trivial case: is this revision on the branch?  (Compare this way to
      # avoid regexps that screw up Emacs indentation, argh.)
      if ( substr($revision, 0, (length($branch_number) + 1))
           eq
           ($branch_number . ".") ) {
        if ( $followsub ) {
          return 1;
        } elsif (length($revision) == length($branch_number)+2 ) {
          return 1;
        }
      } elsif ( length($branch_number) > length($revision)
                and
                $No_Ancestors ) {
        # Non-trivial case: check if rev is ancestral to branch

        # r_left still has the trailing "."
        my ($r_left, $r_end) = ($revision =~ /^((?:\d+\.)+)(\d+)$/);

        # b_left still has trailing "."
        # b_mid has no trailing "."
        my ($b_left, $b_mid) = ($branch_number =~ /^((?:\d+\.)+)(\d+)\.\d+$/);
        return 1
          if $r_left eq $b_left and $r_end <= $b_mid;
      }
    }
  }

  return;
}

# -------------------------------------

sub output_changelog {
my $self = shift; my $class = ref $self;
  my ($grand_poobah) = @_;
  ### Process each ChangeLog

  while (my ($dir,$authorhash) = each %$grand_poobah)
  {
    &main::debug ("DOING DIR: $dir\n");

    # Here we twist our hash around, from being
    #   author => time => message => filelist
    # in %$authorhash to
    #   time => author => message => filelist
    # in %changelog.
    #
    # This is also where we merge entries.  The algorithm proceeds
    # through the timeline of the changelog with a sliding window of
    # $Max_Checkin_Duration seconds; within that window, entries that
    # have the same log message are merged.
    #
    # (To save space, we zap %$authorhash after we've copied
    # everything out of it.)

    my %changelog;
    while (my ($author,$timehash) = each %$authorhash)
    {
      my %stamptime;
      foreach my $time (sort {$a <=> $b} (keys %$timehash))
      {
        my $msghash = $timehash->{$time};
        while (my ($msg,$qunklist) = each %$msghash)
        {
          my $stamptime = $stamptime{$msg};
          if ((defined $stamptime)
              and (($time - $stamptime) < $Max_Checkin_Duration)
              and (defined $changelog{$stamptime}{$author}{$msg}))
          {
            push(@{$changelog{$stamptime}{$author}{$msg}}, $qunklist->files);
          }
          else {
            $changelog{$time}{$author}{$msg} = $qunklist->files;
            $stamptime{$msg} = $time;
          }
        }
      }
    }
    undef (%$authorhash);

    ### Now we can write out the ChangeLog!

    my ($logfile_here, $logfile_bak, $tmpfile);
    my $lastdate;

    if (! $Output_To_Stdout) {
      $logfile_here =  $dir . $Log_File_Name;
      $logfile_here =~ s/^\.\/\//\//;   # fix any leading ".//" problem
      $tmpfile      = "${logfile_here}.cvs2cl$$.tmp";
      $logfile_bak  = "${logfile_here}.bak";

      open (LOG_OUT, ">$tmpfile") or die "Unable to open \"$tmpfile\"";
    }
    else {
      open (LOG_OUT, ">-") or die "Unable to open stdout for writing";
    }

    print LOG_OUT $ChangeLog_Header;

    my %tag_date_printed;

    $self->output_header(\*LOG_OUT);

    my @key_list = ();
    if($Chronological_Order) {
        @key_list = sort {$a <=> $b} (keys %changelog);
    } else {
        @key_list = sort {$b <=> $a} (keys %changelog);
    }
    foreach my $time (@key_list)
    {
      next if ($Delta_Mode &&
               (($time <= $Delta_StartTime) ||
                ($time > $Delta_EndTime && $Delta_EndTime)));

      # Set up the date/author line.
      # kff todo: do some more XML munging here, on the header
      # part of the entry:
      my (undef,$min,$hour,$mday,$mon,$year,$wday)
          = $UTC_Times ? gmtime($time) : localtime($time);

      $wday = $self->wday($wday);
      # XML output includes everything else, we might as well make
      # it always include Day Of Week too, for consistency.
      my $authorhash = $changelog{$time};
      if ($Show_Tag_Dates) {
        my %tags;
        while (my ($author,$mesghash) = each %$authorhash) {
          while (my ($msg,$qunk) = each %$mesghash) {
            foreach my $qunkref2 (@$qunk) {
              if (defined ($qunkref2->tags)) {
                foreach my $tag (@{$qunkref2->tags}) {
                  $tags{$tag} = 1;
                }
              }
            }
          }
        }
        # Sort here for determinism to ease testing
        foreach my $tag (sort keys %tags) {
          if ( ! defined $tag_date_printed{$tag} ) {
            $tag_date_printed{$tag} = $time;
            $self->output_tagdate(\*LOG_OUT, $time, $tag);
          }
        }
      }
      while (my ($author,$mesghash) = each %$authorhash)
      {
        # If XML, escape in outer loop to avoid compound quoting:
        $author = $self->escape($author);

      FOOBIE:
        # We sort here to enable predictable ordering for the testing porpoises
        for my $msg (sort keys %$mesghash)
        {
          my $qunklist = $mesghash->{$msg};

          my @qunklist =
            grep $self->_revision_is_wanted($_), @$qunklist;

          next FOOBIE unless @qunklist;

          my $files               = $self->pretty_file_list(\@qunklist);
          my $header_line;          # date and author
          my $wholething;           # $header_line + $body

          my $date = $self->fdatetime($time);
          $header_line = $self->header_line($time, $author, $lastdate);
          $lastdate = $date;

          $Text::Wrap::huge = 'overflow'
            if $Text::Wrap::VERSION >= 2001.0130;
          # Reshape the body according to user preferences.
          my $body = $self->format_body($msg, $files, \@qunklist);

          $body =~ s/[ \t]+\n/\n/g;
          $wholething = $header_line . $body;

          # One last check: make sure it passes the regexp test, if the
          # user asked for that.  We have to do it here, so that the
          # test can match against information in the header as well
          # as in the text of the log message.

          # How annoying to duplicate so much code just because I
          # can't figure out a way to evaluate scalars on the trailing
          # operator portion of a regular expression.  Grrr.
          if ($Case_Insensitive) {
            unless ( $Regexp_Gate and ( $wholething !~ /$Regexp_Gate/oi ) ) {
              $self->output_entry(\*LOG_OUT, $wholething);
            }
          }
          else {
            unless ( $Regexp_Gate and ( $wholething !~ /$Regexp_Gate/o ) ) {
              $self->output_entry(\*LOG_OUT, $wholething);
            }
          }
        }
      }
    }

    $self->output_footer(\*LOG_OUT);

    close (LOG_OUT);

    if ( ! $Output_To_Stdout ) {
      # If accumulating, append old data to new before renaming.  But
      # don't append the most recent entry, since it's already in the
      # new log due to CVS's idiosyncratic interpretation of "log -d".
      if ($Cumulative && -f $logfile_here) {
        open NEW_LOG, ">>$tmpfile"
          or die "trouble appending to $tmpfile ($!)";

        open OLD_LOG, "<$logfile_here"
          or die "trouble reading from $logfile_here ($!)";

        my $started_first_entry = 0;
        my $passed_first_entry = 0;
        while (<OLD_LOG>) {
          if ( ! $passed_first_entry ) {
            if ( ( ! $started_first_entry )
                and /^(\d\d\d\d-\d\d-\d\d\s+\d\d:\d\d)/ ) {
              $started_first_entry = 1;
            } elsif ( /^(\d\d\d\d-\d\d-\d\d\s+\d\d:\d\d)/ ) {
              $passed_first_entry = 1;
              print NEW_LOG $_;
            }
          } else {
            print NEW_LOG $_;
          }
        }

        close NEW_LOG;
        close OLD_LOG;
      }