gentrevml #19

#!/usr/local/bin/perl -w

=head2 NAME

gentrevml - Generate a .revml file used by the t/ scripts

=head2 SYNOPSIS

   perl bin/gentrevml --(revml|p4|cvs|vss) [--bootstrap] [--batch=1]

=head2 DESCRIPTION

The test suite uses a bas RevML file to check to see vcp it can copy in to
and out of a repository correctly.  This is done for each repository class.

Note that going through a repository may lose some information, so the
test suite can't always compare the input RevML to the output RevML.

Only the revml->revml case is known to be idempotent.

I chose to do this over using some base repository because not every user
is going to happen to have that repository, and (2) not every repository
will pass through all information correctly.

=head2 COPYRIGHT

Copyright 2000, Perforce Software, Inc.  All Rights Reserved.

This will be licensed under a suitable license at a future date.  Until
then, you may only use this for evaluation purposes.  Besides which, it's
in an early alpha state, so you shouldn't depend on it anyway.

=head2 AUTHOR

Barrie Slaymaker <barries@slaysys.com>

=cut

use Text::Diff ;
use VCP::DiffFormat ;
use Getopt::Long ;
use MIME::Base64 ;

use strict ;

my $which ;
my $debug ;

sub which {
   die "Only one mode allowed\n" if $which ;
   $which = shift ;
}

my $batch ;
my $bootstrap ;

BEGIN {
   ## Need to know how to name the output file before we can
   ## "use RevML::Writer".
   $batch = 0 ;
   Getopt::Long::Configure( qw( no_auto_abbrev no_getopt_compat ) ) ;
   unless (
      GetOptions(
	 'p4'           => \&which,
	 'cvs'          => \&which,
	 'revml'        => \&which,
	 'vss'          => \&which,
	 'b|bootstrap'  => \$bootstrap,
	 'batch=i'      => \$batch,
	 'd|debug'      => \$debug,
      )
      && $which
   ) {
      require Pod::Usage ;
      Pod::Usage::pod2usage( exitval => 2, verbose => 3 ) ;
   }
}

if ( $debug ) {
   print STDERR "for $which\n" ;
   print STDERR "bootstrap mode ", $bootstrap ? "on" : "off", "\n" ;
   print STDERR "batch $batch\n" ;
   print STDERR "\n" ;
}

##
## BUILD  THE MANIFEST
##
my @file_names ;
## Put @files in alpha order.  p4 likes to output in alpha order, and this
## makes comparing p4->revml output to revml->p4 input easier.
for my $main (
   qw( a/deeply/buried/file a_big_file add branched binary del readd ),
#   "spacey file name"
) {
   if ( $main eq "add" || $main eq "del" ) {
      for my $file    ( qw( f1 f2 f3 f4 ) ) {
	 my $fn = "$main/$file" ;
	 next if $fn eq "del/f1" ; # Can't delete in change 1
	 push @file_names, $fn ;
      }
   }
   else {
      push @file_names, $main ;
   }
}


##
## BUILD REVISIONS IN MEMORY
##
my @changes ;

my $binary_counter = 0 ;

