view release on metacpan or  search on metacpan

t/unit.t  view on Meta::CPAN

	ok !$@, "report() does not die when called without prior method calls: $@";
	ok defined $r, 'report() returns a value';

	restore_net();
};

# =============================================================================
# NEW: _is_private IPv6 additions
# =============================================================================
subtest '_is_private() — IPv6 private ranges recognised' => sub {
	my $a = Email::Abuse::Investigator->new();
	ok  $a->_is_private('::1'),		'IPv6 loopback ::1';
	ok  $a->_is_private('fc00::1'),		 'ULA fc00::/7';
	ok  $a->_is_private('fd12::1'),		 'ULA fd00::/8';
	ok  $a->_is_private('fe80::1'),		 'link-local fe80::/10';
	ok  $a->_is_private('2001:db8::1'),	'documentation 2001:db8::/32';
	ok  $a->_is_private('64:ff9b::1'),	 'NAT64 64:ff9b::/96';
	ok !$a->_is_private('2a00:1450::1'),		'public Google IPv6 not private';
};

# =============================================================================
# NEW: _decode_multipart depth guard contract
# =============================================================================
subtest '_decode_multipart() — depth >= MAX_MULTIPART_DEPTH carps and returns' => sub {
	my $bnd  = 'UNITDEPTH';
	my $body = "--$bnd\r\nContent-Type: text/plain\r\n\r\ncontent\r\n--$bnd--\r\n";
	my $a	 = Email::Abuse::Investigator->new();
	$a->{_body_plain} = '';
	my $carped = 0;
	{
		no warnings 'redefine';
		local *Carp::carp = sub { $carped++ };
		$a->_decode_multipart($body, $bnd, 20);
	}
	is $carped, 1,	'_decode_multipart carps once at depth 20';
	is $a->{_body_plain}, '', 'body not populated at depth limit';
};


# =============================================================================
# NEW SECTIONS: Tests for TODO-implemented features
# =============================================================================

# Object::Configure integration
subtest 'new() — Object::Configure::configure() is called' => sub {
	 my @calls;
	 {
	 no warnings 'redefine';
	 local *Object::Configure::configure = sub {
		  push @calls, { class => $_[0], params => $_[1] };
		  return $_[1];
	 };
	 Email::Abuse::Investigator->new(timeout => 7);
	 ok scalar @calls > 0, 'Object::Configure::configure() called during new()';
	 is $calls[0]{class}, 'Email::Abuse::Investigator',
		  'configure() receives correct class name';
	 is ref($calls[0]{params}), 'HASH', 'configure() receives hashref';
	 }
};

subtest 'new() — Object::Configure overlay takes effect' => sub {
	 {
	 no warnings 'redefine';
	 local *Object::Configure::configure = sub {
		  return { %{ $_[1] }, timeout => 42, verbose => 1 };
	 };
	 my $a = Email::Abuse::Investigator->new();
	 is $a->{timeout}, 42, 'configure() overlay applied to timeout';
	 is $a->{verbose},  1, 'configure() overlay applied to verbose';
	 }
};

# _sanitise_output contract
subtest '_sanitise_output() — strips C0 controls, preserves printable' => sub {
	 my $fn = \&Email::Abuse::Investigator::_sanitise_output;
	 ok defined &Email::Abuse::Investigator::_sanitise_output,
	 '_sanitise_output is defined as a package function';
	 is $fn->('Hello, World!'), 'Hello, World!', 'printable ASCII unchanged';
	 is $fn->(undef), '',				 'undef returns empty string';
	 is $fn->("\x01\x02\x03abc"), 'abc',	'C0 controls stripped';
	 is $fn->("abc\x7Fdef"), 'abcdef',		 'DEL (0x7F) stripped';
	 is $fn->("tab\there"), "tab\there",	 'tab (0x09) preserved';
	 is $fn->("line\nbreak"), "line\nbreak",	 'LF (0x0A) preserved';
	 my $utf8 = "caf\xC3\xA9";
	 is $fn->($utf8), $utf8, 'UTF-8 high bytes preserved';
};

subtest 'report() — output contains no C0 controls from adversarial input' => sub {
	 stub_net();
	 no warnings 'redefine';
	 local *Email::Abuse::Investigator::_domain_whois = sub { undef };
	 my $a = Email::Abuse::Investigator->new();
	 $a->parse_email(make_email());
	 $a->{_origin}	  = undef;
	 $a->{_urls}		 = [];
	 $a->{_mailto_domains} = [{
	 domain		=> 'ctrl.example',
	 source		=> 'body',
	 registrar	=> "Evil\x07Registrar\x01Inc",
	 registrar_abuse => 'abuse@evil.example',
	 }];
	 my $r = $a->report();
	 ok $r !~ /[\x01-\x08\x0B\x0C\x0E-\x1F\x7F]/,
	 'report() output contains no C0 control characters';
	 restore_net();
};

subtest 'report() — originating IP section shows (could not determine) when undef' => sub {
	my $a = Email::Abuse::Investigator->new();
	$a->parse_email("From: x\@y.com\nSubject: s\n\nbody");
	$a->{_origin}		= undef;
	$a->{_urls}		= [];
	$a->{_mailto_domains} = [];

	my $r = $a->report();
	like $r, qr/could not determine originating IP/,
		'"could not determine" message shown when origin is undef';
};

subtest 'report() — URL section shows "(none found)" when no URLs present' => sub {
	my $a = Email::Abuse::Investigator->new();
	$a->parse_email(make_email(body => 'No links here.'));
	$a->{_origin}		= undef;
	$a->{_urls}		= [];
	$a->{_mailto_domains} = [];

	my $r = $a->report();
	like $r, qr/none found/, '"none found" shown when no URLs';
};