#!/usr/bin/env perl
use strict; use warnings;
use English qw( -no_match_vars );
use Config;
use rlib '../lib';
use Test::More;
note( "Testing Devel::Trepan::Util" );
BEGIN {
use_ok( 'Devel::Trepan::Util' );
}
import Devel::Trepan::Util;
note 'Test hash_merge';
my $default_config = {a => 1, b => 'c', term_adjust=>0};
my $config = {};
hash_merge $config, $default_config;
is($config->{a}, $default_config->{a},
"Should pick up default_config value");
$config = {
term_adjust => 1,
bogus => 'yep'
};
is($config->{term_adjust}, 1,
"Should pick up supplied value over default");
is($config->{bogus}, 'yep',
"Should pick up supplied value");
note 'Test safe_repr';
my $string = 'The time has come to talk of many things.';
is(safe_repr($string, 50), $string);
is(safe_repr($string, 17), 'The time... things.');
note 'Test uniq_abbrev';
my @list = qw(disassemble disable distance up);
for my $pair
(
['dis', 'dis'],
['disas', 'disassemble'],
['u', 'up'],
['upper', 'upper'],
['foo', 'foo']) {
my ($name, $expect) = @$pair;
is(uniq_abbrev(\@list, $name), $expect);
}
note 'Test extract expression';
for my $triple (
['if (condition("if"))', 'condition("if")', 'if'],
['if (condition("if")) {', 'condition("if")', 'if (...) {'],
['if(condition("if")){', 'condition("if")', 'if (...){'],
['until (until_termination)', 'until_termination', 'until(...)'],
['until (until_termination){', 'until_termination', 'until(...){'],
['return return_value', 'return_value', 'return'],
['return return_value;', 'return_value', 'return ...;'],
['nothing to be done', 'nothing to be done', 'no change'],
['my ($a,$b) = (5,6);', '($a,$b) = (5,6)', 'my vars assign'],
['my $scalar = "Scalar value";', '"Scalar value"', 'my scalar assign'],
) {
my ($stmt, $expect, $msg) = @$triple;
is(extract_expression($stmt), $expect, $msg);
}
note 'Test parse_eval_suffix';
for my $pair (
['eval', ''],
['eval$', '$'],
['eval%', '%'],
['eval@', '@'],
['evaluate%', '%'],
['none', '']) {
is(parse_eval_suffix($pair->[0]), parse_eval_suffix($pair->[1]),
sprintf("parse_eval_suffix(%s) => '%s' should be '%s'",
$pair->[0], parse_eval_suffix($pair->[0]), $pair->[1]));
}
for my $pair
([__FILE__, ''],
['bogus', 1]) {
my ($name, $expect) = @$pair;
my $result = Devel::Trepan::Util::invalid_filename($name);
is(!!$result, $expect, $result || "$name should exist");
};
for my $pair
(['yes', 1],
['no', 1],
['Y', 1],
['NO', 1],
['nein', 1],
['nien', ''],
['huh?', '']) {
my ($resp, $expect) = @$pair;
my $result = Devel::Trepan::Util::YN($resp);
is($result, $expect, $resp);
}
for my $pair
([1, 'Yes'],
[0, 'No'],
['', 'No'],
['Foo', 'Yes'],
[undef, 'No']) {
my ($resp, $expect) = @$pair;
my $result = Devel::Trepan::Util::bool2YN($resp);
is($result, $expect, 'bool2YN of ' . ($resp || 'undef'));
}
if ($OSNAME ne 'MSWin32') {
for my $expr ('1+', '{cmd=5}') {
ok(Devel::Trepan::Util::invalid_perl_syntax($expr),
"invalid perl expression '$expr'");
}
for my $expr ('-e "\$x=1"') {
ok(!Devel::Trepan::Util::invalid_perl_syntax($expr, 1),
"valid perl expression '$expr'");
}
}
for my $expr ('-e "$x="', '-e "(1,2"') {
ok(Devel::Trepan::Util::invalid_perl_syntax($expr, 1),
"invalid perl expression '$expr'");
}
for my $expr ('\$x=2', '-e "{a => 1}"', '-e "(1,2)"') {
ok(!Devel::Trepan::Util::invalid_perl_syntax($expr, 1),
"valid perl expression '$expr'");
}
done_testing();