{
   my $user_id = "${which}_t_user" ;
   $user_id .= '@p4_t_client' if $which eq 'p4' ;

   my %rev_num ;

   ## We never get around to changes 7..9
   my %deleted_change_num = (
      ## Delete the 'del/f<x>' in change <x>
      ## except you can't delete anything in change 1, eh?
      map( ( "del/f$_" => $_ ), (2..9) ),
   ) ;

   my %created_change_num = (
      ## Add the 'add/f<x>' in change <x>
      map( ( "add/f$_" => $_ ), (1..9) ),
   ) ;

   my $counter = "00" ;

   for my $change_num ( 1..6 ) {
      print STDERR "concocting \@$change_num:\n" if $debug ;
      ## We do the file names in sorted order because going in and out of
      ## some repositories like CVS folds all timestamps in a change to
      ## all be the same time (the cvs commit sets the timestamp), and
      ## we want the revml that comes out to be in the same order
      ## as the revml that went in.

      for my $name ( sort @file_names ) {
         my $branch_id;
         my $branch_only;

         if ( $change_num > 2 && $change_num % 2 && $name eq "branched"
&& 0 <= index "revml", $which 
         ) {
            $branch_id = "branch-1";
         }


	 next
	    if (
	       defined $created_change_num{$name}
	       && $change_num < $created_change_num{$name} 
	    )
	    || (
	       defined $deleted_change_num{$name}
	    && $change_num > $deleted_change_num{$name}
	    )
         ;

	 ++$rev_num{$name} ;

	 print STDERR "   $name#$rev_num{$name}:" if $debug ;

	 die "counter too big" if $counter > 254 ;

	 my $char_num = $counter + 1;

	 ## CVS on Win32 gets bummed out about ^Z in text files.
	 $char_num++ if $^O =~ /Win32/ && $char_num == 26;

	 my $content =  $name eq "binary" 
	   ? chr( $binary_counter++ & 0x07 ) x 100
	   : sprintf(
	       qq{%s, revision %d, char 0x%02x="%s"\n},
	       $name,
	       $rev_num{$name},
	       $char_num,
	       chr( $char_num ),
	    ) ;

	 $content = $content x 200 if $name eq "a_big_file" ;

	 my $r = {
	    name     => $name,
	    type     => $name eq "binary" ? "binary" : "text",
	    encoding => $name eq "binary" ? "base64" : "none",
	    user_id  => $user_id,
	    content  => $content,
	    time     => "2000-01-01 12:00:${counter}Z",
	    ## In p4, all files in a change number have an identical comment.
	    ## We impose this on the other solutions to test foo->p4 change
	    ## number aggregation.
	    comment  => "comment $change_num\n",
	 } ;

	 ## p4 doesn't handle modtime until very recently, and then it
	 ## doesn't expose it easily.
	 $r->{mod_time} = "2000-01-01 12:01:${counter}Z" unless $which eq 'p4' ;

         $r->{branch_id} = $branch_id;

	 if ( $which eq 'p4' ) {
	    $r->{p4_info}   = "Some info $which might emit about this file" ;
	    $r->{rev_id}    = $rev_num{$name} ;
	    ## In p4, you may have skipped some change numbers
	    $r->{change_id} = ( $r->{rev_id} - 1 ) * 2 + 1 ;
	    ## TODO: Delete this next line when we get VCP::Dest::p4 to sync
	    ## change numbers
	    $r->{change_id} = $change_num ;
	 }
	 elsif ( $which eq 'cvs' ) {
	    $r->{cvs_info}  = "Some info $which might emit about this file" ;
	    $r->{rev_id} = "1.$rev_num{$name}" ;
	    # We provide a change ID to see if the label makes it in and
	    # so that the label can be used to test incremental exports from
	    # cvs.
	    $r->{change_id} = $change_num ;
	 }
	 elsif ( $which eq 'revml' ) {
	    $r->{cvs_info}  ="Some info about this file" ;
	    $r->{rev_id}    = $rev_num{$name} ;
	    $r->{change_id} = $change_num ;
	 }
	 elsif ( $which eq 'vss' ) {
	    $r->{rev_id}    = $rev_num{$name} ;
            ## change_id is provided to drive the "is_first" detection
            ## below and so that extraction of incremental exports can
            ## use the ch_4 label.
	    $r->{change_id} = $change_num ;
	 }
	 else {
	    die "$which unhandled" ;
	 }

	 if (  defined $deleted_change_num{$name} 
	    && $change_num == $deleted_change_num{$name}
	 ) {
	    $r->{action} = 'delete' ;
	 }
	 elsif ( $rev_num{$name} eq 1 ) {
	    $r->{action} = 'add' ;
	 }
	 elsif ( $name eq "readd" ) {
	     if ( $change_num % 2 ) {
	         ## Add it on the odd numbers
		 $r->{action} = 'add' ;
	     }
	     else {
	         $r->{action} = 'delete' ;
	     }
	 }
	 else {
	    $r->{action} = 'edit' ;
	 }

	 unless ( $r->{action} eq 'delete' || $counter % 2 ) {
	    $r->{labels} = [
		"achoo$counter",
		"blessyou$counter",
	    ] ;
	 }

	 $counter = sprintf "%02d", $counter + 1 ;

	 push @{$changes[$change_num]}, $r ;
	 if ( $debug ) {
	    print STDERR " #$r->{rev_id}" ;
	    print STDERR " \@$r->{change_id})" if defined $r->{change_id} ;
	    print STDERR " ($r->{action})\n" ;
	 }
      }
      print STDERR "\n" if $debug ;
   }
}

