TestUtils.pm 20.3 KB
Newer Older
1
2
=head1 LICENSE

Magali Ruffier's avatar
Magali Ruffier committed
3
Copyright [1999-2015] Wellcome Trust Sanger Institute and the EMBL-European Bioinformatics Institute
premanand17's avatar
premanand17 committed
4
Copyright [2016-2018] EMBL-European Bioinformatics Institute
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

     http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

=cut

20
21
package Bio::EnsEMBL::Test::TestUtils;

22

Javier Herrero's avatar
Fix POD  
Javier Herrero committed
23
24
25
26
27
28
=head1 NAME

Bio::EnsEMBL::Test::TestUtils - Utilities for testing the EnsEMBL Perl API

=head1 SYNOPSIS

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
29
30
31
    debug("Testing Bio::EnsEMBL::Slice->foo() method");
    ok( &test_getter_setter( $object, 'foo', 'value' ) );
    count_rows( $human_dba, "gene" );
Javier Herrero's avatar
Fix POD  
Javier Herrero committed
32
33
34
35
36
37
38
39
40
41
42
43

=head1 DESCRIPTION

This module contains a several utilities for testing the EnsEMBL Perl API.

=head1 EXPORTS

This modules exports the following methods by default:

 - debug
 - test_getter_setter
 - count_rows
44
45
 - find_circular_refs
 - dump_vars
Javier Herrero's avatar
Fix POD  
Javier Herrero committed
46
47
48

=head1 CONTACT

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
49
Email questions to the ensembl developer mailing list
Magali Ruffier's avatar
Magali Ruffier committed
50
<http://lists.ensembl.org/mailman/listinfo/dev>
Javier Herrero's avatar
Fix POD  
Javier Herrero committed
51
52
53
54
55

=head1 METHODS

=cut

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
56
57
58
use strict;
use warnings;

59
60
use Exporter;

61
62
63
64

use Devel::Peek;
use Devel::Cycle;
use Error qw(:try);
65
use IO::String;
66
use PadWalker qw/peek_our peek_my/;
67
68
use Test::Builder::Module;
use Bio::EnsEMBL::Utils::IO qw/gz_work_with_file work_with_file/;
69
use Time::Piece;
70

71
72
use vars qw( @ISA @EXPORT );

73
@ISA = qw(Exporter Test::Builder::Module);
74
75
76
77
78
79
80
81
82
83
84
@EXPORT = qw(
  debug 
  test_getter_setter 
  count_rows 
  find_circular_refs 
  capture_std_streams 
  is_rows 
  warns_like 
  mock_object 
  ok_directory_contents 
  is_file_line_count
85
  compare_file_line
86
87
88
89
  has_apache2_licence
  all_has_apache2_licence
  all_source_code
);
90
91
92
93
94
95
96
97
98
99
100

=head2 test_getter_setter

  Arg [1]    : Object $object
               The object to test the getter setter on
  Arg [2]    : string $method
               The name of the getter setter method to test
  Arg [3]    : $test_val
               The value to use to test the set behavior of the method.
  Example    : ok(&TestUtils::test_getter_setter($object, 'type', 'value'));
  Description: Tests a getter setter method by attempting to set a value
Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
101
102
103
               and verifying that the newly set value can be retrieved.
               The old value of the the attribute is restored after the
               test (providing the method functions correctly).
104
105
106
107
108
109
  Returntype : boolean - true value on success, false on failure
  Exceptions : none
  Caller     : test scripts

=cut

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
110
111
112
113
sub test_getter_setter
{
    my ( $object, $method, $test_val ) = @_;

114
    my $ret_val = 0;
Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
115
116
117
118

    # Save the old value
    my $old_val = $object->$method();

119
120
    $object->$method($test_val);

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
121
122
123
124
125
126
    # Verify value was set
    $ret_val =
      (      ( !defined($test_val) && !defined( $object->$method() ) )
          || ( $object->$method() eq $test_val ) );

    # Restore the old value
127
    $object->$method($old_val);
Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
128

129
130
131
    return $ret_val;
}

