root/feedmelinks/bin/cvs2cl.pl

#!/bin/sh
exec perl -w -x $0 ${1+"$@"} # -*- mode: perl; perl-indent-level: 2; -*-
#!perl -w


##############################################################
###                                                        ###
### cvs2cl.pl: produce ChangeLog(s) from `cvs log` output. ###
###                                                        ###
##############################################################

## $Revision$
## $Date$
## $Author$
##

use strict;

use File::Basename qw( fileparse );
use Getopt::Long   qw( GetOptions );
use Text::Wrap     qw( );
use Time::Local    qw( timegm );
use User::pwent    qw( getpwnam );

# The Plan:
#
# Read in the logs for multiple files, spit out a nice ChangeLog that
# mirrors the information entered during `cvs commit'.
#
# The problem presents some challenges. In an ideal world, we could
# detect files with the same author, log message, and checkin time --
# each <filelist, author, time, logmessage> would be a changelog entry.
# We'd sort them; and spit them out.  Unfortunately, CVS is *not atomic*
# so checkins can span a range of times.  Also, the directory structure
# could be hierarchical.
#
# Another question is whether we really want to have the ChangeLog
# exactly reflect commits. An author could issue two related commits,
# with different log entries, reflecting a single logical change to the
# source. GNU style ChangeLogs group these under a single author/date.
# We try to do the same.
#
# So, we parse the output of `cvs log', storing log messages in a
# multilevel hash that stores the mapping:
#   directory => author => time => message => filelist
# As we go, we notice "nearby" commit times and store them together
# (i.e., under the same timestamp), so they appear in the same log
# entry.
#
# When we've read all the logs, we twist this mapping into
# a time => author => message => filelist mapping for each directory.
#
# If we're not using the `--distributed' flag, the directory is always
# considered to be `./', even as descend into subdirectories.

# Call Tree

# name                         number of lines (10.xii.03)
# parse_options                         192
# derive_changelog                       13
# +-maybe_grab_accumulation_date         38
# +-read_changelog                      277
#   +-maybe_read_user_map_file           94
#     +-run_ext                           9
#   +-read_file_path                     29
#   +-read_symbolic_name                 43
#   +-read_revision                      49
#   +-read_date_author_and_state         25
#     +-parse_date_author_and_state      20
#   +-read_branches                      36
# +-output_changelog                    424
#   +-pretty_file_list                  290
#     +-common_path_prefix               35
#   +-preprocess_msg_text                30
#     +-min                               1
#   +-mywrap                             16
#   +-last_line_len                       5
#   +-wrap_log_entry                    177
#
# Utilities
#
# xml_escape                              6
# slurp_file                             11
# debug                                   5
# version                                 2
# usage                                 142

# -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*- -*-
#
# Note about a bug-slash-opportunity:
# -----------------------------------
#
# There's a bug in Text::Wrap, which affects cvs2cl.  This script
# reveals it:
#
#   #!/usr/bin/perl -w
#
#   use Text::Wrap;
#
#   my $test_text =
#   "This script demonstrates a bug in Text::Wrap.  The very long line
#   following this paragraph will be relocated relative to the surrounding
#   text:
#
#   ====================================================================
#
#   See?  When the bug happens, we'll get the line of equal signs below
#   this paragraph, even though it should be above.";
#
#
#   # Print out the test text with no wrapping:
#   print "$test_text";
#   print "\n";
#   print "\n";
#
#   # Now print it out wrapped, and see the bug:
#   print wrap ("\t", "        ", "$test_text");
#   print "\n";
#   print "\n";
#
# If the line of equal signs were one shorter, then the bug doesn't
# happen.  Interesting.
#
# Anyway, rather than fix this in Text::Wrap, we might as well write a
# new wrap() which has the following much-needed features:
#
# * initial indentation, like current Text::Wrap()
# * subsequent line indentation, like current Text::Wrap()
# * user chooses among: force-break long words, leave them alone, or die()?
# * preserve existing indentation: chopped chunks from an indented line
#   are indented by same (like this line, not counting the asterisk!)
# * optional list of things to preserve on line starts, default ">"
#
# Note that the last two are essentially the same concept, so unify in
# implementation and give a good interface to controlling them.
#
# And how about:
#
# Optionally, when encounter a line pre-indented by same as previous
# line, then strip the newline and refill, but indent by the same.
# Yeah...

