← Back to branch summary

~ubuntu-branches/ubuntu/utopic/libxml-bare-perl/utopic-proposed

« back to all changes in this revision

Viewing changes to t/memory_leak.t

  • Committer: Package Import Robot
  • Author(s): Nuno Carvalho, gregor herrmann, Salvatore Bonaccorso, Axel Beckert, Nuno Carvalho
  • Date: 2013-09-17 15:54:28 UTC
  • mfrom: (1.1.4)
  • Revision ID: package-import@ubuntu.com-20130917155428-4d0xb5cissw2323f
Tags: 0.53-1
* Team upload.

[ gregor herrmann ]
* debian/control: update {versioned,alternative} (build) dependencies.

[ Salvatore Bonaccorso ]
* Change Vcs-Git to canonical URI (git://anonscm.debian.org)
* Change search.cpan.org based URIs to metacpan.org based URIs

[ Axel Beckert ]
* debian/copyright: migrate pre-1.0 format to 1.0 using "cme fix dpkg-
  copyright"

[ Nuno Carvalho ]
* New upstream release.
* debian/copyright: update copyright years.
* debian/control: update standards version.
* debian/control: update debhelper required version, in order to pass all
  the hardening flags to EUMM.
* Add lintian override to apparently false-positive warning.
* Add set of patches accepted upstream but still not included in this
  release, visit https://rt.cpan.org/Public/Bug/Display.html?id=88155
  for details.

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/memory_leak.t
1
 
#!/usr/bin/perl -w
2
 
 
3
 
#
4
 
# This code tests for a set of memory leaks that were present in the simple
5
 
# decoder.   Its really crude, but should show up major issues...
6
 
#
7
 
use strict;
8
 
use warnings;
9
 
 
10
 
use Test::More;
11
 
 
12
 
plan skip_all => "This tests is for release candidate testing" unless ( $ENV{AUTHOR_TESTING} );
13
 
 
14
 
eval "use Unix::Getrusage";
15
 
plan skip_all => "Unix::Getrusage required for testing memory leakiness" if $@;
16
 
 
17
 
use_ok('XML::Bare');
18
 
use_ok('Unix::Getrusage');
19
 
 
20
 
no strict "subs";    # getrusage triggers this...
21
 
 
22
 
# Build an XML document, reasonable size, combination of hash and arrays
23
 
my $numbers = join( '', ( map {"<number>$_</number>"} 0 .. 100 ) );
24
 
my $xmldoc = join( '', '<document>', ( map {"<$_>$numbers</$_>"} 'a' .. 'z' ), '</document>' );
25
 
 
26
 
my $obj = XML::Bare->new( text => $xmldoc );
27
 
my $hash = $obj->simple;
28
 
 
29
 
ok( $hash, 'First conversion XML -> hash' );
30
 
undef($hash);        # force release
31
 
my $count = 0;
32
 
 
33
 
my $final_stats   = Unix::Getrusage::getrusage();    # preusing memory
34
 
my $initial_stats = Unix::Getrusage::getrusage();
35
 
ok( $initial_stats, 'Got process stats' );
36
 
 
37
 
foreach my $codepath ( 'simple', 'parse' ) {
38
 
 
39
 
    # now loop over conversion
40
 
    while ( $count++ < 500 ) {
41
 
        $obj = XML::Bare->new( text => $xmldoc );
42
 
        $hash = $obj->$codepath;
43
 
        undef($hash);                                # force release
44
 
    }
45
 
 
46
 
    ok( 1, "Completed test loop for $codepath" );
47
 
 
48
 
    $final_stats = Unix::Getrusage::getrusage();
49
 
    ok( $final_stats, "Got process stats" );
50
 
 
51
 
    my $is_slim = ( ( $initial_stats->{ru_maxrss} * 2 ) > $final_stats->{ru_maxrss} ) ? 1 : 0;
52
 
    ok( $is_slim, "Process has not bloated on $codepath codepath" );
53
 
 
54
 
    unless ($is_slim) {
55
 
        diag( "Initial: " . $initial_stats->{ru_maxrss} );
56
 
        diag( "Final:   " . $final_stats->{ru_maxrss} );
57
 
    }
58
 
}
59
 
 
60
 
done_testing;