Javier Herrero's avatar
Fix POD  
Javier Herrero committed
132
133
134
135
136
137
138
139
140
141
142
143
=head2 debug

  Arg [...]  : array of strings to be printed
  Example    : debug("Testing Bio::EnsEMBL::Slice->foo() method")
  Description: Prints a debug message on the standard error console
               if the verbosity has not been swithed off
  Returntype : none
  Exceptions : none
  Caller     : test scripts

=cut

144
sub debug {
145
  Bio::EnsEMBL::Test::TestUtils->builder->note(@_);
146
147
}

Javier Herrero's avatar
Fix POD  
Javier Herrero committed
148
149
150
151
=head2 count_rows

  Arg [1]    : Bio::EnsEMBL::DBSQL::DBAdaptor $dba
  Arg [2]    : string $tablename
152
153
  Arg [3]    : string $constraint
  Arg [4]    : Array $params
Javier Herrero's avatar
Fix POD  
Javier Herrero committed
154
  Example    : count_rows($human_dba, "gene");
Andy Yates's avatar
Andy Yates committed
155
  Example    : count_rows($human_dba, "gene", 'where analysis_id=?', [1028]);
Javier Herrero's avatar
Fix POD  
Javier Herrero committed
156
157
158
159
160
161
162
  Description: Returns the number of rows in the table $tablename
  Returntype : int
  Exceptions : none
  Caller     : test scripts

=cut

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
163
164
165
166
sub count_rows
{
    my $db        = shift;
    my $tablename = shift;
167
168
    my $constraint = shift;
    my $params     = shift;
Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
169

170
171
172
173
    $constraint ||= q{};
    $params     ||= [];
    
    my $sth = $db->dbc->prepare("select count(*) from $tablename $constraint");
Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
174

175
    $sth->execute(@{$params});
Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
176
177

    my ($count) = $sth->fetchrow_array();
178

Andreas Kusalananda Kähäri's avatar
Cleanup  
Andreas Kusalananda Kähäri committed
179
    return $count;
180
181
}

182
183
184
185
186
187
188
189
=head2 is_rows

  Arg [1]    : int $expected_count
  Arg [2]    : Bio::EnsEMBL::DBSQL::DBAdaptor $dba
  Arg [3]    : string $tablename
  Arg [4]    : string $constraint
  Arg [5]    : Array $params
  Example    : is_rows(20, $human_dba, "gene");
Andy Yates's avatar
Andy Yates committed
190
  Example    : is_rows(0, $human_dba, "gene", 'where analysis_id =?', [1025]);
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
  Description: Asserts the count returned is the same as the expected value
  Returntype : None
  Exceptions : None
  Caller     : test scripts

=cut

sub is_rows {
  my ($expected_count, $db, $tablename, $constraint, $params) = @_;
  $constraint ||= q{};
  my $actual_count = count_rows($db, $tablename, $constraint, $params);
  my $joined_params = join(q{, }, @{($params || [] )});
  my $name = sprintf(q{Asserting row count is %d from %s with constraint '%s' with params [%s]}, 
    $expected_count, $tablename, $constraint, $joined_params
  );
206
  return __PACKAGE__->builder->is_num($actual_count, $expected_count, $name);
207
208
}

209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
=head2 capture_std_streams

  Arg [1]     : CodeRef callback to execute which will attempt to write to STD streams
  Arg [2]     : Boolean 1-dump variables
  Example     : capture_std_streams(sub { 
                 my ($stdout_ref, $stderr_ref) = @_; 
                 print 'hello'; 
                 is(${$stdout_ref}, 'hello', 'STDOUT contains expected';) 
                });
  Description : Provides access to the STDOUT and STDERR streams captured into
                references. This allows you to assert code which writes to
                these streams but offers no way of changing their output
                stream.
  Returntype  : None
  Exceptions  : None
  Caller      : test scripts

=cut

sub capture_std_streams {
  my ($callback) = @_;
  
  my ($stderr_string, $stdout_string) = (q{}, q{});
  
  my $new_stderr = IO::String->new(\$stderr_string);
  my $old_stderr_fh = select(STDERR);
  local *STDERR = $new_stderr;
  
  my $new_stdout = IO::String->new(\$stdout_string);
  my $old_stdout_fh = select(STDOUT);
  local *STDOUT = $new_stdout;
  
  $callback->(\$stdout_string, \$stderr_string);
  
  return;
}