# Globals --------------------------------------------------------------------

use constant MAILNAME => "/etc/mailname";

# In case we have to print it out:
my $VERSION = '$Revision$';
$VERSION =~ s/\S+\s+(\S+)\s+\S+/$1/;

## Vars set by options:

# Print debugging messages?
my $Debug = 0;

# Just show version and exit?
my $Print_Version = 0;

# Just print usage message and exit?
my $Print_Usage = 0;

# What file should we generate (defaults to "ChangeLog")?
my $Log_File_Name = "ChangeLog";

# Grab most recent entry date from existing ChangeLog file, just add
# to that ChangeLog.
my $Cumulative = 0;

# `cvs log -d`, this will repeat the last entry in the old log.  This is OK,
# as it guarantees at least one entry in the update changelog, which means
# that there will always be a date to extract for the next update.  The repeat
# entry can be removed in postprocessing, if necessary.

# MJP 2003-08-02
# I don't think this actually does anything useful
my $Update = 0;

# Expand usernames to email addresses based on a map file?
my $User_Map_File = '';
my $User_Passwd_File;
my $Mail_Domain;

# Output log in chronological order? [default is reverse chronological order]
my $Chronological_Order = 0;

# Grab user details via gecos
my $Gecos = 0;

# User domain for gecos email addresses
my $Domain;

# Output to a file or to stdout?
my $Output_To_Stdout = 0;

# Eliminate empty log messages?
my $Prune_Empty_Msgs = 0;

# Tags of which not to output
my %ignore_tags;

# Show only revisions with Tags
my %show_tags;

# Don't call Text::Wrap on the body of the message
my $No_Wrap = 1;

# Indentation of log messages
my $Indent = "  ";

# Don't do any pretty print processing
my $Summary = 0;

# Separates header from log message.  Code assumes it is either " " or
# "\n\n", so if there's ever an option to set it to something else,
# make sure to go through all conditionals that use this var.
my $After_Header = " ";

# XML Encoding
my $XML_Encoding = '';

# Format more for programs than for humans.
my $XML_Output = 0;
my $No_XML_Namespace = 0;
my $No_XML_ISO_Date = 0;

# Do some special tweaks for log data that was written in FSF
# ChangeLog style.
my $FSF_Style = 0;

# Show times in UTC instead of local time
my $UTC_Times = 0;

# Show times in output?
my $Show_Times = 1;

# Show day of week in output?
my $Show_Day_Of_Week = 1;

# Show revision numbers in output?
my $Show_Revisions = 1;

# Show dead files in output?
my $Show_Dead = 0;

# Hide dead trunk files which were created as a result of additions on a
# branch?
my $Hide_Branch_Additions = 1;

# Show tags (symbolic names) in output?
my $Show_Tags = 0;

# Show tags separately in output?
my $Show_Tag_Dates = 0;

# Show branches by symbolic name in output?
my $Show_Branches = 0;

# Show only revisions on these branches or their ancestors.
my @Follow_Branches;

# Don't bother with files matching this regexp.
my @Ignore_Files;

# How exactly we match entries.  We definitely want "o",
# and user might add "i" by using --case-insensitive option.
my $Case_Insensitive = 0;

# Maybe only show log messages matching a certain regular expression.
my $Regexp_Gate = '';

# Pass this global option string along to cvs, to the left of `log':
my $Global_Opts = '';

# Pass this option string along to the cvs log subcommand:
my $Command_Opts = '';

