← Back to branch summary

~percona-toolkit-dev/percona-toolkit/fix-change-master-bug-932614

« back to all changes in this revision

Viewing changes to lib/MaatkitTest.pm

  • Committer: Daniel Nichter
  • Date: 2011-06-24 17:22:06 UTC
  • Revision ID: daniel@percona.com-20110624172206-c7q4s4ad6r260zz6
Add lib/, t/lib/, and sandbox/.  All modules are updated and passing on MySQL 5.1.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/MaatkitTest.pm
 
1
# This program is copyright 2009-2011 Percona Inc.
 
2
# Feedback and improvements are welcome.
 
3
#
 
4
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
 
5
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
 
6
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
 
7
#
 
8
# This program is free software; you can redistribute it and/or modify it under
 
9
# the terms of the GNU General Public License as published by the Free Software
 
10
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
 
11
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
 
12
# licenses.
 
13
#
 
14
# You should have received a copy of the GNU General Public License along with
 
15
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
 
16
# Place, Suite 330, Boston, MA  02111-1307  USA.
 
17
# ###########################################################################
 
18
# MaatkitTest package $Revision: 7096 $
 
19
# ###########################################################################
 
20
 
 
21
# Package: MaatkitTest
 
22
# MaatkitTest is a collection of helper-subs for the Maatkit tests.
 
23
# Any file arguments (like no_diff() $expected_output) are relative to
 
24
# PERCONA_TOOLKIT_BRANCH.  So passing "commont/t/samples/foo" means
 
25
# "PERCONA_TOOLKIT_BRANCH/common/t/samples/foo".  Do not BAIL_OUT() because
 
26
# this terminates the *entire* test process; die instead.  All
 
27
# subs are exported by default, so is the variable $trunk, so there's
 
28
# no need to import() in the test scripts.
 