246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
=head2 warns_like

  Arg [1]    : CodeRef code to run; can be a code ref or a block since we can prototype into a code block
  Arg [2]    : Regex regular expression to run against the thrown warnings
  Arg [3]    : String message to print to screen
  Example    : warns_like { do_something(); } qr/^expected warning$/, 'I expect this!';
               warns_like(sub { do_something(); }, qr/^expected$/, 'I expect this!');
  Description: Attempts to run the given code block and then regexs the captured
               warnings raised to SIG{'__WARN__'}. This is done using 
               Test::Builder so we are Test::More compliant. 
  Returntype : None
  Exceptions : none
  Caller     : test scripts

=cut

sub warns_like (&$;$) {
  my ($callback, $regex, $msg) = @_;
  my $warnings;
  local $SIG{'__WARN__'} = sub {
    $warnings .= $_[0];
  };
  $callback->();
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
  return __PACKAGE__->builder()->like($warnings, $regex, $msg);
}

=head2 ok_directory_contents

  Arg [1]    : String directory to search for files in
  Arg [2]    : ArrayRef filenames to look for
  Arg [3]    : String message to print 
  Example    : ok_directory_contents('/etc', 'hosts', '/etc/hosts is there');
  Description: 
  Returntype : Boolean declares if the test was a success
  Exceptions : none
  Caller     : test scripts

=cut

sub ok_directory_contents ($$;$) {
  my ($dir, $files, $msg) = @_;
  my $result;
  my @missing;
  foreach my $file (@{$files}) {
    my $full_path = File::Spec->catfile($dir, $file);
    if(! -e $full_path || ! -s $full_path) {
      push(@missing, $file);
    }
  }
  my $builder = __PACKAGE__->builder();
  if(@missing) {
    $result = $builder->ok(0, $msg);
    $builder->diag("Directory '$dir' is missing the following files");
    my $missing_msg = join(q{, }, @missing);
    $builder->diag(sprintf('[%s]', $missing_msg));
  }
  else {
    $result = $builder->ok(1, $msg);
  }
  return $result;
}

308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
=head2 compare_file_line

  Arg [1]    : String file to test. Can be a gzipped file or uncompressed
  Arg [2]    : Line number to test
  Arg [3]    : String, the expected line
  Arg [3]    : String optional message to print to screen
  Example    : compare_file_line('/etc/hosts', 5, 'On the fifth line it said', 'The line is as expected');
  Description: Opens the given file (can be gzipped or not) and compares a given line number 
               with an expected string
  Returntype : Boolean Declares if the test succeeeded or not
  Exceptions : none
  Caller     : test scripts

=cut

sub compare_file_line ($$;$;$;$) {
  my ($file, $line_number, $expected_line, $msg) = @_;
  my $builder = __PACKAGE__->builder();
  if(! -e $file) {
    my $r = $builder->ok(0, $msg);
    $builder->diag("$file does not exist");
    return $r;
  }

  my $result_line;
  my $sub_line = sub {
    my ($fh, $line) = @_;
    my $count = 0;
    while(my $line = <$fh>) {
      chomp $line;
      $count++;
      if ($count == $line_number) {
        $result_line = $line;
        last;
      }
    }
    return;
  };

  if($file =~ /.gz$/) {
    gz_work_with_file($file, 'r', $sub_line);
  }
  else {
    work_with_file($file, 'r', $sub_line);
  }

  return $builder->cmp_ok($result_line, 'eq', $expected_line, $msg);
}

357
358
359
360
361
=head2 is_file_line_count

  Arg [1]    : String file to test. Can be a gzipped file or uncompressed
  Arg [2]    : Integer the number of expected rows
  Arg [3]    : String optional message to print to screen
362
  Arg [4]    : Pattern for matching lines
363
364
365
366
367
368
369
370
371
  Example    : is_file_line_count('/etc/hosts', 10, 'We have 10 entries in /etc/hosts');
  Description: Opens the given file (can be gzipped or not) and counts the number of
               lines by simple line iteration
  Returntype : Boolean Declares if the test succeeeded or not
  Exceptions : none
  Caller     : test scripts