# Read log output from stdin instead of invoking cvs log?
my $Input_From_Stdin = 0;

# Don't show filenames in output.
my $Hide_Filenames = 0;

# Don't shorten directory names from filenames.
my $Common_Dir = 1;

# Max checkin duration. CVS checkin is not atomic, so we may have checkin
# times that span a range of time. We assume that checkins will last no
# longer than $Max_Checkin_Duration seconds, and that similarly, no
# checkins will happen from the same users with the same message less
# than $Max_Checkin_Duration seconds apart.
my $Max_Checkin_Duration = 180;

# What to put at the front of [each] ChangeLog.
my $ChangeLog_Header = '';

# Whether to enable 'delta' mode, and for what start/end tags.
my $Delta_Mode = 0;
my $Delta_From = '';
my $Delta_To = '';

my $TestCode;

# Whether to parse filenames from the RCS filename, and if so what
# prefix to strip.
my $RCS_Root;

## end vars set by options.

# latest observed times for the start/end tags in delta mode
my $Delta_StartTime = 0;
my $Delta_EndTime = 0;

# In 'cvs log' output, one long unbroken line of equal signs separates
# files:
my $file_separator = "======================================="
                   . "======================================";

# In 'cvs log' output, a shorter line of dashes separates log messages
# within a file:
my $logmsg_separator = "----------------------------";

my $No_Ancestors = 0;

my $No_Extra_Indent = 0;

my $GroupWithinDate = 0;

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

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

sub new {
  my $class = shift;
  my %self;
  bless \%self, $class;
}

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

sub output_changelog {
  my $output_type = $XML_Output ? 'XML' : 'Text';
  my $output_class = "CVS::Utils::ChangeLog::EntrySet::Output::${output_type}";
  $output_class->new->output_changelog(@_);
}

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

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

use base qw( CVS::Utils::ChangeLog::EntrySet::Output );

use File::Basename qw( fileparse );

sub new {
  my $class = shift;
  bless \(my($ self)), $class;
}

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

sub wday {
  my $self = shift; my $class = ref $self;
  my ($wday) = @_;

  return $Show_Day_Of_Week ? ' ' . $class->weekday_en($wday) : '';
}

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

sub header_line {
  my $self = shift;
  my ($time, $author, $lastdate) = @_;

  my $header_line = '';

  my (undef,$min,$hour,$mday,$mon,$year,$wday)
    = $UTC_Times ? gmtime($time) : localtime($time);

  my $date = $self->fdatetime($time);

  if ($Show_Times) {
    $header_line =
      sprintf "%s  %s\n\n", $date, $author;
  } else {
    if ( ! defined $lastdate or $date ne $lastdate or ! $GroupWithinDate ) {
      if ( $GroupWithinDate ) {
        $header_line = "$date\n\n";
      } else {
        $header_line = "$date  $author\n\n";
      }
    } else {
      $header_line = '';
    }
  }
}

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

sub preprocess_msg_text {
  my $self = shift;
  my ($text) = @_;

  $text = $self->SUPER::preprocess_msg_text($text);

  unless ( $No_Wrap ) {
    # Strip off lone newlines, but only for lines that don't begin with
    # whitespace or a mail-quoting character, since we want to preserve
    # that kind of formatting.  Also don't strip newlines that follow a
    # period; we handle those specially next.  And don't strip
    # newlines that precede an open paren.
    1 while $text =~ s/(^|\n)([^>\s].*[^.\n])\n([^>\n])/$1$2 $3/g;

    # If a newline follows a period, make sure that when we bring up the
    # bottom sentence, it begins with two spaces.
    1 while $text =~ s/(^|\n)([^>\s].*)\n([^>\n])/$1$2  $3/g;
  }

  return $text;
}

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

