#!/usr/bin/perl
# Unit testing for PPI::Token::Word
use lib 't/lib';
use PPI::Test::pragmas;
use Test::More tests => 1762 + ($ENV{AUTHOR_TESTING} ? 1 : 0);
use PPI;
use lib 't/lib';
use Helper 'check_with';
LITERAL: {
my @pairs = (
"F", 'F',
"Foo::Bar", 'Foo::Bar',
"Foo'Bar", 'Foo::Bar',
);
while ( @pairs ) {
my $from = shift @pairs;
my $to = shift @pairs;
my $doc = PPI::Document->new( \"$from;" );
isa_ok( $doc, 'PPI::Document' );
my $word = $doc->find_first('Token::Word');
isa_ok( $word, 'PPI::Token::Word' );
is( $word->literal, $to, "The source $from becomes $to ok" );
}
}
METHOD_CALL: {
my $Document = PPI::Document->new(\<<'END_PERL');
indirect $foo;
indirect_class_with_colon Foo::;
$bar->method_with_parentheses;
print SomeClass->method_without_parentheses + 1;
sub_call();
$baz->chained_from->chained_to;
a_first_thing a_middle_thing a_last_thing;
(first_list_element, second_list_element, third_list_element);
first_comma_separated_word, second_comma_separated_word, third_comma_separated_word;
single_bareword_statement;
{ bareword_no_semicolon_end_of_block }
$buz{hash_key};
fat_comma_left_side => $thingy;
END_PERL
isa_ok( $Document, 'PPI::Document' );
my $words = $Document->find('Token::Word');
is( scalar @{$words}, 23, 'Found the 23 test words' );
my %words = map { $_ => $_ } @{$words};
is(
scalar $words{indirect}->method_call,
undef,
'Indirect notation is unknown.',
);
is(
scalar $words{indirect_class_with_colon}->method_call,
1,
'Indirect notation with following word ending with colons is true.',
);
is(
scalar $words{method_with_parentheses}->method_call,
1,
'Method with parentheses is true.',
);
is(
scalar $words{method_without_parentheses}->method_call,
1,
'Method without parentheses is true.',
);
is(
scalar $words{print}->method_call,
undef,
'Plain print is unknown.',
);
is(
scalar $words{SomeClass}->method_call,
undef,
'Class in class method call is unknown.',
);
is(
scalar $words{sub_call}->method_call,
0,
'Subroutine call is false.',
);
is(
scalar $words{chained_from}->method_call,
1,
'Method that is chained from is true.',
);
is(
scalar $words{chained_to}->method_call,
1,
'Method that is chained to is true.',
);
is(
scalar $words{a_first_thing}->method_call,
undef,
'First bareword is unknown.',
);
is(
scalar $words{a_middle_thing}->method_call,
undef,
'Bareword in the middle is unknown.',
);
is(
scalar $words{a_last_thing}->method_call,
0,
'Bareword at the end is false.',
);
foreach my $false_word (
qw<
first_list_element second_list_element third_list_element
first_comma_separated_word second_comma_separated_word third_comma_separated_word
single_bareword_statement
bareword_no_semicolon_end_of_block
hash_key
fat_comma_left_side
>
) {
is(
scalar $words{$false_word}->method_call,
0,
"$false_word is false.",
);
}
}
__TOKENIZER__ON_CHAR: {
# PPI::Statement::Operator
for my $test (
[ q{$foo and'bar';}, 'and' ],
[ q{$foo cmp'bar';}, 'cmp' ],
[ q{$foo eq'bar';}, 'eq' ],
[ q{$foo ge'bar';}, 'ge' ],
[ q{$foo gt'bar';}, 'gt' ],
[ q{$foo le'bar';}, 'le' ],
[ q{$foo lt'bar';}, 'lt' ],
[ q{$foo ne'bar';}, 'ne' ],
[ q{$foo not'bar';}, 'not' ],
[ q{$foo or'bar';}, 'or' ],
[ q{$foo x'bar';}, 'x' ],
[ q{$foo xor'bar';}, 'xor' ],
) {
my ( $code, $expected ) = @$test;
my ( $Document, $statement ) = _parse_to_statement( $code, 'PPI::Statement' );
is( $statement, $code, "$code: statement text matches" );
_compare_child( $statement, 2, 'PPI::Token::Operator', $expected, $code );
_compare_child( $statement, 3, 'PPI::Token::Quote::Single', "'bar'", $code );
_compare_child( $statement, 4, 'PPI::Token::Structure', ';', $code );
}
# PPI::Token::Quote::*
for my $test (
[ q{q'foo';}, q{q'foo'}, 'PPI::Token::Quote::Literal' ],
[ q{qq'foo';}, q{qq'foo'}, 'PPI::Token::Quote::Interpolate' ],
[ q{qr'foo';}, q{qr'foo'}, 'PPI::Token::QuoteLike::Regexp' ],
[ q{qw'foo';}, q{qw'foo'}, 'PPI::Token::QuoteLike::Words' ],
[ q{qx'foo';}, q{qx'foo'}, 'PPI::Token::QuoteLike::Command' ],
) {
my ( $code, $expected, $type ) = @$test;
my ( $Document, $statement ) = _parse_to_statement( $code, 'PPI::Statement' );
is( $statement, $code, "$code: statement text matches" );
_compare_child( $statement, 0, $type, $expected, $code );
_compare_child( $statement, 1, 'PPI::Token::Structure', ';', $code );
}
# PPI::Token::Regexp::*
for my $test (
[ q{m'foo';}, q{m'foo'}, 'PPI::Token::Regexp::Match' ],
[ q{s'foo'bar';}, q{s'foo'bar'}, 'PPI::Token::Regexp::Substitute' ],
[ q{tr'fo'ba';}, q{tr'fo'ba'}, 'PPI::Token::Regexp::Transliterate' ],
[ q{y'fo'ba';}, q{y'fo'ba'}, 'PPI::Token::Regexp::Transliterate' ],
) {
my ( $code, $expected, $type ) = @$test;
my ( $Document, $statement ) = _parse_to_statement( $code, 'PPI::Statement' );
is( $statement, $code, "$code: statement text matches" );
_compare_child( $statement, 0, $type, $expected, $code );
_compare_child( $statement, 1, 'PPI::Token::Structure', ';', $code );
}
# PPI::Token::Word
for my $test (
[ q{abs'3';}, 'abs' ],
[ q{accept'1234',2345;}, 'accept' ],
[ q{alarm'5';}, 'alarm' ],
[ q{atan2'5';}, 'atan2' ],
[ q{bind'5',"";}, 'bind' ],
[ q{binmode'5';}, 'binmode' ],
[ q{bless'foo', 'bar';}, 'bless' ],
[ q{break'foo' when 1;}, 'break' ],
[ q{caller'3';}, 'caller' ],
[ q{chdir'foo';}, 'chdir' ],
[ q{chmod'0777', 'foo';}, 'chmod' ],
[ q{chomp'a';}, 'chomp' ],
[ q{chop'a';}, 'chop' ],
[ q{chown'a';}, 'chown' ],
[ q{chr'32';}, 'chr' ],
[ q{chroot'a';}, 'chroot' ],
[ q{close'1';}, 'close' ],
[ q{closedir'1';}, 'closedir' ],
[ q{connect'1234',$foo;}, 'connect' ],
[ q{continue'a';}, 'continue' ],
[ q{cos'3';}, 'cos' ],
[ q{crypt'foo', 'bar';}, 'crypt' ],
[ q{dbmclose'foo';}, 'dbmclose' ],
[ q{dbmopen'foo','bar';}, 'dbmopen' ],
[ q{default'a' {}}, 'default' ],
[ q{defined'foo';}, 'defined' ],
[ q{delete'foo';}, 'delete' ],
[ q{die'foo';}, 'die' ],
[ q{do'foo';}, 'do' ],
[ q{dump'foo';}, 'dump' ],
[ q{each'foo';}, 'each' ],
[ q{else'foo' {};}, 'else' ],
[ q{elsif'foo' {};}, 'elsif' ],
[ q{endgrent'foo';}, 'endgrent' ],
[ q{endhostent'foo';}, 'endhostent' ],
[ q{endnetent'foo';}, 'endnetent' ],
[ q{endprotoent'foo';}, 'endprotoent' ],
[ q{endpwent'foo';}, 'endpwent' ],
[ q{endservent'foo';}, 'endservent' ],
[ q{eof'foo';}, 'eof' ],
[ q{eval'foo';}, 'eval' ],
[ q{evalbytes'foo';}, 'evalbytes' ],
[ q{exec'foo';}, 'exec' ],
[ q{exists'foo';}, 'exists' ],
[ q{exit'foo';}, 'exit' ],
[ q{exp'foo';}, 'exp' ],
[ q{fc'foo';}, 'fc' ],
[ q{fcntl'1';}, 'fcntl' ],
[ q{fileno'1';}, 'fileno' ],
[ q{flock'1', LOCK_EX;}, 'flock' ],
[ q{fork'';}, 'fork' ],
[ qq{format''=\n.}, 'format' ],
[ q{formline'@',1;}, 'formline' ],
[ q{getc'1';}, 'getc' ],
[ q{getgrent'foo';}, 'getgrent' ],
[ q{getgrgid'1';}, 'getgrgid' ],
[ q{getgrnam'foo';}, 'getgrnam' ],
[ q{gethostbyaddr'1', AF_INET;}, 'gethostbyaddr' ],
[ q{gethostbyname'foo';}, 'gethostbyname' ],
[ q{gethostent'foo';}, 'gethostent' ],
[ q{getlogin'foo';}, 'getlogin' ],
[ q{getnetbyaddr'1', AF_INET;}, 'getnetbyaddr' ],
[ q{getnetbyname'foo';}, 'getnetbyname' ],
[ q{getnetent'foo';}, 'getnetent' ],
[ q{getpeername'foo';}, 'getpeername' ],
[ q{getpgrp'1';}, 'getpgrp' ],
[ q{getppid'1';}, 'getppid' ],
[ q{getpriority'1',2;}, 'getpriority' ],
[ q{getprotobyname'tcp';}, 'getprotobyname' ],
[ q{getprotobynumber'6';}, 'getprotobynumber' ],
[ q{getprotoent'foo';}, 'getprotoent' ],
[ q{getpwent'foo';}, 'getpwent' ],
[ q{getpwnam'foo';}, 'getpwnam' ],
[ q{getpwuid'1';}, 'getpwuid' ],
[ q{getservbyname'foo', 'bar';}, 'getservbyname' ],
[ q{getservbyport'23', 'tcp';}, 'getservbyport' ],
[ q{getservent'foo';}, 'getservent' ],
[ q{getsockname'foo';}, 'getsockname' ],
[ q{getsockopt'foo', 'bar', TCP_NODELAY;}, 'getsockopt' ],
[ q{glob'foo';}, 'glob' ],
[ q{gmtime'1';}, 'gmtime' ],
[ q{goto'label';}, 'goto' ],
[ q{hex'1';}, 'hex' ],
[ q{index'1','foo';}, 'index' ],
[ q{int'1';}, 'int' ],
[ q{ioctl'1',1;}, 'ioctl' ],
[ q{join'a',@foo;}, 'join' ],
[ q{keys'foo';}, 'keys' ],
[ q{kill'KILL';}, 'kill' ],
[ q{last'label';}, 'last' ],
[ q{lc'foo';}, 'lc' ],
[ q{lcfirst'foo';}, 'lcfirst' ],
[ q{length'foo';}, 'length' ],
[ q{link'foo','bar';}, 'link' ],
[ q{listen'1234',10;}, 'listen' ],
[ q{local'foo';}, 'local' ],
[ q{localtime'1';}, 'localtime' ],
[ q{lock'foo';}, 'lock' ],
[ q{log'foo';}, 'log' ],
[ q{lstat'foo';}, 'lstat' ],
[ q{mkdir'foo';}, 'mkdir' ],
[ q{msgctl'1','foo',1;}, 'msgctl' ],
[ q{msgget'1',1}, 'msgget' ],
[ q{msgrcv'1',$foo,1,1,1;}, 'msgrcv' ],
[ q{msgsnd'1',$foo,1;}, 'msgsnd' ],
[ q{my'foo';}, 'my' ],
[ q{next'label';}, 'next' ],
[ q{oct'foo';}, 'oct' ],
[ q{open'foo';}, 'open' ],
[ q{opendir'foo';}, 'opendir' ],
[ q{ord'foo';}, 'ord' ],
[ q{our'foo';}, 'our' ],
[ q{pack'H*',$data;}, 'pack' ],
[ q{pipe'in','out';}, 'pipe' ],
[ q{pop'foo';}, 'pop' ],
[ q{pos'foo';}, 'pos' ],
[ q{print'foo';}, 'print' ],
[ q{printf'foo','bar';}, 'printf' ],
[ q{prototype'foo';}, 'prototype' ],
[ q{push'foo','bar';}, 'push' ],
[ q{quotemeta'foo';}, 'quotemeta' ],
[ q{rand'1';}, 'rand' ],
[ q{read'1',$foo,100;}, 'read' ],
[ q{readdir'1';}, 'readdir' ],
[ q{readline'1';}, 'readline' ],
[ q{readlink'1';}, 'readlink' ],
[ q{readpipe'1';}, 'readpipe' ],
[ q{recv'1',$foo,100,1;}, 'recv' ],
[ q{redo'label';}, 'redo' ],
[ q{ref'foo';}, 'ref' ],
[ q{rename'foo','bar';}, 'rename' ],
[ q{require'foo';}, 'require' ],
[ q{reset'f';}, 'reset' ],
[ q{return'foo';}, 'return' ],
[ q{reverse'foo','bar';}, 'reverse' ],
[ q{rewinddir'1';}, 'rewinddir' ],
[ q{rindex'1','foo';}, 'rindex' ],
[ q{rmdir'foo';}, 'rmdir' ],
[ q{say'foo';}, 'say' ],
[ q{scalar'foo','bar';}, 'scalar' ],
[ q{seek'1',100,0;}, 'seek' ],
[ q{seekdir'1',100;}, 'seekdir' ],
[ q{select'1';}, 'select' ],
[ q{semctl'1',1,1;}, 'semctl' ],
[ q{semget'foo',1,1;}, 'semget' ],
[ q{semop'foo','bar';}, 'semop' ],
[ q{send'1',$foo'100,1;}, 'send' ],
[ q{setgrent'foo';}, 'setgrent' ],
[ q{sethostent'1';}, 'sethostent' ],
[ q{setnetent'1';}, 'setnetent' ],
[ q{setpgrp'1',2;}, 'setpgrp' ],
[ q{setpriority'1',2, 3;}, 'setpriority' ],
[ q{setprotoent'1';}, 'setprotoent' ],
[ q{setpwent'foo';}, 'setpwent' ],
[ q{setservent'1';}, 'setservent' ],
[ q{setsockopt'1',2,'foo',3;}, 'setsockopt' ],
[ q{shift'1','2';}, 'shift' ],
[ q{shmctl'1',2,$foo;}, 'shmctl' ],
[ q{shmget'1',2,1;}, 'shmget' ],
[ q{shmread'1',$foo,0,10;}, 'shmread' ],
[ q{shmwrite'1',$foo,0,10;}, 'shmwrite' ],
[ q{shutdown'1',0;}, 'shutdown' ],
[ q{sin'1';}, 'sin' ],
[ q{sleep'1';}, 'sleep' ],
[ q{socket'1',2,3,6;}, 'socket' ],
[ q{socketpair'1',2,3,4,6;}, 'socketpair' ],
[ q{splice'1',2;}, 'splice' ],
[ q{split'1','foo';}, 'split' ],
[ q{sprintf'foo','bar';}, 'sprintf' ],
[ q{sqrt'1';}, 'sqrt' ],
[ q{srand'1';}, 'srand' ],
[ q{stat'foo';}, 'stat' ],
[ q{state'foo';}, 'state' ],
[ q{study'foo';}, 'study' ],
[ q{substr'foo',1;}, 'substr' ],
[ q{symlink'foo','bar';}, 'symlink' ],
[ q{syscall'foo';}, 'syscall' ],
[ q{sysopen'foo','bar',1;}, 'sysopen' ],
[ q{sysread'1',$bar,1;}, 'sysread' ],
[ q{sysseek'1',0,0;}, 'sysseek' ],
[ q{system'foo';}, 'system' ],
[ q{syswrite'1',$bar,1;}, 'syswrite' ],
[ q{tell'1';}, 'tell' ],
[ q{telldir'1';}, 'telldir' ],
[ q{tie'foo',$bar;}, 'tie' ],
[ q{tied'foo';}, 'tied' ],
[ q{time'foo';}, 'time' ],
[ q{times'foo';}, 'times' ],
[ q{truncate'foo',1;}, 'truncate' ],
[ q{uc'foo';}, 'uc' ],
[ q{ucfirst'foo';}, 'ucfirst' ],
[ q{umask'foo';}, 'umask' ],
[ q{undef'foo';}, 'undef' ],
[ q{unlink'foo';}, 'unlink' ],
[ q{unpack'H*',$data;}, 'unpack' ],
[ q{unshift'1';}, 'unshift' ],
[ q{untie'foo';}, 'untie' ],
[ q{utime'1','2';}, 'utime' ],
[ q{values'foo';}, 'values' ],
[ q{vec'1',0.0;}, 'vec' ],
[ q{wait'1';}, 'wait' ],
[ q{waitpid'1',0;}, 'waitpid' ],
[ q{wantarray'foo';}, 'wantarray' ],
[ q{warn'foo';}, 'warn' ],
[ q{when'foo' {}}, 'when' ],
[ q{write'foo';}, 'write' ],
) {
my ( $code, $expected ) = @$test;
my ( $Document, $statement ) = _parse_to_statement( $code, 'PPI::Statement' );
is( $statement, $code, "$code: statement text matches" );
_compare_child( $statement, 0, 'PPI::Token::Word', $expected, $code );
isa_ok( $statement->child(1), 'PPI::Token::Quote::Single', "$code: second child is a 'PPI::Token::Quote::Single'" );
}
for my $test (
[ q{1 for'foo';}, 'for' ],
[ q{1 foreach'foo';}, 'foreach' ],
[ q{1 if'foo';}, 'if' ],
[ q{1 unless'foo';}, 'unless' ],
[ q{1 until'foo';}, 'until' ],
[ q{1 while'foo';}, 'while' ],
) {
my ( $code, $expected ) = @$test;
my ( $Document, $statement ) = _parse_to_statement( $code, 'PPI::Statement' );
is( $statement, $code, "$code: statement text matches" );
_compare_child( $statement, 2, 'PPI::Token::Word', $expected, $code );
_compare_child( $statement, 3, 'PPI::Token::Quote::Single', "'foo'", $code );
}
# Untested: given, grep map, sort, sub
# PPI::Statement::Include
for my $test (
[ "no'foo';", 'no' ],
[ "require'foo';", 'require' ],
[ "use'foo';", 'use' ],
) {
my ( $code, $expected ) = @$test;
my ( $Document, $statement ) = _parse_to_statement( $code, 'PPI::Statement::Include' );
is( $statement, $code, "$code: statement text matches" );
_compare_child( $statement, 0, 'PPI::Token::Word', $expected, $code );
_compare_child( $statement, 1, 'PPI::Token::Quote::Single', "'foo'", $code );
_compare_child( $statement, 2, 'PPI::Token::Structure', ';', $code );
}
# PPI::Statement::Package
my ( $PackageDocument, $statement ) = _parse_to_statement( "package'foo';", 'PPI::Statement::Package' );
is( $statement, q{package'foo';}, q{package'foo'} );
_compare_child( $statement, 0, 'PPI::Token::Word', 'package', 'package statement' );
_compare_child( $statement, 1, 'PPI::Token::Quote::Single', "'foo'", 'package statement' );
_compare_child( $statement, 2, 'PPI::Token::Structure', ';', 'package statement' );
}
sub _parse_to_statement {
local $Test::Builder::Level = $Test::Builder::Level+1;
my $code = shift;
my $type = shift;
my $Document = PPI::Document->new( \$code );
isa_ok( $Document, 'PPI::Document', "$code: got the document" );
my $statements = $Document->find( $type );
is( scalar(@$statements), 1, "$code: got one $type" );
isa_ok( $statements->[0], $type, "$code: got the statement" );
return ( $Document, $statements->[0] );
}
sub _compare_child {
local $Test::Builder::Level = $Test::Builder::Level+1;
my $statement = shift;
my $childno = shift;
my $type = shift;
my $content = shift;
my $desc = shift;
isa_ok( $statement->child($childno), $type, "$desc child $childno is a $type");
is( $statement->child($childno), $content, "$desc child $childno is 1" );
return;
}
check_with "1.eqm'bar';", sub {
is $_->child( 0 )->child( 1 )->content, "eqm'bar",
"eqm' bareword after number and concat op is not mistaken for eq";
};
check_with "__DATA__", sub {
is $_->child( 1 ), undef, 'DATA segment without following newline does not get one added';
};
check_with "__DATA__ a", sub {
is $_->child( 1 )->content, ' a',
'DATA segment without following newline, but text, has text added as comment in following token';
};
check_with "__END__", sub {
is $_->child( 1 ), undef, 'END segment without following newline does not get one added';
};
check_with "__END__ a", sub {
is $_->child( 0 )->child( 1 )->content, ' a',
'END segment without following newline, but text, has text added as comment in children list';
};
check_with "__END__ a\n", sub {
is $_->child( 0 )->child( 1 )->content, ' a',
'END segment, followed by text and newline, has text added as comment in children list';
};
check_with "__DATA__ a\n", sub {
is $_->child( 1 )->content, ' a',
'DATA segment, followed by text and newline, has text added as comment in following token';
};
1;