=cut

372
373
sub is_file_line_count ($$;$;$) {
  my ($file, $expected_count, $msg, $pattern) = @_;
374
375
376
377
378
379
380
381
382
383
384
  my $builder = __PACKAGE__->builder();
  if(! -e $file) {
    my $r = $builder->ok(0, $msg);
    $builder->diag("$file does not exist");
    return $r;
  }

  my $count = 0;
  my $sub_counter = sub {
    my ($fh) = @_;
    while(my $line = <$fh>) {
385
      if ($pattern && $line !~ /$pattern/) { next; }
386
387
388
389
390
391
392
393
394
395
396
397
398
      $count++;
    }
    return;
  };

  if($file =~ /.gz$/) {
    gz_work_with_file($file, 'r', $sub_counter);
  }
  else {
    work_with_file($file, 'r', $sub_counter); 
  }

  return $builder->cmp_ok($count, '==', $expected_count, $msg);
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
}

=head2 mock_object

  Arg [1]    : Object used to mock
  Arg [2]    : Boolean 1-dump variables
  Example    : my $mock = mock_object($obj); $mock->hello(); is($mock->_called('hello'), 1);
  Description: Returns a mock object which counts the number of times a method
               is invoked on itself. This is very useful to use when we want
               to make sure certain methods are & are not called.
  Returntype : Bio::EnsEMBL::Test::TestUtils::MockObject
  Exceptions : none
  Caller     : test scripts

=cut

sub mock_object {
  my ($obj) = @_;
  return Bio::EnsEMBL::Test::TestUtils::MockObject->new($obj);
418
419
}

420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
=head2 all_has_apache2_licence

  Arg [n]    : Directories to scan. Defaults to blib, t, modules, lib and sql 
               should they exist (remember relative locations matter if you give them)
  Example    : my @files = all_has_apache2_licence();
               my @files = all_has_apache2_licence('../lib/t');
  Description: Scans the given directories and returns all found instances of
               source code. This includes Perl (pl,pm,t), Java(java), C(c,h) and 
               SQL (sql) suffixed files. It then looks for the Apache licence 2.0 
               declaration in the top of the file (30 lines leway given).

               Should you not need it to scan a directory then put a no critic 
               declaration at the top. This will prevent the code from scanning and
               mis-marking the file. The scanner directive is (American spelling also supported)
                  no critic (RequireApache2Licence) 
  Returntype : Boolean indicating if all given directories has source code 
               with the expected licence

=cut

sub all_has_apache2_licence {
  my @files = all_source_code(@_);
  my $ok = 1;
  foreach my $file (@files) {
    $ok = 0 if ! has_apache2_licence($file);
  }
  return $ok;
}

=head2 has_apache2_licence

  Arg [1]    : File path to the file to test
  Example    : has_apache2_licence('/my/file.pm');
  Description: Asserts if we can find the short version of the Apache v2.0
454
               licence and correct Copyright year within the first 30 lines of the given file. You can
455
456
457
458
459
460
461
462
463
464
465
               skip the test with a C<no critic (RequireApache2Licence)> tag. We
               also support the American spelling of this.
  Returntype : None
  Exceptions : None

=cut