# Here we take a bunch of qunks and convert them into printed
# summary that will include all the information the user asked for.
sub pretty_file_list {
  my $self = shift;

  return ''
    if $Hide_Filenames;

  my $qunksref = shift;

  my @filenames;
  my $beauty = '';          # The accumulating header string for this entry.
  my %non_unanimous_tags;   # Tags found in a proper subset of qunks
  my %unanimous_tags;       # Tags found in all qunks
  my %all_branches;         # Branches found in any qunk
  my $fbegun = 0;           # Did we begin printing filenames yet?

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

  my @qunkrefs = @$qunkrefs;

  # Not XML output, so complexly compactify for chordate consumption.  At this
  # point we have enough global information about all the qunks to organize
  # them non-redundantly for output.

  if ($common_dir) {
    # Note that $common_dir still has its trailing slash
    $beauty .= "$common_dir: ";
  }

  if ($Show_Branches)
  {
    # For trailing revision numbers.
    my @brevisions;

    foreach my $branch (keys (%all_branches))
    {
      foreach my $qunkref (@qunkrefs)
      {
        if ((defined ($qunkref->branch))
            and ($qunkref->branch eq $branch))
        {
          if ($fbegun) {
            # kff todo: comma-delimited in XML too?  Sure.
            $beauty .= ", _BREAK_ ";
          }
          else {
            $fbegun = 1;
          }
          my $fname = substr ($qunkref->filename, length ($common_dir));
          $beauty .= $fname;
          $qunkref->{'printed'} = 1;  # Just setting a mark bit, basically

          if ( $Show_Tags and defined $qunkref->tags ) {
            my @tags = grep ($non_unanimous_tags{$_}, @{$qunkref->tags});

            if (@tags) {
              $beauty .= " (tags: ";
              $beauty .= join (', ', @tags);
              $beauty .= ")";
            }
          }

          if ($Show_Revisions) {
            # Collect the revision numbers' last components, but don't
            # print them -- they'll get printed with the branch name
            # later.
            $qunkref->revision =~ /.+\.([\d]+)$/;
            push (@brevisions, $1);

            # todo: we're still collecting branch roots, but we're not
            # showing them anywhere.  If we do show them, it would be
            # nifty to just call them revision "0" on a the branch.
            # Yeah, that's the ticket.
          }
        }
      }
      $beauty .= " ($branch";
      if (@brevisions) {
        if ((scalar (@brevisions)) > 1) {
          $beauty .= ".[";
          $beauty .= (join (',', @brevisions));
          $beauty .= "]";
        }
        else {
          # Square brackets are spurious here, since there's no range to
          # encapsulate
          $beauty .= ".$brevisions[0]";
        }
      }
      $beauty .= ")";
    }
  }

  # Okay; any qunks that were done according to branch are taken care
  # of, and marked as printed.  Now print everyone else.

  my %fileinfo_printed;
  foreach my $qunkref (@qunkrefs)
  {
    next if (defined ($qunkref->{'printed'}));   # skip if already printed

    my $b = substr ($qunkref->filename, length ($common_dir));
    # todo: Shlomo's change was this:
    # $beauty .= substr ($qunkref->filename,
    #              (($common_dir eq "./") ? '' : length ($common_dir)));
    $qunkref->{'printed'} = 1;  # Set a mark bit.

    if ($Show_Revisions || $Show_Tags || $Show_Dead)
    {
      my $started_addendum = 0;

      if ($Show_Revisions) {
        $started_addendum = 1;
        $b .= " (";
        $b .= $qunkref->revision;
      }
      if ($Show_Dead && $qunkref->state =~ /dead/)
      {
        # Deliberately not using $started_addendum. Keeping it simple.
        $b .= "[DEAD]";
      }
      if ($Show_Tags && (defined $qunkref->tags)) {
        my @tags = grep ($non_unanimous_tags{$_}, @{$qunkref->tags});
        if ((scalar (@tags)) > 0) {
          if ($started_addendum) {
            $b .= ", ";
          }
          else {
            $b .= " (tags: ";
          }
          $b .= join (', ', @tags);
          $started_addendum = 1;
        }
      }
      if ($started_addendum) {
        $b .= ")";
      }
    }

    unless ( exists $fileinfo_printed{$b} ) {
      if ($fbegun) {
        $beauty .= ", ";
      } else {
        $fbegun = 1;
      }
      $beauty .= $b, $fileinfo_printed{$b} = 1;
    }
  }

  # Unanimous tags always come last.
  if ($Show_Tags && %unanimous_tags)
  {
    $beauty .= " (utags: ";
    $beauty .= join (', ', sort keys (%unanimous_tags));
    $beauty .= ")";
  }

  # todo: still have to take care of branch_roots?

  $beauty = "$beauty:";

  return $beauty;
}

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