29
{
 
30
package MaatkitTest;
 
31
 
 
32
use strict;
 
33
use warnings FATAL => 'all';
 
34
use English qw(-no_match_vars);
 
35
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
 
36
 
 
37
use Test::More;
 
38
use Time::HiRes qw(usleep);
 
39
use POSIX qw(signal_h);
 
40
use Data::Dumper;
 
41
$Data::Dumper::Indent    = 1;
 
42
$Data::Dumper::Sortkeys  = 1;
 
43
$Data::Dumper::Quotekeys = 0;
 
44
 
 
45
require Exporter;
 
46
our @ISA         = qw(Exporter);
 
47
our %EXPORT_TAGS = ();
 
48
our @EXPORT_OK   = qw();
 
49
our @EXPORT      = qw(
 
50
   output
 
51
   load_data
 
52
   load_file
 
53
   parse_file
 
54
   wait_until
 
55
   wait_for
 
56
   test_log_parser
 
57
   test_protocol_parser
 
58
   test_packet_parser
 
59
   no_diff
 
60
   throws_ok
 
61
   remove_traces
 
62
   $trunk
 
63
   $dsn_opts
 
64
   $sandbox_version
 
65
);
 
66
 
 
67
our $trunk = $ENV{PERCONA_TOOLKIT_BRANCH};
 
68
 
 
69
our $sandbox_version = '';
 
70
eval {
 
71
   chomp(my $v = `$trunk/sandbox/test-env version`);
 
72
   $sandbox_version = $v if $v;
 
73
};
 
74
 
 
75
our $dsn_opts = [
 
76
   {
 
77
      key  => 'A',
 
78
      desc => 'Default character set',
 
79
      dsn  => 'charset',
 
80
      copy => 1,
 
81
   },
 
82
   {
 
83
      key  => 'D',
 
84
      desc => 'Database to use',
 
85
      dsn  => 'database',
 
86
      copy => 1,
 
87
   },
 
88
   {
 
89
      key  => 'F',
 
90
      desc => 'Only read default options from the given file',
 
91
      dsn  => 'mysql_read_default_file',
 
92
      copy => 1,
 
93
   },
 
94
   {
 
95
      key  => 'h',
 
96
      desc => 'Connect to host',
 
97
      dsn  => 'host',
 
98
      copy => 1,
 
99
   },
 
100
   {
 
101
      key  => 'p',
 
102
      desc => 'Password to use when connecting',
 
103
      dsn  => 'password',
 
104
      copy => 1,
 
105
   },
 
106
   {
 
107
      key  => 'P',
 
108
      desc => 'Port number to use for connection',
 
109
      dsn  => 'port',
 
110
      copy => 1,
 
111
   },
 
112
   {
 
113
      key  => 'S',
 
114
      desc => 'Socket file to use for connection',
 
115
      dsn  => 'mysql_socket',
 
116
      copy => 1,
 
117
   },
 
118
   {
 
119
      key  => 't',
 
120
      desc => 'Table',
 
121
      dsn  => undef,
 
122
      copy => 1,
 
123
   },
 
124
   {
 
125
      key  => 'u',
 
126
      desc => 'User for login if not current user',
 
127
      dsn  => 'user',
 
128
      copy => 1,
 
129
   },
 
130
];
 
131
 
 
132
# Runs code, captures and returns its output.
 
133
# Optional arguments:
 
134
#   * file    scalar: capture output to this file (default none)
 
135
#   * stderr  scalar: capture STDERR (default no)
 
136
#   * die     scalar: die if code dies (default no)
 
137
#   * trf     coderef: pass output to this coderef (default none)
 
138
sub output {
 
139
   my ( $code, %args ) = @_;
 
140
   die "I need a code argument" unless $code;
 
141
   my ($file, $stderr, $die, $trf) = @args{qw(file stderr die trf)};
 
142
 
 
143
   my $output = '';
 
144
   if ( $file ) { 
 
145
      open *output_fh, '>', $file
 
146
         or die "Cannot open file $file: $OS_ERROR";
 
147
   }
 
148
   else {
 
149
      open *output_fh, '>', \$output
 
150
         or die "Cannot capture output to variable: $OS_ERROR";
 
151
   }
 
152
   local *STDOUT = *output_fh;
 
153
 
 
154
   # If capturing STDERR we must dynamically scope (local) STDERR
 
155
   # in the outer scope of the sub.  If we did,
 
156
   #   if ( $args{stderr} ) { local *STDERR; ... }
 
157
   # then STDERR would revert to its original value outside the if
 
158
   # block.
 
159
   local *STDERR     if $args{stderr};  # do in outer scope of this sub
 
160
   *STDERR = *STDOUT if $args{stderr};
 
161
 
 
162
   eval { $code->() };
 
163
   close *output_fh;
 
164
   if ( $EVAL_ERROR ) {
 
165
      die $EVAL_ERROR if $die;
 
166
      return $EVAL_ERROR;
 
167
   }
 
168
 
 
169
   # Possible transform output before returning it.  This doesn't work
 
170
   # if output was captured to a file.
 
171
   $output = $trf->($output) if $trf;
 
172
 
 
173
   return $output;
 
174
}
 
175
 
 
176
# Load data from file and removes spaces.  Used to load tcpdump dumps.
 
177
sub load_data {
 
178
   my ( $file ) = @_;
 
179
   $file = "$trunk/$file";
 
180
   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
 
181
   my $contents = do { local $/ = undef; <$fh> };
 
182
   close $fh;
 
183
   (my $data = join('', $contents =~ m/(.*)/g)) =~ s/\s+//g;
 
184
   return $data;
 
185
}
 
186
 
 
187
# Slurp file and return its entire contents.
 
188
sub load_file {
 
189
   my ( $file, %args ) = @_;
 
190
   $file = "$trunk/$file";
 
191
   open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
 
192
   my $contents = do { local $/ = undef; <$fh> };
 
193
   close $fh;
 
194
   chomp $contents if $args{chomp_contents};
 
195
   return $contents;
 
196
}
 
197
 
 
198
sub parse_file {
 
199
   my ( $file, $p, $ea ) = @_;
 
200
   $file = "$trunk/$file";
 
201
   my @e;
 
202
   eval {
 
203
      open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
 
204
      my %args = (
 
205
         next_event => sub { return <$fh>;    },
 
206
         tell       => sub { return tell $fh; },
 
207
         fh         => $fh,
 
208
      );
 
209
      while ( my $e = $p->parse_event(%args) ) {
 
210
         push @e, $e;
 
211
         $ea->aggregate($e) if $ea;
 
212
      }
 
213
      close $fh;
 
214
   };
 
215
   die $EVAL_ERROR if $EVAL_ERROR;
 
216
   return \@e;
 
217
}
 
218
 
 
219
# Wait until code returns true.
 
220
sub wait_until {
 
221
   my ( $code, $t, $max_t ) = @_;
 
222
   my $slept     = 0;
 
223
   my $sleep_int = $t || .5;
 
224
   $t     ||= .5;
 
225
   $max_t ||= 5;
 
226
   $t *= 1_000_000;
 
227
   while ( $slept <= $max_t ) {
 
228
      return if $code->();
 
229
      usleep($t);
 
230
      $slept += $sleep_int;
 
231
   }
 
232
   return;
 
233
}
 
234
 
 
235
# Wait t seconds for code to return.
 
236
sub wait_for {
 
237
   my ( $code, $t ) = @_;
 
238
   $t ||= 0;
 
239
   my $mask   = POSIX::SigSet->new(&POSIX::SIGALRM);
 
240
   my $action = POSIX::SigAction->new(
 
241
      sub { die },
 
242
      $mask,
 
243
   );
 
244
   my $oldaction = POSIX::SigAction->new();
 
245
   sigaction(&POSIX::SIGALRM, $action, $oldaction);
 
246
   eval {
 
247
      alarm $t;
 
248
      $code->();
 
249
      alarm 0;
 
250
   };
 
251
   if ( $EVAL_ERROR ) {
 
252
      # alarm was raised
 
253
      return 1;
 
254
   }
 
255
   return 0;
 
256
}
 
257
 
 
258
sub _read {
 
259
   my ( $fh ) = @_;
 
260
   return <$fh>;
 
261
}
 
262
 
 
263
sub test_log_parser {
 
264
   my ( %args ) = @_;
 
265
   foreach my $arg ( qw(parser file) ) {
 
266
      die "I need a $arg argument" unless $args{$arg};
 
267
   }
 
268
   my $p = $args{parser};
 
269
 
 
270
   # Make sure caller isn't giving us something we don't understand.
 
271
   # We could ignore it, but then caller might not get the results
 
272
   # they expected.
 
273
   map  { die "What is $_ for?"; }
 
274
   grep { $_ !~ m/^(?:parser|misc|file|result|num_events|oktorun)$/ }
 
275
   keys %args;
 
276
 
 
277
   my $file = "$trunk/$args{file}";
 
278
   my @e;
 
279
   eval {
 
280
      open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
 
281
      my %parser_args = (
 
282
         next_event => sub { return _read($fh); },
 
283
         tell       => sub { return tell($fh);  },
 
284
         fh         => $fh,
 
285
         misc       => $args{misc},
 
286
         oktorun    => $args{oktorun},
 
287
      );
 
288
      while ( my $e = $p->parse_event(%parser_args) ) {
 
289
         push @e, $e;
 
290
      }
 
291
      close $fh;
 
292
   };
 
293
 
 
294
   is(
 
295
      $EVAL_ERROR,
 
296
      '',
 
297
      "No error on $args{file}"
 
298
   );
 
299
 
 
300
   if ( defined $args{result} ) {
 
301
      is_deeply(
 
302
         \@e,
 
303
         $args{result},
 
304
         $args{file}
 
305
      ) or print "Got: ", Dumper(\@e);
 
306
   }
 
307
 
 
308
   if ( defined $args{num_events} ) {
 
309
      is(
 
310
         scalar @e,
 
311
         $args{num_events},
 
312
         "$args{file} num_events"
 
313
      );
 
314
   }
 
315
 
 
316
   return \@e;
 
317
}
 
318
 
 
319
sub test_protocol_parser {
 
320
   my ( %args ) = @_;
 
321
   foreach my $arg ( qw(parser protocol file) ) {
 
322
      die "I need a $arg argument" unless $args{$arg};
 
323
   }
 
324
   my $parser   = $args{parser};
 
325
   my $protocol = $args{protocol};
 
326
 
 
327
   # Make sure caller isn't giving us something we don't understand.
 
328
   # We could ignore it, but then caller might not get the results
 
329
   # they expected.
 
330
   map { die "What is $_ for?"; }
 
331
   grep { $_ !~ m/^(?:parser|protocol|misc|file|result|num_events|desc)$/ }
 
332
   keys %args;
 
333
 
 
334
   my $file = "$trunk/$args{file}";
 
335
   my @e;
 
336
   eval {
 
337
      open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
 
338
      my %parser_args = (
 
339
         next_event => sub { return _read($fh); },
 
340
         tell       => sub { return tell($fh);  },
 
341
         misc       => $args{misc},
 
342
      );
 
343
      while ( my $p = $parser->parse_event(%parser_args) ) {
 
344
         my $e = $protocol->parse_event(%parser_args, event => $p);
 
345
         push @e, $e if $e;
 
346
      }
 
347
      close $fh;
 
348
   };
 
349
 
 
350
   is(
 
351
      $EVAL_ERROR,
 
352
      '',
 
353
      "No error on $args{file}"
 
354
   );
 
355
   
 
356
   if ( defined $args{result} ) {
 
357
      is_deeply(
 
358
         \@e,
 
359
         $args{result},
 
360
         $args{file} . ($args{desc} ? ": $args{desc}" : '')
 
361
      ) or print "Got: ", Dumper(\@e);
 
362
   }
 
363
 
 
364
   if ( defined $args{num_events} ) {
 
365
      is(
 
366
         scalar @e,
 
367
         $args{num_events},
 
368
         "$args{file} num_events"
 
369
      );
 
370
   }
 
371
 
 
372
   return \@e;
 
373
}
 
374
 
 
375
sub test_packet_parser {
 
376
   my ( %args ) = @_;
 
377
   foreach my $arg ( qw(parser file) ) {
 
378
      die "I need a $arg argument" unless $args{$arg};
 
379
   }
 
380
   my $parser   = $args{parser};
 
381
 
 
382
   # Make sure caller isn't giving us something we don't understand.
 
383
   # We could ignore it, but then caller might not get the results
 
384
   # they expected.
 
385
   map { die "What is $_ for?"; }
 
386
   grep { $_ !~ m/^(?:parser|misc|file|result|desc|oktorun)$/ }
 
387
   keys %args;
 
388
 
 
389
   my $file = "$trunk/$args{file}";
 
390
   my @packets;
 
391
   open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
 
392
   my %parser_args = (
 
393
      next_event => sub { return _read($fh); },
 
394
      tell       => sub { return tell($fh);  },
 
395
      misc       => $args{misc},
 
396
      oktorun    => $args{oktorun},
 
397
   );
 
398
   while ( my $packet = $parser->parse_event(%parser_args) ) {
 
399
      push @packets, $packet;
 
400
   }
 
401
 
 
402
   # raw_packet is the actual dump text from the file.  It's used
 
403
   # in MySQLProtocolParser but I don't think we need to double-check
 
404
   # it here.  It will make the results very long.
 
405
   foreach my $packet ( @packets ) {
 
406
      delete $packet->{raw_packet};
 
407
   }
 
408
 
 
409
   if ( !is_deeply(
 
410
         \@packets,
 
411
         $args{result},
 
412
         "$args{file}" . ($args{desc} ? ": $args{desc}" : '')
 
413
      ) ) {
 
414
      print Dumper(\@packets);
 
415
   }
 
416
 
 
417
   return;
 
418
}
 
419
 
 
420
# no_diff() compares the STDOUT output of a cmd or code to expected output.
 
421
# Returns true if there are no differences between the two outputs,
 
422
# else returns false.  Dies if the cmd/code dies.  Does not capture STDERR.
 
423
# Args:
 
424
#   * cmd                 scalar or coderef: if cmd is a scalar then the
 
425
#                         cmd is ran via the shell.  if it's a coderef then
 
426
#                         the code is ran.  the latter is preferred because
 
427
#                         it generates test coverage.
 
428
#   * expected_output     scalar: file name relative to PERCONA_TOOLKIT_BRANCH
 
429
#   * args                hash: (optional) may include
 
430
#       update_sample            overwrite expected_output with cmd/code output
 
431
#       keep_output              keep last cmd/code output file
 
432
#   *   trf                      transform cmd/code output before diff
 
433
# The sub dies if cmd or code dies.  STDERR is not captured.
 
434
sub no_diff {
 
435
   my ( $cmd, $expected_output, %args ) = @_;
 
436
   die "I need a cmd argument" unless $cmd;
 
437
   die "I need an expected_output argument" unless $expected_output;
 
438
 
 
439
   $expected_output = "$trunk/$expected_output";
 
440
   die "$expected_output does not exist" unless -f $expected_output;
 
441
 
 
442
   my $tmp_file      = '/tmp/maatkit-test-output.txt';
 
443
   my $tmp_file_orig = '/tmp/maatkit-test-output-original.txt';
 
444
 
 
445
   # Determine cmd type and run it.
 
446
   if ( ref $cmd eq 'CODE' ) {
 
447
      output($cmd, file => $tmp_file);
 
448
   }
 
449
   elsif ( $args{cmd_output} ) {
 
450
      # Copy cmd output to tmp file so we don't with the original.
 
451
      open my $tmp_fh, '>', $tmp_file or die "Cannot open $tmp_file: $OS_ERROR";
 
452
      print $tmp_fh $cmd;
 
453
      close $tmp_fh;
 
454
   }
 
455
   else {
 
456
      `$cmd > $tmp_file`;
 
457
   }
 
458
 
 
459
   # Do optional arg stuff.
 
460
   `cp $tmp_file $tmp_file_orig`;
 
461
   if ( my $trf = $args{trf} ) {
 
462
      `$trf $tmp_file_orig > $tmp_file`;
 
463
   }
 
464
   if ( my $sed = $args{sed} ) {
 
465
      foreach my $sed_args ( @{$args{sed}} ) {
 
466
         `sed $sed_args $tmp_file`;
 
467
      }
 
468
   }
 
469
 
 
470
   # diff the outputs.
 
471
   my $retval = system("diff $tmp_file $expected_output");
 
472
 
 
473
   # diff returns 0 if there were no differences,
 
474
   # so !0 = 1 = no diff in our testing parlance.
 
475
   $retval = $retval >> 8; 
 
476
 
 
477
   if ( $retval ) {
 
478
      if ( $ENV{UPDATE_SAMPLES} || $args{update_sample} ) {
 
479
         `cat $tmp_file > $expected_output`;
 
480
         print STDERR "Updated $expected_output\n";
 
481
      }
 
482
   }
 
483
 
 
484
   # Remove our tmp files.
 
485
   `rm -f $tmp_file $tmp_file_orig`
 
486
      unless $ENV{KEEP_OUTPUT} || $args{keep_output};
 
487
 
 
488
   return !$retval;
 
489
}
 
490
 
 
491
sub throws_ok {
 
492
   my ( $code, $pat, $msg ) = @_;
 
493
   eval { $code->(); };
 
494
   like ( $EVAL_ERROR, $pat, $msg );
 
495
}
 
496
 
 
497
# Remove /*maatkit ...*/ trace comments from the given SQL statement(s).
 
498
# Traces are added in ChangeHandler::process_rows().
 
499
sub remove_traces {
 
500
   my ( $sql ) = @_;
 
501
   my $trace_pat = qr/ \/\*maatkit .+?\*\//;
 
502
   if ( ref $sql && ref $sql eq 'ARRAY' ) {
 
503
      map { $_ =~ s/$trace_pat//gm } @$sql;
 
504
   }
 
505
   else {
 
506
      $sql =~ s/$trace_pat//gm;
 
507
   }
 
508
   return $sql;
 
509
}
 
510
 
 
511
1;
 
512
}
 
513
# ###########################################################################
 
514
# End MaatkitTest package
 
515
# ###########################################################################