sub has_apache2_licence {
  my ($file) = @_;
  my $count = 0;
  my $max_lines = 30;
466
467
468
  my ($found_copyright, $found_url, $found_warranties, $skip_test, $found_sanger_embl_ebi_year, $found_embl_ebi_year) = (0,0,0,0,0,0);
  my $current_year = Time::Piece->new()->year();

469
470
471
472
473
474
475
476
477
478
  open my $fh, '<', $file or die "Cannot open $file: $!";
  while(my $line = <$fh>) {
    last if $count >= $max_lines;
    if($line =~ /no critic \(RequireApache2Licen(c|s)e\)/) {
      $skip_test = 1;
      last;
    }
    $found_copyright = 1 if $line =~ /Apache License, Version 2\.0/;
    $found_url = 1 if $line =~ /www.apache.org.+LICENSE-2.0/;
    $found_warranties = 1 if $line =~ /WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND/;
479
480
    $found_sanger_embl_ebi_year = 1 if $line =~ /Copyright \[1999\-2015\] Wellcome Trust Sanger Institute and the EMBL-European Bioinformatics Institute/;
    $found_embl_ebi_year = 1 if $line =~ /Copyright \[2016\-$current_year\] EMBL-European Bioinformatics Institute/;
481
482
483
484
485
486
    $count++;
  }
  close $fh;
  if($skip_test) {
    return __PACKAGE__->builder->ok(1, "$file has a no critic (RequireApache2Licence) directive");
  }
487
488
  if($found_copyright && $found_url && $found_warranties && $found_sanger_embl_ebi_year && $found_embl_ebi_year) {
    return __PACKAGE__->builder->ok(1, "$file has a Apache v2.0 licence declaration and correct Copyright year [2016-$current_year]");
489
  }
490
491
492
  __PACKAGE__->builder->diag("$file is missing Apache v2.0 declaration") unless $found_copyright;
  __PACKAGE__->builder->diag("$file is missing Apache URL")              unless $found_url;
  __PACKAGE__->builder->diag("$file is missing Apache v2.0 warranties")  unless $found_warranties;
493
494
495
  __PACKAGE__->builder->diag("$file is missing Copyright \[1999\-2015\] Wellcome Trust Sanger Institute and the EMBL-European Bioinformatics Institute")  unless $found_sanger_embl_ebi_year;
  __PACKAGE__->builder->diag("$file is missing Copyright \[2016\-$current_year\] EMBL-European Bioinformatics Institute")  unless $found_embl_ebi_year;
  return __PACKAGE__->builder->ok(0, "$file does not have an Apache v2.0 licence declaration and correct Copyright year [2016-$current_year] in the first $max_lines lines");
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
}

=head2 all_source_code

  Arg [n]    : Directories to scan. Defaults to blib, t, modules, lib and sql 
               should they exist (remember relative locations matter if you give them)
  Example    : my @files = all_source_code();
               my @files = all_source_code('lib/t');
  Description: Scans the given directories and returns all found instances of
               source code. This includes Perl (pl,pm,t), Java(java), C(c,h) and 
               SQL (sql) suffixed files.
  Returntype : Array of all found files

=cut

sub all_source_code {
  my @starting_dirs = @_ ? @_ : _starting_dirs();
  my @files;
  my @dirs = @starting_dirs;
  while ( my $file = shift @dirs ) {
    if ( -d $file ) {
      opendir my $dir, $file or next;
      my @new_files = 
        grep { $_ ne 'CVS' && $_ ne '.svn' && $_ ne '.git' && $_ !~ /^\./ } 
        File::Spec->no_upwards(readdir $dir);
      closedir $dir;
522
      push(@dirs, map {File::Spec->catfile($file, $_)} @new_files);
523
524
    }
    if ( -f $file ) {
525
      next unless $file =~ /\.([chtr]|p[lmy]|sh|java|(my|pg|)sql|sqlite)$/i;
526
527
528
529
530
531
532
533
534
535
536
537
      push(@files, $file);
    }
  } # while
  return @files;
}

sub _starting_dirs {
  my @dirs;
  push(@dirs, grep { -e $_ } qw/blib lib sql t modules/);
  return @dirs;
}

538
539
540
541
=head2 find_circular_refs

  Arg [1]    : Boolean 1-print cycles
  Arg [2]    : Boolean 1-dump variables
542
  Example    : my $count = find_circular_refs(1,1);
543
  Description: Returns the number of variables with circular references. 
544
               Only variables which are ensembl objects are considered.
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
               The sub will go through variables which are in scope at the point it was called. 
  Returntype : int
  Exceptions : none
  Caller     : test scripts

=cut

my %ensembl_objects = ();
my $cycle_found;
my $print_cycles;

