view release on metacpan or  search on metacpan

src/subversion/tools/dev/stress.pl  view on Meta::CPAN

      }
    close COMMIT_ERR_READ or die "$stress: close COMMIT_ERR_READ: $!\n";
    close COMMIT_WRITE or die "$stress: close COMMIT_WRITE: $!\n";
    close COMMIT_READ or die "$stress: close COMMIT_READ: $!\n";

    # Get commit subprocess exit status
    die "$stress: waitpid: $!\n" if $pid != waitpid $pid, 0;
    die "$stress: unexpected commit fail: exit status: $?\n"
      if ( $? != 0 and $? != 256 ) or ( $? == 256 and $acceptable_error != 1 );

    return $? == 256 ? 1 : 0;
  }

# Get a list of all versioned files in the working copy
{
  my @get_list_of_files_helper_array;
  sub GetListOfFilesHelper
    {
      $File::Find::prune = 1 if $File::Find::name =~ m[/.svn];
      return if $File::Find::prune or -d;
      push @get_list_of_files_helper_array, $File::Find::name;
    }
  sub GetListOfFiles
    {
      my ( $wc_dir ) = @_;
      @get_list_of_files_helper_array = ();
      find( \&GetListOfFilesHelper, $wc_dir);
      return @get_list_of_files_helper_array;
    }
}

# Populate a working copy
sub populate
  {
    my ( $dir, $dir_width, $file_width, $depth, $pad, $props ) = @_;
    return if not $depth--;

    for my $nfile ( 1..$file_width )
      {
        my $filename = "$dir/foo$nfile";
        open( FOO, ">$filename" ) or die "$stress: open $filename: $!\n";

        for my $line ( 0..9 )
          {
            print FOO "A$line\n$line\n"
                or die "$stress: write to $filename: $!\n";
            map { print FOO $_ x 255, "\n"; } ("a", "b", "c", "d")
              foreach (1..$pad);
          }
        print FOO "\$HeadURL: \$\n"
            or die "$stress: write to $filename: $!\n" if $props;
        close FOO or die "$stress: close $filename: $!\n";

        my $svn_cmd = "svn add $filename";
        system( $svn_cmd ) and die "$stress: $svn_cmd: failed: $?\n";

        if ( $props )
          {
            $svn_cmd = "svn propset svn:eol-style native $filename";
            system( $svn_cmd ) and die "$stress: $svn_cmd: failed: $?\n";

            $svn_cmd = "svn propset svn:keywords HeadURL $filename";
            system( $svn_cmd ) and die "$stress: $svn_cmd: failed: $?\n";
          }
      }

    if ( $depth )
      {
        for my $ndir ( 1..$dir_width )
          {
            my $dirname = "$dir/bar$ndir";
            my $svn_cmd = "svn mkdir $dirname";
            system( $svn_cmd ) and die "$stress: $svn_cmd: failed: $?\n";

            populate( "$dirname", $dir_width, $file_width, $depth, $pad,
                      $props );
          }
      }
  }

# Modify a versioned file in the working copy
sub ModFile
  {
    my ( $filename, $mod_number, $id ) = @_;

    # Read file into memory replacing the line that starts with our ID
    open( FOO, "<$filename" ) or die "$stress: open $filename: $!\n";
    my @lines = map { s[(^$id.*)][$1,$mod_number]; $_ } <FOO>;
    close FOO or die "$stress: close $filename: $!\n";

    # Write the memory back to the file
    open( FOO, ">$filename" ) or die "$stress: open $filename: $!\n";
    print FOO or die "$stress: print $filename: $!\n" foreach @lines;
    close FOO or die "$stress: close $filename: $!\n";
  }

sub ParseCommandLine
  {
    my %cmd_opts;
    my $usage = "
usage: stress.pl [-cdfhprW] [-i num] [-n num] [-s secs] [-x num] [-o options]
                 [-D num] [-F num] [-N num] [-P num] [-R path] [-S path]
                 [-U url]

where
  -c cause repository creation
  -d don't make the status calls
  -f use --fs-type fsfs during repository creation
  -h show this help information (other options will be ignored)
  -i the ID (valid IDs are 0 to 9, default is 0 if -c given, 1 otherwise)
  -n the number of sets of changes to commit
  -p add svn:eol-style and svn:keywords properties to the files
  -r perform update-time conflict resolution
  -s the sleep delay (-1 wait for key, 0 none)
  -x the number of files to modify in each commit
  -o options to pass for subversion client
  -D the number of sub-directories per directory in the tree
  -F the number of files per directory in the tree
  -N the depth of the tree
  -P the number of 10K blocks with which to pad the file
  -R the path to the repository
  -S the path to the file whose presence stops this script
  -U the URL to the repository (file:///<-R path> by default)
  -W use --bdb-txn-nosync during repository creation
";

    # defaults
    $cmd_opts{'D'} = 2;            # number of subdirs per dir
    $cmd_opts{'F'} = 2;            # number of files per dir
    $cmd_opts{'N'} = 2;            # depth
    $cmd_opts{'P'} = 0;            # padding blocks
    $cmd_opts{'R'} = "repostress"; # repository name
    $cmd_opts{'S'} = "stop";       # path of file to stop the script
    $cmd_opts{'U'} = "none";       # URL
    $cmd_opts{'W'} = 0;            # create with --bdb-txn-nosync
    $cmd_opts{'c'} = 0;            # create repository
    $cmd_opts{'d'} = 0;            # disable status
    $cmd_opts{'f'} = 0;            # create with --fs-type fsfs
    $cmd_opts{'h'} = 0;            # help
    $cmd_opts{'i'} = 0;            # ID
    $cmd_opts{'n'} = 200;          # sets of changes
    $cmd_opts{'p'} = 0;            # add file properties
    $cmd_opts{'r'} = 0;            # conflict resolution
    $cmd_opts{'s'} = -1;           # sleep interval
    $cmd_opts{'x'} = 4;            # files to modify
    $cmd_opts{'o'} = "";           # no options passed

    getopts( 'cdfhi:n:prs:x:o:D:F:N:P:R:S:U:W', \%cmd_opts ) or die $usage;

    # print help info (and exit nicely) if requested
    if ( $cmd_opts{'h'} )
      {
        print( $usage );
        exit 0;
      }

    # default ID if not set
    $cmd_opts{'i'} = 1 - $cmd_opts{'c'} if not $cmd_opts{'i'};
    die $usage if $cmd_opts{'i'} !~ /^[0-9]$/;

    return %cmd_opts;
  }

############################################################################
# Main

# Why the fixed seed?  I use this script for more than stress testing,
# I also use it to create test repositories.  When creating a test
# repository, while I don't care exactly which files get modified, I
# find it useful for the repositories to be reproducible, i.e. to have
# the same files modified each time.  When using this script for
# stress testing one could remove this fixed seed and Perl will