Skip to content

fix: generalize test_document/test_statement into Helper.pm #446

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
toddr-bot wants to merge 2 commits into
base: master
Choose a base branch
from
Draft

fix: generalize test_document/test_statement into Helper.pm #446

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
527b13c
test: add TODO tests for generalized test_document/test_statement in …
toddr-bot Apr 30, 2026
b7b7eb0
generalize test_document/test_statement into Helper.pm
toddr-bot May 4, 2026
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
42 changes: 1 addition & 41 deletions t/feature_tracking.t
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@ use B 'perlstring';

use PPI ();
use PPI::Dumper;
use Helper 'test_document';

#use DB::Skip subs => [
# qw( PPI::Document::new PPI::Lexer::lex_source PPI::Lexer::new
Expand All @@ -16,8 +17,6 @@ use PPI::Dumper;
# qr/^PPI::Tokenizer::__ANON__.*237.*$/
#];

sub test_document;

FEATURE_TRACKING: {
test_document
<<'END_PERL',
Expand Down Expand Up @@ -435,42 +434,3 @@ SIMPLE_LIST: {

ok( PPI::Tokenizer->new( \"d()" )->all_tokens, "bare tokenizer auto-vivifies document object" );

### TODO from ppi_token_unknown.t , deduplicate

sub one_line_explain {
my ($data) = @_;
my @explain = explain $data;
s/\n//g for @explain;
return join "", @explain;
}

sub main_level_line {
return "" if not $TODO;
my @outer_final;
my $level = 0;
while ( my @outer = caller( $level++ ) ) {
@outer_final = @outer;
}
return "l $outer_final[2] - ";
}

sub test_document {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $args = ref $_[0] eq "ARRAY" ? shift : [];
my ( $code, $expected, $msg ) = @_;
$msg = perlstring $code if !defined $msg;

my $d = PPI::Document->new( \$code, @{$args} ) or die explain $@;
my $tokens = $d->find( sub { $_[1]->significant } );
$tokens = [ map { ref($_), $_->content } @$tokens ];

my $ok = is_deeply( $tokens, $expected, main_level_line . $msg );
if ( !$ok ) {
diag ">>> $code -- $msg\n";
diag( PPI::Dumper->new($d)->string );
diag one_line_explain $tokens;
diag one_line_explain $expected;
}

return;
}
69 changes: 69 additions & 0 deletions t/helper_test_functions.t
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,69 @@
#!/usr/bin/perl

# Test that Helper.pm exports generalized test_document and test_statement

use lib 't/lib';
use PPI::Test::pragmas;
use Test::More tests => 8 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );

use Helper qw( test_document test_statement );
use PPI ();

# test_statement: with explicit Statement class in expected
test_statement(
'my $x = 1;',
[
'PPI::Statement::Variable' => 'my $x = 1;',
'PPI::Token::Word' => 'my',
'PPI::Token::Symbol' => '$x',
'PPI::Token::Operator' => '=',
'PPI::Token::Number' => '1',
'PPI::Token::Structure' => ';',
],
"test_statement with explicit Statement in expected"
);

# test_statement: auto-wraps in PPI::Statement when no Statement prefix
test_statement(
'print 1;',
[
'PPI::Token::Word' => 'print',
'PPI::Token::Number' => '1',
'PPI::Token::Structure' => ';',
],
"test_statement auto-wraps in PPI::Statement"
);

# test_document: simple variable declaration
test_document(
'my $x = 1;',
[
'PPI::Statement::Variable', 'my $x = 1;',
'PPI::Token::Word', 'my',
'PPI::Token::Symbol', '$x',
'PPI::Token::Operator', '=',
'PPI::Token::Number', '1',
'PPI::Token::Structure', ';',
],
"test_document with simple variable declaration"
);

# test_document: with PPI::Document options passed as first arrayref
test_document(
[ feature_mods => { signatures => 1 } ],
'sub foo ($x) {}',
[
'PPI::Statement::Sub', 'sub foo ($x) {}',
'PPI::Token::Word', 'sub',
'PPI::Token::Word', 'foo',
'PPI::Structure::Signature', '($x)',
'PPI::Token::Structure', '(',
'PPI::Statement::Expression', '$x',
'PPI::Token::Symbol', '$x',
'PPI::Token::Structure', ')',
'PPI::Structure::Block', '{}',
'PPI::Token::Structure', '{',
'PPI::Token::Structure', '}',
],
"test_document with feature_mods option"
);
110 changes: 109 additions & 1 deletion t/lib/Helper.pm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,12 @@ use warnings;

use parent 'Exporter';
use Test::More;
use B 'perlstring';

use PPI::Document ();
use PPI::Dumper ();

our @EXPORT_OK = qw( check_with safe_new );
our @EXPORT_OK = qw( check_with safe_new test_document test_statement );

=head1 safe_new @args

Expand Down Expand Up @@ -54,4 +56,110 @@ sub check_with {
return $checker->();
}

=head1 test_document

test_document(
'my $x = 1;',
[ 'PPI::Statement::Variable', 'my $x = 1;', ... ],
"optional message"
);

test_document(
[ feature_mods => { signatures => 1 } ],
'sub foo ($x) {}',
[ ... ],
"with document options"
);

Parses the given code into a PPI::Document, extracts all significant elements
(class name and content pairs), and compares against the expected arrayref.

An optional first arrayref argument passes options to PPI::Document->new().

=cut

sub test_document {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my $args = ref $_[0] eq "ARRAY" ? shift : [];
my ( $code, $expected, $msg ) = @_;
$msg = perlstring $code if !defined $msg;

my $d = PPI::Document->new( \$code, @{$args} ) or die explain $@;
my $tokens = $d->find( sub { $_[1]->significant } );
$tokens = [ map { ref($_), $_->content } @$tokens ];

my $ok = is_deeply( $tokens, $expected, _main_level_line() . $msg );
if ( !$ok ) {
diag ">>> $code -- $msg\n";
diag( PPI::Dumper->new($d)->string );
diag _one_line_explain($tokens);
diag _one_line_explain($expected);
}

return;
}

=head1 test_statement

test_statement(
'my $x = 1;',
[
'PPI::Token::Word' => 'my',
'PPI::Token::Symbol' => '$x',
'PPI::Token::Operator' => '=',
'PPI::Token::Number' => '1',
'PPI::Token::Structure' => ';',
],
"optional message"
);

Parses the given code into a PPI::Document, extracts all significant elements
(class name and content pairs), and compares against the expected arrayref.

If the first element of the expected array does not start with
C<PPI::Statement>, the expected array is automatically wrapped with the
statement class and the full code as its content.

=cut

sub test_statement {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my ( $code, $expected, $msg ) = @_;
$msg = perlstring $code if !defined $msg;

my $d = safe_new \$code;
my $tokens = $d->find( sub { $_[1]->significant } );
$tokens = [ map { ref($_), $_->content } @$tokens ];

if ( $expected->[0] !~ /^PPI::Statement/ ) {
$expected = [ 'PPI::Statement', $code, @$expected ];
}
my $ok = is_deeply( $tokens, $expected, _main_level_line() . $msg );
if ( !$ok ) {
diag ">>> $code -- $msg\n";
diag( PPI::Dumper->new($d)->string );
diag _one_line_explain($tokens);
diag _one_line_explain($expected);
}

return;
}

sub _one_line_explain {
my ($data) = @_;
my @explain = explain $data;
s/\n//g for @explain;
return join "", @explain;
}

sub _main_level_line {
return "" if not $TODO;
my @outer_final;
my $level = 0;
while ( my @outer = caller( $level++ ) ) {
@outer_final = @outer;
}
return "l $outer_final[2] - ";
}

1;
40 changes: 1 addition & 39 deletions t/marpa.t
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ use Test::More tests => 69 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
use B qw( perlstring );

use PPI ();
use Helper 'safe_new';
use Helper qw( safe_new test_statement );

test_statement(
'use v5 ;',
Expand Down Expand Up @@ -305,41 +305,3 @@ test_statement(
]
);

sub one_line_explain {
my ( $data ) = @_;
my @explain = explain $data;
s/\n//g for @explain;
return join "", @explain;
}

sub main_level_line {
return "" if not $TODO;
my @outer_final;
my $level = 0;
while ( my @outer = caller( $level++ ) ) {
@outer_final = @outer;
}
return "l $outer_final[2] - ";
}

sub test_statement {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my ( $code, $expected, $msg ) = @_;
$msg = perlstring $code if !defined $msg;

my $d = safe_new \$code;
my $tokens = $d->find( sub { $_[1]->significant } );
$tokens = [ map { ref( $_ ), $_->content } @$tokens ];

if ( $expected->[0] !~ /^PPI::Statement/ ) {
$expected = [ 'PPI::Statement', $code, @$expected ];
}
my $ok = is_deeply( $tokens, $expected, main_level_line . $msg );
if ( !$ok ) {
diag ">>> $code -- $msg\n";
diag "GOT: " . one_line_explain $tokens;
diag "EXP: " . one_line_explain $expected;
}

return;
}
40 changes: 1 addition & 39 deletions t/ppi_token_quote_literal.t
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ use Test::More tests => 23 + ( $ENV{AUTHOR_TESTING} ? 1 : 0 );
use B qw( perlstring );

use PPI ();
use Helper 'safe_new';
use Helper qw( safe_new test_statement );

STRING: {
my $Document = safe_new \"print q{foo}, q!bar!, q <foo>, q((foo));";
Expand Down Expand Up @@ -61,41 +61,3 @@ test_statement(
"invalid syntax is identified correctly",
);

sub one_line_explain {
my ( $data ) = @_;
my @explain = explain $data;
s/\n//g for @explain;
return join "", @explain;
}

sub main_level_line {
return "" if not $TODO;
my @outer_final;
my $level = 0;
while ( my @outer = caller( $level++ ) ) {
@outer_final = @outer;
}
return "l $outer_final[2] - ";
}

sub test_statement {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my ( $code, $expected, $msg ) = @_;
$msg = perlstring $code if !defined $msg;

my $d = safe_new \$code;
my $tokens = $d->find( sub { $_[1]->significant } );
$tokens = [ map { ref( $_ ), $_->content } @$tokens ];

if ( $expected->[0] !~ /^PPI::Statement/ ) {
$expected = [ 'PPI::Statement', $code, @$expected ];
}
my $ok = is_deeply( $tokens, $expected, main_level_line . $msg );
if ( !$ok ) {
diag ">>> $code -- $msg\n";
diag one_line_explain $tokens;
diag one_line_explain $expected;
}

return;
}
Loading
Loading