## Emit the document

use Digest::MD5 qw( md5_base64 ) ;
use File::Basename ;
use RevML::Doctype 'DEFAULT' ;
use RevML::Writer qw( :all :dtd_tags ) ;

sub _emit_characters {
   my ( $buf ) = @_ ;

   setDataMode( 0 ) ;
   ## note that we don't let XML munge \r to be \n!
   while ( $buf =~ m{\G(?:
      (  [ \x00-\x08\x0b-\x1f\x7f-\xff])
      | ([^\x00-\x08\x0b-\x1f\x7f-\xff]*)
      )}gx
   ) {
      if ( defined $1 ) {
	 char( "", code => sprintf( "0x%02x", ord $1 ) ) ;
      }
      else {
	 characters( $2 ) ;
      }
   }

}


my $prog = basename $0 ;
my $f0 = "$prog.0" ;
my $f1 = "$prog.1" ;

binmode STDOUT ;

setDataMode 1 ;

xmlDecl ;
time '2000-01-01 00:00:00Z' ;
rep_type $which ;
rep_desc 'random text, for now' ;
if ( $which eq "revml" ) {
   ## These are ignored by other interfaces, so don't test with them.
   comment "A comment" ;
}

if ( 0 <= index "revml", $which ) {
    start_branches;
      start_branch;
        branch_id "branch-1";
        dest_branch_id   "branch-1";
      end_branch;
    end_branches;
}

my %prev ;

## TODO: Branching, moving, and binary files

# This is a bogus rev_root, we set it to see if it gets ignored on
# transfers with a destination rev_root specified on the command line.
# TODO: We should also see what happens when dest no rev_root is specified.
rev_root "foo/bar/bah" ;

## Note the overlapping range here.  Batch 1 (0 or 1) needs to have a digest
## of the rev _before_ the start of the batch unless it's in bootstrap mode.
my @change_nums = (
   ( ! $batch )
      ? (1..3)
   : $bootstrap
      ? (4..6)
      : (3..6)
) ;

## Build @files from @changes.  An older version built revml in change number
## order, but we now built in filename, change number order to make sorting
## of the output of vcp tests in to a predictable order possible.  This is
## because cvs->revml does not result in predictable revml order due to
## cvs oddities, so all the tests generate revml in name,rev order.
my %revs_by_name ;

for my $change_num ( @change_nums ) {
   for my $rev ( @{$changes[$change_num]} ) {
      push @{$revs_by_name{$rev->{name}}}, $rev ;
   }
}

my @sorted_rev_names = sort {
   my @a = split "/", $a ;
   my @b = split "/", $b ;
   while ( @a && @b ) {
      my $result = shift( @a ) cmp shift( @b ) ;
      return $result if $result ;
   }
   return @a <=> @b ;
} keys %revs_by_name ;


