package tests::UtilsTest;
use strict;
use base qw/ Lire::Test::TestCase /;
use File::Spec;
use Lire::Utils qw/xml_encode latex_encode diff_lists tilde_expand
tmpdir tempfile tempdir min max ratio ratio100
shell_quote file_content create_file sql_quote_name
tree_apply item_index deep_copy
check_param check_object_param indent
period_range text_for_width is_url parse_url
unique /;
use Time::Local;
#our @TESTS = qw//;
sub set_up {
my $self = $_[0];
$self->SUPER::set_up();
return;
}
sub tear_down {
my $self = $_[0];
$self->SUPER::tear_down();
return;
}
sub test_xml_encode {
my $self = $_[0];
my $v = xml_encode( "<XML> & </XML> Joe \"Such\" a Friend's birtday" );
$self->assert_equals( "<XML> & </XML> Joe "Such" a Friend's birtday", $v );
}
sub test_latex_encode {
my $self = $_[0];
$self->assert_str_equals( '\\# \\$ \\& \\~{} \\_ \\^{} \\% \\{ \\} $\\backslash$ Other $[$ $]$ $<$ $>$', latex_encode( '# $ & ~ _ ^ % { } \\ Other [ ] < >' ) );
}
sub test_diff_lists {
my $self = $_[0];
my $diff = diff_lists( [qw/field1 field2 field3 field4/],
[qw/field4 field3 field2 field1/] );
$self->assert_null( $diff, "should have found no diffs" );
$diff = diff_lists( [qw/field1 field2 field3 field4/],
[qw/field3 field2 field4 field5/],
);
$self->assert_not_null( $diff, "should have found diffs" );
$self->assert_deep_equals( [ "field1" ], $diff->{'remove'} );
$self->assert_deep_equals( [ "field5" ], $diff->{'new'} );
$diff = diff_lists( [qw/field1 field2 field3 field4/],
[qw/field6 field3 field2 field4 field5/],
);
$self->assert_not_null( $diff, "should have found diffs" );
$self->assert_deep_equals( [ "field1" ], $diff->{'remove'} );
$self->assert_deep_equals( [ "field5", "field6" ], $diff->{'new'} );
}
sub test_tilde_expansion {
my $self = $_[0];
my $home = $ENV{'HOME'};
$self->assert_equals($home, tilde_expand('~'));
$self->assert_equals("$home/", tilde_expand('~/'));
$self->assert_equals("$home/~", tilde_expand('~/~'));
$self->assert_equals("$home/~/", tilde_expand('~/~/'));
$self->assert_equals('/~', tilde_expand('/~'));
$self->assert_equals('/~/', tilde_expand('/~/'));
my $user = 'uioxzcyo';
$self->assert_equals("~$user", tilde_expand("~$user"));
$self->assert_equals("~$user/", tilde_expand("~$user/"));
$self->assert_equals("/$user~", tilde_expand("/$user~"));
$self->assert_equals("/$user~/", tilde_expand("/$user~/"));
$user = getpwuid($<);
my ($name,$pass,$uid,$gid,$quota,$comment,$gecos,$dir) = getpwnam($user)
or return;
$self->assert_equals("$dir", tilde_expand("~$user"));
$self->assert_equals("$dir/", tilde_expand("~$user/"));
$self->assert_equals("/$user~", tilde_expand("/$user~"));
$self->assert_equals("/$user~/", tilde_expand("/$user~/"));
}
sub test_min {
my $self = $_[0];
$self->assert_null( min() );
$self->assert_null( min( undef, undef ) );
$self->assert_num_equals( -1, min( -1, undef) );
$self->assert_num_equals( 2, min( 2, undef) );
$self->assert_num_equals( -2, min( -1,-2, 0 ) );
$self->assert_num_equals( 0, min(0,0,0));
$self->assert_num_equals( 0, min(1,0,0));
}
sub test_max {
my $self = $_[0];
$self->assert_null( max() );
$self->assert_null( max( undef, undef ) );
$self->assert_num_equals( 1, max( -1, 0, 1, undef ) );
$self->assert_num_equals( -1, max( -1, -2) );
$self->assert_num_equals( 0, max( 0, 0, 0) );
$self->assert_num_equals( -1, max( -1, undef ) );
}
sub test_tmpdir {
my $self = $_[0];
$self->assert_equals( File::Spec->tmpdir, tmpdir() );
{
local $ENV{'TMPDIR'} = $ENV{'HOME'};
$self->assert_equals( $ENV{'HOME'}, Lire::Utils::_tmpdir() );
}
}
sub test_tempfile {
my $self = $_[0];
my $fh = Lire::Utils::_tempfile();
$self->assert_not_null( $fh, "_tempfile() returned undef" );
$self->assert( -r $fh, "file handle isn't readable" );
$self->assert( -w $fh, "file handle isn't writeable" );
my ( $nfh, $filename ) = Lire::Utils::_tempfile( "lireXXXXXX" );
$self->assert( qr/lire[a-zA-Z0-9]{6}$/, $filename );
$self->assert( -r $nfh, "file handle isn't readable" );
$self->assert( -w $nfh, "file handle isn't writeable" );
unlink $filename;
# Try with perl's standard ones. (PerlUnit only works with perl 5.6.1 and
# later
my $pfh = tempfile();
$self->assert_not_null( $pfh, "tempfile() returned undef" );
$self->assert( -r $pfh, "file handle isn't readable" );
$self->assert( -w $pfh, "file handle isn't writeable" );
my ( $pnfh, $pfilename ) = tempfile( "lireXXXXXX" );
$self->assert( qr/lire[a-zA-Z0-9]{6}$/, $pfilename );
$self->assert( -r $pnfh, "file handle isn't readable" );
$self->assert( -w $pnfh, "file handle isn't writeable" );
unlink $pfilename;
}
sub test_tempdir {
my $self = $_[0];
my $tmpdir = Lire::Utils::_tempdir();
$self->assert_not_null( $tmpdir, "_tempdir() returned undef" );
$self->assert( -r $tmpdir, "tempory dir isn't readable" );
$self->assert( -w $tmpdir, "tempory dir isn't writeable" );
$self->assert( -x $tmpdir, "tempory dir isn't searchable" );
rmdir $tmpdir;
$tmpdir = Lire::Utils::_tempdir( "lireXXXXXX" );;
$self->assert_not_null( $tmpdir, "_tempdir() returned undef" );
$self->assert( qr/lire[a-zA-Z0-9]{6}$/, $tmpdir );
$self->assert( -r $tmpdir, "tempory dir isn't readable" );
$self->assert( -w $tmpdir, "tempory dir isn't writeable" );
$self->assert( -x $tmpdir, "tempory dir isn't searchable" );
rmdir $tmpdir;
# Try with perl's standard ones. (PerlUnit only works with perl 5.6.1 and
# later
my $ptmpdir = tempdir();
$self->assert_not_null( $ptmpdir, "tempdir() returned undef" );
$self->assert( -r $ptmpdir, "tempory dir isn't readable" );
$self->assert( -w $ptmpdir, "tempory dir isn't writeable" );
$self->assert( -x $ptmpdir, "tempory dir isn't searchable" );
rmdir $ptmpdir;
$ptmpdir = tempdir( "lireXXXXXX" );;
$self->assert_not_null( $ptmpdir, "_tmpdir() returned undef" );
$self->assert( qr/lire[a-zA-Z0-9]{6}$/, $ptmpdir );
$self->assert( -r $ptmpdir, "tempory dir isn't readable" );
$self->assert( -w $ptmpdir, "tempory dir isn't writeable" );
$self->assert( -x $ptmpdir, "tempory dir isn't searchable" );
rmdir $ptmpdir;
}
sub test_ratio {
my $self = $_[0];
$self->assert_equals( 2, ratio( 10, 5 ) );
# Force string comparison since NaN == NaN is false
$self->assert_str_equals( "NaN", ratio( 10, 0 ) );
$self->assert_equals( 0, ratio( 0, 10 ) );
$self->assert_equals( "3.33", ratio( 10, 3 ) );
}
sub test_ratio100 {
my $self = $_[0];
$self->assert_equals( 50, ratio100( 5, 10 ) );
# Force string comparison since NaN == NaN is false
$self->assert_str_equals( "NaN", ratio100( 0, 0 ) );
$self->assert_equals( 0, ratio100( 0, 10 ) );
$self->assert_equals( "33.3", ratio100( 3333, 10000 ) );
}
sub test_shell_quote {
my $self = $_[0];
$self->assert_equals( "''", shell_quote( undef ) );
$self->assert_equals( "'Test'", shell_quote( 'Test' ) );
$self->assert_equals( q{'Test'\'''}, shell_quote( "Test'" ) );
$self->assert_equals( q{'`echo shell'\''s test`'}, shell_quote( "`echo shell's test`" ) );
}
sub test_file_content {
my $self = $_[0];
my $content = <<EOF;
This is the file content.
More than one line.
EOF
my ($fh, $name ) = File::Temp::tempfile();
print $fh $content;
close $fh;
$self->assert_dies( qr/missing 'filename' parameter/,
sub { file_content() } );
$self->assert_dies( qr{could not open '/no/such/file' for reading},
sub { file_content( "/no/such/file" ) } );
$self->assert_equals( $content, file_content( $name ) );
unlink $name;
}
sub test_create_file {
my $self = $_[0];
no warnings 'redefine';
my $encoding = undef;
my $set_fh_encoding = sub {
$encoding = 1;
};
local *Lire::I18N::set_fh_encoding = $set_fh_encoding;
$self->assert_died( sub { create_file()},
qr/missing 'filename' parameter/ );
$self->assert_died( sub { create_file( "/no/such/file" ) },
qr/error creating.*: No such file/ );
my $content = <<EOF;
This is a file.
And its content.
EOF
my $tmpdir = File::Temp::tempdir( "Utils_XXXXXX", 'CLEANUP' => 1 );
my $filename = "$tmpdir/test_file";
create_file( $filename );
$self->assert( -f $filename, "$filename wasn't created" );
$self->assert( ! -s $filename, "$filename should be empty" );
create_file( $filename, $content );
my $fh;
open $fh, $filename
or $self->error( "open failed: $!" );
local $/;
my $new_content = <$fh>;
close $fh;
$self->assert_equals( $content, $new_content );
$self->assert_null( $encoding );
create_file( $filename, $content, 1 );
$self->assert_num_equals( 1, $encoding );
return;
}
sub test_sql_quote_name {
my $self = $_[0];
$self->assert_equals( 'field_name', sql_quote_name( 'field_name' ) );
$self->assert_equals( '"field-name"', sql_quote_name( 'field-name' ) );
$self->assert_equals( '"field.name"', sql_quote_name( 'field.name' ) );
$self->assert_equals( '"field:name"', sql_quote_name( 'field:name' ) );
}
sub set_up_tree {
my $self = $_[0];
my $root = new tests::node();
my @nodes = ( $root );
for ( 1..3) {
push @nodes, new tests::node( $root );
}
for ( 1..3 ) {
push @nodes, new tests::node( $nodes[$_] );
push @nodes, new tests::node( $nodes[$_] );
}
$self->assert_equals( 10, scalar @nodes );
return ( $root, \@nodes );
}
sub test_tree_apply_bad_params {
my $self = $_[0];
$self->assert_died( sub { tree_apply() },
qr/missing 'root' parameter/ );
$self->assert_died( sub { tree_apply( {}, ) },
qr/missing 'children_func' parameter/ );
$self->assert_died( sub { tree_apply( {}, sub {} ) },
qr/missing 'apply_func' parameter/ );
}
sub test_tree_apply_subref {
my $self = $_[0];
my ( $root, $nodes ) = $self->set_up_tree();
my $preorder_nodes = [ $nodes->[0],
$nodes->[0]{'children'}[0],
$nodes->[0]{'children'}[0]{'children'}[0],
$nodes->[0]{'children'}[0]{'children'}[1],
$nodes->[0]{'children'}[1],
$nodes->[0]{'children'}[1]{'children'}[0],
$nodes->[0]{'children'}[1]{'children'}[1],
$nodes->[0]{'children'}[2],
$nodes->[0]{'children'}[2]{'children'}[0],
$nodes->[0]{'children'}[2]{'children'}[1],
];
my $idx = 1;
my $result = tree_apply( $root, sub { $_[0]->{'children'} },
sub { $_[0]{'flag'} = $idx++ } );
my $e_result = [ 1 .. 10 ];
$self->assert_deep_equals( $e_result, $result );
for ( my $i=0; $i < @$preorder_nodes; $i++ ) {
$self->assert_equals( $e_result->[$i], $preorder_nodes->[$i]{'flag'} );
}
}
sub test_tree_apply_method {
my $self = $_[0];
my ( $root, $nodes ) = $self->set_up_tree();
my $result = tree_apply( $root, 'children', 'set_flag' );
$self->assert_deep_equals( [ ( 1 ) x 10 ], $result );
foreach my $n ( @$nodes ) {
$self->assert_equals( 1, $n->{'flag'} );
}
}
sub test_item_index {
my $self = $_[0];
my $ref = {};
my $array = [ 'wawa', 2, $ref, 4.0 ];
$self->assert_died( sub { item_index() },
qr/missing 'array' parameter/ );
$self->assert_died( sub { item_index( {} ) },
qr/'array' should be an array ref, not 'HASH/ ); #'
$self->assert_died( sub { item_index( [] ) },
qr/missing 'item' parameter/ );
$self->assert_num_equals( 0, item_index( $array, 'wawa' ) );
$self->assert_num_equals( 1, item_index( $array, '2' ) );
$self->assert_num_equals( 2, item_index( $array, $ref ) );
$self->assert_num_equals( 3, item_index( $array, 4 ) );
$self->assert_null( undef, item_index( $array, 'cocotte' ) );
}
sub test_deep_copy {
my $self = $_[0];
$self->assert_died( sub { deep_copy() },
qr/missing 'object' parameter/ );
$self->assert_str_equals( 'Test', deep_copy( 'Test' ) );
$self->assert_died( sub { deep_copy( 'Test', {} ) },
qr/'exclusions' should be an array reference, not 'HASH/ );
my $array = [ 1, 'string', [ 2, undef, 4 ] ];
$self->assert_deep_equals( $array, deep_copy( $array ) );
$self->assert_str_not_equals( $array, deep_copy( $array ) );
my $rx = qr/.*/;
$self->assert_str_equals( $rx, deep_copy( $rx ) );
my $hash = { 'key1' => $array,
'key2' => 1,
'key3' => $array, };
$hash->{'key4'} = $hash; # cyclic reference
my $copy = deep_copy( $hash );
$self->assert_deep_equals( $hash, $copy );
$self->assert_str_not_equals( $hash, $copy );
$self->assert_str_not_equals( $array, $copy->{'key1'} );
$self->assert_str_equals( $copy->{'key1'}, $copy->{'key3'} );
$self->assert_str_equals( $copy, $copy->{'key4'} );
my $object = bless { 'key' => 'string1' }, 'object';
my $object_copy = deep_copy( $object );
$self->assert_str_equals( ref $object, ref $object_copy );
$self->assert_str_not_equals( $object, $object_copy );
$self->assert_deep_equals( $object, $object_copy );
}
sub test_clone_scalar_ref {
my $self = $_[0];
my $string = 'wawa';
my $ref1 = \$string;
my $ref2 = \$ref1;
my $excl = [];
no warnings 'redefine';
local *Lire::Utils::_deep_copy = sub {
my ( $object, $seen, $exclusions ) = @_;
$self->assert_str_equals( $excl, $exclusions );
return $object unless ref $object;
return $seen->{$object} if exists $seen->{$object};
if ( ref $object eq 'REF' || ref $object eq 'SCALAR') {
return Lire::Utils::_clone_scalar_ref( $object, $seen,$exclusions);
} else {
$self->error( "ref type unsupported by deep_copy(): $object" );
}
};
my $seen = {};
my $ref1_copy = Lire::Utils::_clone_scalar_ref( $ref1, $seen, $excl );
$self->assert_str_equals( $$ref1, $$ref1_copy );
$self->assert_str_not_equals( $ref1, $ref1_copy );
$self->assert_str_equals( $seen->{$ref1}, $ref1_copy );
my $ref2_copy = Lire::Utils::_clone_scalar_ref( $ref2, $seen, $excl );
$self->assert_str_equals( $$ref2_copy, $ref1_copy );
$self->assert_str_equals( $seen->{$ref2}, $ref2_copy );
}
sub test_clone_array_ref {
my $self = $_[0];
my $array1 = [ 1, 2, 3 ];
my $array2 = [ $array1 ];
my $excl = [];
no warnings 'redefine';
local *Lire::Utils::_deep_copy = sub {
my ( $object, $seen, $exclusions ) = @_;
$self->assert_str_equals( $excl, $exclusions );
return $object unless ref $object;
return $seen->{$object} if exists $seen->{$object};
if ( ref $object eq 'ARRAY' ) {
return Lire::Utils::_clone_array_ref( $object, $seen, $exclusions);
} else {
$self->error( "ref type unsupported by deep_copy(): $object" );
}
};
my $seen = {};
my $array1_copy = Lire::Utils::_clone_array_ref( $array1, $seen, $excl );
$self->assert_str_not_equals( $array1, $array1_copy );
$self->assert_deep_equals( $array1_copy, $array1 );
$self->assert_str_equals( $array1_copy, $seen->{$array1} );
my $array2_copy = Lire::Utils::_clone_array_ref( $array2, $seen, $excl );
$self->assert_str_equals( $array2_copy, $seen->{$array2} );
$self->assert_deep_equals( $array2_copy, $array2 );
}
sub test_clone_hash_ref {
my $self = $_[0];
my $hash1 = { 'key1' => 'value1',
'key2' => 'value2' };
my $hash2 = { 'key1' => 1,
'key2' => $hash1 };
my $excl = [];
no warnings 'redefine';
local *Lire::Utils::_deep_copy = sub {
my ( $object, $seen, $exclusions ) = @_;
$self->assert_str_equals( $excl, $exclusions );
return $object unless ref $object;
return $seen->{$object} if exists $seen->{$object};
if ( ref $object eq 'HASH' ) {
return Lire::Utils::_clone_hash_ref( $object, $seen, $exclusions );
} else {
$self->error( "ref type unsupported by deep_copy(): $object" );
}
};
my $seen = {};
my $hash1_copy = Lire::Utils::_clone_hash_ref( $hash1, $seen, $excl );
$self->assert_str_not_equals( $hash1, $hash1_copy );
$self->assert_deep_equals( $hash1_copy, $hash1 );
$self->assert_str_equals( $hash1_copy, $seen->{$hash1} );
my $hash2_copy = Lire::Utils::_clone_hash_ref( $hash2, $seen, $excl );
$self->assert_str_equals( $hash2_copy, $seen->{$hash2} );
$self->assert_deep_equals( $hash2_copy, $hash2 );
}
sub test_clone_object {
my $self = $_[0];
my $scalar = 'Test';
my $scalar_object = bless \$scalar, 'scalar';
my $array_object = bless [], 'array';
my $glob_object = bless \*SYMBOL, 'symbol';
my $object1 = bless { 'key1' => 1 }, "package1";
my $object2 = bless { 'key1' => $object1 }, 'package2';
$self->assert_died( sub { Lire::Utils::_clone_object( $glob_object, {} ) },
qr/unsupported object storage: 'symbol=GLOB/ );
my $seen = {};
my $ob1_copy = Lire::Utils::_clone_object( $object1, $seen );
$self->assert_str_not_equals( $object1, $ob1_copy );
$self->assert_str_equals( ref $object1, ref $ob1_copy );
$self->assert_deep_equals( $object1, $ob1_copy );
$self->assert_str_equals( $ob1_copy, $seen->{$object1} );
my $ob2_copy = Lire::Utils::_clone_object( $object2, $seen );
$self->assert_str_equals( $ob2_copy, $seen->{$object2} );
$self->assert_deep_equals( $ob2_copy, $object2 );
$self->assert_str_equals( $object2,
Lire::Utils::_clone_object( $object2, $seen,
[ 'package2' ] ) );
}
sub test_check_param {
my $self = $_[0];
$self->assert_died( sub { check_param() },
qr/check_param needs at least 2 arguments: a parameter, the parameter\'s name/ );
$self->assert_died( sub { check_param( undef, 'wawa&' ) },
qr/parameter 'name' is not a valid name: 'wawa&'/ );
$self->assert_died( sub { check_param( undef, 'wawa' ) },
qr/missing \'wawa\' parameter/ );
$self->assert_died( sub { check_param( '123', 'wawa', qr/^[a-z]+$/ ) },
qr/\'wawa\' parameter doesn\'t match \'\(.*\)': \'123\'/ );
$self->assert_died( sub { check_param( 'abc', 'wawa', qr/^[0-9]+$/,
"'wawa' parameter is not a valid integer" )},
qr/\'wawa\' parameter is not a valid integer: \'abc\'/ );
$self->assert_died( sub { check_param( 0, 'wawa', sub { return $_[0] },
"'wawa' parameter is false" )},
qr/\'wawa\' parameter is false: \'0\'/ );
check_param( 1, 'wawa', sub { return $_[0] },
"This test of check_param should have passed" );
return;
}
sub test_check_object_param {
my $self = $_[0];
my $test_obj = bless {}, 'TestClass';
$self->assert_died( sub { check_object_param() },
qr/check_object_param needs 3 arguments: an object, the object parameter\'s name, the object's class name/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawaobj&',
[ 'WawaClass' ] ) },
qr/parameter 'name' is not a valid name: 'wawaobj&'/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawaobj',
'WawaClass&' ) },
qr/parameter 'class' contains an invalid class name: 'WawaClass&'/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawaobj',
[ 'WawaClass&' ] ) },
qr/parameter 'class' contains an invalid class name: 'WawaClass&'/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawaobj',
[ 'Wawa:Class' ] ) },
qr/parameter 'class' contains an invalid class name: 'Wawa:Class'/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawaobj',
[ 'Wawa:::Class' ] ) },
qr/parameter 'class' contains an invalid class name: 'Wawa:::Class'/ );
$self->assert_died( sub { check_object_param( 'wawa', 'wawaname',
[ 'wawaclass' ] ) },
qr/'wawaname' parameter should be a 'wawaclass' instance, not \'wawa\'/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawa',
'WawaClass' ) },
qr/'wawa' parameter should be a 'WawaClass' instance, not 'TestClass/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawa',
[ 'WawaClass' ] ) },
qr/'wawa' parameter should be a 'WawaClass' instance, not 'TestClass/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawa',
[ 'WawaClass',
'Chill::Class',
'Mega::Class::Name' ] ) },
qr/'wawa' parameter should be a 'WawaClass', 'Chill::Class' or 'Mega::Class::Name' instance, not 'TestClass/ );
$self->assert_died( sub { check_object_param( $test_obj, 'wawa',
[] )},
qr/parameter \'class\' should contain at least one class name/ );
my $rc = check_object_param( $test_obj, 'wawaobj', [ 'TestClass' ] );
$self->assert_null( $rc, "there should be no return code" );
check_object_param( bless ({}, 'Test::Class') , 'wawaobj', [ 'Test::Class' ] );
return;
}
sub _check_object_param_fail_method {
my ( $self, $object );
check_object_param( $object, 'test_object', [ 'tests::UtilsTest' ] );
}
sub test_check_object_param_caller {
my $self = $_[0];
# check_object_param() invocations with a wrong object instance should
# return the method's caller informations (1st check) while bad parameters
# given to check_object_param() itself should refer to the
# check_object_param's caller (2nd check).
my $this_file = 'nofile';
my $this_line = 'noline';
eval { $this_file = __FILE__;
$this_line = __LINE__; _check_object_param_fail_method( undef ); };
my $err = $@;
$self->assert_not_null( $err, "no error message??" );
$self->assert_matches( qr/^missing 'test_object' parameter at $this_file:$this_line$/,
$err );
eval { $this_file = __FILE__;
$this_line = __LINE__; check_object_param();};
$err = $@;
$self->assert_not_null( $err, "no error message??" );
$self->assert_matches( qr/^check_object_param needs 3 arguments: an object, the object parameter's name, the object's class name at $this_file:$this_line$/,
$err );
return;
}
sub test_indent {
my $self = $_[0];
$self->assert_str_equals( '', indent() );
$self->assert_str_equals( '', indent( '' ) );
my $start_text = 'simple line';
$self->assert_str_equals( ' simple line', indent( $start_text ) );
$start_text = <<_EOT;
text for indentation
indented line
end of indentation
_EOT
my $e_text = <<_EOT;
text for indentation
indented line
end of indentation
_EOT
$self->assert_str_equals( $e_text, indent( $start_text ) );
$e_text = <<_EOT;
text for indentation
indented line
end of indentation
_EOT
$self->assert_str_equals( $e_text, indent( $start_text, 4 ) );
return;
}
sub test_period_range {
my $self = $_[0];
$self->{'cfg'}{'lr_week_numbering'} = 'U';
$self->set_up_tz( 'UTC' );
my $dec31_2004 = timelocal( 0, 5, 23, 31, 11, 2004 );
$self->assert_dies( qr/'period' parameter should be one of 'hourly', 'daily', 'weekly', 'monthly' or 'yearly'/,
sub { period_range( 'unique', $dec31_2004 ) } );
$self->assert_deep_equals( [ timelocal( 0, 0, 23, 31, 11, 2004 ),
timelocal( 0, 0, 0, 1, 0, 2005 ) ],
period_range( 'hourly', $dec31_2004 ) );
$self->assert_deep_equals( [ timelocal( 0, 0, 0, 31, 11, 2004 ),
timelocal( 0, 0, 0, 1, 0, 2005 ) ],
period_range( 'daily', $dec31_2004 ) );
$self->assert_deep_equals( [ timelocal( 0, 0, 0, 1, 11, 2004 ),
timelocal( 0, 0, 0, 1, 0, 2005 ) ],
period_range( 'monthly', $dec31_2004 ) );
my $jan1_2004 = timelocal( 0, 0, 0, 1, 0, 2004 );
$self->assert_deep_equals( [ timelocal( 0, 0, 0, 1, 0, 2004 ),
timelocal( 0, 0, 0, 1, 1, 2004 ) ],
period_range( 'monthly', $jan1_2004 ) );
$self->assert_deep_equals( [ timelocal( 0, 0, 0, 1, 0, 2004 ),
timelocal( 0, 0, 0, 1, 0, 2005 ) ],
period_range( 'yearly', $dec31_2004 ) );
$self->assert_deep_equals( [ timelocal( 0, 0, 0, 26, 11, 2004 ),
timelocal( 0, 0, 0, 2, 0, 2005 ) ],
period_range( 'weekly', $dec31_2004 ) );
}
sub test_text_for_width {
my $self = $_[0];
$self->assert_dies( qr/missing \'text\' parameter/,
sub { text_for_width() } );
$self->assert_dies( qr/missing \'width\' parameter/,
sub { text_for_width( 'wawa' ) } );
$self->assert_dies( qr/\'width' should be a positive, greater than or equal to 5, integer: \'-3\'/,
sub { text_for_width( 'wawa', -3 ) } );
$self->assert_dies( qr/\'width' should be a positive, greater than or equal to 5, integer: \'wawa\'/,
sub { text_for_width( 'wawa', 'wawa' ) } );
$self->assert_str_equals( 'wawa',
text_for_width( 'wawa', 10 ) );
$self->assert_str_equals( 'b...s',
text_for_width( 'bigwawatestormorethan9chars', 5 ) );
$self->assert_str_equals( 'big...ars',
text_for_width( 'big wawa test or more than 9 chars', 9 ) );
$self->assert_str_equals( 'big...hars',
text_for_width( 'big wawa test or more than 10 chars', 10 ) );
$self->assert_str_equals( 'big...test',
text_for_width( 'big test', 10 ) );
}
sub test_is_url {
my $self = $_[0];
my $nourl_string1 = "/etc/lire";
my $nourl_string2 = "/etc/lire/file://tmp";
my $nourl_string3 = "file:/etc/lire/wawa";
my $nourl_string4 = "fi le://etc/lire/wawa";
my $url_string1 = "http://www.wawa.org";
my $url_string2 = "file:///tmp";
my $url_string3 = "file://c:/temp";
$self->assert_num_equals( 0, is_url( $nourl_string1 ) );
$self->assert_num_equals( 0, is_url( $nourl_string2 ) );
$self->assert_num_equals( 0, is_url( $nourl_string3 ) );
$self->assert_num_equals( 0, is_url( $nourl_string4 ) );
$self->assert_num_equals( 1, is_url( $url_string1 ) );
$self->assert_num_equals( 1, is_url( $url_string2 ) );
$self->assert_num_equals( 1, is_url( $url_string3 ) );
return;
}
sub test_parse_url {
my $self = $_[0];
$self->assert_deep_equals( { 'scheme' => 'http',
'host' => 'www.logreport.org',
'port' => 80,
'path' => '/index.html',
'query' => 'search=test',
'fragment' => 'anchor' },
parse_url( 'http://www.logreport.org:80/index.html?search=test#anchor' ) );
$self->assert_deep_equals( { 'scheme' => 'http',
'host' => 'www.logreport.org',
'port' => undef,
'path' => '/index.html',
'query' => undef,
'fragment' => undef },
parse_url( 'http://www.logreport.org/index.html' ) );
$self->assert_deep_equals( { 'scheme' => undef,
'host' => undef,
'port' => undef,
'path' => '/index.html',
'query' => undef,
'fragment' => 'anchor' },
parse_url( '/index.html#anchor' ) );
}
sub test_unique {
my $self = $_[0];
$self->assert_deep_equals( [ 1, 2, 3 ],
unique( [ 1, 2, 3, 1, 2, 3] ) );
$self->assert_deep_equals( [ 'aa', 'b', 'c' ],
unique( [ 'aa', 'aa', 'aa', 'b', 'c' ] ) );
}
package tests::node;
sub new {
my ( $pkg, $parent ) = @_;
my $self = bless { 'flag' => 0, 'children' => [] }, $pkg;
push @{$parent->{'children'}}, $self
if defined $parent;
return $self;
}
sub children {
return $_[0]{'children'};
}
sub set_flag {
return $_[0]{'flag'} = 1;
}
1;
syntax highlighted by Code2HTML, v. 0.9.1