sub output_tagdate {
  my $self = shift;
  my ($fh, $time, $tag) = @_;

  my $fdatetime = $self->fdatetime($time);
  print $fh "$fdatetime  tag $tag\n\n";
  return;
}

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

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

  my $body;

  if ( $No_Wrap and ! $Summary ) {
    $msg = $self->preprocess_msg_text($msg);
    $files = $self->mywrap("\t", "\t  ", "* $files") . "\n\n\t";
    #$files =~ s:, :\n\t\t:g;
    #$files = "\t* files:\n\t\t$files\n\t";
    $msg =~ s/\n(.+)/\n$Indent$1/g;
    unless ($After_Header eq " ") {
      $msg =~ s/^(.+)/$Indent$1/g;
    }
    if ( $Hide_Filenames ) {
      $body = $After_Header . $msg;
    } else {
      $body = $files . $After_Header . $msg;
    }
  } elsif ( $Summary ) {
    my ($filelist, $qunk);
    my (@DeletedQunks, @AddedQunks, @ChangedQunks);

    $msg = $self->preprocess_msg_text($msg);
    #
    #     Sort the files (qunks) according to the operation that was
    # performed.  Files which were added have no line change
    # indicator, whereas deleted files have state dead.
    #
    foreach $qunk ( @$qunklist ) {
      if ( "dead" eq $qunk->state) {
        push @DeletedQunks, $qunk;
      } elsif ( ! defined $qunk->lines ) {
        push @AddedQunks, $qunk;
      } else {
        push @ChangedQunks, $qunk;
      }
    }
    #
    #     The qunks list was  originally in tree search order.  Let's
    # get that back.  The lists, if they exist, will be reversed upon
    # processing.
    #

    #
    #     Now write the three sections onto $filelist
    #
    if ( @DeletedQunks ) {
      $filelist .= "\tDeleted:\n";
      foreach $qunk ( @DeletedQunks ) {
        $filelist .= "\t\t" . $qunk->filename;
        $filelist .= " (" . $qunk->revision . ")";
        $filelist .= "\n";
      }
      undef @DeletedQunks;
    }

    if ( @AddedQunks ) {
      $filelist .= "\tAdded:\n";
      foreach $qunk (@AddedQunks) {
        $filelist .= "\t\t" . $qunk->filename;
        $filelist .= " (" . $qunk->revision . ")";
        $filelist .= "\n";
      }
      undef @AddedQunks ;
    }

    if ( @ChangedQunks ) {
      $filelist .= "\tChanged:\n";
      foreach $qunk (@ChangedQunks) {
        $filelist .= "\t\t" . $qunk->filename;
        $filelist .= " (" . $qunk->revision . ")";
        $filelist .= ", \"" . $qunk->state . "\"";
        $filelist .= ", lines: " . $qunk->lines;
        $filelist .= "\n";
      }
      undef @ChangedQunks;
    }

    chomp $filelist;

    if ( $Hide_Filenames ) {
      $filelist = '';
    }

    $msg =~ s/\n(.*)/\n$Indent$1/g;
    unless ( $After_Header eq " " or $FSF_Style ) {
      $msg =~ s/^(.*)/$Indent$1/g;
    }