for my $rev_name ( @sorted_rev_names ) {
   print STDERR "emitting $rev_name:\n" if $debug ;

   for my $r ( @{$revs_by_name{$rev_name}} ) {
      my $change_num = $r->{change_id} ;
      my $is_first = $change_num eq $change_nums[0] ;
      my $digest_mode = $is_first && $batch && ! $bootstrap ;

      next if ( $is_first
	 && ( ! $batch || $digest_mode )
	 && $r->{action} eq 'delete'
      ) ;

      next if ( $which eq "vss"
	 && $r->{action} eq "delete"
         && $r->{name} eq "readd"
         && $change_num != $change_nums[-1]
      );

      print STDERR "   $r->{name}#$r->{rev_id}:" if $debug ;

      my $prev_key = "$r->{name}(" . ( $r->{branch_id} || "main" ) . ")";

      my $pr = $prev{$prev_key};

      ## First rev in a branch is based on a rev in the main branch.
      if ( ! $pr && defined $r->{branch_id} && ! $digest_mode ) {
         my $key = "$r->{name}(main)";
         $pr = $prev{$key};
         die "No base_rev found for $r->{name}#$r->{rev_id} ($r->{branch_id})",
            ": key '$key', does not exist in ",
            join " ", map "'$_'", sort keys %prev
            unless $pr;
      }

      start_rev ;
      name        $r->{name} ;
      type        $r->{type} unless $which eq "vss" && $r->{action} eq "delete";

      if ( ! $digest_mode ) {
	 p4_info       $r->{p4_info}  if defined $r->{p4_info} ;
	 cvs_info      $r->{cvs_info} if defined $r->{cvs_info} ;
      }

      branch_id        $r->{branch_id} if defined $r->{branch_id};
      rev_id           $r->{rev_id};
      change_id        $r->{change_id}
         if defined $r->{change_id};# && $which ne "vss" ;

      my $digestion = 1 ;

      if ( $digest_mode ) {
	 print STDERR " digest" if $debug ;
      }
      else {
	 time      $r->{time} unless $which eq "vss" && $r->{action} eq "delete";
	 mod_time  $r->{mod_time}
            if defined $r->{mod_time}
               && ! ( $which eq "vss" && $r->{action} eq "delete" );

	 user_id   $r->{user_id} unless $which eq "vss" && $r->{action} eq "delete";

         if ( $r->{labels} ) {
	    label $_ for @{$r->{labels}} ;
	 }

	 ## In p4, all files in a change number have an identical comment.
	 comment $r->{comment} unless $which eq "vss" && $r->{action} eq "delete";

	 if ( $r->{action} eq 'delete' ) {
	    print STDERR " delete" if $debug ;
	    defaultWriter->delete() ;
	    $digestion = 0 ;
	 }
	 else {
	    if ( ! $pr || $r->{encoding} ne "none" ) {
	       print STDERR " content" if $debug ;
	       start_content encoding => $r->{encoding} ;
	       if ( $r->{encoding} eq "none" ) {
		  _emit_characters $r->{content} ;
	       }
	       else {
	          setDataMode( 0 ) ;
	          characters encode_base64 $r->{content} ;
	       }
	       end_content ;
	       setDataMode( 1 ) ;
	    }
	    else {
	       print STDERR " delta" if $debug ;
	       base_rev_id $pr->{rev_id} ;
	       start_delta type => 'diff-u', encoding => 'none' ;
	       _emit_characters(
                  diff \$pr->{content}, \$r->{content}, {
                     STYLE => "VCP::DiffFormat",
                  }
               );
	       end_delta ;
	       setDataMode( 1 ) ;
	    }
	 }
      }
      digest md5_base64( $r->{content} ), type => 'MD5', encoding => 'base64'
         if $digestion ;

      $prev{$prev_key} = $r->{action} eq "delete" ? undef : $r ;
      if ( $debug ) {
	 print STDERR " #$r->{rev_id}" ;
	 print STDERR " \@$r->{change_id})" if defined $r->{change_id} ;
	 print STDERR " ($r->{action})\n" ;
      }
   }
   print STDERR "\n" if $debug ;
}

END {
   if ( -f $f0 ) {
      unlink $f0 or warn "$!: $f0" ;
   }
   if ( -f $f1 ) {
      unlink $f1 or warn "$!: $f1" ;
   }
}

endAllTags ;