sub find_circular_refs { 
 
    $print_cycles = shift;
    my $dump_vars = shift;
    my $message;
    my $lexical  = peek_my(1);
 
    while (my ($var, $ref) = each %$lexical) {
	my $dref = $ref;
    	while (ref($dref) eq "REF") {
	    $dref = $$dref;
	}
	if ( ref($dref) =~ /Bio\:\:EnsEMBL/ and !defined($ensembl_objects{$var.ref($dref)}) )  { 
	    $ensembl_objects{$var.ref($dref)} = 0;	    
	    $message = $var ." ". ref($dref);
	    _get_cycles($var,$dref,$message, $dump_vars);
 	} 
	if (ref($dref) eq "HASH") {
		my %dref_hash = %$dref;
		my $value_count = 0;
		foreach my $key (keys %dref_hash) {
		    $value_count ++;
		    if (ref($dref_hash{$key}) =~ /Bio\:\:EnsEMBL/ and !defined($ensembl_objects{$var.$value_count.ref($dref_hash{$key})} ) ) {	
			$ensembl_objects{$var.$value_count.ref($dref_hash{$key})} = 0;			
			$message = $var . " HASH value ".$value_count." ". ref($dref_hash{$key});
			_get_cycles($var,$dref_hash{$key},$message,$dump_vars,$key);		
		    }
		}
	}
	if (ref($dref) eq "ARRAY") {
	    #for an array check the first element only
	    my @dref_array = @$dref;
	  
	       if (ref($dref_array[0]) =~ /Bio\:\:EnsEMBL/ and  !defined($ensembl_objects{$var."0".ref($dref_array[0])}) ) {	
		   $ensembl_objects{$var."0".ref($dref_array[0])} = 0;
		   $message = $var ." ARRAY element 0 ". ref($dref_array[0]);
		   _get_cycles($var,$dref_array[0],$message,$dump_vars,undef,0);		
	       }
		    		
	}
	
    }
    my $circular_count = 0;
    foreach my $value (values %ensembl_objects) {
	$circular_count += $value;
    }
    return $circular_count;
}

sub _get_cycles {
    
    my $var = shift;
    my $dref = shift;
    my $message = shift;
    my $dump_vars = shift;
    my $hash_key = shift;
    my $array_element = shift;

    $cycle_found = 0; 
    if ($print_cycles) {
	find_cycle($dref);
	find_cycle($dref, \&_count_cycles);	
    }
    else {
    #use try/catch to return after 1st cycle is found if we're not printing cycles
	try {
	    find_cycle($dref, \&_count_cycles);
	}
	catch Error::Simple with {
	    
	};
    }
    
    if ($cycle_found) {

	my $key = "";
	if ($hash_key) {
	    $key = $var.$hash_key;
	}
	elsif (defined $array_element) {
	    $key = $var.$array_element;
	}
	$ensembl_objects{$key.ref($dref)} += 1;
	print "circular reference found in ".$message."\n";
	if ($dump_vars) {
	    Dump($dref);
	}
    }
}

sub _count_cycles {
   if (!$print_cycles && $cycle_found) {
       throw Error::Simple;
   }
   my $cycle_array_ref = shift;
   my @cycle_array = @$cycle_array_ref;
   if (scalar(@cycle_array) > 0) {
	$cycle_found = 1;
   }  
}

657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
#See mock_object() for more information about how to use
package Bio::EnsEMBL::Test::TestUtils::MockObject;

use base qw/Bio::EnsEMBL::Utils::Proxy/;

sub __clear {
  my ($self) = @_;
  $self->{__counts} = undef;
}

sub __called {
  my ($self, $method) = @_;
  return $self->{__counts}->{$method} if exists $self->{__counts}->{$method};
  return 0;
}

sub __is_called {
  my ($self, $method, $times, $msg) = @_;
  my $calls = $self->__called($method);
676
  return Bio::EnsEMBL::Test::TestUtils->builder()->is_num($calls, $times, $msg);
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
}

sub __resolver {
  my ($invoker, $package, $method) = @_;
  return sub {
    my ($self, @args) = @_;
    my $wantarray = wantarray();
    $self->{__counts}->{$method} = 0 unless $self->{__counts}->{$method}; 
    my @capture = $self->__proxy()->$method(@args);
    $self->{__counts}->{$method}++;
    return @capture if $wantarray;
    return shift @capture;
  };
}

692
1;