1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
|
#!/usr/bin/perl
# Unit testing for PPI::Token::_QuoteEngine::Full
use lib 't/lib';
use PPI::Test::pragmas;
use Test::More tests => 123 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
use PPI ();
use Helper 'safe_new';
NEW: {
# Verify that Token::Quote, Token::QuoteLike and Token::Regexp
# do not have ->new functions
my $RE_SYMBOL = qr/\A(?!\d)\w+\z/;
foreach my $name ( qw{Token::Quote Token::QuoteLike Token::Regexp} ) {
no strict 'refs';
my @functions = sort
grep { defined &{"${name}::$_"} }
grep { /$RE_SYMBOL/o }
keys %{"PPI::${name}::"};
is( scalar(grep { $_ eq 'new' } @functions), 0,
"$name does not have a new function" );
}
}
# This primarily to ensure that qw() with non-balanced types
# are treated the same as those with balanced types.
QW: {
my @seps = ( undef, undef, '/', '#', ',' );
my @types = ( '()', '<>', '//', '##', ',,' );
my @braced = ( qw{ 1 1 0 0 0 } );
my $i = 0;
for my $q ('qw()', 'qw<>', 'qw//', 'qw##', 'qw,,') {
my $d = safe_new \$q;
my $o = $d->{children}->[0]->{children}->[0];
my $s = $o->{sections}->[0];
is( $o->{operator}, 'qw', "$q correct operator" );
is( $o->{_sections}, 1, "$q correct _sections" );
is( $o->{braced}, $braced[$i], "$q correct braced" );
is( $o->{separator}, $seps[$i], "$q correct separator" );
is( $o->{content}, $q, "$q correct content" );
is( $s->{position}, 3, "$q correct position" );
is( $s->{type}, $types[$i], "$q correct type" );
is( $s->{size}, 0, "$q correct size" );
$i++;
}
}
QW2: {
my @stuff = ( qw-( ) < > / / -, '#', '#', ',',',' );
my @seps = ( undef, undef, '/', '#', ',' );
my @braced = ( qw{ 1 1 0 0 0 } );
my @secs = ( qw{ 1 1 1 1 1 } );
my $i = 0;
while ( @stuff ) {
my $opener = shift @stuff;
my $closer = shift @stuff;
my $d = safe_new \"qw${opener}a";
my $o = $d->{children}->[0]->{children}->[0];
my $s = $o->{sections}->[0];
is( $o->{operator}, 'qw', "qw$opener correct operator" );
is( $o->{_sections}, $secs[$i], "qw$opener correct _sections" );
is( $o->{braced}, $braced[$i], "qw$opener correct braced" );
is( $o->{separator}, $seps[$i], "qw$opener correct separator" );
is( $o->{content}, "qw${opener}a", "qw$opener correct content" );
if ( $secs[$i] ) {
is( $s->{type}, "$opener$closer", "qw$opener correct type" );
}
$i++;
}
}
OTHER: {
foreach (
[ '/foo/i', 'foo', undef, { i => 1 }, [ '//' ] ],
[ 'm<foo>x', 'foo', undef, { x => 1 }, [ '<>' ] ],
[ 's{foo}[bar]g', 'foo', 'bar', { g => 1 }, [ '{}', '[]' ] ],
[ 'tr/fo/ba/', 'fo', 'ba', {}, [ '//', '//' ] ],
[ 'qr{foo}smx', 'foo', undef, { s => 1, m => 1, x => 1 },
[ '{}' ] ],
) {
my ( $code, $match, $subst, $mods, $delims ) = @{ $_ };
my $doc = safe_new \$code;
$doc or warn "'$code' did not create a document";
my $obj = $doc->child( 0 )->child( 0 );
is( $obj->_section_content( 0 ), $match, "$code correct match" );
is( $obj->_section_content( 1 ), $subst, "$code correct subst" );
is_deeply( { $obj->_modifiers() }, $mods, "$code correct modifiers" );
is_deeply( [ $obj->_delimiters() ], $delims, "$code correct delimiters" );
}
}
|
