#!perl
use 5.006001;
our $VERSION = '1.101_003';
Readonly::Scalar my $EXCEPTION_MESSAGE_REGEX =>
qr<malformed [ ] name [ ] section>xmsi;
BEGIN {
use_ok('Perl::Critic::Utils::POD', qw< :all >)
or confess 'No point in continuing.';
}
can_ok('main', 'get_pod_file_for_module');
can_ok('main', 'get_raw_pod_section_from_file');
can_ok('main', 'get_raw_pod_section_from_filehandle');
can_ok('main', 'get_raw_pod_section_from_string');
can_ok('main', 'get_raw_pod_section_for_module');
can_ok('main', 'get_pod_section_from_file');
can_ok('main', 'get_pod_section_from_filehandle');
can_ok('main', 'get_pod_section_from_string');
can_ok('main', 'get_pod_section_for_module');
can_ok('main', 'trim_raw_pod_section');
can_ok('main', 'trim_pod_section');
can_ok('main', 'get_raw_module_abstract_from_file');
can_ok('main', 'get_raw_module_abstract_from_filehandle');
can_ok('main', 'get_raw_module_abstract_from_string');
can_ok('main', 'get_raw_module_abstract_for_module');
can_ok('main', 'get_module_abstract_from_file');
can_ok('main', 'get_module_abstract_from_filehandle');
can_ok('main', 'get_module_abstract_from_string');
can_ok('main', 'get_module_abstract_for_module');
{
my $code = q<my $x = 3;>;
my $pod = get_raw_pod_section_from_string( $code, 'SYNOPSIS' );
is(
$pod,
undef,
qq<get_raw_pod_section_from_string($code, 'SYNOPSIS')>,
);
$pod = get_pod_section_from_string( $code, 'SYNOPSIS' );
is(
$pod,
undef,
qq<get_pod_section_from_string($code, 'SYNOPSIS')>,
);
}
{
my $code = <<'END_CODE';
=pod
END_CODE
my $pod = get_raw_pod_section_from_string( $code, 'SYNOPSIS' );
is(
$pod,
undef,
q<get_raw_pod_section_from_string('=pod', 'SYNOPSIS')>,
);
$pod = get_pod_section_from_string( $code, 'SYNOPSIS' );
is(
$pod,
undef,
q<get_pod_section_from_string('=pod', 'SYNOPSIS')>,
);
}
{
my $code = <<'END_CODE';
=pod
=head1 FOO
Some plain text.
=cut
END_CODE
my $pod = get_raw_pod_section_from_string( $code, 'FOO' );
my $expected = <<'END_EXPECTED';
=head1 FOO
Some plain text.
END_EXPECTED
is(
$pod,
$expected,
q<get_raw_pod_section_from_string('=head1 FOO Some plain text.', 'FOO')>,
);
$pod = get_pod_section_from_string( $code, 'FOO' );
$expected = <<'END_EXPECTED';
FOO
Some plain text.
END_EXPECTED
is(
$pod,
$expected,
q<get_pod_section_from_string('=head1 FOO Some plain text.', 'FOO')>,
);
}
{
my $code = <<'END_CODE';
=pod
=head1 FOO
Some C<escaped> text.
=cut
END_CODE
my $pod = get_raw_pod_section_from_string( $code, 'FOO' );
my $expected = <<'END_EXPECTED';
=head1 FOO
Some C<escaped> text.
END_EXPECTED
is(
$pod,
$expected,
q/get_raw_pod_section_from_string('=head1 FOO Some C<escaped> text.', 'FOO')/,
);
$pod = get_pod_section_from_string( $code, 'FOO' );
$expected = <<'END_EXPECTED';
FOO
Some `escaped' text.
END_EXPECTED
is(
$pod,
$expected,
q/get_pod_section_from_string('=head1 FOO Some C<escaped> text.', 'FOO')/,
);
}
{
my $code = <<'END_CODE';
=pod
=head1 FOO
Some plain text.
=head1 BAR
=cut
END_CODE
my $pod = get_raw_pod_section_from_string( $code, 'FOO' );
my $expected = <<'END_EXPECTED';
=head1 FOO
Some plain text.
END_EXPECTED
is(
$pod,
$expected,
q<get_raw_pod_section_from_string('=head1 FOO ... =head1 BAR', 'FOO')>,
);
$pod = get_pod_section_from_string( $code, 'FOO' );
$expected = <<'END_EXPECTED';
FOO
Some plain text.
END_EXPECTED
is(
$pod,
$expected,
q<get_pod_section_from_string('=head1 FOO ... =head1 BAR', 'FOO')>,
);
}
{
my $code = <<'END_CODE';
=pod
=head1 FOO
Some plain text.
=head2 BAR
=cut
END_CODE
my $pod = get_raw_pod_section_from_string( $code, 'FOO' );
my $expected = <<'END_EXPECTED';
=head1 FOO
Some plain text.
=head2 BAR
END_EXPECTED
is(
$pod,
$expected,
q<get_raw_pod_section_from_string('=head1 FOO ... =head2 BAR', 'FOO')>,
);
$pod = get_pod_section_from_string( $code, 'FOO' );
$expected = qr<
\A
FOO \n
[ ]{4} Some [ ] plain [ ] text.\n
\n
[ ]{2} BAR\n
\s*
\z
>xms;
like(
$pod,
$expected,
q<get_pod_section_from_string('=head1 FOO ... =head2 BAR', 'FOO')>,
);
}
{
my $code = <<'END_CODE';
=pod
=head2 FOO
Some plain text.
=cut
END_CODE
my $pod = get_raw_pod_section_from_string( $code, 'FOO' );
is(
$pod,
undef,
q<get_raw_pod_section_from_string('=head2 FOO Some plain text.', 'FOO')>,
);
$pod = get_pod_section_from_string( $code, 'FOO' );
is(
$pod,
undef,
q<get_pod_section_from_string('=head2 FOO Some plain text.', 'FOO')>,
);
}
{
my $original = <<'END_POD';
=head1 LYRICS
We like talking dirty. We smoke and we drink. We're KMFDM and all other bands
stink.
END_POD
my $trimmed = trim_raw_pod_section( $original );
my $expected =
q<We like talking dirty. We smoke and we drink. >
. qq<We're KMFDM and all other bands\n>
. q<stink.>;
is(
$trimmed,
$expected,
'trim_raw_pod_section() with section header',
);
$trimmed = trim_pod_section( $original );
is(
$trimmed,
$expected,
'trim_pod_section() with section header',
);
}
{
my $original = <<'END_VOCAL_SAMPLE';
You see, I believe in the noble, aristocratic art of doin' absolutely nothin'.
And I hope someday to be in a position where I can do even less.
END_VOCAL_SAMPLE
my $trimmed = trim_raw_pod_section( $original );
my $expected =
q<You see, I believe in the noble, aristocratic art of doin' >
. qq<absolutely nothin'.\n>
. q<And I hope someday to be in a position where I can do even >
. q<less.>;
is(
$trimmed,
$expected,
'trim_raw_pod_section() without section header',
);
$trimmed = trim_pod_section( $original );
is(
$trimmed,
$expected,
'trim_pod_section() without section header',
);
}
{
my $original = <<'END_INDENTATION';
Some indented text.
END_INDENTATION
my $trimmed = trim_raw_pod_section( $original );
my $expected = q<Some indented text.>;
is(
$trimmed,
$expected,
'trim_raw_pod_section() indented',
);
$trimmed = trim_pod_section( $original );
$expected = q< > . $expected;
is(
$trimmed,
$expected,
'trim_pod_section() indented',
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Stupendous::Module - An abstract.
END_MODULE
my $expected = q<An abstract.>;
my $result = get_raw_module_abstract_from_string( $source );
is(
$result,
$expected,
q<get_raw_module_abstract_from_string() with proper abstract>,
);
$result = get_module_abstract_from_string( $source );
is(
$result,
$expected,
q<get_module_abstract_from_string() with proper abstract>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Stupendous::Code::Module - An abstract involving C<$code>.
END_MODULE
my $expected = q<An abstract involving C<$code>.>;
my $result = get_raw_module_abstract_from_string( $source );
is(
$result,
$expected,
q<get_raw_module_abstract_from_string() with proper abstract>,
);
$expected = q<An abstract involving `$code'.>;
$result = get_module_abstract_from_string( $source );
is(
$result,
$expected,
q<get_module_abstract_from_string() with proper abstract>,
);
}
{
my $source = <<'END_MODULE';
=head1 NOT NAME
There's nobody home.
END_MODULE
my $result = get_raw_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_raw_module_abstract_from_string() with no name section>,
);
$result = get_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_module_abstract_from_string() with no name section>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
=head1 DESCRIPTION
END_MODULE
my $result = get_raw_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_raw_module_abstract_from_string() without NAME section content>,
);
$result = get_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_module_abstract_from_string() without NAME section content>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Not::So::Stupendous::Module
END_MODULE
my $result = get_raw_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_raw_module_abstract_from_string() with no abstract>,
);
$result = get_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_module_abstract_from_string() with no abstract>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Not::So::Stupendous::Module -
END_MODULE
my $result = get_raw_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_raw_module_abstract_from_string() with hyphen but no abstract>,
);
$result = get_module_abstract_from_string( $source );
is(
$result,
undef,
q<get_module_abstract_from_string() with hyphen but no abstract>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Not::So::Stupendous::Module No hyphen.
END_MODULE
test_exception_from_get_raw_module_abstract_from_string(
$source, q<with abstract but no hyphen>,
);
test_exception_from_get_module_abstract_from_string(
$source, q<with abstract but no hyphen>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Not::So::Stupendous::Module -- Double hyphen.
END_MODULE
test_exception_from_get_raw_module_abstract_from_string(
$source, q<with double hyphen>,
);
test_exception_from_get_module_abstract_from_string(
$source, q<with double hyphen>,
);
}
{
my $source = <<'END_MODULE';
=head1 NAME
A::Not::So::Stupendous::Module - Abstract goes across
multiple lines.
END_MODULE
test_exception_from_get_raw_module_abstract_from_string(
$source, q<with multiple lines>,
);
}
sub test_exception_from_get_raw_module_abstract_from_string {
my ($source, $name) = @_;
my $result;
my $message_like_name =
qq<Got expected message for get_raw_module_abstract_from_string() $name>;
local $EVAL_ERROR = undef;
eval {
$result = get_raw_module_abstract_from_string( $source );
};
_test_exception_from_get_module_abstract_from_string(
$source, $name, $result, $message_like_name,
);
return;
}
sub test_exception_from_get_module_abstract_from_string {
my ($source, $name) = @_;
my $result;
my $message_like_name =
qq<Got expected message for get_module_abstract_from_string() $name>;
local $EVAL_ERROR = undef;
eval {
$result = get_module_abstract_from_string( $source );
};
_test_exception_from_get_module_abstract_from_string(
$source, $name, $result, $message_like_name,
);
return;
}
sub _test_exception_from_get_module_abstract_from_string {
my ($source, $name, $result, $message_like_name) = @_;
my $eval_error = $EVAL_ERROR;
my $exception = Perl::Critic::Exception::Fatal::Generic->caught();
if (
ok(
ref $exception,
qq<Got the right kind of exception for get_module_abstract_from_string() $name>,
)
) {
like( $exception->message(), $EXCEPTION_MESSAGE_REGEX, $message_like_name );
}
else {
diag( 'Result: ', (defined $result ? ">$result<" : '<undef>') );
if ($eval_error) {
diag(
qq<However, did get an exception: $eval_error>,
);
like( $eval_error, $EXCEPTION_MESSAGE_REGEX, $message_like_name );
}
else {
fail($message_like_name);
}
}
return;
}
1;