PPI-1.220/0000755000175100010010000000000012430470371007055 5ustar PPI-1.220/t/0000755000175100010010000000000012430470371007320 5ustar PPI-1.220/t/23_file.t0000755000175100010010000000126612251445131010735 0ustar #!/usr/bin/perl # Testing of PPI::Document::File use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 5; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI::Document::File; ##################################################################### # Creating Documents SCOPE: { # From a specific file my $file = catfile('t', 'data', 'basic.pl'); ok( -f $file, 'Found test file' ); # Load from the file my $doc = PPI::Document::File->new( $file ); isa_ok( $doc, 'PPI::Document::File' ); isa_ok( $doc, 'PPI::Document' ); is( $doc->filename, $file, '->filename ok' ); } PPI-1.220/t/13_data.t0000755000175100010010000000173712251445131010731 0ustar #!/usr/bin/perl # Tests functionality relating to __DATA__ sections of files use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 8; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; my $module = catfile('t', 'data', '13_data', 'Foo.pm'); ok( -f $module, 'Test file exists' ); my $Document = PPI::Document->new( $module ); isa_ok( $Document, 'PPI::Document' ); # Get the data token my $Token = $Document->find_first( 'Token::Data' ); isa_ok( $Token, 'PPI::Token::Data' ); # Get the handle my $handle = $Token->handle; isa_ok( $handle, 'IO::String' ); # Try to read a line off the handle my $line = <$handle>; is( $line, "This is data\n", "Reading off a handle works as expected" ); # Print to the handle ok( $handle->print("Foo bar\n"), "handle->print returns ok" ); is( $Token->content, "This is data\nFoo bar\nis\n", "handle->print modifies the content as expected" ); PPI-1.220/t/ppi_element.t0000755000175100010010000001403112310327137012006 0ustar #!/usr/bin/perl # Unit testing for PPI::Element use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 58; use Test::NoWarnings; use PPI; __INSERT_AFTER: { my $Document = PPI::Document->new( \"print 'Hello World';" ); isa_ok( $Document, 'PPI::Document' ); my $string = $Document->find_first('Token::Quote'); isa_ok( $string, 'PPI::Token::Quote' ); is( $string->content, "'Hello World'", 'Got expected token' ); my $foo = PPI::Token::Word->new('foo'); isa_ok( $foo, 'PPI::Token::Word' ); is( $foo->content, 'foo', 'Created Word token' ); $string->__insert_after( $foo ); is( $Document->serialize, "print 'Hello World'foo;", '__insert_after actually inserts' ); } __INSERT_BEFORE: { my $Document = PPI::Document->new( \"print 'Hello World';" ); isa_ok( $Document, 'PPI::Document' ); my $semi = $Document->find_first('Token::Structure'); isa_ok( $semi, 'PPI::Token::Structure' ); is( $semi->content, ';', 'Got expected token' ); my $foo = PPI::Token::Word->new('foo'); isa_ok( $foo, 'PPI::Token::Word' ); is( $foo->content, 'foo', 'Created Word token' ); $semi->__insert_before( $foo ); is( $Document->serialize, "print 'Hello World'foo;", '__insert_before actually inserts' ); } ANCESTOR_OF: { my $Document = PPI::Document->new( \'( [ thingy ] ); $blarg = 1' ); isa_ok( $Document, 'PPI::Document' ); ok( $Document->ancestor_of($Document), 'Document is an ancestor of itself.', ); my $words = $Document->find('Token::Word'); is(scalar @{$words}, 1, 'Document contains 1 Word.'); my $word = $words->[0]; ok( $word->ancestor_of($word), 'Word is an ancestor of itself.', ); ok( ! $word->ancestor_of($Document), 'Word is not an ancestor of the Document.', ); ok( $Document->ancestor_of($word), 'Document is an ancestor of the Word.', ); my $symbols = $Document->find('Token::Symbol'); is(scalar @{$symbols}, 1, 'Document contains 1 Symbol.'); my $symbol = $symbols->[0]; ok( ! $word->ancestor_of($symbol), 'Word is not an ancestor the Symbol.', ); ok( ! $symbol->ancestor_of($word), 'Symbol is not an ancestor the Word.', ); } COLUMN_NUMBER: { my $document = PPI::Document->new(\<<'END_PERL'); foo END_PERL isa_ok( $document, 'PPI::Document' ); my $words = $document->find('PPI::Token::Word'); is( scalar @{$words}, 1, 'Found expected word token.' ); is( $words->[0]->column_number, 4, 'Got correct column number.' ); } DESCENDANT_OF: { my $Document = PPI::Document->new( \'( [ thingy ] ); $blarg = 1' ); isa_ok( $Document, 'PPI::Document' ); ok( $Document->descendant_of($Document), 'Document is a descendant of itself.', ); my $words = $Document->find('Token::Word'); is(scalar @{$words}, 1, 'Document contains 1 Word.'); my $word = $words->[0]; ok( $word->descendant_of($word), 'Word is a descendant of itself.', ); ok( $word->descendant_of($Document), 'Word is a descendant of the Document.', ); ok( ! $Document->descendant_of($word), 'Document is not a descendant of the Word.', ); my $symbols = $Document->find('Token::Symbol'); is(scalar @{$symbols}, 1, 'Document contains 1 Symbol.'); my $symbol = $symbols->[0]; ok( ! $word->descendant_of($symbol), 'Word is not a descendant the Symbol.', ); ok( ! $symbol->descendant_of($word), 'Symbol is not a descendant the Word.', ); } INSERT_AFTER: { my $Document = PPI::Document->new( \"print 'Hello World';" ); isa_ok( $Document, 'PPI::Document' ); my $string = $Document->find_first('Token::Quote'); isa_ok( $string, 'PPI::Token::Quote' ); is( $string->content, "'Hello World'", 'Got expected token' ); my $foo = PPI::Token::Word->new('foo'); isa_ok( $foo, 'PPI::Token::Word' ); is( $foo->content, 'foo', 'Created Word token' ); $string->insert_after( $foo ); is( $Document->serialize, "print 'Hello World'foo;", 'insert_after actually inserts' ); } INSERT_BEFORE: { my $Document = PPI::Document->new( \"print 'Hello World';" ); isa_ok( $Document, 'PPI::Document' ); my $semi = $Document->find_first('Token::Structure'); isa_ok( $semi, 'PPI::Token::Structure' ); is( $semi->content, ';', 'Got expected token' ); my $foo = PPI::Token::Word->new('foo'); isa_ok( $foo, 'PPI::Token::Word' ); is( $foo->content, 'foo', 'Created Word token' ); $semi->insert_before( $foo ); is( $Document->serialize, "print 'Hello World'foo;", 'insert_before actually inserts' ); } LINE_NUMBER: { my $document = PPI::Document->new(\<<'END_PERL'); foo END_PERL isa_ok( $document, 'PPI::Document' ); my $words = $document->find('PPI::Token::Word'); is( scalar @{$words}, 1, 'Found expected word token.' ); is( $words->[0]->line_number, 3, 'Got correct line number.' ); } LOGICAL_FILENAME: { # Double quoted so that we don't really have a "#line" at the beginning and # errors in this file itself aren't affected by this. my $document = PPI::Document->new(\<<"END_PERL"); \#line 1 test-file foo END_PERL isa_ok( $document, 'PPI::Document' ); my $words = $document->find('PPI::Token::Word'); is( scalar @{$words}, 1, 'Found expected word token.' ); is( $words->[0]->logical_filename, 'test-file', 'Got correct logical line number.', ); } LOGICAL_LINE_NUMBER: { # Double quoted so that we don't really have a "#line" at the beginning and # errors in this file itself aren't affected by this. my $document = PPI::Document->new(\<<"END_PERL"); \#line 1 test-file foo END_PERL isa_ok( $document, 'PPI::Document' ); my $words = $document->find('PPI::Token::Word'); is( scalar @{$words}, 1, 'Found expected word token.' ); is( $words->[0]->logical_line_number, 1, 'Got correct logical line number.' ); } VISUAL_COLUMN_NUMBER: { my $document = PPI::Document->new(\<<"END_PERL"); \t foo END_PERL isa_ok( $document, 'PPI::Document' ); my $tab_width = 5; $document->tab_width($tab_width); # don't use a "usual" value. my $words = $document->find('PPI::Token::Word'); is( scalar @{$words}, 1, 'Found expected word token.' ); is( $words->[0]->visual_column_number, $tab_width + 2, 'Got correct visual column number.', ); } PPI-1.220/t/ppi_node.t0000755000175100010010000000135212310327137011304 0ustar #!/usr/bin/perl # Unit testing for PPI::Node use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 3; use Test::NoWarnings; use PPI; PRUNE: { # Avoids a bug in old Perls relating to the detection of scripts # Known to occur in ActivePerl 5.6.1 and at least one 5.6.2 install. my $hashbang = reverse 'lrep/nib/rsu/!#'; my $document = PPI::Document->new( \<<"END_PERL" ); $hashbang use strict; sub one { 1 } sub two { 2 } sub three { 3 } print one; print "\n"; print three; print "\n"; exit; END_PERL isa_ok( $document, 'PPI::Document' ); ok( defined($document->prune ('PPI::Statement::Sub')), 'Pruned multiple subs ok' ); } PPI-1.220/t/ppi_token_word.t0000755000175100010010000003777712426751160012563 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Word use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 1756; use Test::NoWarnings; use PPI; 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; } PPI-1.220/t/ppi_statement_compound.t0000755000175100010010000000574412310327137014300 0ustar #!/usr/bin/perl # Unit testing for PPI::Statement::Compound use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 53; use Test::NoWarnings; use PPI; TYPE: { my $Document = PPI::Document->new(\<<'END_PERL'); while (1) { } until (1) { } LABEL: while (1) { } LABEL: until (1) { } if (1) { } unless (1) { } for (@foo) { } foreach (@foo) { } for $x (@foo) { } foreach $x (@foo) { } for my $x (@foo) { } foreach my $x (@foo) { } for state $x (@foo) { } foreach state $x (@foo) { } LABEL: for (@foo) { } LABEL: foreach (@foo) { } LABEL: for $x (@foo) { } LABEL: foreach $x (@foo) { } LABEL: for my $x (@foo) { } LABEL: foreach my $x (@foo) { } LABEL: for state $x (@foo) { } LABEL: foreach state $x (@foo) { } for qw{foo} { } foreach qw{foo} { } for $x qw{foo} { } foreach $x qw{foo} { } for my $x qw{foo} { } foreach my $x qw{foo} { } for state $x qw{foo} { } foreach state $x qw{foo} { } LABEL: for qw{foo} { } LABEL: foreach qw{foo} { } LABEL: for $x qw{foo} { } LABEL: foreach $x qw{foo} { } LABEL: for my $x qw{foo} { } LABEL: foreach my $x qw{foo} { } LABEL: for state $x qw{foo} { } LABEL: foreach state $x qw{foo} { } for ( ; ; ) { } foreach ( ; ; ) { } for ($x = 0 ; $x < 1; $x++) { } foreach ($x = 0 ; $x < 1; $x++) { } for (my $x = 0 ; $x < 1; $x++) { } foreach (my $x = 0 ; $x < 1; $x++) { } LABEL: for ( ; ; ) { } LABEL: foreach ( ; ; ) { } LABEL: for ($x = 0 ; $x < 1; $x++) { } LABEL: foreach ($x = 0 ; $x < 1; $x++) { } LABEL: for (my $x = 0 ; $x < 1; $x++) { } LABEL: foreach (my $x = 0 ; $x < 1; $x++) { } END_PERL isa_ok( $Document, 'PPI::Document' ); my $statements = $Document->find('Statement::Compound'); is( scalar @{$statements}, 50, 'Found the 50 test statements' ); is( $statements->[0]->type, 'while', q ); is( $statements->[1]->type, 'while', q ); is( $statements->[2]->type, 'while', q ); is( $statements->[3]->type, 'while', q ); is( $statements->[4]->type, 'if', q ); is( $statements->[5]->type, 'if', q ); foreach my $index (6..37) { my $statement = $statements->[$index]; is( $statement->type, 'foreach', qq ); } foreach my $index (38..49) { my $statement = $statements->[$index]; is( $statement->type, 'for', qq ); } } PPI-1.220/t/20_tokenizer_regression.t0000755000175100010010000000720512426751160014272 0ustar #!/usr/bin/perl # code/dump-style regression tests for known lexing problems. # Some other regressions tests are included here for simplicity. use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use File::Spec::Functions ':ALL'; use PPI::Lexer; use PPI::Dumper; use Carp 'croak'; use Params::Util qw{_INSTANCE}; sub pause { local $@; sleep 1 if !eval { require Time::HiRes; Time::HiRes::sleep(0.1); 1 }; } ##################################################################### # Prepare use vars qw{@FAILURES}; BEGIN { @FAILURES = ( # Failed cases 3 chars or less '!%:', '!%:', '!%:', '!%:', '!*:', '!@:', '%:', '%:,', '%:;', '*:', '*:,', '*::', '*:;', '+%:', '+*:', '+@:', '-%:', '-*:', '-@:', ';%:', ';*:', ';@:', '@:', '@:,', '@::', '@:;', '\%:', '\&:', '\*:', '\@:', '~%:', '~*:', '~@:', '(<', '(<', '=<', 'm(', 'm(', 'm<', 'm[', 'm{', 'q(', 'q<', 'q[', 'q{', 's(', 's<', 's[', 's{', 'y(', 'y<', 'y[', 'y{', '$\'0', '009', '0bB', '0xX', '009;', '0bB;', '0xX;', "<<'", '<<"', '<<`', '&::', '<s', 's<>-', '*::0', '*::1', '*:::', '*::\'', '$::0', '$:::', '$::\'', '@::0', '@::1', '@:::', '&::0', '&::\'', '%:::', '%::\'', # More-specific single cases thrown up during the heavy testing '$:::z', '*:::z', "\\\@::'9:!", "} mz}~<\nV" ); } use Test::More tests => 1 + scalar(@FAILURES) * 3; use Test::NoWarnings; ##################################################################### # Code/Dump Testing foreach my $code ( @FAILURES ) { test_code( $code ); # Verify there are no stale %PARENT entries my $quotable = quotable($code); is( scalar(keys %PPI::Element::PARENT), 0, "\"$quotable\": No stale %PARENT entries" ); %PPI::Element::PARENT = %PPI::Element::PARENT; } exit(0); ##################################################################### # Support Functions sub test_code { my $code = shift; my $quotable = quotable($code); my $Document = eval { # $SIG{__WARN__} = sub { croak('Triggered a warning') }; PPI::Document->new(\$code); }; ok( _INSTANCE($Document, 'PPI::Document'), "\"$quotable\": Document parses ok" ); unless ( _INSTANCE($Document, 'PPI::Document') ) { diag( "\"$quotable\": Parsing failed" ); my $short = quotable(quickcheck($code)); diag( "Shortest failing substring: \"$short\"" ); return; } # Version of the code for use in error messages my $joined = $Document->serialize; my $joined_quotable = quotable($joined); is( $joined, $code, "\"$quotable\": Document round-trips ok: \"$joined_quotable\"" ); } # Find the shortest failing substring of known bad string sub quickcheck { my $code = shift; my $fails = $code; # $SIG{__WARN__} = sub { croak('Triggered a warning') }; while ( length $fails ) { chop $code; PPI::Document->new(\$code) or last; $fails = $code; } while ( length $fails ) { substr( $code, 0, 1, '' ); PPI::Document->new(\$code) or return $fails; $fails = $code; } return $fails; } sub quotable { my $quotable = shift; $quotable =~ s/\\/\\\\/g; $quotable =~ s/\t/\\t/g; $quotable =~ s/\n/\\n/g; $quotable =~ s/\$/\\\$/g; $quotable =~ s/\@/\\\@/g; return $quotable; } PPI-1.220/t/22_readonly.t0000755000175100010010000000214212251445131011624 0ustar #!/usr/bin/perl # Testing of readonly functionality use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 9; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI::Document; ##################################################################### # Creating Documents SCOPE: { # Blank document my $empty = PPI::Document->new; isa_ok( $empty, 'PPI::Document' ); is( $empty->readonly, '', '->readonly is false for blank' ); # From source my $source = 'print "Hello World!\n"'; my $doc1 = PPI::Document->new( \$source ); isa_ok( $doc1, 'PPI::Document' ); is( $doc1->readonly, '', '->readonly is false by default' ); # With explicit false my $doc2 = PPI::Document->new( \$source, readonly => undef, ); isa_ok( $doc2, 'PPI::Document' ); is( $doc2->readonly, '', '->readonly is false for explicit false' ); # With explicit true my $doc3 = PPI::Document->new( \$source, readonly => 2, ); isa_ok( $doc3, 'PPI::Document' ); is( $doc3->readonly, 1, '->readonly is true for explicit true' ); } PPI-1.220/t/ppi_statement.t0000755000175100010010000000474012425222277012375 0ustar #!/usr/bin/perl # Unit testing for PPI::Statement use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 23; use Test::NoWarnings; use PPI; SPECIALIZED: { my $Document = PPI::Document->new(\<<'END_PERL'); package Foo; use strict; ; while (1) { last; } BEGIN { } sub foo { } state $x; $x = 5; END_PERL isa_ok( $Document, 'PPI::Document' ); my $statements = $Document->find('Statement'); is( scalar @{$statements}, 10, 'Found the 10 test statements' ); isa_ok( $statements->[0], 'PPI::Statement::Package', 'Statement 1: isa Package' ); ok( $statements->[0]->specialized, 'Statement 1: is specialized' ); isa_ok( $statements->[1], 'PPI::Statement::Include', 'Statement 2: isa Include' ); ok( $statements->[1]->specialized, 'Statement 2: is specialized' ); isa_ok( $statements->[2], 'PPI::Statement::Null', 'Statement 3: isa Null' ); ok( $statements->[2]->specialized, 'Statement 3: is specialized' ); isa_ok( $statements->[3], 'PPI::Statement::Compound', 'Statement 4: isa Compound' ); ok( $statements->[3]->specialized, 'Statement 4: is specialized' ); isa_ok( $statements->[4], 'PPI::Statement::Expression', 'Statement 5: isa Expression' ); ok( $statements->[4]->specialized, 'Statement 5: is specialized' ); isa_ok( $statements->[5], 'PPI::Statement::Break', 'Statement 6: isa Break' ); ok( $statements->[5]->specialized, 'Statement 6: is specialized' ); isa_ok( $statements->[6], 'PPI::Statement::Scheduled', 'Statement 7: isa Scheduled' ); ok( $statements->[6]->specialized, 'Statement 7: is specialized' ); isa_ok( $statements->[7], 'PPI::Statement::Sub', 'Statement 8: isa Sub' ); ok( $statements->[7]->specialized, 'Statement 8: is specialized' ); isa_ok( $statements->[8], 'PPI::Statement::Variable', 'Statement 9: isa Variable' ); ok( $statements->[8]->specialized, 'Statement 9: is specialized' ); is( ref $statements->[9], 'PPI::Statement', 'Statement 10: is a simple Statement' ); ok( ! $statements->[9]->specialized, 'Statement 10: is not specialized' ); } PPI-1.220/t/ppi_token_quote_single.t0000755000175100010010000000206712310327137014261 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Quote::Single use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 25; use Test::NoWarnings; use PPI; STRING: { my $Document = PPI::Document->new( \"print 'foo';" ); isa_ok( $Document, 'PPI::Document' ); my $Single = $Document->find_first('Token::Quote::Single'); isa_ok( $Single, 'PPI::Token::Quote::Single' ); is( $Single->string, 'foo', '->string returns as expected' ); } LITERAL: { my @pairs = ( "''", '', "'f'", 'f', "'f\\'b'", "f\'b", "'f\\nb'", "f\\nb", "'f\\\\b'", "f\\b", "'f\\\\\\b'", "f\\\\b", "'f\\\\\\\''", "f\\'", ); while ( @pairs ) { my $from = shift @pairs; my $to = shift @pairs; my $doc = PPI::Document->new( \"print $from;" ); isa_ok( $doc, 'PPI::Document' ); my $quote = $doc->find_first('Token::Quote::Single'); isa_ok( $quote, 'PPI::Token::Quote::Single' ); is( $quote->literal, $to, "The source $from becomes $to ok" ); } } PPI-1.220/t/interactive.t0000755000175100010010000000130512251445131012021 0ustar #!/usr/bin/perl # Script used to temporarily test the most recent parser bug. # Testing it here is must more efficient than having to trace # down through the entire set of regression tests. use strict; use File::Spec::Functions ':ALL'; BEGIN { $| = 1; $PPI::XS_DISABLE = 1; $PPI::XS_DISABLE = 1; # Prevent warning } use PPI; # Execute the tests use Test::More tests => 2; # Define the test code my $code = 'sub f:f('; ##################################################################### # Run the actual tests my $document = eval { PPI::Document->new(\$code) }; $DB::single = $DB::single = 1 if $@; # Catch exceptions is( $@, '', 'Parsed without error' ); isa_ok( $document, 'PPI::Document' ); PPI-1.220/t/17_storable.t0000755000175100010010000000261412426751160011640 0ustar #!/usr/bin/perl # Test compatibility with Storable use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More; BEGIN { # Is Storable installed? if ( eval { require Storable; 1 } ) { plan( tests => 10 ); } else { plan( 'skip_all' ); exit(0); } } use Test::NoWarnings; use Scalar::Util 'refaddr'; use PPI; ##################################################################### # Test freeze/thaw of PPI::Document objects SCOPE: { # Create a document with various example package statements my $Document = PPI::Lexer->lex_source( <<'END_PERL' ); package Foo; @ISA = (qw/File::Spec/); 1; END_PERL Test::More::isa_ok( $Document, 'PPI::Document' ); { my $isa = $Document->find_first(sub { $_[1] eq '@ISA'; }); Test::More::ok( $isa, "Found ISA var"); Test::More::is( $isa->parent, q|@ISA = (qw/File::Spec/);|, "Got parent ok"); } my $clone = Storable::dclone($Document); Test::More::ok($clone, "dclone ok"); Test::More::isnt( refaddr($Document), refaddr($clone), "Not the same object" ); Test::More::is(ref($Document), ref($clone), "Same class"); Test::More::is_deeply( $Document, $clone, "Deeply equal" ); { my $isa = $clone->find_first(sub { $_[1] eq '@ISA'; }); Test::More::ok($isa, "Found ISA var"); Test::More::is($isa->parent, q|@ISA = (qw/File::Spec/);|, "Got parent ok"); # <-- this one fails } } PPI-1.220/t/ppi_lexer.t0000755000175100010010000001230312426751160011501 0ustar #!/usr/bin/perl # Unit testing for PPI::Lexer use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 44; use Test::NoWarnings; use PPI; UNMATCHED_BRACE: { my $token = new_ok( 'PPI::Token::Structure' => [ ')' ] ); my $brace = new_ok( 'PPI::Statement::UnmatchedBrace' => [ $token ] ); is( $brace->content, ')', '->content ok' ); } _CURLY: { my $document = PPI::Document->new(\<<'END_PERL'); use constant { One => 1 }; use constant 1 { One => 1 }; $foo->{bar}; $foo[1]{bar}; $foo{bar}; sub {1}; grep { $_ } 0 .. 2; map { $_ => 1 } 0 .. 2; sort { $b <=> $a } 0 .. 2; do {foo}; $foo = { One => 1 }; $foo ||= { One => 1 }; 1, { One => 1 }; One => { Two => 2 }; {foo, bar}; {foo => bar}; {}; +{foo, bar}; {; => bar}; @foo{'bar', 'baz'}; @{$foo}{'bar', 'baz'}; ${$foo}{bar}; return { foo => 'bar' }; bless { foo => 'bar' }; $foo &&= { One => 1 }; $foo //= { One => 1 }; $foo //= { 'a' => 1, 'b' => 2 }; 0 || { One => 1 }; 1 && { One => 1 }; undef // { One => 1 }; $x ? {a=>1} : 1; $x ? 1 : {a=>1}; $x ? {a=>1} : {b=>1}; END_PERL isa_ok( $document, 'PPI::Document' ); $document->index_locations(); my @statements; foreach my $elem ( @{ $document->find( 'PPI::Statement' ) || [] } ) { $statements[ $elem->line_number() - 1 ] ||= $elem; } is( scalar(@statements), 33, 'Found 33 statements' ); isa_ok( $statements[0]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[0]); isa_ok( $statements[1]->schild(3), 'PPI::Structure::Constructor', 'The curly in ' . $statements[1]); isa_ok( $statements[2]->schild(2), 'PPI::Structure::Subscript', 'The curly in ' . $statements[2]); isa_ok( $statements[3]->schild(2), 'PPI::Structure::Subscript', 'The curly in ' . $statements[3]); isa_ok( $statements[4]->schild(1), 'PPI::Structure::Subscript', 'The curly in ' . $statements[4]); isa_ok( $statements[5]->schild(1), 'PPI::Structure::Block', 'The curly in ' . $statements[5]); isa_ok( $statements[6]->schild(1), 'PPI::Structure::Block', 'The curly in ' . $statements[6]); isa_ok( $statements[7]->schild(1), 'PPI::Structure::Block', 'The curly in ' . $statements[7]); isa_ok( $statements[8]->schild(1), 'PPI::Structure::Block', 'The curly in ' . $statements[8]); isa_ok( $statements[9]->schild(1), 'PPI::Structure::Block', 'The curly in ' . $statements[9]); isa_ok( $statements[10]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[10]); isa_ok( $statements[11]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[11]); isa_ok( $statements[12]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[12]); isa_ok( $statements[13]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[13]); isa_ok( $statements[14]->schild(0), 'PPI::Structure::Block', 'The curly in ' . $statements[14]); isa_ok( $statements[15]->schild(0), 'PPI::Structure::Constructor', 'The curly in ' . $statements[15]); isa_ok( $statements[16]->schild(0), 'PPI::Structure::Constructor', 'The curly in ' . $statements[16]); isa_ok( $statements[17]->schild(1), 'PPI::Structure::Constructor', 'The curly in ' . $statements[17]); isa_ok( $statements[18]->schild(0), 'PPI::Structure::Block', 'The curly in ' . $statements[18]); isa_ok( $statements[19]->schild(1), 'PPI::Structure::Subscript', 'The curly in ' . $statements[19]); isa_ok( $statements[20]->schild(2), 'PPI::Structure::Subscript', 'The curly in ' . $statements[20]); isa_ok( $statements[21]->schild(2), 'PPI::Structure::Subscript', 'The curly in ' . $statements[21]); isa_ok( $statements[22]->schild(1), 'PPI::Structure::Constructor', 'The curly in ' . $statements[22]); isa_ok( $statements[23]->schild(1), 'PPI::Structure::Constructor', 'The curly in ' . $statements[23]); isa_ok( $statements[24]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[24]); isa_ok( $statements[25]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[25]); isa_ok( $statements[26]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[26]); isa_ok( $statements[27]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[27]); isa_ok( $statements[28]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[28]); isa_ok( $statements[29]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[29]); isa_ok( $statements[30]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[30]); isa_ok( $statements[31]->schild(4), 'PPI::Structure::Constructor', 'The curly in ' . $statements[31]); # Check two things in the same statement isa_ok( $statements[32]->schild(2), 'PPI::Structure::Constructor', 'The curly in ' . $statements[32]); isa_ok( $statements[32]->schild(4), 'PPI::Structure::Constructor', 'The curly in ' . $statements[32]); } LEX_STRUCTURE: { # Validate the creation of a null statement SCOPE: { my $token = new_ok( 'PPI::Token::Structure' => [ ';' ] ); my $null = new_ok( 'PPI::Statement::Null' => [ $token ] ); is( $null->content, ';', '->content ok' ); } # Validate the creation of an empty statement new_ok( 'PPI::Statement' => [ ] ); } PPI-1.220/t/19_selftesting.t0000755000175100010010000001362012425223367012357 0ustar #!/usr/bin/perl # Load ALL of the PPI files, and look for a collection # of known problems, implemented using PPI itself. # Using PPI to analyse its own code at install-time? Fuck yeah! :) use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More; # Plan comes later use Test::NoWarnings; use Test::Object; use File::Spec::Functions ':ALL'; use Params::Util qw{_CLASS _ARRAY _INSTANCE _IDENTIFIER}; use Class::Inspector; use PPI; use t::lib::PPI; use constant CI => 'Class::Inspector'; ##################################################################### # Prepare # Find all of the files to be checked my %tests = map { $_ => $INC{$_} } grep { ! /\bXS\.pm/ } grep { /^PPI\b/ } keys %INC; unless ( %tests ) { Test::More::plan( tests => 2 ); ok( undef, "Failed to find any files to test" ); exit(); } my @files = sort values %tests; # Find all the testable perl files in t/data foreach my $dir ( '05_lexer', '08_regression', '11_util', '13_data', '15_transform' ) { my @perl = find_files( $dir ); push @files, @perl; } # Declare our plan Test::More::plan( tests => scalar(@files) * 14 + 4 ); ##################################################################### # Self-test the search functions before we use them # Check this actually finds something bad my $sample = PPI::Document->new(\<<'END_PERL'); isa($foo, 'Bad::Class1'); isa($foo, 'PPI::Document'); $foo->isa('Bad::Class2'); $foo->isa("Bad::Class3"); isa($foo, 'ARRAY'); # Not bad isa($foo->thing, qq # ok? ); END_PERL isa_ok( $sample, 'PPI::Document' ); my $bad = $sample->find( \&bug_bad_isa_class_name ); ok( _ARRAY($bad), 'Found bad things' ); @$bad = map { $_->string } @$bad; is_deeply( $bad, [ 'Bad::Class1', 'Bad::Class2', 'Bad::Class3', 'Bad::Class4' ], 'Found all found known bad things' ); ##################################################################### # Run the Tests foreach my $file ( @files ) { # MD5 the raw file my $md5a = PPI::Util::md5hex_file($file); like( $md5a, qr/^[0-9a-f]{32}\z/, 'md5hex_file ok' ); # Load the file my $Document = PPI::Document->new($file); ok( _INSTANCE($Document, 'PPI::Document'), "$file: Parsed ok" ); # Compare the preload signature to the post-load value my $md5b = $Document->hex_id; is( $md5b, $md5a, '->hex_id matches md5hex' ); # By this point, everything should have parsed properly at least # once, so no need to skip. SCOPE: { my $rv = $Document->find( \&bug_bad_isa_class_name ); if ( $rv ) { $Document->index_locations; foreach ( @$rv ) { print "# $file: Found bad class " . $_->content . "\n"; } } is_deeply( $rv, '', "$file: All class names in ->isa calls exist" ); } SCOPE: { my $rv = $Document->find( \&bad_static_method ); if ( $rv ) { $Document->index_locations; foreach ( @$rv ) { my $c = $_->sprevious_sibling->content; my $m = $_->snext_sibling->content; my $l = $_->location; print "# $file: Found bad call ${c}->${m} at line $l->[0], col $l->[1]\n"; } } is_deeply( $rv, '', "$file: All class names in static method calls" ); } # Test with Test::Object stuff object_ok( $Document ); } ##################################################################### # Test Functions # Find file names in named t/data dirs sub find_files { my $dir = shift; my $testdir = catdir( 't', 'data', $dir ); # Does the test directory exist? -e $testdir and -d $testdir and -r $testdir or die "Failed to find test directory $testdir"; # Find the .code test files opendir( TESTDIR, $testdir ) or die "opendir: $!"; my @perl = map { catfile( $testdir, $_ ) } sort grep { /\.(?:code|pm)$/ } readdir(TESTDIR); closedir( TESTDIR ) or die "closedir: $!"; return @perl; } # Check for accidental use of illegal or non-existant classes in # ->isa calls. This has happened at least once, presumably because # PPI has a LOT of classes and it can get confusing. sub bug_bad_isa_class_name { my ($Document, $Element) = @_; # Find a quote containing a class name $Element->isa('PPI::Token::Quote') or return ''; _CLASS($Element->string) or return ''; if ( $Element->string =~ /^(?:ARRAY|HASH|CODE|SCALAR|REF|GLOB)$/ ) { return ''; } # It should be the last thing in an expression in a list my $Expression = $Element->parent or return ''; $Expression->isa('PPI::Statement::Expression') or return ''; $Element == $Expression->schild(-1) or return ''; my $List = $Expression->parent or return ''; $List->isa('PPI::Structure::List') or return ''; $List->schildren == 1 or return ''; # The list should be the params list for an isa call my $Word = $List->sprevious_sibling or return ''; $Word->isa('PPI::Token::Word') or return ''; $Word->content =~ /^(?:UNIVERSAL::)?isa\z/s or return ''; # Is the class real and loaded? CI->loaded($Element->string) and return ''; # Looks like we found a class that doesn't exist in # an isa call. return 1; } # Check for the use of a method that doesn't exist sub bad_static_method { my ($document, $element) = @_; # Find a quote containing a class name $element->isa('PPI::Token::Operator') or return ''; $element->content eq '->' or return ''; # Check the method my $method = $element->snext_sibling or return ''; $method->isa('PPI::Token::Word') or return ''; _IDENTIFIER($method->content) or return ''; # Check the class my $class = $element->sprevious_sibling or return ''; $class->isa('PPI::Token::Word') or return ''; _CLASS($class->content) or return ''; # It's usually a deep class $class = $class->content; $method = $method->content; $class =~ /::/ or return ''; # Check the method exists $class->can($method) and return ''; return 1; } 1; PPI-1.220/t/ppi_token_magic.t0000755000175100010010000000323312426751160012644 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Magic use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 39; use Test::NoWarnings; use PPI; __TOKENIZER_ON_CHAR: { my $document = PPI::Document->new(\<<'END_PERL'); $[; # Magic $[ $$; # Magic $$ %-; # Magic %- $#-; # Magic $#- $$foo; # Symbol $foo Dereference of $foo $^W; # Magic $^W $^WIDE_SYSTEM_CALLS; # Magic $^WIDE_SYSTEM_CALLS ${^MATCH}; # Magic ${^MATCH} @{^_Bar}; # Magic @{^_Bar} ${^_Bar}[0]; # Magic @{^_Bar} %{^_Baz}; # Magic %{^_Baz} ${^_Baz}{burfle}; # Magic %{^_Baz} $${^MATCH}; # Magic ${^MATCH} Dereference of ${^MATCH} \${^MATCH}; # Magic ${^MATCH} $0; # Magic $0 -- program being executed $0x2; # Magic $0 -- program being executed $10; # Magic $10 -- capture variable $1100; # Magic $1100 -- capture variable END_PERL isa_ok( $document, 'PPI::Document' ); $document->index_locations(); my $symbols = $document->find( 'PPI::Token::Symbol' ); is( scalar(@$symbols), 18, 'Found the correct number of symbols' ); my $comments = $document->find( 'PPI::Token::Comment' ); foreach my $token ( @$symbols ) { my ($hash, $class, $name, $remk) = split /\s+/, $comments->[$token->line_number - 1], 4; isa_ok( $token, "PPI::Token::$class" ); is( $token->symbol, $name, $remk || "The symbol is $name" ); } } PPI-1.220/t/ppi_statement_package.t0000755000175100010010000000157712310327137014047 0ustar #!/usr/bin/perl # Unit testing for PPI::Statement::Package use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 3; use Test::NoWarnings; use PPI; HASH_CONSTRUCTORS_DONT_CONTAIN_PACKAGES_RT52259: { my $Document = PPI::Document->new(\<<'END_PERL'); { package => "", }; +{ package => "", }; { 'package' => "", }; +{ 'package' => "", }; { 'package' , "", }; +{ 'package' , "", }; END_PERL isa_ok( $Document, 'PPI::Document' ); my $packages = $Document->find('PPI::Statement::Package'); my $test_name = 'Found no package statements in hash constructors - RT #52259'; if (not $packages) { pass $test_name; } elsif ( not is(scalar @{$packages}, 0, $test_name) ) { diag 'Package statements found:'; diag $_->parent()->parent()->content() foreach @{$packages}; } } PPI-1.220/t/21_exhaustive.t0000755000175100010010000001032112426751160012177 0ustar #!/usr/bin/perl # Exhaustively test all possible Perl programs to a particular length use strict; use Carp 'croak'; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use vars qw{$MAX_CHARS $ITERATIONS $LENGTH @ALL_CHARS}; BEGIN { # When distributing, keep this in to verify the test script # is working correctly, but limit to 2 (maaaaybe 3) so we # don't slow the install process down too much. $MAX_CHARS = 2; $ITERATIONS = 1000; $LENGTH = 190; @ALL_CHARS = ( qw{a b c f g m q r s t w x y z V W X 0 1 8 9}, ';', '[', ']', '{', '}', '(', ')', '=', '?', '|', '+', '<', '>', '.', '!', '~', '^', '*', '$', '@', '&', ':', '%', ',', '\\', '/', '_', ' ', "\n", "\t", '-', "'", '"', '`', '#', # Comment out to make parsing more intense ); #my @ALL_CHARS = ( # qw{a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H # I J K L M N O P Q R S T U V W X Y Z 0 1 2 3 4 5 6 7 8 9}, # ';', '[', ']', '{', '}', '(', ')', '=', '?', '|', '+', '<', '>', '.', # '!', '~', '^', '*', '$', '@', '&', ':', '%', '#', ',', "'", '"', '`', # '\\', '/', '_', ' ', "\n", "\t", '-', # ); } ##################################################################### # Prepare use Test::More tests => ($MAX_CHARS + $ITERATIONS + 3); use Test::NoWarnings; use File::Spec::Functions ':ALL'; use Params::Util qw{_INSTANCE}; use PPI; ##################################################################### # Retest Previous Failures test_code2( "( {8" ); ##################################################################### # Code/Dump Testing my $failures = 0; my $last_index = scalar(@ALL_CHARS) - 1; LENGTHLOOP: foreach my $len ( 1 .. $MAX_CHARS ) { # Initialise the char array and failure count my $failures = 0; my @chars = (0) x $len; # The main test loop CHARLOOP: while ( 1 ) { # Test the current set of chars my $code = join '', map { $ALL_CHARS[$_] } @chars; unless ( length($code) == $len ) { die "Failed sanity check. Error in the code generation mechanism"; } test_code( $code ); # Increment the last character $chars[$len - 1]++; # Cascade the wrapping as needed foreach ( reverse( 0 .. $len - 1 ) ) { next CHARLOOP unless $chars[$_] > $last_index; if ( $_ == 0 ) { # End of the iterations, move to the next length last CHARLOOP; } # Carry to the previous char $chars[$_] = 0; $chars[$_ - 1]++; } } is( $failures, 0, "No tokenizer failures for all $len-length programs" ); } ##################################################################### # Test a series of random strings for ( 1 .. $ITERATIONS ) { # Generate a random string my $code = join( '', map { $ALL_CHARS[$_] } map { int(rand($last_index) + 1) } (1 .. $LENGTH) ); # Test it as normal test_code2( $code ); # Verify there are no stale %PARENT entries #my $quotable = quotable($code); #is( scalar(keys %PPI::Element::PARENT), 0, # "%PARENT is clean \"$quotable\"" ); } is( scalar(keys %PPI::Element::PARENT), 0, 'No stale \%PARENT entries at the end of testing' ); %PPI::Element::PARENT = %PPI::Element::PARENT; ##################################################################### # Support Functions sub test_code2 { $failures = 0; my $string = shift; my $quotable = quotable($string); test_code( $string ); is( $failures, 0, "String parses ok \"$quotable\"" ); } sub test_code { my $code = shift; my $Document = eval { # $SIG{__WARN__} = sub { croak('Triggered a warning') }; PPI::Document->new(\$code); }; # Version of the code for use in error messages my $quotable = quotable($code); unless ( _INSTANCE($Document, 'PPI::Document') ) { $failures++; diag( "\"$quotable\": Parser did not return a Document" ); return; } my $joined = $Document->serialize; my $joined_quotable = quotable($joined); unless ( $joined eq $code ) { $failures++; diag( "\"$quotable\": Document round-trips ok" ); diag( "\"$joined_quotable\" (round-trips to)" ); return; } } sub quotable { my $quotable = shift; $quotable =~ s/\\/\\\\/g; $quotable =~ s/\t/\\t/g; $quotable =~ s/\n/\\n/g; $quotable =~ s/\$/\\\$/g; $quotable =~ s/\@/\\\@/g; $quotable =~ s/\"/\\\"/g; return $quotable; } exit(0); PPI-1.220/t/ppi_statement_scheduled.t0000755000175100010010000000245412426751160014414 0ustar #!/usr/bin/perl # Test PPI::Statement::Scheduled use strict; BEGIN { $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 241; use Test::NoWarnings; use PPI; SUB_WORD_OPTIONAL: { for my $name ( qw( BEGIN CHECK UNITCHECK INIT END ) ) { for my $sub ( '', 'sub ' ) { # '{}' -- function definition # ';' -- function declaration # '' -- function declaration with missing semicolon for my $followed_by ( ' {}', '{}', ';', '' ) { test_sub_as( $sub, $name, $followed_by ); } } } } sub test_sub_as { my ( $sub, $name, $followed_by ) = @_; my $code = "$sub$name$followed_by"; my $Document = PPI::Document->new( \$code ); isa_ok( $Document, 'PPI::Document', "$code: got document" ); my ( $sub_statement, $dummy ) = $Document->schildren; isa_ok( $sub_statement, 'PPI::Statement::Scheduled', "$code: document child is a scheduled statement" ); is( $dummy, undef, "$code: document has exactly one child" ); ok( $sub_statement->reserved, "$code: is reserved" ); is( $sub_statement->name, $name, "$code: name() correct" ); if ( $followed_by =~ /}/ ) { isa_ok( $sub_statement->block, 'PPI::Structure::Block', "$code: has a block" ); } else { ok( !$sub_statement->block, "$code: has no block" ); } return; } PPI-1.220/t/03_document.t0000755000175100010010000000354012271460262011633 0ustar #!/usr/bin/perl # PPI::Document tests use strict; use File::Spec::Functions ':ALL'; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use PPI; # Execute the tests use Test::More tests => 14; use Test::NoWarnings; # Test file my $file = catfile(qw{ t data 03_document test.dat }); my $empty = catfile(qw{ t data 03_document empty.dat }); ok( -f $file, 'Found test file' ); ok( -f $empty, 'Found test file' ); # Test script my $script = <<'END_PERL'; #!/usr/bin/perl # A simple test script print "Hello World!\n"; END_PERL ##################################################################### # Test a basic document # Parse a simple document in all possible ways SCOPE: { my $doc1 = PPI::Document->new( $file ); isa_ok( $doc1, 'PPI::Document' ); my $doc2 = PPI::Document->new( \$script ); isa_ok( $doc2, 'PPI::Document' ); my $doc3 = PPI::Document->new( [ "#!/usr/bin/perl", "", "# A simple test script", "", "print \"Hello World!\\n\";", ] ); isa_ok( $doc3, 'PPI::Document' ); # Compare the three forms is_deeply( $doc1, $doc2, 'Stringref form matches file form' ); is_deeply( $doc1, $doc3, 'Arrayref form matches file form' ); } # Repeat the above with a null document SCOPE: { my $doc1 = PPI::Document->new( $empty ); isa_ok( $doc1, 'PPI::Document' ); my $doc2 = PPI::Document->new( \'' ); isa_ok( $doc2, 'PPI::Document' ); my $doc3 = PPI::Document->new( [ ] ); isa_ok( $doc3, 'PPI::Document' ); # Compare the three forms is_deeply( $doc1, $doc2, 'Stringref form matches file form' ); is_deeply( $doc1, $doc3, 'Arrayref form matches file form' ); # Make sure the null document round-trips my $string = $doc1->serialize; is( $string, '', '->serialize ok' ); # Check for warnings on null document index_locations { local $^W = 1; $doc1->index_locations(); } } PPI-1.220/t/ppi_token_operator.t0000755000175100010010000003241512430461105013413 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Operator use strict; BEGIN { $| = 1; select STDERR; $| = 1; select STDOUT; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 398; use Test::NoWarnings; use PPI; FIND_ONE_OP: { my $source = '$a = .987;'; my $doc = PPI::Document->new( \$source ); isa_ok( $doc, 'PPI::Document', "parsed '$source'" ); my $ops = $doc->find( 'Token::Number::Float' ); is( ref $ops, 'ARRAY', "found number" ); is( @$ops, 1, "number found exactly once" ); is( $ops->[0]->content(), '.987', "text matches" ); $ops = $doc->find( 'Token::Operator' ); is( ref $ops, 'ARRAY', "operator = found operators in number test" ); is( @$ops, 1, "operator = found exactly once in number test" ); } HEREDOC: { my $source = '$a = <new( \$source ); isa_ok( $doc, 'PPI::Document', "parsed '$source'" ); my $ops = $doc->find( 'Token::HereDoc' ); is( ref $ops, 'ARRAY', "found heredoc" ); is( @$ops, 1, "heredoc found exactly once" ); $ops = $doc->find( 'Token::Operator' ); is( ref $ops, 'ARRAY', "operator = found operators in heredoc test" ); is( @$ops, 1, "operator = found exactly once in heredoc test" ); } PARSE_ALL_OPERATORS: { foreach my $op ( sort keys %PPI::Token::Operator::OPERATOR ) { my $source = $op eq '<>' ? '<>;' : "\$foo $op 2;"; my $doc = PPI::Document->new( \$source ); isa_ok( $doc, 'PPI::Document', "operator $op parsed '$source'" ); my $ops = $doc->find( $op eq '<>' ? 'Token::QuoteLike::Readline' : 'Token::Operator' ); is( ref $ops, 'ARRAY', "operator $op found operators" ); is( @$ops, 1, "operator $op found exactly once" ); is( $ops->[0]->content(), $op, "operator $op operator text matches" ); } } OPERATOR_X: { my @tests = ( { desc => 'integer with integer', code => '1 x 3', expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'string with integer', code => '"y" x 3', expected => [ 'PPI::Token::Quote::Double' => '"y"', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'string with integer', code => 'qq{y} x 3', expected => [ 'PPI::Token::Quote::Interpolate' => 'qq{y}', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'string no whitespace with integer', code => '"y"x 3', expected => [ 'PPI::Token::Quote::Double' => '"y"', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'variable with integer', code => '$a x 3', expected => [ 'PPI::Token::Symbol' => '$a', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'variable with no whitespace integer', code => '$a x3', expected => [ 'PPI::Token::Symbol' => '$a', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '3', ], }, { desc => 'variable, post ++, x, no whitespace anywhere', code => '$a++x3', expected => [ 'PPI::Token::Symbol' => '$a', 'PPI::Token::Operator' => '++', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '3', ], }, { desc => 'double quote, no whitespace', code => '"y"x 3', expected => [ 'PPI::Token::Quote::Double' => '"y"', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'single quote, no whitespace', code => "'y'x 3", expected => [ 'PPI::Token::Quote::Single' => "'y'", 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'parens, no whitespace, number', code => "(5)x 3", expected => [ 'PPI::Structure::List' => '(5)', 'PPI::Token::Structure' => '(', 'PPI::Statement::Expression' => '5', 'PPI::Token::Number' => '5', 'PPI::Token::Structure' => ')', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '3', ], }, { desc => 'number following x is hex', code => "1x0x1", expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number::Hex' => '0x1', ], }, { desc => 'x followed by symbol', code => '1 x$y', expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Symbol' => '$y', ], }, { desc => 'x= with no trailing whitespace, symbol', code => '$z x=3', expected => [ 'PPI::Token::Symbol' => '$z', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x=', 'PPI::Token::Number' => '3', ], }, { desc => 'x= with no trailing whitespace, symbol', code => '$z x=$y', expected => [ 'PPI::Token::Symbol' => '$z', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x=', 'PPI::Token::Symbol' => '$y', ], }, { desc => 'x plus whitespace on the left of => that is not the first token in the doc', code => '1;x =>1;', expected => [ 'PPI::Statement' => '1;', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ';', 'PPI::Statement' => 'x =>1;', 'PPI::Token::Word' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => '=>', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ';', ], }, { desc => 'x on the left of => that is not the first token in the doc', code => '1;x=>1;', expected => [ 'PPI::Statement' => '1;', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ';', 'PPI::Statement' => 'x=>1;', 'PPI::Token::Word' => 'x', 'PPI::Token::Operator' => '=>', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ';', ], }, { desc => 'x on the left of => that is not the first token in the doc', code => '$hash{x}=1;', expected => [ 'PPI::Token::Symbol' => '$hash', 'PPI::Structure::Subscript' => '{x}', 'PPI::Token::Structure' => '{', 'PPI::Statement::Expression' => 'x', 'PPI::Token::Word' => 'x', 'PPI::Token::Structure' => '}', 'PPI::Token::Operator' => '=', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ';', ], }, { desc => 'x plus whitespace on the left of => is not an operator', code => 'x =>1', expected => [ 'PPI::Token::Word' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => '=>', 'PPI::Token::Number' => '1', ], }, { desc => 'x immediately followed by => should not be mistaken for x=', code => 'x=>1', expected => [ 'PPI::Token::Word' => 'x', 'PPI::Token::Operator' => '=>', 'PPI::Token::Number' => '1', ], }, { desc => 'xx on left of => not mistaken for an x operator', code => 'xx=>1', expected => [ 'PPI::Token::Word' => 'xx', 'PPI::Token::Operator' => '=>', 'PPI::Token::Number' => '1', ], }, { desc => 'x right of => is not an operator', code => '1=>x', expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Operator' => '=>', 'PPI::Token::Word' => 'x', ], }, { desc => 'xor right of => is an operator', code => '1=>xor', expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Operator' => '=>', 'PPI::Token::Operator' => 'xor', ], }, { desc => 'RT 37892: list as arg to x operator 1', code => '(1) x 6', expected => [ 'PPI::Structure::List' => '(1)', 'PPI::Token::Structure' => '(', 'PPI::Statement::Expression' => '1', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ')', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Number' => '6', ], }, { desc => 'RT 37892: list as arg to x operator 2', code => '(1) x6', expected => [ 'PPI::Structure::List' => '(1)', 'PPI::Token::Structure' => '(', 'PPI::Statement::Expression' => '1', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ')', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '6', ], }, { desc => 'RT 37892: list as arg to x operator 3', code => '(1)x6', expected => [ 'PPI::Structure::List' => '(1)', 'PPI::Token::Structure' => '(', 'PPI::Statement::Expression' => '1', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ')', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '6', ], }, { desc => 'RT 37892: x following function is operator', code => 'foo()x6', expected => [ 'PPI::Token::Word' => 'foo', 'PPI::Structure::List' => '()', 'PPI::Token::Structure' => '(', 'PPI::Token::Structure' => ')', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '6', ], }, { desc => 'RT 37892: list as arg to x operator 4', code => 'qw(1)x6', expected => [ 'PPI::Token::QuoteLike::Words' => 'qw(1)', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '6', ], }, { desc => 'RT 37892: list as arg to x operator 5', code => 'qw<1>x6', expected => [ 'PPI::Token::QuoteLike::Words' => 'qw<1>', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '6', ], }, { desc => 'RT 37892: listref as arg to x operator 6', code => '[1]x6', expected => [ 'PPI::Structure::Constructor' => '[1]', 'PPI::Token::Structure' => '[', 'PPI::Statement' => '1', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ']', 'PPI::Token::Operator' => 'x', 'PPI::Token::Number' => '6', ], }, { desc => 'x followed by sigil $ that is not also an operator', code => '1x$bar', expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Operator' => 'x', 'PPI::Token::Symbol' => '$bar', ], }, { desc => 'x followed by sigil @ that is not also an operator', code => '1x@bar', expected => [ 'PPI::Token::Number' => '1', 'PPI::Token::Operator' => 'x', 'PPI::Token::Symbol' => '@bar', ], }, { desc => 'sub name /^x/', code => 'sub xyzzy : _5x5 {1;}', expected => [ 'PPI::Statement::Sub' => 'sub xyzzy : _5x5 {1;}', 'PPI::Token::Word' => 'sub', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Word' => 'xyzzy', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Operator' => ':', 'PPI::Token::Whitespace' => ' ', 'PPI::Token::Attribute' => '_5x5', 'PPI::Token::Whitespace' => ' ', 'PPI::Structure::Block' => '{1;}', 'PPI::Token::Structure' => '{', 'PPI::Statement' => '1;', 'PPI::Token::Number' => '1', 'PPI::Token::Structure' => ';', 'PPI::Token::Structure' => '}', ] }, ); # Exhaustively test when a preceding operator implies following # 'x' is word not an operator. This detects the regression in # which '$obj->x86_convert()' was being parsed as an the x # operator. my %operators = ( %PPI::Token::Operator::OPERATOR, map { $_ => 1 } qw( -r -w -x -o -R -W -X -O -e -z -s -f -d -l -p -S -b -c -t -u -g -k -T -B -M -A -C ) ); # Don't try to test operators for which PPI currently (1.215) # doesn't recognize when they're followed immediately by a word. # E.g.: # sub x3 {15;} my $z=6; print $z&x3; # sub x3 {3;} my $z=2; print $z%x3; delete $operators{'&'}; delete $operators{'%'}; delete $operators{'*'}; foreach my $operator ( keys %operators ) { my $code = ''; my @expected; if ( $operator =~ /^\w/ ) { $code .= '$a '; push @expected, ( 'PPI::Token::Symbol' => '$a' ); push @expected, ( 'PPI::Token::Whitespace' => ' ' ); } elsif ( $operator !~ /^-\w/ ) { # filetest operators $code .= '$a'; push @expected, ( 'PPI::Token::Symbol' => '$a' ); } $code .= $operator; push @expected, ( ($operator eq '<>' ? 'PPI::Token::QuoteLike::Readline' : 'PPI::Token::Operator') => $operator ); if ( $operator =~ /\w$/ || $operator eq '<<' ) { # want << operator, not heredoc $code .= ' '; push @expected, ( 'PPI::Token::Whitespace' => ' ' ); } $code .= 'x3'; my $desc; if ( $operator eq '--' || $operator eq '++' || $operator eq '<>' ) { push @expected, ( 'PPI::Token::Operator' => 'x' ); push @expected, ( 'PPI::Token::Number' => '3' ); $desc = "operator $operator does not imply following 'x' is a word"; } else { push @expected, ( 'PPI::Token::Word' => 'x3' ); $desc = "operator $operator implies following 'x' is a word"; } push @tests, { desc => $desc, code => $code, expected => \@expected }; } foreach my $test ( @tests ) { my $d = PPI::Document->new( \$test->{code} ); my $tokens = $d->find( sub { 1; } ); $tokens = [ map { ref($_), $_->content() } @$tokens ]; my $expected = $test->{expected}; if ( $expected->[0] !~ /^PPI::Statement/ ) { unshift @$expected, 'PPI::Statement', $test->{code}; } my $ok = is_deeply( $tokens, $expected, $test->{desc} ); if ( !$ok ) { diag "$test->{code} ($test->{desc})\n"; diag explain $tokens; diag explain $test->{expected}; } } } PPI-1.220/t/10_statement.t0000755000175100010010000000335312251445131012015 0ustar #!/usr/bin/perl # Test the various PPI::Statement packages use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } # Execute the tests use Test::More tests => 12; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use Scalar::Util 'refaddr'; use PPI::Lexer (); ##################################################################### # Tests for PPI::Statement::Package SCOPE: { # Create a document with various example package statements my $Document = PPI::Lexer->lex_source( <<'END_PERL' ); package Foo; SCOPE: { package # comment Bar::Baz; 1; } 1; END_PERL isa_ok( $Document, 'PPI::Document' ); # Check that both of the package statements are detected my $packages = $Document->find('Statement::Package'); is( scalar(@$packages), 2, 'Found 2 package statements' ); is( $packages->[0]->namespace, 'Foo', 'Package 1 returns correct namespace' ); is( $packages->[1]->namespace, 'Bar::Baz', 'Package 2 returns correct namespace' ); is( $packages->[0]->file_scoped, 1, '->file_scoped returns true for package 1' ); is( $packages->[1]->file_scoped, '', '->file_scoped returns false for package 2' ); } ##################################################################### # Basic subroutine test SCOPE: { my $doc = PPI::Document->new( \"sub foo { 1 }" ); isa_ok( $doc, 'PPI::Document' ); isa_ok( $doc->child(0), 'PPI::Statement::Sub' ); } ##################################################################### # Regression test, make sure utf8 is a pragma SCOPE: { my $doc = PPI::Document->new( \"use utf8;" ); isa_ok( $doc, 'PPI::Document' ); isa_ok( $doc->child(0), 'PPI::Statement::Include' ); is( $doc->child(0)->pragma, 'utf8', 'use utf8 is a pragma' ); } PPI-1.220/t/06_round_trip.t0000755000175100010010000000572312271013342012203 0ustar #!/usr/bin/perl # Load ALL of the PPI files, lex them in, dump them # out, and verify that the code goes in and out cleanly. use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More; # Plan comes later use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; ##################################################################### # Prepare # Find all of the files to be checked my %tests = map { $_ => $INC{$_} } grep { ! /\bXS\.pm/ } grep { /^PPI\b/ } keys %INC; my @files = sort values %tests; unless ( @files ) { Test::More::plan( tests => 2 ); ok( undef, "Failed to find any files to test" ); exit(); } # Find all the testable perl files in t/data foreach my $dir ( '05_lexer', '07_token', '08_regression', '11_util', '13_data', '15_transform' ) { my @perl = find_files( catdir( 't', 'data', $dir ) ); push @files, @perl; } # Add the test scripts themselves push @files, find_files( 't' ); # Declare our plan Test::More::plan( tests => 1 + scalar(@files) * 9 ); ##################################################################### # Run the Tests foreach my $file ( @files ) { roundtrip_ok( $file ); } ##################################################################### # Test Functions sub roundtrip_ok { my $file = shift; local *FILE; my $rv = open( FILE, '<', $file ); ok( $rv, "$file: Found file " ); SKIP: { skip "No file to test", 7 unless $rv; my $source = do { local $/ = undef; }; close FILE; ok( length $source, "$file: Loaded cleanly" ); $source =~ s/(?:\015{1,2}\012|\015|\012)/\n/g; # Load the file as a Document SKIP: { skip( 'Ignoring 14_charset.t', 7 ) if $file =~ /14_charset/; my $Document = PPI::Document->new( $file ); ok( $Document, "$file: ->new returned true" ); isa_ok( $Document, 'PPI::Document' ); # Serialize it back out, and compare with the raw version skip( "Ignoring failed parse of $file", 5 ) unless defined $Document; my $content = $Document->serialize; ok( length($content), "$file: PPI::Document serializes" ); is( $content, $source, "$file: Round trip was successful" ); # Are there any unknown things? is( $Document->find_any('Token::Unknown'), '', "$file: Contains no PPI::Token::Unknown elements" ); is( $Document->find_any('Structure::Unknown'), '', "$file: Contains no PPI::Structure::Unknown elements" ); is( $Document->find_any('Statement::Unknown'), '', "$file: Contains no PPI::Statement::Unknown elements" ); } } } # Find file names in named t/data dirs sub find_files { my $testdir = shift; # Does the test directory exist? -e $testdir and -d $testdir and -r $testdir or die "Failed to find test directory $testdir"; # Find the .code test files opendir( TESTDIR, $testdir ) or die "opendir: $!"; my @perl = map { catfile( $testdir, $_ ) } sort grep { /\.(?:code|pm|t)$/ } readdir(TESTDIR); closedir( TESTDIR ) or die "closedir: $!"; return @perl; } PPI-1.220/t/08_regression.t0000755000175100010010000002613512426751160012211 0ustar #!/usr/bin/perl # code/dump-style regression tests for known lexing problems. # Some other regressions tests are included here for simplicity. use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } # For each new item in t/data/08_regression add another 15 tests use Test::More tests => 932; use Test::NoWarnings; use t::lib::PPI; use PPI; sub pause { local $@; sleep 1 if !eval { require Time::HiRes; Time::HiRes::sleep(0.1); 1 }; } ##################################################################### # Code/Dump Testing # ntests = 2 + 14 * nfiles t::lib::PPI->run_testdir(qw{ t data 08_regression }); ##################################################################### # Regression Test for rt.cpan.org #11522 # Check that objects created in a foreach don't leak circulars. foreach ( 1 .. 3 ) { pause(); is( scalar(keys(%PPI::Element::_PARENT)), 0, "No parent links at start of loop $_" ); # Keep the document from going out of scope before the _PARENT test below. my $Document = PPI::Document->new(\q[print "Foo!"]); ## no critic ( Variables::ProhibitUnusedVarsStricter ) is( scalar(keys(%PPI::Element::_PARENT)), 4, 'Correct number of keys created' ); } ##################################################################### # A number of things picked up during exhaustive testing I want to # watch for regressions on # Create a document with a complete braced regexp SCOPE: { my $Document = PPI::Document->new( \"s {foo} i" ); isa_ok( $Document, 'PPI::Document' ); my $stmt = $Document->first_element; isa_ok( $stmt, 'PPI::Statement' ); my $regexp = $stmt->first_element; isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); # Check the regexp matches what we would expect (specifically # the fine details about the sections. my $expected = { _sections => 2, braced => 1, content => 's {foo} i', modifiers => { i => 1 }, operator => 's', sections => [ { position => 3, size => 3, type => '{}', }, { position => 9, size => 3, type => '<>', } ], separator => undef, }; is_deeply( { %$regexp }, $expected, 'Complex regexp matches expected' ); } # Also test the handling of a screwed up single part multi-regexp SCOPE: { my $Document = PPI::Document->new( \"s {foo}_" ); isa_ok( $Document, 'PPI::Document' ); my $stmt = $Document->first_element; isa_ok( $stmt, 'PPI::Statement' ); my $regexp = $stmt->first_element; isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); # Check the internal details as before my $expected = { _sections => 2, _error => "No second section of regexp, or does not start with a balanced character", braced => 1, content => 's {foo}', modifiers => {}, operator => 's', sections => [ { position => 3, size => 3, type => '{}', }, { position => 7, size => 0, type => '', } ], separator => undef, }; is_deeply( { %$regexp }, $expected, 'Badly short regexp matches expected' ); } # Encode an assumption that the value of a zero-length substr one char # after the end of the string returns ''. This assumption is used to make # the decision on the sections->[1]->{position} value being one char after # the end of the current string is( substr('foo', 3, 0), '', 'substr one char after string end returns ""' ); # rt.cpan.org: Ticket #16671 $_ is not localized # Apparently I DID fix the localisation during parsing, but I forgot to # localise in PPI::Node::DESTROY (ack). $_ = 1234; is( $_, 1234, 'Set $_ to 1234' ); SCOPE: { my $Document = PPI::Document->new( \"print 'Hello World';"); isa_ok( $Document, 'PPI::Document' ); } is( $_, 1234, 'Remains after document creation and destruction' ); ##################################################################### # Bug 16815: location of Structure::List is not defined. SCOPE: { my $code = '@foo = (1,2)'; my $doc = PPI::Document->new(\$code); isa_ok( $doc, 'PPI::Document' ); ok( $doc->find_first('Structure::List')->location, '->location for a ::List returns true' ); } ##################################################################### # Bug 18413: PPI::Node prune() implementation broken SCOPE: { my $doc = PPI::Document->new( \<<'END_PERL' ); #!/usr/bin/perl use warnings; sub one { 1 } sub two { 2 } sub three { 3 } print one; print "\n"; print three; print "\n"; exit; END_PERL isa_ok( $doc, 'PPI::Document' ); ok( defined $doc->prune('PPI::Statement::Sub'), '->prune ok' ); } ##################################################################### # Bug 19883: 'package' bareword used as hash key is detected as package statement SCOPE: { my $doc = PPI::Document->new( \'(package => 123)' ); isa_ok( $doc, 'PPI::Document' ); isa_ok( $doc->child(0)->child(0)->child(0), 'PPI::Statement' ); isa_ok( $doc->child(0)->child(0)->child(0), 'PPI::Statement::Expression' ); } ##################################################################### # Bug 19629: End of list mistakenly seen as end of statement SCOPE: { my $doc = PPI::Document->new( \'()' ); isa_ok( $doc, 'PPI::Document' ); isa_ok( $doc->child(0), 'PPI::Statement' ); } SCOPE: { my $doc = PPI::Document->new( \'{}' ); isa_ok( $doc, 'PPI::Document' ); isa_ok( $doc->child(0), 'PPI::Statement' ); } SCOPE: { my $doc = PPI::Document->new( \'[]' ); isa_ok( $doc, 'PPI::Document' ); isa_ok( $doc->child(0), 'PPI::Statement' ); } ##################################################################### # Bug 21571: PPI::Token::Symbol::symbol does not properly handle # variables with adjacent braces SCOPE: { my $doc = PPI::Document->new( \'$foo{bar}' ); my $symbol = $doc->child(0)->child(0); isa_ok( $symbol, 'PPI::Token::Symbol' ); is( $symbol->symbol, '%foo', 'symbol() for $foo{bar}' ); } SCOPE: { my $doc = PPI::Document->new( \'$foo[0]' ); my $symbol = $doc->child(0)->child(0); isa_ok( $symbol, 'PPI::Token::Symbol' ); is( $symbol->symbol, '@foo', 'symbol() for $foo[0]' ); } SCOPE: { my $doc = PPI::Document->new( \'@foo{bar}' ); my $symbol = $doc->child(0)->child(0); isa_ok( $symbol, 'PPI::Token::Symbol' ); is( $symbol->symbol, '%foo', 'symbol() for @foo{bar}' ); } ##################################################################### # Bug 21575: PPI::Statement::Variable::variables breaks for lists # with leading whitespace SCOPE: { my $doc = PPI::Document->new( \'my ( $self, $param ) = @_;' ); my $stmt = $doc->child(0); isa_ok( $stmt, 'PPI::Statement::Variable' ); is_deeply( [$stmt->variables], ['$self', '$param'], 'variables() for my list with whitespace' ); } ##################################################################### # Bug #23788: PPI::Statement::location() returns undef for C<({})>. SCOPE: { my $doc = PPI::Document->new( \'({})' ); isa_ok( $doc, 'PPI::Document' ); my $bad = $doc->find( sub { not defined $_[1]->location } ); is( $bad, '', 'All elements return defined for ->location' ); } ##################################################################### # Chris Laco on users@perlcritic.tigris.org (sorry no direct URL...) # http://perlcritic.tigris.org/servlets/SummarizeList?listName=users # Empty constructor has no location SCOPE: { my $doc = PPI::Document->new( \'$h={};' ); my $hash = $doc->find('PPI::Structure::Constructor')->[0]; ok($hash, 'location for empty constructor - fetched a constructor'); is_deeply( $hash->location, [1,4,4,1,undef], 'location for empty constructor'); } ##################################################################### # Perl::MinimumVersion regression SCOPE: { my $doc = PPI::Document->new( \'use utf8;' ); my $stmt = $doc->child(0); isa_ok( $stmt, 'PPI::Statement::Include' ); is( $stmt->pragma, 'utf8', 'pragma() with numbers' ); } ##################################################################### # Proof that _new_token must return "1" SCOPE: { my $doc = PPI::Document->new(\<<'END_PERL'); $$content =~ s/(?:\015{1,2}\012|\015|\012)/\n/gs; END_PERL isa_ok( $doc, 'PPI::Document' ); } ###################################################################### # Check quoteengine token behaviour at end of file SCOPE: { my $doc = PPI::Document->new(\'s/'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 0, 'Found 0 section' ); } SCOPE: { my $doc = PPI::Document->new(\'s{'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 0, 'Found 0 section' ); } SCOPE: { my $doc = PPI::Document->new(\'s/foo'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 1, 'Found 1 section' ); is( $regexp->_section_content(0), 'foo', 's/foo correct at EOL' ); } SCOPE: { my $doc = PPI::Document->new(\'s{foo'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 1, 'Found 1 section' ); is( $regexp->_section_content(0), 'foo', 's{foo correct at EOL' ); } SCOPE: { my $doc = PPI::Document->new(\'s/foo/'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 1, 'Found 1 section' ); } SCOPE: { my $doc = PPI::Document->new(\'s{foo}{'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 1, 'Found 1 section' ); } SCOPE: { my $doc = PPI::Document->new(\'s{foo}/'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 1, 'Found 1 section' ); } SCOPE: { my $doc = PPI::Document->new(\'s/foo/bar'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 2, 'Found 2 sections' ); is( $regexp->_section_content(1), 'bar', 's/foo/bar correct at EOL' ); } SCOPE: { my $doc = PPI::Document->new(\'s{foo}{bar'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 2, 'Found 2 sections' ); is( $regexp->_section_content(1), 'bar', 's{foo}{bar correct at EOL' ); } SCOPE: { my $doc = PPI::Document->new(\'s{foo}/bar'); isa_ok( $doc, 'PPI::Document' ); my $regexp = $doc->child(0)->child(0); isa_ok( $regexp, 'PPI::Token::Regexp::Substitute' ); is( $regexp->_sections, 2, 'Found 2 sections' ); is( $regexp->_section_content(1), 'bar', 's{foo}/bar correct at EOL' ); } ###################################################################### # Confirmation of cases where we special case / to a regex SCOPE: { my $doc = PPI::Document->new(\<<'END_PERL'); @foo = split /foo/, $var; return / Special /x ? 0 : 1; print "Hello" if /regex/; END_PERL isa_ok( $doc, 'PPI::Document' ); my $match = $doc->find('PPI::Token::Regexp::Match'); is( scalar(@$match), 3, 'Found expected number of matches' ); } PPI-1.220/t/ppi_token_quote.t0000755000175100010010000000140612310327137012714 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Quote use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 16; use Test::NoWarnings; use PPI; STRING: { # Prove what we say in the ->string docs my $Document = PPI::Document->new(\<<'END_PERL'); 'foo' "foo" q{foo} qq END_PERL isa_ok( $Document, 'PPI::Document' ); my $quotes = $Document->find('Token::Quote'); is( ref($quotes), 'ARRAY', 'Found quotes' ); is( scalar(@$quotes), 4, 'Found 4 quotes' ); foreach my $Quote ( @$quotes ) { isa_ok( $Quote, 'PPI::Token::Quote'); can_ok( $Quote, 'string' ); is( $Quote->string, 'foo', '->string returns "foo" for ' . $Quote->content ); } } PPI-1.220/t/data/0000755000175100010010000000000012430470371010231 5ustar PPI-1.220/t/data/test2.txt0000755000175100010010000000024512251445131012034 0ustar #!/usr/bin/perl print "Hello World!\n"; =pod =head1 Foo This is the first pod section =cut print "Goodbye World!"; =head1 Bar This is the second pod section PPI-1.220/t/data/05_lexer/0000755000175100010010000000000012430470371011654 5ustar PPI-1.220/t/data/05_lexer/12_switch.code0000755000175100010010000000006612306717230014320 0ustar given ($foo) { when (@blah) { } default { } } PPI-1.220/t/data/05_lexer/02_END.dump0000755000175100010010000000036412306717230013460 0ustar PPI::Document PPI::Token::Comment '# something\n' PPI::Token::Whitespace '\n' PPI::Statement::End PPI::Token::Separator '__END__' PPI::Token::Whitespace '\n' PPI::Token::End '\nThis is after the end of the file\n\n' PPI-1.220/t/data/05_lexer/06_subroutine_prototypes.code0000755000175100010010000000003412306717230017524 0ustar sub RE() { } sub foo ($) {} PPI-1.220/t/data/05_lexer/01_simpleassign.code0000755000175100010010000000003112306717230015503 0ustar my $a = 1; state $b = 1; PPI-1.220/t/data/05_lexer/11_dor.dump0000755000175100010010000000070512306717230013635 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$a' PPI::Token::Whitespace ' ' PPI::Token::Operator '//=' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Token::Operator '//' PPI::Token::Whitespace ' ' PPI::Token::Word 'die' PPI::Token::Whitespace ' ' PPI::Token::Quote::Double '"foo"' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/05_lexer/02_END.code0000755000175100010010000000007112306717230013420 0ustar # something __END__ This is after the end of the file PPI-1.220/t/data/05_lexer/08_subroutines.dump0000755000175100010010000000244212306717230015441 0ustar PPI::Document PPI::Statement::Scheduled PPI::Token::Word 'BEGIN' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Scheduled PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'BEGIN' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Prototype '()' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Token::Prototype '()' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI-1.220/t/data/05_lexer/09_heredoc.code0000755000175100010010000000043212306717230014433 0ustar # Bareword print <' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Readline '' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Readline '<>' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Word 'while' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Readline '<>' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'grep' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Regexp::Match '/foo/' PPI::Token::Whitespace ' ' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Readline '' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Variable PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@v' PPI::Token::Operator '=' PPI::Token::QuoteLike::Readline '<$up../*.v>' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/05_lexer/03_subroutine_attributes.dump0000755000175100010010000000263612306717230017524 0ustar PPI::Document PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'bar(quax => &#"Foo")' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Prototype '($)' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Attribute 'bar(quax => &#"Foo")' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Token::Prototype '(&$@)' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'bar' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'baz' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'bingo(blah flasd: fasdf)' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/05_lexer/07_unmatched_braces.code0000755000175100010010000000004112306717230016303 0ustar sub foo { print( "Foo"; } ) PPI-1.220/t/data/05_lexer/09_heredoc.dump0000755000175100010010000000351312306717230014471 0ustar PPI::Document PPI::Token::Comment '# Bareword\n' PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::HereDoc '<) {} @foo = ; @foo = <>; print while <>; grep { /foo/ } ; my @v=<$up../*.v>; PPI-1.220/t/data/05_lexer/07_unmatched_braces.dump0000755000175100010010000000133012306717230016340 0ustar PPI::Document PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ??? PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Quote::Double '"Foo"' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI::Statement::UnmatchedBrace PPI::Token::Structure ')' PPI::Token::Whitespace '\n' PPI-1.220/t/data/05_lexer/04_anonymous_subroutines.code0000755000175100010010000000006212306717230017506 0ustar my $a = sub {}; $b = sub($){}; $c = sub (&$@) {}; PPI-1.220/t/data/05_lexer/03_subroutine_attributes.code0000755000175100010010000000017612306717230017466 0ustar sub foo : bar(quax => &#"Foo") {} sub foo($) :bar(quax => &#"Foo") {} sub foo (&$@): bar : baz : bingo(blah flasd: fasdf) { } PPI-1.220/t/data/05_lexer/05_compound_loops.dump0000755000175100010010000001501712426751160016121 0ustar PPI::Document PPI::Statement::Compound PPI::Token::Word 'while' PPI::Token::Whitespace ' ' PPI::Structure::Condition ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'while' PPI::Token::Whitespace ' ' PPI::Structure::Condition ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Token::Word 'continue' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Label 'LABEL:' PPI::Token::Whitespace ' ' PPI::Token::Word 'while' PPI::Token::Whitespace ' ' PPI::Structure::Condition ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Label 'LABEL:' PPI::Token::Whitespace ' ' PPI::Token::Word 'while' PPI::Token::Whitespace ' ' PPI::Structure::Condition ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Token::Word 'continue' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'until' PPI::Token::Whitespace ' ' PPI::Structure::Condition ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Label 'LABEL:' PPI::Token::Whitespace ' ' PPI::Token::Word 'until' PPI::Token::Whitespace ' ' PPI::Structure::Condition ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Words 'qw{}' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Label 'LABEL:' PPI::Token::Whitespace ' ' PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Token::Operator '..' PPI::Token::Whitespace ' ' PPI::Token::Number '20' PPI::Token::Whitespace ' ' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Token::Word 'state' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'for' PPI::Token::Whitespace ' ' PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'for' PPI::Token::Whitespace ' ' PPI::Token::Word 'state' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'for' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'for' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Words 'qw' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Word 'for' PPI::Token::Whitespace ' ' PPI::Structure::For ( ... ) PPI::Statement::Variable PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$a' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Number '0' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Symbol '$a' PPI::Token::Whitespace ' ' PPI::Token::Operator '<' PPI::Token::Whitespace ' ' PPI::Token::Number '10' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Symbol '$a' PPI::Token::Operator '++' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI-1.220/t/data/05_lexer/05_compound_loops.code0000755000175100010010000000055512426751160016067 0ustar while (1) {} while (1) {} continue {} LABEL: while (1) {} LABEL: while (1) {} continue {} until (1) {} LABEL: until (1) {} foreach qw{} {} foreach () {} LABEL: foreach $foo ( 1 .. 20 ) { } foreach my $foo () {} foreach state $foo () {} for my $foo () {} for state $foo () {} foreach $foo () {} for $foo () {} for $foo qw {} for (my $a = 0; $a < 10; $a++) { } PPI-1.220/t/data/05_lexer/08_subroutines.code0000755000175100010010000000010212306717230015375 0ustar BEGIN {} sub BEGIN {} sub {}; sub () {}; sub foo {} sub foo () {} PPI-1.220/t/data/05_lexer/04_anonymous_subroutines.dump0000755000175100010010000000206112306717230017542 0ustar PPI::Document PPI::Statement::Variable PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$a' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$b' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Word 'sub' PPI::Token::Prototype '($)' PPI::Structure::Block { ... } PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$c' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Prototype '(&$@)' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/0000755000175100010010000000000012430470371012720 5ustar PPI-1.220/t/data/08_regression/41_scalar_hash.dump0000755000175100010010000000044712306717230016373 0ustar PPI::Document PPI::Statement PPI::Token::Word 'scalar' PPI::Token::Whitespace ' ' PPI::Structure::Constructor { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Symbol '%x' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/23_rt_cpan_8752.dump0000755000175100010010000000106012306717230016226 0ustar PPI::Document PPI::Statement PPI::Token::Word 'ok' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Statement PPI::Token::Word 'die' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Quote::Double '"goodbye"' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n'PPI-1.220/t/data/08_regression/32_readline.dump0000755000175100010010000000066212306717230015705 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::QuoteLike::Readline '<$fh1>' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::QuoteLike::Readline '<$fh2>' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/42_numeric_package.dump0000755000175100010010000000031412306717230017232 0ustar PPI::Document PPI::Statement::Package PPI::Token::Word 'package' PPI::Token::Whitespace ' ' PPI::Token::Word 'Foo::100' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/38_multiply.code0000755000175100010010000000000512306717230015743 0ustar 2*fooPPI-1.220/t/data/08_regression/09_for_var.code0000755000175100010010000000001712306717230015523 0ustar for $foo () {} PPI-1.220/t/data/08_regression/01_rt_cpan_19629.code0000755000175100010010000000001412306717230016252 0ustar (0) || (1); PPI-1.220/t/data/08_regression/14_minus.code0000755000175100010010000000000412306717230015210 0ustar 1-1 PPI-1.220/t/data/08_regression/38_multiply.dump0000755000175100010010000000017012306717230016001 0ustar PPI::Document PPI::Statement PPI::Token::Number '2' PPI::Token::Operator '*' PPI::Token::Word 'foo' PPI-1.220/t/data/08_regression/15_dash_t.dump0000755000175100010010000000017712306717230015366 0ustar PPI::Document PPI::Statement PPI::Token::Operator '-t' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/27_constant_hash.code0000755000175100010010000000007412306717230016724 0ustar use constant { foo => 'bar' }; my $code = { foo => 'bar' }; PPI-1.220/t/data/08_regression/22_hash_vs_brace.dump0000755000175100010010000000366012306717230016711 0ustar PPI::Document PPI::Statement PPI::Token::Word 'map' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Statement PPI::Token::Magic '$_' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'map' PPI::Structure::List ( ... ) PPI::Statement PPI::Structure::Block { ... } PPI::Statement PPI::Token::Magic '$_' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Statement PPI::Token::Magic '$_' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'foo' PPI::Structure::List ( ... ) PPI::Statement PPI::Structure::Constructor { ... } PPI::Statement PPI::Token::Magic '$_' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/13_goto.dump0000755000175100010010000000061712306717230015071 0ustar PPI::Document PPI::Statement PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement::Break PPI::Token::Word 'goto' PPI::Token::Whitespace ' ' PPI::Token::Word 'FOO' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/43_nonblock_map.dump0000755000175100010010000000127212306717230016564 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Operator '=' PPI::Token::Word 'map' PPI::Token::Regexp::Match '/bar/' PPI::Token::Operator ',' PPI::Token::Symbol '@foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Word 'map' PPI::Token::Whitespace ' ' PPI::Token::Regexp::Match '/bar/' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/07_partial_quote_single.dump0000755000175100010010000000021312306717230020326 0ustar PPI::Document PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Quote::Single ''Hello...' PPI-1.220/t/data/08_regression/24_compound.code0000755000175100010010000000003012306717230015701 0ustar eval( {some_code() } ); PPI-1.220/t/data/08_regression/34_attr_whitespace.code0000755000175100010010000000010012306717230017242 0ustar sub foo: Attr { } sub bar : Attr(x y) { } sub baz : Attr( ) { } PPI-1.220/t/data/08_regression/08_partial_regex_substitution.dump0000755000175100010010000000031212306717230021577 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=~' PPI::Token::Whitespace ' ' PPI::Token::Regexp::Substitute 's' PPI-1.220/t/data/08_regression/29_chained_casts.code0000755000175100010010000000002212306717230016653 0ustar my $bar = \%*$foo;PPI-1.220/t/data/08_regression/26_rt_cpan_23253.code0000755000175100010010000000006612306717230016254 0ustar print $h{local}, $h{my}, $h{our}, $h{state}, $h{foo}; PPI-1.220/t/data/08_regression/01_rt_cpan_19629.dump0000755000175100010010000000061212306717230016311 0ustar PPI::Document PPI::Statement PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Number '0' PPI::Token::Whitespace ' ' PPI::Token::Operator '||' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n'PPI-1.220/t/data/08_regression/24_compound.dump0000755000175100010010000000070512306717230015745 0ustar PPI::Document PPI::Statement PPI::Token::Word 'eval' PPI::Structure::List ( ... ) PPI::Statement::Compound PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Statement PPI::Token::Word 'some_code' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/11_multiply_vs_glob_cast.dump0000755000175100010010000000027612306717230020524 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$one' PPI::Token::Operator '*' PPI::Token::Symbol '$two' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/25_hash_block.code0000755000175100010010000000003112306717230016154 0ustar $x = { f => { f => 1 } } PPI-1.220/t/data/08_regression/40_foreach_eval.code0000755000175100010010000000005312306717230016476 0ustar foreach my $thingy ( eval { bar; } ) { 1 } PPI-1.220/t/data/08_regression/21_list_of_refs.dump0000755000175100010010000000073612306717230016600 0ustar PPI::Document PPI::Statement PPI::Structure::List ( ... ) PPI::Statement PPI::Structure::Constructor [ ... ] PPI::Token::Operator ',' PPI::Structure::Constructor [ ... ] PPI::Token::Structure ';' PPI::Statement PPI::Structure::List ( ... ) PPI::Statement PPI::Structure::Constructor { ... } PPI::Token::Operator ',' PPI::Structure::Constructor { ... } PPI::Token::Structure ';' PPI-1.220/t/data/08_regression/12_pow.dump0000755000175100010010000000030012306717230014712 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$one' PPI::Token::Operator '**' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$two' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/18_decimal_point.code0000755000175100010010000000000512306717230016671 0ustar .1234PPI-1.220/t/data/08_regression/43_nonblock_map.code0000755000175100010010000000005412306717230016526 0ustar @foo=map/bar/,@foo; @foo = map /bar/, @foo; PPI-1.220/t/data/08_regression/36_begin_label.dump0000755000175100010010000000122112306717230016341 0ustar PPI::Document PPI::Statement::Compound PPI::Token::Label 'BEGIN:' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI::Statement::Compound PPI::Token::Label 'BEGIN :' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/39_foreach_our.dump0000755000175100010010000000064512306717230016426 0ustar PPI::Document PPI::Statement::Compound PPI::Token::Word 'for' PPI::Token::Whitespace ' ' PPI::Token::Word 'our' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$k' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/29_magic_carat.dump0000755000175100010010000000033312306717230016355 0ustar PPI::Document PPI::Statement PPI::Token::Magic '$^X' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/05_rt_cpan_13425.dump0000755000175100010010000000101612306717230016300 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$p' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'package' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$p' PPI::Structure::Subscript { ... } PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Word 'package' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/33_magic_carat_long.dump0000755000175100010010000000041312306717230017366 0ustar PPI::Document PPI::Statement PPI::Token::Magic '$^WIDE_SYSTEM_CALLS' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/16_sub_declaration.dump0000755000175100010010000000074712306717230017266 0ustar PPI::Document PPI::Statement::Compound PPI::Structure::Block { ... } PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Number '123' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/19_long_operators.code0000755000175100010010000000000712306717230017122 0ustar $a /= 2PPI-1.220/t/data/08_regression/02_rt_cpan_9582.code0000755000175100010010000000016312306717230016175 0ustar y {abc} {def}; $foo or $bar; sub y { 1 }; sub or { 1 }; foo->y(); foo->or(); y => 1; $foo->{q}; foo => q'not bar'; PPI-1.220/t/data/08_regression/19_long_operators2.code0000755000175100010010000000000712306717230017204 0ustar $a *= 2PPI-1.220/t/data/08_regression/10_leading_regexp.dump0000755000175100010010000000046312306717230017072 0ustar PPI::Document PPI::Statement PPI::Token::Regexp::Match '/./' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/14b_minus.code0000755000175100010010000000001612306717230015355 0ustar @{$arr_ref}-1 PPI-1.220/t/data/08_regression/10_leading_regexp.code0000755000175100010010000000001612306717230017031 0ustar /./ ; print 1 PPI-1.220/t/data/08_regression/31_hash_carat_H.dump0000755000175100010010000000023712306717230016463 0ustar PPI::Document PPI::Statement PPI::Token::Magic '%^H' PPI::Token::Operator '=' PPI::Structure::List ( ... ) PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/29_magic_carat.code0000755000175100010010000000001012306717230016312 0ustar $^X = 1 PPI-1.220/t/data/08_regression/17_scope.dump0000755000175100010010000000067412306717230015241 0ustar PPI::Document PPI::Statement::Compound PPI::Token::Label 'SCOPE:' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\t' PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n'PPI-1.220/t/data/08_regression/37_partial_prototype.code0000755000175100010010000000000512306717230017644 0ustar sub (PPI-1.220/t/data/08_regression/04_tinderbox.code0000755000175100010010000000011712306717230016057 0ustar $#arrayindex; $foo %2; $foo &64; $foo *2; %::; $'foo; $::foo; $::|=1; @0 = @c; PPI-1.220/t/data/08_regression/32_readline.code0000755000175100010010000000003012306717230015637 0ustar @foo = (<$fh1>, <$fh2>) PPI-1.220/t/data/08_regression/28_backref_style_heredoc.code0000755000175100010010000000002012306717230020366 0ustar <<\EOF; foo EOF PPI-1.220/t/data/08_regression/25_hash_block.dump0000755000175100010010000000147712306717230016226 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$x' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Structure::Constructor { ... } PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Word 'f' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Structure::Constructor { ... } PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Word 'f' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/30_hash_bang.dump0000755000175100010010000000034012306717230016023 0ustar PPI::Document PPI::Statement PPI::Token::Magic '%!' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/06_partial_quote_double.dump0000755000175100010010000000021312306717230020316 0ustar PPI::Document PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Quote::Double '"Hello...' PPI-1.220/t/data/08_regression/04_tinderbox.dump0000755000175100010010000000274412306717230016122 0ustar PPI::Document PPI::Statement PPI::Token::ArrayIndex '$#arrayindex' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '%' PPI::Token::Number '2' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '&' PPI::Token::Number '64' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '*' PPI::Token::Number '2' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '%::' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$'foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$::foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Magic '$::|' PPI::Token::Operator '=' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Magic '@0' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Token::Symbol '@c' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/08_partial_regex_substitution.code0000755000175100010010000000001112306717230021540 0ustar $foo =~ sPPI-1.220/t/data/08_regression/35_attr_perlsub.dump0000755000175100010010000000274112306717230016633 0ustar PPI::Document PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'fnord' PPI::Token::Whitespace ' ' PPI::Token::Prototype '(&\%)' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'switch(10,foo(7,3))' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'expensive' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'xyzzy' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute '_5x5' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Operator '...' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'plugh' PPI::Token::Whitespace ' ' PPI::Token::Prototype '()' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'Ugly('\(")' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Attribute 'Bad' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/34_attr_whitespace.dump0000755000175100010010000000215612306717230017312 0ustar PPI::Document PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'Attr' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'bar' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'Attr(x\ny)' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'baz' PPI::Token::Whitespace ' ' PPI::Token::Operator ':' PPI::Token::Whitespace ' ' PPI::Token::Attribute 'Attr(\n)' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/20_hash_constructor.code0000755000175100010010000000000512306717230017443 0ustar $a={}PPI-1.220/t/data/08_regression/05_rt_cpan_13425.code0000755000175100010010000000003412306717230016244 0ustar $p{package}; $p{ package }; PPI-1.220/t/data/08_regression/15_dash_t.code0000755000175100010010000000000412306717230015320 0ustar -t; PPI-1.220/t/data/08_regression/40_foreach_eval.dump0000755000175100010010000000155612306717230016542 0ustar PPI::Document PPI::Statement::Compound PPI::Token::Word 'foreach' PPI::Token::Whitespace ' ' PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$thingy' PPI::Token::Whitespace ' ' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Word 'eval' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Word 'bar' PPI::Token::Structure ';' PPI::Token::Whitespace ' ' PPI::Token::Whitespace ' ' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/16_sub_declaration.code0000755000175100010010000000003012306717230017214 0ustar {print 123;} sub foo {} PPI-1.220/t/data/08_regression/06_partial_quote_double.code0000755000175100010010000000001712306717230020265 0ustar print "Hello...PPI-1.220/t/data/08_regression/26_rt_cpan_23253.dump0000755000175100010010000000211212306717230016301 0ustar PPI::Document PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$h' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'local' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$h' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'my' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$h' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'our' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$h' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'state' PPI::Token::Operator ',' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$h' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/28_backref_style_heredoc.dump0000755000175100010010000000020212306717230020423 0ustar PPI::Document PPI::Statement PPI::Token::HereDoc '<<\EOF' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/41_scalar_hash.code0000755000175100010010000000001612306717230016330 0ustar scalar { %x } PPI-1.220/t/data/08_regression/21_list_of_refs.code0000755000175100010010000000002012306717230016527 0ustar ([],[]);({},{});PPI-1.220/t/data/08_regression/01_rt_cpan_19629b.code0000755000175100010010000000001612306717230016416 0ustar {(0) || (1);} PPI-1.220/t/data/08_regression/02_rt_cpan_9582.dump0000755000175100010010000000442412306717230016234 0ustar PPI::Document PPI::Statement PPI::Token::Regexp::Transliterate 'y {abc} {def}' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator 'or' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$bar' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'y' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Statement::Null PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Sub PPI::Token::Word 'sub' PPI::Token::Whitespace ' ' PPI::Token::Word 'or' PPI::Token::Whitespace ' ' PPI::Structure::Block { ... } PPI::Token::Whitespace ' ' PPI::Statement PPI::Token::Number '1' PPI::Token::Whitespace ' ' PPI::Statement::Null PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'foo' PPI::Token::Operator '->' PPI::Token::Word 'y' PPI::Structure::List ( ... ) PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'foo' PPI::Token::Operator '->' PPI::Token::Word 'or' PPI::Structure::List ( ... ) PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'y' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Operator '->' PPI::Structure::Subscript { ... } PPI::Statement::Expression PPI::Token::Word 'q' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Quote::Literal 'q'not bar'' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/18_decimal_point.dump0000755000175100010010000000010712306717230016727 0ustar PPI::Document PPI::Statement PPI::Token::Number::Float '.1234' PPI-1.220/t/data/08_regression/11_multiply_vs_glob_cast.code0000755000175100010010000000001312306717230020456 0ustar $one*$two; PPI-1.220/t/data/08_regression/39_foreach_our.code0000755000175100010010000000002512306717230016363 0ustar for our $k (@foo) {} PPI-1.220/t/data/08_regression/03_rt_cpan_9614.dump0000755000175100010010000000306412306717230016230 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '<<' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '<<' PPI::Token::Whitespace '\n' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Symbol '$foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '<<' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$bar' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Operator '<<' PPI::Token::Whitespace ' ' PPI::Token::Word 'foo' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::HereDoc '<' PPI::Token::Whitespace ' ' PPI::Token::Quote::Single ''bar'' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement::Variable PPI::Token::Word 'my' PPI::Token::Whitespace ' ' PPI::Token::Symbol '$code' PPI::Token::Whitespace ' ' PPI::Token::Operator '=' PPI::Token::Whitespace ' ' PPI::Structure::Constructor { ... } PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Word 'foo' PPI::Token::Whitespace ' ' PPI::Token::Operator '=>' PPI::Token::Whitespace ' ' PPI::Token::Quote::Single ''bar'' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/08_regression/03_rt_cpan_9614.code0000755000175100010010000000013512306717230016171 0ustar $foo << 1; $foo << 1; $foo << $bar; << foo; < 1} @foo; map({$_ => 1} @foo); foo {$_ => 1}, @foo; foo({$_ => 1}, @foo); PPI-1.220/t/data/08_regression/33_magic_carat_long.code0000755000175100010010000000003112306717230017327 0ustar $^WIDE_SYSTEM_CALLS = 1; PPI-1.220/t/data/24_v6/0000755000175100010010000000000012430470371011071 5ustar PPI-1.220/t/data/24_v6/Grammar.pm0000755000175100010010000004325412306717230013030 0ustar use v6-alpha; grammar KindaPerl6::Grammar { use KindaPerl6::Grammar::Regex; use KindaPerl6::Grammar::Mapping; use KindaPerl6::Grammar::Control; use KindaPerl6::Grammar::Parameters; use KindaPerl6::Grammar::Term; use KindaPerl6::Grammar::Statements; use KindaPerl6::Grammar::Quote; use KindaPerl6::Grammar::Sub; use KindaPerl6::Grammar::Token; my $Class_name; # for diagnostic messages sub get_class_name { $Class_name }; token ident_digit { [ [ | _ | ] | <''> ] }; token ident { | [ | _ ] [ ':<' '>' | '' ] | ¢ }; token full_ident { [ <'::'> | <''> ] }; token namespace { | '::' [ | { return [ $$, @( $$ ) ] } | { return [ $$ ] } ] | { return [ ] } }; token to_line_end { | \N | <''> }; token pod_begin { | \n <'=end'> | . }; token pod_other { | \n <'=cut'> | . }; token ws { [ | <'#'> | \n [ | <'=begin'> | <'=kwid'> | <'=pod'> | <'=for'> | <'=head1'> | <''> ] | \s ] [ | <''> ] }; token opt_ws { | <''> }; token opt_ws2 { | <''> }; token opt_ws3 { | <''> }; token parse { | [ | { return [ $$, @( $$ ) ] } | { return [ $$ ] } ] | { return [] } }; token unit_type { <'class'> | <'grammar'> | <'role'> | <'module'> }; token trait_auxiliary { is | does | meta }; token class_trait { { return [ $$, $$ ] } }; token class_traits { | [ | { return [ $$, @( $$ ) ] } | { return [ $$ ] } ] | { return [] } }; token comp_unit { [\; | <''> ] [ <'use'> <'v6-'> \; | <''> ] [ <'{'> { $Class_name := ~$ } { COMPILER::add_pad( $Class_name ); } <'}'> [\; | <''> ] { my $env := @COMPILER::PAD[0]; COMPILER::drop_pad(); return ::CompUnit( 'unit_type' => $$, 'name' => $$, 'traits' => $$, 'attributes' => { }, 'methods' => { }, 'body' => ::Lit::Code( pad => $env, state => { }, sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ), body => $$, ), ) } ] | [ { $Class_name := 'Main'; COMPILER::add_pad( $Class_name ); } { my $env := @COMPILER::PAD[0]; COMPILER::drop_pad(); return ::CompUnit( 'unit_type' => 'module', 'name' => 'Main', 'traits' => [], 'attributes' => { }, 'methods' => { }, 'body' => ::Lit::Code( pad => $env, state => { }, sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ), body => $$, ), ) } ] }; token infix_op { <'+'> | <'-'> | <'*'> | <'/'> | eq | ne | <'=='> | <'!='> | <'&&'> | <'||'> | <'~~'> | <'~'> | '<=>' | '<=' | '>=' | '<' | '>' | '&' | '^' | '|' | '..' }; token hyper_op { <'>>'> | <''> }; token prefix_op { [ '$' | '@' | '%' | '?' | '!' | '++' | '--' | '+' | '-' | '~' | '|' ] }; token declarator { <'my'> | <'state'> | <'has'> | <'our'> }; token opt_declarator { {return $$;} | {return '';} }; token exp2 { { return $$ } }; token exp { # { say 'exp: going to match at ', $/.to; } [ <'??'> [ <'!!'> { # XXX TODO - expand macro # is &ternary: a macro? my $macro_ast := ::Var( 'sigil' => '&', 'twigil' => '', 'name' => 'ternary:', namespace => [ ] ); my $macro := COMPILER::get_var( $macro_ast ); if defined($macro) { # fetch the macro my $sub := ( @COMPILER::PAD[0] ).eval_ast( $macro_ast ); Main::expand_macro( $sub, $$, $$, $$ ); # say "# ternary macro = ", $sub.perl; } return ::Apply( 'code' => ::Var( 'sigil' => '&', 'twigil' => '', 'name' => 'ternary:', namespace => [ ] ), 'arguments' => [ $$, $$, $$ ], ); } | { say '*** Syntax error in ternary operation' } ] | { return ::Apply( 'code' => ::Var( 'sigil' => '&', 'twigil' => '', 'name' => 'infix:<' ~ $ ~ '>', namespace => [ ] ), 'arguments' => [ $$, $$ ], ) } | <'::='> { my $bind := ::Bind( 'parameters' => $$, 'arguments' => $$); COMPILER::begin_block( $bind ); # ::= compile-time return $bind; # := run-time } | <':='> { return ::Bind( 'parameters' => $$, 'arguments' => $$) } | <'='> { return ::Assign( 'parameters' => $$, 'arguments' => $$) } | { return $$ } ] }; token opt_ident { | { return $$ } | <''> { return 'postcircumfix:<( )>' } }; token term_meth { [ \. [ \( \) # { say 'found parameter list: ', $.perl } | \: | { return ::Call( 'invocant' => ::Proto( 'name' => ~$ ), 'method' => $$, 'arguments' => undef, 'hyper' => $$, ) } ] { return ::Call( 'invocant' => ::Proto( 'name' => ~$ ), 'method' => $$, 'arguments' => $$, 'hyper' => $$, ) } ] | [ \. # $obj.(42) [ \( # { say 'testing exp_parameter_list at ', $/.to } \) # { say 'found parameter list: ', $.perl } | \: | { return ::Call( 'invocant' => $$, 'method' => $$, 'arguments' => undef, 'hyper' => $$, ) } ] { return ::Call( 'invocant' => $$, 'method' => $$, 'arguments' => $$, 'hyper' => $$, ) } | \[ \] { return ::Index( 'obj' => $$, 'index' => $$ ) } # $a[exp] | \{ \} { return ::Lookup( 'obj' => $$, 'index' => $$ ) } # $a{exp} | \< \> { return ::Lookup( 'obj' => $$, 'index' => ::Val::Buf( 'buf' => ~$ ), ) } # $a | { return $$ } ] }; token sub_or_method_name { [ \. | <''> ] }; token opt_type { | [ <'::'> | <''> ] { return $$ } | <''> { return '' } }; token use_from_perl5 { ':from' {return 1} | {return 0} } #token index { XXX } #token lookup { XXX } token sigil { \$ |\% |\@ |\& }; token twigil { [ \. | \! | \^ | \* ] | <''> }; # XXX unused? # token var_name { | <'/'> | }; # used in Term.pm token undeclared_var { { # no pre-declaration checks return ::Var( sigil => ~$, twigil => ~$, name => ~$, namespace => $$, ) } }; token var { '/' { return ::Var( sigil => ~$, twigil => '', name => '/', namespace => [ ], ) } | { # check for pre-declaration return COMPILER::get_var( ::Var( sigil => ~$, twigil => ~$, name => ~$, namespace => $$, ) ) } }; token val { | { return $$ } # undef # | $ := # (not exposed to the outside) | { return $$ } # 123 | { return $$ } # True, False | { return $$ } # 123.456 | { return $$ } # 'moose' }; token val_bit { | True { return ::Val::Bit( 'bit' => 1 ) } | False { return ::Val::Bit( 'bit' => 0 ) } }; token val_undef { undef { return ::Val::Undef( ) } }; token val_num { XXX { return 'TODO: val_num' } }; token digits { \d [ | <''> ] }; token val_int { { return ::Val::Int( 'int' => ~$/ ) } }; # XXX obsolete? token exp_seq { | # { say 'exp_seq: matched ' } [ | \, [ \, | <''> ] { return [ $$, @( $$ ) ] } | [ \, | <''> ] { return [ $$ ] } ] | # { say 'exp_seq: end of match' } { return [] } }; token lit { #| { return $$ } # (a, b, c) #| { return $$ } # [a, b, c] #| { return $$ } # {a => x, b => y} #| { return $$ } # sub $x {...} | { return $$ } # ::Tree(a => x, b => y); }; token lit_seq { XXX { return 'TODO: lit_seq' } }; token lit_array { XXX { return 'TODO: lit_array' } }; token lit_hash { XXX { return 'TODO: lit_hash' } }; token lit_code { XXX { return 'TODO - Lit::Code' } }; token lit_object { <'::'> \( [ \) { # say 'Parsing Lit::Object ', $$, ($$).perl; return ::Lit::Object( 'class' => $$, 'fields' => $$ ) } | { say '*** Syntax Error parsing Constructor ',$$; die() } ] }; #token bind { # <':='> # { # return ::Bind( # 'parameters' => $$, # 'arguments' => $$, # ) # } #}; token call { \. \( \) { return ::Call( 'invocant' => $$, 'method' => $$, 'arguments' => $$, ) } }; token apply { [ [ \( \) | ] { return ::Apply( 'code' => COMPILER::get_var( ::Var( sigil => '&', twigil => '', name => $$, namespace => $$, ) ), 'arguments' => $$, ) } | { return ::Apply( 'code' => COMPILER::get_var( ::Var( sigil => '&', twigil => '', name => $$, namespace => $$, ) ), 'arguments' => [], ) } ] }; token opt_name { | '' }; token invocant { | \: { return $$ } | { return undef } }; token capture { # TODO - exp_seq / exp_mapping == positional / named # XXX use exp_parameter_list instead | \: { return ::Capture( 'invocant' => $$, 'array' => $$, 'hash' => [ ] ); } | { return ::Capture( 'invocant' => undef, 'array' => [ ], 'hash' => $$ ); } # ??? doesn't work here #| # { return ::Capture( 'invocant' => undef, 'array' => $$, 'hash' => [ ] ); } }; token sig { # TODO - exp_seq / exp_mapping == positional / named # ??? exp_parameter_list { # say ' invocant: ', ($$).perl; # say ' positional: ', ($$).perl; return ::Sig( 'invocant' => $$, 'positional' => $$, 'named' => { } ); } }; token base_class { } token subset { # example: subset Not_x of Str where { $_ ne 'x' } subset of where \{ # { say ' parsing statement list ' } { COMPILER::add_pad(); } [ \} | { say '*** Syntax Error in subset \'', get_class_name(), '.', $$, '\' near pos=', $/.to; die 'error in Block'; } ] { # say ' block: ', ($$).perl; my $env := @COMPILER::PAD[0]; COMPILER::drop_pad(); return ::Subset( 'name' => $$, 'base_class' => ::Proto( name => $$ ), 'block' => ::Sub( 'name' => undef, 'block' => ::Lit::Code( pad => $env, state => { }, sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ), body => $$, ), ), ); } } token begin_block { BEGIN \{ { COMPILER::add_pad(); } [ \} | { say '*** Syntax Error in BEGIN near pos=', $/.to; die 'error in Block'; } ] { # say ' block: ', ($$).perl; my $env := @COMPILER::PAD[0]; #print " grammar: dropping pad\n"; COMPILER::drop_pad(); #say "BEGIN block"; #print " grammar: entering begin block\n"; return COMPILER::begin_block( # $env, ::Lit::Code( pad => $env, state => { }, sig => ::Sig( 'invocant' => undef, 'positional' => [ ], 'named' => { } ), body => $$, ), ); } }; token check_block { CHECK \{ [ \} | { say '*** Syntax Error in CHECK block'; die 'error in Block'; } ] { #say "CHECK block"; return COMPILER::check_block( $$ ); } }; } =begin =head1 NAME KindaPerl6::Grammar - Grammar for KindaPerl6 =head1 SYNOPSIS my $match := $source.parse; ($$match).perl; # generated KindaPerl6 AST =head1 DESCRIPTION This module generates a syntax tree for the KindaPerl6 compiler. =head1 AUTHORS The Pugs Team Eperl6-compiler@perl.orgE. =head1 SEE ALSO The Perl 6 homepage at L. The Pugs homepage at L. =head1 COPYRIGHT Copyright 2006, 2007 by Flavio Soibelmann Glock, Audrey Tang and others. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =end PPI-1.220/t/data/24_v6/Simple.pm0000755000175100010010000000002312306717230012656 0ustar use v6-alpha; foo PPI-1.220/t/data/15_transform/0000755000175100010010000000000012430470371012551 5ustar PPI-1.220/t/data/15_transform/sample1.pm_out0000755000175100010010000000001512306717230015337 0ustar my$foo='bar';PPI-1.220/t/data/15_transform/sample1.pm0000755000175100010010000000002312306717230014447 0ustar my $foo = 'bar'; PPI-1.220/t/data/13_data/0000755000175100010010000000000012430470371011445 5ustar PPI-1.220/t/data/13_data/Foo.pm0000755000175100010010000000011012306717230012521 0ustar package Foo; print "Hello World!\n"; __DATA__ This is data So is this PPI-1.220/t/data/11_util/0000755000175100010010000000000012430470371011507 5ustar PPI-1.220/t/data/11_util/test.pm0000755000175100010010000000003012306717230013020 0ustar print "Hello World!\n"; PPI-1.220/t/data/basic.pl0000755000175100010010000000007412251445131011650 0ustar #!/usr/bin/perl if ( 1 ) { print "Hello World!\n"; } 1; PPI-1.220/t/data/26_bom/0000755000175100010010000000000012430470371011315 5ustar PPI-1.220/t/data/26_bom/utf8.code0000755000175100010010000000001412306717230013035 0ustar print 1; PPI-1.220/t/data/26_bom/utf8.dump0000755000175100010010000000032612306717230013076 0ustar PPI::Document PPI::Token::BOM '' PPI::Statement PPI::Token::Word 'print' PPI::Token::Whitespace ' ' PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/07_token/0000755000175100010010000000000012430470371011657 5ustar PPI-1.220/t/data/07_token/range_operator.code0000755000175100010010000000002412306717230015521 0ustar 1..2; 12.34..56.78; PPI-1.220/t/data/07_token/hex.dump0000755000175100010010000000013512306717230013334 0ustar PPI::Document PPI::Statement PPI::Token::Number::Hex '0x' PPI::Token::Word 'g' PPI-1.220/t/data/07_token/smart_match.dump0000755000175100010010000000023712306717230015055 0ustar PPI::Document PPI::Statement PPI::Token::Symbol '@foo' PPI::Token::Operator '~~' PPI::Token::Symbol '@bar' PPI::Token::Whitespace '\n' PPI-1.220/t/data/07_token/range_operator.dump0000755000175100010010000000057212306717230015564 0ustar PPI::Document PPI::Statement PPI::Token::Number '1' PPI::Token::Operator '..' PPI::Token::Number '2' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number::Float '12.34' PPI::Token::Operator '..' PPI::Token::Number::Float '56.78' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/07_token/smart_match.code0000755000175100010010000000001312306717230015012 0ustar @foo~~@bar PPI-1.220/t/data/07_token/exp.dump0000755000175100010010000000275612306717230013357 0ustar PPI::Document PPI::Statement PPI::Token::Number::Exp '0E0' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number::Exp '1.0e-02' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number::Exp '1.0E-2' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number::Exp '1e+10' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number::Exp '1E+10' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'e' PPI::Token::Number '-1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number '0' PPI::Token::Whitespace ' ' PPI::Token::Word 'e0' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number '1' PPI::Token::Operator '.' PPI::Token::Word 'e' PPI::Structure::List ( ... ) PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number '1' PPI::Token::Operator '.' PPI::Token::Word 'exp' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Number '1' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Number::Exp '1__E+__1__0' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI-1.220/t/data/07_token/hex.code0000755000175100010010000000000312306717230013273 0ustar 0xgPPI-1.220/t/data/07_token/exp.code0000755000175100010010000000011512306717230013307 0ustar 0E0; 1.0e-02; 1.0E-2; 1e+10; 1E+10; e-1; 0 e0; 1.e(); 1.exp(1); 1__E+__1__0; PPI-1.220/t/data/27_complete/0000755000175100010010000000000012430470371012351 5ustar PPI-1.220/t/data/27_complete/01y_helloworld.code0000755000175100010010000000005112306717230016050 0ustar #!/usr/bin/perl print "Hello World!\n"; PPI-1.220/t/data/27_complete/02n_helloworld.code0000755000175100010010000000005012306717230016035 0ustar #!/usr/bin/perl print "Hello World!\n" PPI-1.220/t/data/03_document/0000755000175100010010000000000012430470371012351 5ustar PPI-1.220/t/data/03_document/empty.dat0000755000175100010010000000000012306717230014172 0ustar PPI-1.220/t/data/03_document/test.dat0000755000175100010010000000010112306717230014015 0ustar #!/usr/bin/perl # A simple test script print "Hello World!\n"; PPI-1.220/t/ppi_token_quote_interpolate.t0000755000175100010010000000164312310327137015325 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Quote::Interpolate use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 9; use Test::NoWarnings; use PPI; STRING: { my $Document = PPI::Document->new( \"print qq{foo}, qq!bar!, qq ;" ); isa_ok( $Document, 'PPI::Document' ); my $Interpolate = $Document->find('Token::Quote::Interpolate'); is( scalar(@$Interpolate), 3, '->find returns three objects' ); isa_ok( $Interpolate->[0], 'PPI::Token::Quote::Interpolate' ); isa_ok( $Interpolate->[1], 'PPI::Token::Quote::Interpolate' ); isa_ok( $Interpolate->[2], 'PPI::Token::Quote::Interpolate' ); is( $Interpolate->[0]->string, 'foo', '->string returns as expected' ); is( $Interpolate->[1]->string, 'bar', '->string returns as expected' ); is( $Interpolate->[2]->string, 'foo', '->string returns as expected' ); } PPI-1.220/t/27_complete.t0000755000175100010010000000306512251445131011631 0ustar #!/usr/bin/perl # Testing for the PPI::Document ->complete method use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; # This test uses a series of ordered files, containing test code. # The letter after the number acts as a boolean yes/no answer to # "Is this code complete" my @files = find_files( catdir( 't', 'data', '27_complete' ) ); my $tests = (scalar(@files) * 2) + 2; plan( tests => $tests ); ##################################################################### # Resource Location ok( scalar(@files), 'Found at least one ->complete test file' ); foreach my $file ( @files ) { # Load the document my $document = PPI::Document->new( $file ); isa_ok( $document, 'PPI::Document' ); # Test if complete or not my $got = !! ($document->complete); my $expected = !! ($file =~ /\d+y\w+\.code$/); my $isnot = ($got == $expected) ? 'is' : 'is NOT'; is( $got, $expected, "File $file $isnot complete" ); } ##################################################################### # Support Functions sub find_files { my $testdir = shift; # Does the test directory exist? -e $testdir and -d $testdir and -r $testdir or die "Failed to find test directory $testdir"; # Find the .code test files opendir( TESTDIR, $testdir ) or die "opendir: $!"; my @perl = map { catfile( $testdir, $_ ) } sort grep { /\.(?:code|pm|t)$/ } readdir(TESTDIR); closedir( TESTDIR ) or die "closedir: $!"; return @perl; } PPI-1.220/t/18_cache.t0000755000175100010010000001275112426751160011074 0ustar #!/usr/bin/perl # Test compatibility with Storable use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 43; use Test::NoWarnings; use File::Spec::Unix; use File::Spec::Functions ':ALL'; use Scalar::Util 'refaddr'; use File::Remove (); use PPI::Document (); use PPI::Cache (); use constant VMS => !! ( $^O eq 'VMS' ); use constant FILE => VMS ? 'File::Spec::Unix' : 'File::Spec'; my $this_file = FILE->catdir( 't', 'data', '03_document', 'test.dat' ); my $cache_dir = FILE->catdir( 't', 'data', '18_cache' ); # Define, create and clear the test cache File::Remove::remove( \1, $cache_dir ) if -e $cache_dir; ok( ! -e $cache_dir, 'The cache path does not exist' ); END { File::Remove::remove( \1, $cache_dir ) if -e $cache_dir } ok( scalar(mkdir $cache_dir), 'mkdir $cache_dir returns true' ); ok( -d $cache_dir, 'Verified the cache path exists' ); ok( -w $cache_dir, 'Can write to the cache path' ); my $sample_document = \'print "Hello World!\n";'; ##################################################################### # Basic Testing # Create a basic cache object my $Cache = PPI::Cache->new( path => $cache_dir, ); isa_ok( $Cache, 'PPI::Cache' ); is( scalar($Cache->path), $cache_dir, '->path returns the original path' ); is( scalar($Cache->readonly), '', '->readonly returns false by default' ); # Create a test document my $doc = PPI::Document->new( $sample_document ); isa_ok( $doc, 'PPI::Document' ); my $doc_md5 = '64568092e7faba16d99fa04706c46517'; is( $doc->hex_id, $doc_md5, '->hex_id specifically matches the UNIX newline md5' ); my $doc_file = catfile($cache_dir, '6', '64', '64568092e7faba16d99fa04706c46517.ppi'); my $bad_md5 = 'abcdef1234567890abcdef1234567890'; my $bad_file = catfile($cache_dir, 'a', 'ab', 'abcdef1234567890abcdef1234567890.ppi'); # Save to an arbitrary location ok( $Cache->_store($bad_md5, $doc), '->_store returns true' ); ok( -f $bad_file, 'Created file where expected' ); my $loaded = $Cache->_load($bad_md5); isa_ok( $loaded, 'PPI::Document' ); is_deeply( $doc, $loaded, '->_load loads the same document back in' ); # Store the test document in the cache in it's proper place is( scalar( $Cache->store_document($doc) ), 1, '->store_document(Document) returns true' ); ok( -f $doc_file, 'The document was stored in the expected location' ); # Check the _md5hex method is( PPI::Cache->_md5hex($sample_document), $doc_md5, '->_md5hex returns as expected for sample document' ); is( PPI::Cache->_md5hex($doc_md5), $doc_md5, '->_md5hex null transform works as expected' ); is( $Cache->_md5hex($sample_document), $doc_md5, '->_md5hex returns as expected for sample document' ); is( $Cache->_md5hex($doc_md5), $doc_md5, '->_md5hex null transform works as expected' ); # Retrieve the Document by content $loaded = $Cache->get_document( $sample_document ); isa_ok( $loaded, 'PPI::Document' ); is_deeply( $doc, $loaded, '->get_document(\$source) loads the same document back in' ); # Retrieve the Document by md5 directly $loaded = $Cache->get_document( $doc_md5 ); isa_ok( $loaded, 'PPI::Document' ); is_deeply( $doc, $loaded, '->get_document($md5hex) loads the same document back in' ); ##################################################################### # Empiric Testing # Load a test document twice, and see how many tokenizer objects get # created internally. is( PPI::Document->get_cache, undef, 'PPI::Document cache initially undef' ); ok( PPI::Document->set_cache( $Cache ), 'PPI::Document->set_cache returned true' ); isa_ok( PPI::Document->get_cache, 'PPI::Cache' ); is( refaddr($Cache), refaddr(PPI::Document->get_cache), '->get_cache returns the same cache object' ); SKIP: { skip("Test::SubCalls requires >= 5.6", 7 ) if $] < 5.006; require Test::SubCalls; # Set the tracking on the Tokenizer constructor ok( Test::SubCalls::sub_track( 'PPI::Tokenizer::new' ), 'Tracking calls to PPI::Tokenizer::new' ); Test::SubCalls::sub_calls( 'PPI::Tokenizer::new', 0 ); my $doc1 = PPI::Document->new( $this_file ); my $doc2 = PPI::Document->new( $this_file ); isa_ok( $doc1, 'PPI::Document' ); isa_ok( $doc2, 'PPI::Document' ); unless ( $doc1 and $doc2 ) { skip( "Skipping due to previous failures", 3 ); } Test::SubCalls::sub_calls( 'PPI::Tokenizer::new', 1, 'Two calls to PPI::Document->new results in one Tokenizer object creation' ); ok( refaddr($doc1) != refaddr($doc2), 'PPI::Document->new with cache enabled does NOT return the same object' ); is_deeply( $doc1, $doc2, 'PPI::Document->new with cache enabled returns two identical objects' ); } SKIP: { skip("Test::SubCalls requires >= 5.6", 8 ) if $] < 5.006; # Done now, can we clear the cache? is( PPI::Document->set_cache(undef), 1, '->set_cache(undef) returns true' ); is( PPI::Document->get_cache, undef, '->get_cache returns undef' ); # Next, test the import mechanism is( eval "use PPI::Cache path => '$cache_dir'; 1", 1, 'use PPI::Cache path => ...; succeeded' ); isa_ok( PPI::Document->get_cache, 'PPI::Cache' ); is( scalar(PPI::Document->get_cache->path), $cache_dir, '->path returns the original path' ); is( scalar(PPI::Document->get_cache->readonly), '', '->readonly returns false by default' ); # Does it still keep the previously cached documents Test::SubCalls::sub_reset( 'PPI::Tokenizer::new' ); my $doc3 = PPI::Document->new( $this_file ); isa_ok( $doc3, 'PPI::Document' ); Test::SubCalls::sub_calls( 'PPI::Tokenizer::new', 0, 'Tokenizer was not created. Previous cache used ok' ); } 1; PPI-1.220/t/24_v6.t0000755000175100010010000000144312251445131010347 0ustar #!/usr/bin/perl # Regression test of a Perl 5 grammar that exploded # with a "98 subroutine recursion" error in 1.201 use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 9; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; foreach my $file ( qw{ Simple.pm Grammar.pm } ) { my $path = catfile( qw{ t data 24_v6 }, $file ); ok( -f $path, "Found test file $file" ); my $doc = PPI::Document->new( $path ); isa_ok( $doc, 'PPI::Document' ); # Find the first Perl6 include my $include = $doc->find_first( 'PPI::Statement::Include::Perl6' ); isa_ok( $include, 'PPI::Statement::Include::Perl6' ); ok( scalar($include->perl6), 'use v6 statement has a working ->perl6 method', ); } PPI-1.220/t/ppi_token_prototype.t0000755000175100010010000000367012426751160013636 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Prototype use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 801; use Test::NoWarnings; use PPI; PARSING: { for my $name ( 'sub foo', 'sub foo ', 'sub', 'sub ', 'sub AUTOLOAD', 'sub AUTOLOAD ', 'sub DESTROY', 'sub DESTROY ', ) { for my $block ( '{1;}', ';' ) { for my $proto_and_expected ( [ '', '', '' ], [ '()', '()', '' ], [ '( )', '( )', '' ], [ ' () ',, '()', '' ], [ '(+@)', '(+@)', '+@' ], [ ' (+@) ', '(+@)', '+@' ], [ '(\[$;$_@])', '(\[$;$_@])', '\[$;$_@]' ], [ '(\ [ $ ])', '(\ [ $ ])', '\[$]' ], [ '(\\\ [ $ ])', '(\\\ [ $ ])', '\\\[$]' ], # nonsense, but perl accepts it [ '($ _ %)', '($ _ %)', '$_%' ], [ '( Z)', '( Z)', 'Z' ], # invalid chars in prototype [ '(!-=|)', '(!-=|)', '!-=|' ], # invalid chars in prototype [ '(()', '(()', '(' ], # perl refuses to compile this ) { my ( $code_prototype, $expected_content, $expected_prototype ) = @$proto_and_expected; my $code = "$name$code_prototype$block"; my $document = PPI::Document->new( \$code ); isa_ok( $document, 'PPI::Document', $code ); my $all_prototypes = $document->find( 'PPI::Token::Prototype' ); if ( $code_prototype eq '' ) { is( $all_prototypes, "", "$code: got no prototypes" ); } else { $all_prototypes = [] if !ref $all_prototypes; is( scalar(@$all_prototypes), 1, "$code: got exactly one prototype" ); my $prototype_obj = $all_prototypes->[0]; is( $prototype_obj, $expected_content, "$code: prototype object content matches" ); is( $prototype_obj->prototype, $expected_prototype, "$code: prototype characters match" ); } } } } } PPI-1.220/t/25_increment.t0000755000175100010010000000133312425223367012007 0ustar #!/usr/bin/perl # Given that we know the regression tests represent potentially # broken locations in the code, process every single transitional # state between an empty document and the entire file to make sure # all of them parse as legal documents and don't crash the parser. use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 3876; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use Params::Util qw{_INSTANCE}; use PPI::Lexer; use PPI::Dumper; use t::lib::PPI; ##################################################################### # Code/Dump Testing t::lib::PPI->increment_testdir(qw{ t data 08_regression }); PPI-1.220/t/05_lexer.t0000755000175100010010000000116612425223367011144 0ustar #!/usr/bin/perl # Compare a large number of specific constructs # with the expected Lexer dumps. use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use PPI::Lexer; use PPI::Dumper; ##################################################################### # Prepare use Test::More tests => 219; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use t::lib::PPI; ##################################################################### # Code/Dump Testing # ntests = 2 + 15 * nfiles t::lib::PPI->run_testdir( catdir( 't', 'data', '05_lexer' ) ); PPI-1.220/t/01_compile.t0000755000175100010010000000201712251445131011435 0ustar #!/usr/bin/perl # Formal testing for PPI # This test script only tests that the tree compiles use strict; use File::Spec::Functions ':ALL'; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 19; use Test::NoWarnings; # Check their perl version ok( $] >= 5.006, "Your perl is new enough" ); # Does the module load use_all_ok( qw{ PPI PPI::Tokenizer PPI::Lexer PPI::Dumper PPI::Find PPI::Normal PPI::Util PPI::Cache } ); sub use_all_ok { my @modules = @_; # Load each of the classes foreach my $module ( @modules ) { use_ok( $module ); } # Check that all of the versions match my $main_module = shift(@modules); my $expected = $main_module->VERSION; ok( $expected, "Found a version for the main module ($expected)" ); foreach my $module ( @modules ) { is( $module->VERSION, $expected, "$main_module->VERSION matches $module->VERSION ($expected)" ); } } ok( ! $PPI::XS::VERSION, 'PPI::XS is correctly NOT loaded' ); PPI-1.220/t/ppi_token_pod.t0000755000175100010010000000213612310327137012342 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Pod use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 9; use Test::NoWarnings; use PPI; MERGE: { # Create the test fragments my $one = PPI::Token::Pod->new("=pod\n\nOne\n\n=cut\n"); my $two = PPI::Token::Pod->new("=pod\n\nTwo"); isa_ok( $one, 'PPI::Token::Pod' ); isa_ok( $two, 'PPI::Token::Pod' ); # Create the combined Pod my $merged = PPI::Token::Pod->merge($one, $two); isa_ok( $merged, 'PPI::Token::Pod' ); is( $merged->content, "=pod\n\nOne\n\nTwo\n\n=cut\n", 'Merged POD looks ok' ); } TOKENIZE: { foreach my $test ( [ "=pod\n=cut", [ 'PPI::Token::Pod' ] ], [ "=pod\n=cut\n", [ 'PPI::Token::Pod' ] ], [ "=pod\n=cut\n\n", [ 'PPI::Token::Pod', 'PPI::Token::Whitespace' ] ], [ "=pod\n=Cut\n\n", [ 'PPI::Token::Pod' ] ], # pod doesn't end, so no whitespace token ) { my $T = PPI::Tokenizer->new( \$test->[0] ); my @tokens = map { ref $_ } @{ $T->all_tokens }; is_deeply( \@tokens, $test->[1], 'all tokens as expected' ); } } PPI-1.220/t/ppi_statement_variable.t0000755000175100010010000000265012310327137014232 0ustar #!/usr/bin/perl # Unit testing for PPI::Statement::Variable use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More 'no_plan'; use Test::NoWarnings; use PPI; VARIABLES: { # Test the things we assert to work in the synopsis my $Document = PPI::Document->new(\<<'END_PERL'); package Bar; my $foo = 1; my ( $foo, $bar) = (1, 2); our $foo = 1; local $foo; local $foo = 1; LABEL: my $foo = 1; # As well as those basics, lets also try some harder ones local($foo = $bar->$bar(), $bar); END_PERL isa_ok( $Document, 'PPI::Document' ); # There should be 6 statement objects my $ST = $Document->find('Statement::Variable'); is( ref($ST), 'ARRAY', 'Found statements' ); is( scalar(@$ST), 7, 'Found 7 ::Variable objects' ); foreach my $Var ( @$ST ) { isa_ok( $Var, 'PPI::Statement::Variable' ); } is_deeply( [ $ST->[0]->variables ], [ '$foo' ], '1: Found $foo' ); is_deeply( [ $ST->[1]->variables ], [ '$foo', '$bar' ], '2: Found $foo and $bar' ); is_deeply( [ $ST->[2]->variables ], [ '$foo' ], '3: Found $foo' ); is_deeply( [ $ST->[3]->variables ], [ '$foo' ], '4: Found $foo' ); is_deeply( [ $ST->[4]->variables ], [ '$foo' ], '5: Found $foo' ); is_deeply( [ $ST->[5]->variables ], [ '$foo' ], '6: Found $foo' ); is_deeply( [ $ST->[6]->variables ], [ '$foo', '$bar' ], '7: Found $foo and $bar' ); } PPI-1.220/t/16_xml.t0000755000175100010010000000212612251445131010614 0ustar #!/usr/bin/perl use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More 0.86 tests => 17; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; ##################################################################### # Begin Tests my $code = 'print "Hello World";'; my $document = new_ok( 'PPI::Document' => [ \$code ] ); my @elements = $document->elements; push @elements, $elements[0]->elements; my @expected = ( [ 'statement', {}, '' ], [ 'token_word', {}, 'print' ], [ 'token_whitespace', {}, ' ' ], [ 'token_quote_double', {}, '"Hello World"' ], [ 'token_structure', {}, ';' ], ); my $i = 0; foreach my $expect ( @expected ) { is( $elements[$i]->_xml_name, $expect->[0], "Got _xml_name '$expect->[0]' as expected", ); is_deeply( $elements[$i]->_xml_attr, $expect->[1], "Got _xml_attr as expected", ); is( $elements[$i]->_xml_content, $expect->[2], "Got _xml_content '$expect->[2]' as expected", ); $i++; } PPI-1.220/t/04_element.t0000755000175100010010000005205312426751160011454 0ustar #!/usr/bin/perl # Formal testing for PPI # This does an empiric test that when we try to parse something, # something ( anything ) comes out the other side. use strict; use File::Spec::Functions ':ALL'; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use PPI::Lexer (); # Execute the tests use Test::More tests => 221; use Test::NoWarnings; use Scalar::Util 'refaddr'; sub is_object { my ($left, $right, $message) = @_; $message ||= "Objects match"; my $condition = ( defined $left and ref $left, and defined $right, and ref $right, and refaddr($left) == refaddr($right) ); ok( $condition, $message ); } use vars qw{$RE_IDENTIFIER}; BEGIN { $RE_IDENTIFIER = qr/[^\W\d]\w*/; } sub omethod_fails { my $object = ref($_[0])->isa('UNIVERSAL') ? shift : die "Failed to pass method_fails test an object"; my $method = (defined $_[0] and $_[0] =~ /$RE_IDENTIFIER/o) ? shift : die "Failed to pass method_fails an identifier"; my $arg_set = ( ref $_[0] eq 'ARRAY' and scalar(@{$_[0]}) ) ? shift : die "Failed to pass method_fails a set of arguments"; foreach my $args ( @$arg_set ) { is( $object->$method( $args ), undef, ref($object) . "->$method fails correctly" ); } } sub pause { local $@; sleep 1 if !eval { require Time::HiRes; Time::HiRes::sleep(0.1); 1 }; } ##################################################################### # Miscellaneous # Confirm that C< weaken( $hash{scalar} = $object ) > works as expected, # adding a weak reference to the has index. use Scalar::Util (); SCOPE: { my %hash; my $counter = 0; SCOPE: { my $object1 = bless { }, 'My::WeakenTest'; my $object2 = bless { }, 'My::WeakenTest'; my $object3 = bless { }, 'My::WeakenTest'; isa_ok( $object1, 'My::WeakenTest' ); isa_ok( $object2, 'My::WeakenTest' ); isa_ok( $object3, 'My::WeakenTest' ); # Do nothing for object1. # Add object2 to a has index normally $hash{foo} = $object2; # Add object2 and weaken Scalar::Util::weaken($hash{bar} = $object3); ok( Scalar::Util::isweak( $hash{bar} ), 'index entry is weak' ); ok( ! Scalar::Util::isweak( $object3 ), 'original is not weak' ); pause(); # Do all the objects still exist isa_ok( $object1, 'My::WeakenTest' ); isa_ok( $object2, 'My::WeakenTest' ); isa_ok( $object3, 'My::WeakenTest' ); isa_ok( $hash{foo}, 'My::WeakenTest' ); isa_ok( $hash{bar}, 'My::WeakenTest' ); } pause(); # Two of the three should have destroyed is( $counter, 2, 'Counter increments as expected normally' ); # foo should still be there isa_ok( $hash{foo}, 'My::WeakenTest' ); # bar should ->exists, but be undefined ok( exists $hash{bar}, 'weakened object hash slot exists' ); ok( ! defined $hash{bar}, 'weakened object hash slot is undefined' ); package My::WeakenTest; sub DESTROY { $counter++; } } # Test interaction between weaken and Clone SCOPE: { my $object = { a => undef }; # my $object = bless { a => undef }, 'Foo'; my $object2 = $object; Scalar::Util::weaken($object2); my $clone = Clone::clone($object); is_deeply( $clone, $object, 'Object is cloned OK when a different reference is weakened' ); } ##################################################################### # Prepare # Build a basic source tree to test with my $source = 'my@foo = (1, 2);'; my $Document = PPI::Lexer->lex_source( $source ); isa_ok( $Document, 'PPI::Document' ); is( $Document->content, $source, "Document round-trips ok" ); is( scalar($Document->tokens), 12, "Basic source contains the correct number of tokens" ); is( scalar(@{$Document->{children}}), 1, "Document contains one element" ); my $Statement = $Document->{children}->[0]; isa_ok( $Statement, 'PPI::Statement' ); isa_ok( $Statement, 'PPI::Statement::Variable' ); is( scalar(@{$Statement->{children}}), 7, "Statement contains the correct number of elements" ); my $Token1 = $Statement->{children}->[0]; my $Token2 = $Statement->{children}->[1]; my $Token3 = $Statement->{children}->[2]; my $Braces = $Statement->{children}->[5]; my $Token7 = $Statement->{children}->[6]; isa_ok( $Token1, 'PPI::Token::Word' ); isa_ok( $Token2, 'PPI::Token::Symbol' ); isa_ok( $Token3, 'PPI::Token::Whitespace' ); isa_ok( $Braces, 'PPI::Structure::List' ); isa_ok( $Token7, 'PPI::Token::Structure' ); ok( ($Token1->isa('PPI::Token::Word') and $Token1->content eq 'my'), 'First token is correct' ); ok( ($Token2->isa('PPI::Token::Symbol') and $Token2->content eq '@foo'), 'Second token is correct' ); ok( ($Token3->isa('PPI::Token::Whitespace') and $Token3->content eq ' '), 'Third token is correct' ); is( $Braces->braces, '()', 'Braces seem correct' ); ok( ($Token7->isa('PPI::Token::Structure') and $Token7->content eq ';'), 'Seventh token is correct' ); isa_ok( $Braces->start, 'PPI::Token::Structure' ); ok( ($Braces->start->isa('PPI::Token::Structure') and $Braces->start->content eq '('), 'Start brace token matches expected' ); isa_ok( $Braces->finish, 'PPI::Token::Structure' ); ok( ($Braces->finish->isa('PPI::Token::Structure') and $Braces->finish->content eq ')'), 'Finish brace token matches expected' ); ##################################################################### # Testing of PPI::Element basic information methods # Testing the ->content method is( $Document->content, $source, "Document content is correct" ); is( $Statement->content, $source, "Statement content is correct" ); is( $Token1->content, 'my', "Token content is correct" ); is( $Token2->content, '@foo', "Token content is correct" ); is( $Token3->content, ' ', "Token content is correct" ); is( $Braces->content, '(1, 2)', "Token content is correct" ); is( $Token7->content, ';', "Token content is correct" ); # Testing the ->tokens method is( scalar($Document->tokens), 12, "Document token count is correct" ); is( scalar($Statement->tokens), 12, "Statement token count is correct" ); isa_ok( $Token1->tokens, 'PPI::Token', "Token token count is correct" ); isa_ok( $Token2->tokens, 'PPI::Token', "Token token count is correct" ); isa_ok( $Token3->tokens, 'PPI::Token', "Token token count is correct" ); is( scalar($Braces->tokens), 6, "Token token count is correct" ); isa_ok( $Token7->tokens, 'PPI::Token', "Token token count is correct" ); # Testing the ->significant method is( $Document->significant, 1, 'Document is significant' ); is( $Statement->significant, 1, 'Statement is significant' ); is( $Token1->significant, 1, 'Token is significant' ); is( $Token2->significant, 1, 'Token is significant' ); is( $Token3->significant, '', 'Token is significant' ); is( $Braces->significant, 1, 'Token is significant' ); is( $Token7->significant, 1, 'Token is significant' ); ##################################################################### # Testing of PPI::Element navigation # Test the ->parent method is( $Document->parent, undef, "Document does not have a parent" ); is_object( $Statement->parent, $Document, "Statement sees document as parent" ); is_object( $Token1->parent, $Statement, "Token sees statement as parent" ); is_object( $Token2->parent, $Statement, "Token sees statement as parent" ); is_object( $Token3->parent, $Statement, "Token sees statement as parent" ); is_object( $Braces->parent, $Statement, "Braces sees statement as parent" ); is_object( $Token7->parent, $Statement, "Token sees statement as parent" ); # Test the special case of parents for the Braces opening and closing braces is_object( $Braces->start->parent, $Braces, "Start brace sees the PPI::Structure as it's parent" ); is_object( $Braces->finish->parent, $Braces, "Finish brace sees the PPI::Structure as it's parent" ); # Test the ->top method is_object( $Document->top, $Document, "Document sees itself as top" ); is_object( $Statement->top, $Document, "Statement sees document as top" ); is_object( $Token1->top, $Document, "Token sees document as top" ); is_object( $Token2->top, $Document, "Token sees document as top" ); is_object( $Token3->top, $Document, "Token sees document as top" ); is_object( $Braces->top, $Document, "Braces sees document as top" ); is_object( $Token7->top, $Document, "Token sees document as top" ); # Test the ->document method is_object( $Document->document, $Document, "Document sees itself as document" ); is_object( $Statement->document, $Document, "Statement sees document correctly" ); is_object( $Token1->document, $Document, "Token sees document correctly" ); is_object( $Token2->document, $Document, "Token sees document correctly" ); is_object( $Token3->document, $Document, "Token sees document correctly" ); is_object( $Braces->document, $Document, "Braces sees document correctly" ); is_object( $Token7->document, $Document, "Token sees document correctly" ); # Test the ->next_sibling method is( $Document->next_sibling, '', "Document returns false for next_sibling" ); is( $Statement->next_sibling, '', "Statement returns false for next_sibling" ); is_object( $Token1->next_sibling, $Token2, "First token sees second token as next_sibling" ); is_object( $Token2->next_sibling, $Token3, "Second token sees third token as next_sibling" ); is_object( $Braces->next_sibling, $Token7, "Braces sees seventh token as next_sibling" ); is( $Token7->next_sibling, '', 'Last token returns false for next_sibling' ); # More extensive test for next_sibling SCOPE: { my $doc = PPI::Document->new( \"sub foo { bar(); }" ); my $end = $doc->last_token; isa_ok( $end, 'PPI::Token::Structure' ); is( $end->content, '}', 'Got end token' ); is( $end->next_sibling, '', '->next_sibling for an end closing brace returns false' ); my $braces = $doc->find_first( sub { $_[1]->isa('PPI::Structure') and $_[1]->braces eq '()' } ); isa_ok( $braces, 'PPI::Structure' ); isa_ok( $braces->next_token, 'PPI::Token::Structure' ); is( $braces->next_token->content, ';', 'Got the correct next_token for structure' ); } # Test the ->previous_sibling method is( $Document->previous_sibling, '', "Document returns false for previous_sibling" ); is( $Statement->previous_sibling, '', "Statement returns false for previous_sibling" ); is( $Token1->previous_sibling, '', "First token returns false for previous_sibling" ); is_object( $Token2->previous_sibling, $Token1, "Second token sees first token as previous_sibling" ); is_object( $Token3->previous_sibling, $Token2, "Third token sees second token as previous_sibling" ); is_object( $Token7->previous_sibling, $Braces, "Last token sees braces as previous_sibling" ); # More extensive test for next_sibling SCOPE: { my $doc = PPI::Document->new( \"{ no strict; bar(); }" ); my $start = $doc->first_token; isa_ok( $start, 'PPI::Token::Structure' ); is( $start->content, '{', 'Got start token' ); is( $start->previous_sibling, '', '->previous_sibling for an start opening brace returns false' ); my $braces = $doc->find_first( sub { $_[1]->isa('PPI::Structure') and $_[1]->braces eq '()' } ); isa_ok( $braces, 'PPI::Structure' ); isa_ok( $braces->previous_token, 'PPI::Token::Word' ); is( $braces->previous_token->content, 'bar', 'Got the correct previous_token for structure' ); } # Test the ->snext_sibling method my $Token4 = $Statement->{children}->[3]; is( $Document->snext_sibling, '', "Document returns false for snext_sibling" ); is( $Statement->snext_sibling, '', "Statement returns false for snext_sibling" ); is_object( $Token1->snext_sibling, $Token2, "First token sees second token as snext_sibling" ); is_object( $Token2->snext_sibling, $Token4, "Second token sees third token as snext_sibling" ); is_object( $Braces->snext_sibling, $Token7, "Braces sees seventh token as snext_sibling" ); is( $Token7->snext_sibling, '', 'Last token returns false for snext_sibling' ); # Test the ->sprevious_sibling method is( $Document->sprevious_sibling, '', "Document returns false for sprevious_sibling" ); is( $Statement->sprevious_sibling, '', "Statement returns false for sprevious_sibling" ); is( $Token1->sprevious_sibling, '', "First token returns false for sprevious_sibling" ); is_object( $Token2->sprevious_sibling, $Token1, "Second token sees first token as sprevious_sibling" ); is_object( $Token3->sprevious_sibling, $Token2, "Third token sees second token as sprevious_sibling" ); is_object( $Token7->sprevious_sibling, $Braces, "Last token sees braces as sprevious_sibling" ); # Test snext_sibling and sprevious_sibling cases when inside a parent block SCOPE: { my $cpan13454 = PPI::Document->new( \'{ 1 }' ); isa_ok( $cpan13454, 'PPI::Document' ); my $num = $cpan13454->find_first('Token::Number'); isa_ok( $num, 'PPI::Token::Number' ); my $prev = $num->sprevious_sibling; is( $prev, '', '->sprevious_sibling returns false' ); my $next = $num->snext_sibling; is( $next, '', '->snext_sibling returns false' ); } ##################################################################### # Test the PPI::Element and PPI::Node analysis methods # Test the find method SCOPE: { is( $Document->find('PPI::Token::End'), '', '->find returns false if nothing found' ); isa_ok( $Document->find('PPI::Structure')->[0], 'PPI::Structure' ); my $found = $Document->find('PPI::Token::Number'); ok( $found, 'Multiple find succeeded' ); is( ref $found, 'ARRAY', '->find returned an array' ); is( scalar(@$found), 2, 'Multiple find returned expected number of items' ); # Test for the ability to shorten the names $found = $Document->find('Token::Number'); ok( $found, 'Multiple find succeeded' ); is( ref $found, 'ARRAY', '->find returned an array' ); is( scalar(@$found), 2, 'Multiple find returned expected number of items' ); } # Test for CPAN #7799 - Unsupported element types are accepted by find # # The correct behaviour for a bad string is a warning, and return C SCOPE: { local $^W = 0; is( $Document->find(undef), undef, '->find(undef) failed' ); is( $Document->find([]), undef, '->find([]) failed' ); is( $Document->find('Foo'), undef, '->find(BAD) failed' ); } # Test the find_first method SCOPE: { is( $Document->find_first('PPI::Token::End'), '', '->find_first returns false if nothing found' ); isa_ok( $Document->find_first('PPI::Structure'), 'PPI::Structure' ); my $found = $Document->find_first('PPI::Token::Number'); ok( $found, 'Multiple find_first succeeded' ); isa_ok( $found, 'PPI::Token::Number' ); # Test for the ability to shorten the names $found = $Document->find_first('Token::Number'); ok( $found, 'Multiple find_first succeeded' ); isa_ok( $found, 'PPI::Token::Number' ); } # Test the find_any method SCOPE: { is( $Document->find_any('PPI::Token::End'), '', '->find_any returns false if nothing found' ); is( $Document->find_any('PPI::Structure'), 1, '->find_any returns true is something found' ); is( $Document->find_any('PPI::Token::Number'), 1, '->find_any returns true for multiple find' ); is( $Document->find_any('Token::Number'), 1, '->find_any returns true for shortened multiple find' ); } # Test the contains method SCOPE: { omethod_fails( $Document, 'contains', [ undef, '', 1, [], bless( {}, 'Foo') ] ); my $found = $Document->find('PPI::Element'); is( ref $found, 'ARRAY', '(preparing for contains tests) ->find returned an array' ); is( scalar(@$found), 15, '(preparing for contains tests) ->find returns correctly for all elements' ); foreach my $Element ( @$found ) { is( $Document->contains( $Element ), 1, 'Document contains ' . ref($Element) . ' known to be in it' ); } shift @$found; foreach my $Element ( @$found ) { is( $Document->contains( $Element ), 1, 'Statement contains ' . ref($Element) . ' known to be in it' ); } } ##################################################################### # Test the PPI::Element manipulation methods # Cloning an Element/Node SCOPE: { my $Doc2 = $Document->clone; isa_ok( $Doc2, 'PPI::Document' ); isa_ok( $Doc2->schild(0), 'PPI::Statement' ); is_object( $Doc2->schild(0)->parent, $Doc2, 'Basic parent links stay intact after ->clone' ); is_object( $Doc2->schild(0)->schild(3)->start->document, $Doc2, 'Clone goes deep, and Structure braces get relinked properly' ); isnt( refaddr($Document), refaddr($Doc2), 'Cloned Document has a different memory location' ); isnt( refaddr($Document->schild(0)), refaddr($Doc2->schild(0)), 'Cloned Document has children at different memory locations' ); } # Delete the second token ok( $Token2->delete, "Deletion of token 2 returns true" ); is( $Document->content, 'my = (1, 2);', "Content is modified correctly" ); is( scalar($Document->tokens), 11, "Modified source contains the correct number of tokens" ); ok( ! defined $Token2->parent, "Token 2 is detached from parent" ); # Delete the braces ok( $Braces->delete, "Deletion of braces returns true" ); is( $Document->content, 'my = ;', "Content is modified correctly" ); is( scalar($Document->tokens), 5, "Modified source contains the correct number of tokens" ); ok( ! defined $Braces->parent, "Braces are detached from parent" ); ##################################################################### # Test DESTROY # Start with DESTROY for an element that never has a parent SCOPE: { my $Token = PPI::Token::Whitespace->new( ' ' ); my $k1 = scalar keys %PPI::Element::_PARENT; $Token->DESTROY; my $k2 = scalar keys %PPI::Element::_PARENT; is( $k1, $k2, '_PARENT key count remains unchanged after naked Element DESTROY' ); } # Next, a single element within a parent SCOPE: { my $k1 = scalar keys %PPI::Element::_PARENT; my $k2; my $k3; SCOPE: { my $Token = PPI::Token::Number->new( '1' ); my $Statement = PPI::Statement->new; $Statement->add_element( $Token ); $k2 = scalar keys %PPI::Element::_PARENT; is( $k2, $k1 + 1, 'PARENT keys increases after adding element' ); $Statement->DESTROY; } pause(); $k3 = scalar keys %PPI::Element::_PARENT; is( $k3, $k1, 'PARENT keys returns to original on DESTROY' ); } # Repeat for an entire (large) file SCOPE: { my $k1 = scalar keys %PPI::Element::_PARENT; my $k2; my $k3; SCOPE: { my $NodeDocument = PPI::Document->new( $INC{"PPI/Node.pm"} ); isa_ok( $NodeDocument, 'PPI::Document' ); $k2 = scalar keys %PPI::Element::_PARENT; ok( $k2 > ($k1 + 3000), 'PARENT keys increases after loading document' ); $NodeDocument->DESTROY; } pause(); $k3 = scalar keys %PPI::Element::_PARENT; is( $k3, $k1, 'PARENT keys returns to original on explicit Document DESTROY' ); } # Repeat again, but with an implicit DESTROY SCOPE: { my $k1 = scalar keys %PPI::Element::_PARENT; my $k2; my $k3; SCOPE: { my $NodeDocument = PPI::Document->new( $INC{"PPI/Node.pm"} ); isa_ok( $NodeDocument, 'PPI::Document' ); $k2 = scalar keys %PPI::Element::_PARENT; ok( $k2 > ($k1 + 3000), 'PARENT keys increases after loading document' ); } pause(); $k3 = scalar keys %PPI::Element::_PARENT; is( $k3, $k1, 'PARENT keys returns to original on implicit Document DESTROY' ); } ##################################################################### # Token-related methods # Test first_token, last_token, next_token and previous_token SCOPE: { my $code = <<'END_PERL'; my $foo = bar(); sub foo { my ($foo, $bar, undef) = ('a', shift(@_), 'bar'); return [ $foo, $bar ]; } END_PERL # Trim off the trailing newline to test last_token better $code =~ s/\s+$//s; # Create the document my $doc = PPI::Document->new( \$code ); isa_ok( $doc, 'PPI::Document' ); # Basic first_token and last_token using a single non-trival sample ### FIXME - Make this more thorough my $first_token = $doc->first_token; isa_ok( $first_token, 'PPI::Token::Word' ); is( $first_token->content, 'my', '->first_token works as expected' ); my $last_token = $doc->last_token; isa_ok( $last_token, 'PPI::Token::Structure' ); is( $last_token->content, '}', '->last_token works as expected' ); # Test next_token is( $last_token->next_token, '', 'last->next_token returns false' ); is( $doc->next_token, '', 'doc->next_token returns false' ); my $next_token = $first_token->next_token; isa_ok( $next_token, 'PPI::Token::Whitespace' ); is( $next_token->content, ' ', 'Trivial ->next_token works as expected' ); my $counter = 1; my $token = $first_token; while ( $token = $token->next_token ) { $counter++; } is( $counter, scalar($doc->tokens), '->next_token iterated the expected number of times for a sample document' ); # Test previous_token is( $first_token->previous_token, '', 'last->previous_token returns false' ); is( $doc->previous_token, '', 'doc->previous_token returns false' ); my $previous_token = $last_token->previous_token; isa_ok( $previous_token, 'PPI::Token::Whitespace' ); is( $previous_token->content, "\n", 'Trivial ->previous_token works as expected' ); $counter = 1; $token = $last_token; while ( $token = $token->previous_token ) { $counter++; } is( $counter, scalar($doc->tokens), '->previous_token iterated the expected number of times for a sample document' ); } ##################################################################### # Simple overload tests # Make sure the 'use overload' is working on Element subclasses SCOPE: { my $source = '1;'; my $Document = PPI::Lexer->lex_source( $source ); isa_ok( $Document, 'PPI::Document' ); ok($Document eq $source, 'overload eq'); ok($Document ne 'foo', 'overload ne'); ok($Document == $Document, 'overload =='); ok($Document != $Document->schild(0), 'overload !='); } PPI-1.220/t/ppi_token_quote_literal.t0000755000175100010010000000237212310327137014433 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Quote::Literal use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 13; use Test::NoWarnings; use PPI; STRING: { my $Document = PPI::Document->new( \"print q{foo}, q!bar!, q ;" ); isa_ok( $Document, 'PPI::Document' ); my $literal = $Document->find('Token::Quote::Literal'); is( scalar(@$literal), 3, '->find returns three objects' ); isa_ok( $literal->[0], 'PPI::Token::Quote::Literal' ); isa_ok( $literal->[1], 'PPI::Token::Quote::Literal' ); isa_ok( $literal->[2], 'PPI::Token::Quote::Literal' ); is( $literal->[0]->string, 'foo', '->string returns as expected' ); is( $literal->[1]->string, 'bar', '->string returns as expected' ); is( $literal->[2]->string, 'foo', '->string returns as expected' ); } LITERAL: { my $Document = PPI::Document->new( \"print q{foo}, q!bar!, q ;" ); isa_ok( $Document, 'PPI::Document' ); my $literal = $Document->find('Token::Quote::Literal'); is( $literal->[0]->literal, 'foo', '->literal returns as expected' ); is( $literal->[1]->literal, 'bar', '->literal returns as expected' ); is( $literal->[2]->literal, 'foo', '->literal returns as expected' ); } PPI-1.220/t/14_charsets.t0000755000175100010010000000511612271014316011627 0ustar #!/usr/bin/perl use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More; BEGIN { if ($] < 5.008007) { Test::More->import( skip_all => "Unicode support requires perl 5.8.7" ); exit(0); } plan( tests => 17 ); } use Test::NoWarnings; use utf8; use File::Spec::Functions ':ALL'; use Params::Util qw{_INSTANCE}; use PPI; sub good_ok { my $source = shift; my $message = shift; my $doc = PPI::Document->new( \$source ); ok( _INSTANCE($doc, 'PPI::Document'), $message ); if ( ! _INSTANCE($doc, 'PPI::Document') ) { diag($PPI::Document::errstr); } } ##################################################################### # Begin Tests # We cannot reliably support Unicode on anything less than 5.8.5 SKIP: { # In some (weird) cases with custom locales, things aren't words # that should be unless ( "ä" =~ /\w/ ) { skip( "Unicode-incompatible locale in use (apparently)", 11 ); } # Notorious test case. # In 1.203 this test case causes a memory leaking infinite loop # that consumes all available memory and then crashes the process. good_ok( '一();', "Function with Chinese characters" ); # Byte order mark with no unicode content good_ok( "\xef\xbb\xbf1;\n", "BOM without actual unicode content" ); # Testing accented characters in UTF-8 good_ok( 'sub func { }', "Parsed code without accented chars" ); good_ok( 'rätselhaft();', "Function with umlaut" ); good_ok( 'ätselhaft()', "Starting with umlaut" ); good_ok( '"rätselhaft"', "In double quotes" ); good_ok( "'rätselhaft'", "In single quotes" ); good_ok( 'sub func { s/a/ä/g; }', "Regex with umlaut" ); good_ok( 'sub func { $ä=1; }', "Variable with umlaut" ); good_ok( '$一 = "壹";', "Variables with Chinese characters" ); good_ok( '$a=1; # ä is an umlaut', "Comment with umlaut" ); good_ok( <<'END_CODE', "POD with umlaut" ); sub func { } =pod =head1 Umlauts like ä } END_CODE ok(utf8::is_utf8('κλειδί'), "utf8 flag set on source string"); good_ok( 'my %h = ( κλειδί => "Clé" );', "Hash with greek key in character string" ); use Encode; my $bytes = Encode::encode('utf8', 'use utf8; my %h = ( κλειδί => "Clé" );'); ok(!utf8::is_utf8($bytes), "utf8 flag not set on byte string"); { local $TODO = "Fix CRASH"; good_ok( $bytes, "Hash with greek key in bytes string" ); } } PPI-1.220/t/ppi_normal.t0000755000175100010010000000505312310327137011651 0ustar #!/usr/bin/perl # Unit testing for PPI::Normal use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 28; use Test::NoWarnings; use PPI; NEW: { # Check we actually set the layer at creation my $layer_1 = PPI::Normal->new; isa_ok( $layer_1, 'PPI::Normal' ); is( $layer_1->layer, 1, '->new creates a layer 1' ); my $layer_1a = PPI::Normal->new(1); isa_ok( $layer_1a, 'PPI::Normal' ); is( $layer_1a->layer, 1, '->new(1) creates a layer 1' ); my $layer_2 = PPI::Normal->new(2); isa_ok( $layer_2, 'PPI::Normal' ); is( $layer_2->layer, 2, '->new(2) creates a layer 2' ); } BAD: { # Test bad things is( PPI::Normal->new(3), undef, '->new only allows up to layer 2' ); is( PPI::Normal->new(undef), undef, '->new(evil) returns undef' ); is( PPI::Normal->new("foo"), undef, '->new(evil) returns undef' ); is( PPI::Normal->new(\"foo"), undef, '->new(evil) returns undef' ); is( PPI::Normal->new([]), undef, '->new(evil) returns undef' ); is( PPI::Normal->new({}), undef, '->new(evil) returns undef' ); } PROCESS: { my $doc1 = PPI::Document->new(\'print "Hello World!\n";'); isa_ok( $doc1, 'PPI::Document' ); my $doc2 = \'print "Hello World!\n";'; my $doc3 = \' print "Hello World!\n"; # comment'; my $doc4 = \'print "Hello World!\n"'; # Normalize them at level 1 my $layer1 = PPI::Normal->new(1); isa_ok( $layer1, 'PPI::Normal' ); my $nor11 = $layer1->process($doc1->clone); my $nor12 = $layer1->process($doc2); my $nor13 = $layer1->process($doc3); isa_ok( $nor11, 'PPI::Document::Normalized' ); isa_ok( $nor12, 'PPI::Document::Normalized' ); isa_ok( $nor13, 'PPI::Document::Normalized' ); # The first 3 should be the same, the second not is_deeply( { %$nor11 }, { %$nor12 }, 'Layer 1: 1 and 2 match' ); is_deeply( { %$nor11 }, { %$nor13 }, 'Layer 1: 1 and 3 match' ); # Normalize them at level 2 my $layer2 = PPI::Normal->new(2); isa_ok( $layer2, 'PPI::Normal' ); my $nor21 = $layer2->process($doc1); my $nor22 = $layer2->process($doc2); my $nor23 = $layer2->process($doc3); my $nor24 = $layer2->process($doc4); isa_ok( $nor21, 'PPI::Document::Normalized' ); isa_ok( $nor22, 'PPI::Document::Normalized' ); isa_ok( $nor23, 'PPI::Document::Normalized' ); isa_ok( $nor24, 'PPI::Document::Normalized' ); # The first 3 should be the same, the second not is_deeply( { %$nor21 }, { %$nor22 }, 'Layer 2: 1 and 2 match' ); is_deeply( { %$nor21 }, { %$nor23 }, 'Layer 2: 1 and 3 match' ); is_deeply( { %$nor21 }, { %$nor24 }, 'Layer 2: 1 and 4 match' ); } PPI-1.220/t/ppi_token_quotelike_words.t0000755000175100010010000000255712426751160015014 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::QuoteLike::Words use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 13; use Test::NoWarnings; use PPI; LITERAL: { my $empty_list_document = PPI::Document->new(\<<'END_PERL'); qw// qw/ / END_PERL isa_ok( $empty_list_document, 'PPI::Document' ); my $empty_list_tokens = $empty_list_document->find('PPI::Token::QuoteLike::Words'); is( scalar @{$empty_list_tokens}, 2, 'Found expected empty word lists.' ); foreach my $token ( @{$empty_list_tokens} ) { my @literal = $token->literal; is( scalar @literal, 0, qq ); } my $non_empty_list_document = PPI::Document->new(\<<'END_PERL'); qw/foo bar baz/ qw/ foo bar baz / qw {foo bar baz} END_PERL my @expected = qw/ foo bar baz /; isa_ok( $non_empty_list_document, 'PPI::Document' ); my $non_empty_list_tokens = $non_empty_list_document->find('PPI::Token::QuoteLike::Words'); is( scalar(@$non_empty_list_tokens), 3, 'Found expected non-empty word lists.', ); foreach my $token ( @$non_empty_list_tokens ) { my $literal = $token->literal; is( $literal, scalar @expected, qq, ); is_deeply( [ $token->literal ], \@expected, '->literal matches expected' ); } } PPI-1.220/t/12_location.t0000755000175100010010000002324112251445131011621 0ustar #!/usr/bin/perl # Tests the accuracy and features for location functionality use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 683; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; my $test_source = <<'END_PERL'; my $foo = 'bar'; # comment sub foo { my ($this, $that) = (<<'THIS', <<"THAT"); foo bar baz THIS foo bar THAT } sub baz { # sub baz contains *tabs* my ($one, $other) = ("one", "other"); # contains 4 tabs foo() ; } sub bar { baz(); #Note that there are leading 4 x space, not 1 x tab in the sub bar bas(); } =head2 fluzz() Print "fluzz". Return 1. =cut sub fluzz { print "fluzz";# line 300 not_at_start_of_line } #line 400 $a # line 500 $b #line600 $c #line 700 filename $d #line 800another-filename $e #line 900 yet-another-filename $f #line 1000"quoted-filename" $g =pod #line 1100 =cut $h =pod #line 1200 =cut $i =pod # line 1300 =cut $j =pod #line1400 =cut $k =pod #line 1500 filename =cut $l =pod #line 1600another-filename =cut $m =pod #line 1700 yet-another-filename =cut $n =pod #line 1800"quoted-filename" =cut $o 1; END_PERL my @test_locations = ( [ 1, 1, 1, 1, undef ], # my [ 1, 3, 3, 1, undef ], # ' ' [ 1, 4, 4, 1, undef ], # $foo [ 1, 8, 8, 1, undef ], # ' ' [ 1, 9, 9, 1, undef ], # = [ 1, 10, 10, 1, undef ], # ' ' [ 1, 11, 11, 1, undef ], # 'bar' [ 1, 16, 16, 1, undef ], # ; [ 1, 17, 17, 1, undef ], # \n [ 2, 1, 1, 2, undef ], # \n [ 3, 1, 1, 3, undef ], # # comment [ 4, 1, 1, 4, undef ], # sub [ 4, 4, 4, 4, undef ], # ' ' [ 4, 5, 5, 4, undef ], # foo [ 4, 8, 8, 4, undef ], # ' ' [ 4, 9, 9, 4, undef ], # { [ 4, 10, 10, 4, undef ], # \n [ 5, 1, 1, 5, undef ], # ' ' [ 5, 5, 5, 5, undef ], # my [ 5, 7, 7, 5, undef ], # ' ' [ 5, 8, 8, 5, undef ], # ( [ 5, 9, 9, 5, undef ], # $this [ 5, 14, 14, 5, undef ], # , [ 5, 15, 15, 5, undef ], # ' ' [ 5, 16, 16, 5, undef ], # $that [ 5, 21, 21, 5, undef ], # ) [ 5, 22, 22, 5, undef ], # ' ' [ 5, 23, 23, 5, undef ], # = [ 5, 24, 24, 5, undef ], # ' ' [ 5, 25, 25, 5, undef ], # ( [ 5, 26, 26, 5, undef ], # <<'THIS' [ 5, 34, 34, 5, undef ], # , [ 5, 35, 35, 5, undef ], # ' ' [ 5, 36, 36, 5, undef ], # <<"THAT" [ 5, 44, 44, 5, undef ], # ) [ 5, 45, 45, 5, undef ], # ; [ 5, 46, 46, 5, undef ], # \n [ 13, 1, 1, 13, undef ], # } [ 13, 2, 2, 13, undef ], # \n [ 14, 1, 1, 14, undef ], # \n [ 15, 1, 1, 15, undef ], # sub [ 15, 4, 4, 15, undef ], # ' ' [ 15, 5, 5, 15, undef ], # baz [ 15, 8, 8, 15, undef ], # ' ' [ 15, 9, 9, 15, undef ], # { [ 15, 10, 10, 15, undef ], # \n [ 16, 1, 1, 16, undef ], # tab# sub baz contains *tabs* [ 17, 1, 1, 17, undef ], # tab [ 17, 2, 5, 17, undef ], # my [ 17, 4, 7, 17, undef ], # ' ' [ 17, 5, 8, 17, undef ], # ( [ 17, 6, 9, 17, undef ], # $one [ 17, 10, 13, 17, undef ], # , [ 17, 11, 14, 17, undef ], # ' ' [ 17, 12, 15, 17, undef ], # $other [ 17, 18, 21, 17, undef ], # ) [ 17, 19, 22, 17, undef ], # ' ' [ 17, 20, 23, 17, undef ], # = [ 17, 21, 24, 17, undef ], # ' tab' [ 17, 23, 29, 17, undef ], # ( [ 17, 24, 30, 17, undef ], # "one" [ 17, 29, 35, 17, undef ], # , [ 17, 30, 36, 17, undef ], # tab [ 17, 31, 37, 17, undef ], # "other" [ 17, 38, 44, 17, undef ], # ) [ 17, 39, 45, 17, undef ], # ; [ 17, 40, 46, 17, undef ], # tab [ 17, 41, 49, 17, undef ], # # contains 3 tabs [ 17, 58, 66, 17, undef ], # \n [ 18, 1, 1, 18, undef ], # \n\t [ 19, 2, 5, 19, undef ], # foo [ 19, 5, 8, 19, undef ], # ( [ 19, 6, 9, 19, undef ], # ) [ 19, 7, 10, 19, undef ], # tab [ 19, 8, 13, 19, undef ], # ; [ 19, 9, 14, 19, undef ], # \n [ 20, 1, 1, 20, undef ], # { [ 20, 2, 2, 20, undef ], # \n [ 21, 1, 1, 21, undef ], # \n [ 22, 1, 1, 22, undef ], # sub [ 22, 4, 4, 22, undef ], # ' ' [ 22, 5, 5, 22, undef ], # bar [ 22, 8, 8, 22, undef ], # ' ' [ 22, 9, 9, 22, undef ], # { [ 22, 10, 10, 22, undef ], # \n [ 23, 1, 1, 23, undef ], # ' ' [ 23, 5, 5, 23, undef ], # baz [ 23, 8, 8, 23, undef ], # ( [ 23, 9, 9, 23, undef ], # ) [ 23, 10, 10, 23, undef ], # ; [ 23, 11, 11, 23, undef ], # \n [ 24, 1, 1, 24, undef ], # \n [ 25, 1, 1, 25, undef ], # #Note that there are leading 4 x space, ... [ 26, 1, 1, 26, undef ], # '\n ' [ 27, 5, 5, 27, undef ], # bas [ 27, 8, 8, 27, undef ], # ( [ 27, 9, 9, 27, undef ], # ) [ 27, 10, 10, 27, undef ], # ; [ 27, 11, 11, 27, undef ], # \n [ 28, 1, 1, 28, undef ], # } [ 28, 2, 2, 28, undef ], # \n [ 29, 1, 1, 29, undef ], # \n [ 30, 1, 1, 30, undef ], # =head2 fluzz() ... [ 35, 1, 1, 35, undef ], # sub [ 35, 4, 4, 35, undef ], # ' ' [ 35, 5, 5, 35, undef ], # fluzz [ 35, 10, 10, 35, undef ], # ' ' [ 35, 11, 11, 35, undef ], # { [ 35, 12, 12, 35, undef ], # \n [ 36, 1, 1, 36, undef ], # ' ' [ 36, 5, 5, 36, undef ], # print [ 36, 10, 10, 36, undef ], # ' ' [ 36, 11, 11, 36, undef ], # "fluzz" [ 36, 18, 18, 36, undef ], # ; [ 36, 19, 19, 36, undef ], # # line 300 not_at_start_of_line [ 36, 50, 50, 36, undef ], # \n [ 37, 1, 1, 37, undef ], # } [ 37, 2, 2, 37, undef ], # \n [ 38, 1, 1, 38, undef ], # \n [ 39, 1, 1, 39, undef ], # #line 400 [ 40, 1, 1, 400, undef ], # $a [ 40, 3, 3, 400, undef ], # \n [ 41, 1, 1, 401, undef ], # # line 500 [ 42, 1, 1, 500, undef ], # $b [ 42, 3, 3, 500, undef ], # \n # No space between "line" and number causes it to not work. [ 43, 1, 1, 501, undef ], # #line600 [ 44, 1, 1, 502, undef ], # $c [ 44, 3, 3, 502, undef ], # \n [ 45, 1, 1, 503, undef ], # #line 700 filename [ 46, 1, 1, 700, 'filename' ], # $d [ 46, 3, 3, 700, 'filename' ], # \n [ 47, 1, 1, 701, 'filename' ], # #line 800another-filename [ 48, 1, 1, 800, 'another-filename' ], # $e [ 48, 3, 3, 800, 'another-filename' ], # \n [ 49, 1, 1, 801, 'another-filename' ], # #line 900 yet-another-filename [ 50, 1, 1, 900, 'yet-another-filename' ], # $f [ 50, 3, 3, 900, 'yet-another-filename' ], # \n [ 51, 1, 1, 901, 'yet-another-filename' ], # #line 1000"quoted-filename" [ 52, 1, 1, 1000, 'quoted-filename' ], # $g [ 52, 3, 3, 1000, 'quoted-filename' ], # \n [ 53, 1, 1, 1001, 'quoted-filename' ], # \n [ 54, 1, 1, 1002, 'quoted-filename' ], # =pod #line 1100 (not in column 1) [ 59, 1, 1, 1007, 'quoted-filename' ], # $h [ 59, 3, 3, 1007, 'quoted-filename' ], # \n [ 60, 1, 1, 1008, 'quoted-filename' ], # =pod #line 1200 [ 65, 1, 1, 1202, 'quoted-filename' ], # $i [ 65, 3, 3, 1202, 'quoted-filename' ], # \n [ 66, 1, 1, 1203, 'quoted-filename' ], # =pod # line 1300 [ 71, 1, 1, 1302, 'quoted-filename' ], # $j [ 71, 3, 3, 1302, 'quoted-filename' ], # \n # No space between "line" and number causes it to not work. [ 72, 1, 1, 1303, 'quoted-filename' ], # =pod #line1400 [ 77, 1, 1, 1308, 'quoted-filename' ], # $k [ 77, 3, 3, 1308, 'quoted-filename' ], # \n [ 78, 1, 1, 1309, 'quoted-filename' ], # =pod #line 1500 filename [ 83, 1, 1, 1502, 'filename' ], # $l [ 83, 3, 3, 1502, 'filename' ], # \n [ 84, 1, 1, 1503, 'filename' ], # =pod #line 1600another-filename [ 89, 1, 1, 1602, 'another-filename' ], # $m [ 89, 3, 3, 1602, 'another-filename' ], # \n [ 90, 1, 1, 1603, 'another-filename' ], # =pod #line 1700 yet-another-filename [ 95, 1, 1, 1702, 'yet-another-filename' ], # $n [ 95, 3, 3, 1702, 'yet-another-filename' ], # \n [ 96, 1, 1, 1703, 'yet-another-filename' ], # =pod #line 1800"quoted-filename" [ 101, 1, 1, 1802, 'quoted-filename' ], # $o [ 101, 3, 3, 1802, 'quoted-filename' ], # \n [ 102, 1, 1, 1803, 'quoted-filename' ], # \n [ 103, 1, 1, 1804, 'quoted-filename' ], # 1 [ 103, 2, 2, 1804, 'quoted-filename' ], # ; [ 103, 3, 3, 1804, 'quoted-filename' ], # \n ); ##################################################################### # Test the locations of everything in the test code # Prepare my $Document = PPI::Document->new( \$test_source ); isa_ok( $Document, 'PPI::Document' ); $Document->tab_width(4); is($Document->tab_width, 4, 'Tab width set correctly'); ok( $Document->index_locations, '->index_locations returns true' ); # Now check the locations of every token my @tokens = $Document->tokens; is( scalar(@tokens), scalar(@test_locations), 'Number of tokens matches expected' ); foreach my $i ( 0 .. $#test_locations ) { my $location = $tokens[$i]->location; is( ref($location), 'ARRAY', "Token $i: ->location returns an ARRAY ref" ); is( scalar(@$location), 5, "Token $i: ->location returns a 5 element ARRAY ref" ); ok( ( $location->[0] > 0 and $location->[1] > 0 and $location->[2] > 0 and $location->[3] > 0 ), "Token $i: ->location returns four positive positions" ); is_deeply( $tokens[$i]->location, $test_locations[$i], "Token $i: ->location matches expected", ); } ok( $Document->flush_locations, '->flush_locations returns true' ); is( scalar(grep { defined $_->{_location} } $Document->tokens), 0, 'All _location attributes removed' ); PPI-1.220/t/11_util.t0000755000175100010010000000326012251445131010764 0ustar #!/usr/bin/perl # Test the PPI::Util package use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 13; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI::Lexer (); use PPI; use PPI::Util qw{_Document _slurp}; # Execute the tests my $testfile = catfile( 't', 'data', '11_util', 'test.pm' ); my $testsource = 'print "Hello World!\n"'; my $slurpfile = catfile( 't', 'data', 'basic.pl' ); my $slurpcode = <<'END_FILE'; #!/usr/bin/perl if ( 1 ) { print "Hello World!\n"; } 1; END_FILE ##################################################################### # Test PPI::Util::_Document my $Document = PPI::Document->new( \$testsource ); isa_ok( $Document, 'PPI::Document' ); # Good things foreach my $thing ( $testfile, \$testsource, $Document, [] ) { isa_ok( _Document( $thing ), 'PPI::Document' ); } # Bad things ### erm... # Evil things foreach my $thing ( {}, sub () { 1 } ) { is( _Document( $thing ), undef, '_Document(evil) returns undef' ); } ##################################################################### # Test PPI::Util::_slurp my $source = _slurp( $slurpfile ); is_deeply( $source, \$slurpcode, '_slurp loads file as expected' ); ##################################################################### # Check the capability flags my $have_alarm = PPI::Util::HAVE_ALARM(); my $have_unicode = PPI::Util::HAVE_UNICODE(); ok( defined $have_alarm, 'HAVE_ALARM defined' ); ok( defined $have_unicode, 'HAVE_UNICODE defined' ); is( $have_alarm, !! $have_alarm, 'HAVE_ALARM is a boolean' ); is( $have_unicode, !! $have_unicode, 'HAVE_UNICODE is a boolean' ); PPI-1.220/t/ppi_statement_include.t0000755000175100010010000001454412310327137014075 0ustar #!/usr/bin/perl # Unit testing for PPI::Statement::Include use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 64; use Test::NoWarnings; use PPI; TYPE: { my $document = PPI::Document->new(\<<'END_PERL'); require 5.6; require Module; require 'Module.pm'; use 5.6; use Module; use Module 1.00; no Module; END_PERL isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('PPI::Statement::Include'); is( scalar(@$statements), 7, 'Found 7 include statements' ); my @expected = qw{ require require require use use use no }; foreach ( 0 .. 6 ) { is( $statements->[$_]->type, $expected[$_], "->type $_ ok" ); } } MODULE_VERSION: { my $document = PPI::Document->new(\<<'END_PERL'); use Integer::Version 1; use Float::Version 1.5; use Version::With::Argument 1 2; use No::Version; use No::Version::With::Argument 'x'; use No::Version::With::Arguments 1, 2; use 5.005; END_PERL isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('PPI::Statement::Include'); is( scalar @{$statements}, 7, 'Found expected include statements.' ); is( $statements->[0]->module_version, 1, 'Integer version' ); is( $statements->[1]->module_version, 1.5, 'Float version' ); is( $statements->[2]->module_version, 1, 'Version and argument' ); is( $statements->[3]->module_version, undef, 'No version, no arguments' ); is( $statements->[4]->module_version, undef, 'No version, with argument' ); is( $statements->[5]->module_version, undef, 'No version, with arguments' ); is( $statements->[6]->module_version, undef, 'Version include, no module' ); } VERSION: { my $document = PPI::Document->new(\<<'END_PERL'); # Examples from perlfunc in 5.10. use v5.6.1; use 5.6.1; use 5.006_001; use 5.006; use 5.6.1; # Same, but using require. require v5.6.1; require 5.6.1; require 5.006_001; require 5.006; require 5.6.1; # Module. use Float::Version 1.5; END_PERL isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('PPI::Statement::Include'); is( scalar @{$statements}, 11, 'Found expected include statements.' ); is( $statements->[0]->version, 'v5.6.1', 'use v-string' ); is( $statements->[1]->version, '5.6.1', 'use v-string, no leading "v"' ); is( $statements->[2]->version, '5.006_001', 'use developer release' ); is( $statements->[3]->version, '5.006', 'use back-compatible version, followed by...' ); is( $statements->[4]->version, '5.6.1', '... use v-string, no leading "v"' ); is( $statements->[5]->version, 'v5.6.1', 'require v-string' ); is( $statements->[6]->version, '5.6.1', 'require v-string, no leading "v"' ); is( $statements->[7]->version, '5.006_001', 'require developer release' ); is( $statements->[8]->version, '5.006', 'require back-compatible version, followed by...' ); is( $statements->[9]->version, '5.6.1', '... require v-string, no leading "v"' ); is( $statements->[10]->version, '', 'use module version' ); } VERSION_LITERAL: { my $document = PPI::Document->new(\<<'END_PERL'); # Examples from perlfunc in 5.10. use v5.6.1; use 5.6.1; use 5.006_001; use 5.006; use 5.6.1; # Same, but using require. require v5.6.1; require 5.6.1; require 5.006_001; require 5.006; require 5.6.1; # Module. use Float::Version 1.5; END_PERL isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('PPI::Statement::Include'); is( scalar @{$statements}, 11, 'Found expected include statements.' ); is( $statements->[0]->version_literal, v5.6.1, 'use v-string' ); is( $statements->[1]->version_literal, 5.6.1, 'use v-string, no leading "v"' ); is( $statements->[2]->version_literal, 5.006_001, 'use developer release' ); is( $statements->[3]->version_literal, 5.006, 'use back-compatible version, followed by...' ); is( $statements->[4]->version_literal, 5.6.1, '... use v-string, no leading "v"' ); is( $statements->[5]->version_literal, v5.6.1, 'require v-string' ); is( $statements->[6]->version_literal, 5.6.1, 'require v-string, no leading "v"' ); is( $statements->[7]->version_literal, 5.006_001, 'require developer release' ); is( $statements->[8]->version_literal, 5.006, 'require back-compatible version, followed by...' ); is( $statements->[9]->version_literal, 5.6.1, '... require v-string, no leading "v"' ); is( $statements->[10]->version_literal, '', 'use module version' ); } ARGUMENTS: { my $document = PPI::Document->new(\<<'END_PERL'); use 5.006; # Don't expect anything. use Foo; # Don't expect anything. use Foo 5; # Don't expect anything. use Foo 'bar'; # One thing. use Foo 5 'bar'; # One thing. use Foo qw< bar >, "baz"; use Test::More tests => 5 * 9 # Don't get tripped up by the lack of the ";" END_PERL isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('PPI::Statement::Include'); is( scalar @{$statements}, 7, 'Found expected include statements.' ); is( scalar $statements->[0]->arguments, undef, 'arguments for perl version', ); is( scalar $statements->[1]->arguments, undef, 'arguments with no arguments', ); is( scalar $statements->[2]->arguments, undef, 'arguments with no arguments but module version', ); my @arguments = $statements->[3]->arguments; is( scalar @arguments, 1, 'arguments with single argument' ); is( $arguments[0]->content, q<'bar'>, 'arguments with single argument' ); @arguments = $statements->[4]->arguments; is( scalar @arguments, 1, 'arguments with single argument and module version', ); is( $arguments[0]->content, q<'bar'>, 'arguments with single argument and module version', ); @arguments = $statements->[5]->arguments; is( scalar @arguments, 3, 'arguments with multiple arguments', ); is( $arguments[0]->content, q/qw< bar >/, 'arguments with multiple arguments', ); is( $arguments[1]->content, q<,>, 'arguments with multiple arguments', ); is( $arguments[2]->content, q<"baz">, 'arguments with multiple arguments', ); @arguments = $statements->[6]->arguments; is( scalar @arguments, 5, 'arguments with Test::More', ); is( $arguments[0]->content, 'tests', 'arguments with Test::More', ); is( $arguments[1]->content, q[=>], 'arguments with Test::More', ); is( $arguments[2]->content, 5, 'arguments with Test::More', ); is( $arguments[3]->content, '*', 'arguments with Test::More', ); is( $arguments[4]->content, 9, 'arguments with Test::More', ); } PPI-1.220/t/28_foreach_qw.t0000755000175100010010000000272512251445131012142 0ustar #!/usr/bin/perl # Standalone tests to check "foreach qw{foo} {}" use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 13; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; ##################################################################### # Parse the canonical cases SCOPE: { my $string = 'for qw{foo} {} foreach'; my $document = PPI::Document->new( \$string ); isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('Statement::Compound'); is( scalar(@$statements), 2, 'Found 2 statements' ); is( $statements->[0]->type, 'foreach', '->type ok' ); is( $statements->[1]->type, 'foreach', '->type ok' ); } SCOPE: { my $string = 'foreach qw{foo} {} foreach'; my $document = PPI::Document->new( \$string ); isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('Statement::Compound'); is( scalar(@$statements), 2, 'Found 2 statements' ); is( $statements->[0]->type, 'foreach', '->type ok' ); is( $statements->[1]->type, 'foreach', '->type ok' ); } SCOPE: { my $string = 'for my $foo qw{bar} {} foreach'; my $document = PPI::Document->new( \$string ); isa_ok( $document, 'PPI::Document' ); my $statements = $document->find('Statement::Compound'); is( scalar(@$statements), 2, 'Found 2 statements' ); is( $statements->[0]->type, 'foreach', '->type ok' ); is( $statements->[1]->type, 'foreach', '->type ok' ); } 1; PPI-1.220/t/ppi_token_number_version.t0000755000175100010010000000163412310327137014617 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Number::Version use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 10; use Test::NoWarnings; use PPI; LITERAL: { my $doc1 = new_ok( 'PPI::Document' => [ \'1.2.3.4' ] ); my $doc2 = new_ok( 'PPI::Document' => [ \'v1.2.3.4' ] ); isa_ok( $doc1->child(0), 'PPI::Statement' ); isa_ok( $doc2->child(0), 'PPI::Statement' ); isa_ok( $doc1->child(0)->child(0), 'PPI::Token::Number::Version' ); isa_ok( $doc2->child(0)->child(0), 'PPI::Token::Number::Version' ); my $literal1 = $doc1->child(0)->child(0)->literal; my $literal2 = $doc2->child(0)->child(0)->literal; is( length($literal1), 4, 'The literal length of doc1 is 4' ); is( length($literal2), 4, 'The literal length of doc1 is 4' ); is( $literal1, $literal2, 'Literals match for 1.2.3.4 vs v1.2.3.4' ); } PPI-1.220/t/15_transform.t0000755000175100010010000000667712426751160012053 0ustar #!/usr/bin/perl use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More 0.86 tests => 24; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use File::Remove; use PPI; use PPI::Transform; use Scalar::Util 'refaddr'; use File::Copy; # Files to clean up my @cleanup; END { foreach ( @cleanup ) { File::Remove::remove( \1, $_ ); } } ##################################################################### # Begin Tests APPLY: { my $code = 'my $foo = "bar";'; my $rv = MyCleaner->apply( \$code ); ok( $rv, 'MyCleaner->apply( \$code ) returns true' ); is( $code, 'my$foo="bar";', 'MyCleaner->apply( \$code ) modifies code as expected' ); ok( PPI::Transform->register_apply_handler( 'Foo', \&Foo::get, \&Foo::set ), "register_apply_handler worked", ); $Foo::VALUE = 'my $foo = "bar";'; my $Foo = Foo->new; isa_ok( $Foo, 'Foo' ); ok( MyCleaner->apply( $Foo ), 'MyCleaner->apply( $Foo ) returns true' ); is( $Foo::VALUE, 'my$foo="bar";', 'MyCleaner->apply( $Foo ) modifies code as expected' ); } ##################################################################### # File transforms my $testdir = catdir( 't', 'data', '15_transform'); # Does the test directory exist? ok( (-e $testdir and -d $testdir and -r $testdir), "Test directory $testdir found" ); # Find the .pm test files opendir( TESTDIR, $testdir ) or die "opendir: $!"; my @files = map { catfile( $testdir, $_ ) } sort grep { /\.pm$/ } readdir(TESTDIR); closedir( TESTDIR ) or die "closedir: $!"; ok( scalar @files, 'Found at least one .pm file' ); ##################################################################### # Testing foreach my $input ( @files ) { # Prepare my $output = "${input}_out"; my $copy = "${input}_copy"; my $copy2 = "${input}_copy2"; push @cleanup, $copy; push @cleanup, $copy2; ok( copy( $input, $copy ), "Copied $input to $copy" ); my $Original = new_ok( 'PPI::Document' => [ $input ] ); my $Input = new_ok( 'PPI::Document' => [ $input ] ); my $Output = new_ok( 'PPI::Document' => [ $output ] ); # Process the file my $rv = MyCleaner->document( $Input ); isa_ok( $rv, 'PPI::Document' ); is( refaddr($rv), refaddr($Input), '->document returns original document' ); is_deeply( $Input, $Output, 'Transform works as expected' ); # Squish to another location ok( MyCleaner->file( $copy, $copy2 ), '->file returned true' ); my $Copy = new_ok( 'PPI::Document' => [ $copy ] ); is_deeply( $Copy, $Original, 'targeted transform leaves original unchanged' ); my $Copy2 = new_ok( 'PPI::Document' => [ $copy2 ] ); is_deeply( $Copy2, $Output, 'targeted transform works as expected' ); # Copy the file and process in-place ok( MyCleaner->file( $copy ), '->file returned true' ); $Copy = new_ok( 'PPI::Document' => [ $copy ] ); is_deeply( $Copy, $Output, 'In-place transform works as expected' ); } ##################################################################### # Support Code # Test Transform class package MyCleaner; use Params::Util qw{_INSTANCE}; use PPI::Transform (); use vars qw{@ISA}; BEGIN { @ISA = 'PPI::Transform'; } sub document { my $self = shift; my $Document = _INSTANCE(shift, 'PPI::Document') or return undef; $Document->prune( 'Token::Whitespace' ); $Document; } package Foo; sub new { bless { }, 'Foo'; } use vars qw{$VALUE}; BEGIN { $VALUE = ''; } sub get { PPI::Document->new( \$VALUE ); } sub set { $VALUE = $_[1]->serialize; } PPI-1.220/t/lib/0000755000175100010010000000000012430470371010066 5ustar PPI-1.220/t/lib/PPI.pm0000755000175100010010000001616412430462144011066 0ustar package t::lib::PPI; use warnings; use strict; use File::Spec::Functions ':ALL'; use Test::More; use Test::Object; use Params::Util qw{_STRING _INSTANCE}; use List::MoreUtils 'any'; use PPI::Dumper; use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } ##################################################################### # PPI::Document Testing Test::Object->register( class => 'PPI::Document', tests => 1, code => \&document_ok, ); sub document_ok { my $doc = shift; # A document should have zero or more children that are either # a statement or a non-significant child. my @children = $doc->children; my $good = grep { _INSTANCE($_, 'PPI::Statement') or ( _INSTANCE($_, 'PPI::Token') and ! $_->significant ) } @children; is( $good, scalar(@children), 'Document contains only statements and non-significant tokens' ); 1; } ##################################################################### # Are there an unknowns Test::Object->register( class => 'PPI::Document', tests => 3, code => \&unknown_objects, ); sub unknown_objects { my $doc = shift; is( $doc->find_any('Token::Unknown'), '', "Contains no PPI::Token::Unknown elements", ); is( $doc->find_any('Structure::Unknown'), '', "Contains no PPI::Structure::Unknown elements", ); is( $doc->find_any('Statement::Unknown'), '', "Contains no PPI::Statement::Unknown elements", ); 1; } ##################################################################### # Are there any invalid nestings? Test::Object->register( class => 'PPI::Document', tests => 1, code => \&nested_statements, ); sub nested_statements { my $doc = shift; ok( ! $doc->find_any( sub { _INSTANCE($_[1], 'PPI::Statement') and any { _INSTANCE($_, 'PPI::Statement') } $_[1]->children } ), 'Document contains no nested statements', ); } Test::Object->register( class => 'PPI::Document', tests => 1, code => \&nested_structures, ); sub nested_structures { my $doc = shift; ok( ! $doc->find_any( sub { _INSTANCE($_[1], 'PPI::Structure') and any { _INSTANCE($_, 'PPI::Structure') } $_[1]->children } ), 'Document contains no nested structures', ); } Test::Object->register( class => 'PPI::Document', tests => 1, code => \&no_attribute_in_attribute, ); sub no_attribute_in_attribute { my $doc = shift; ok( ! $doc->find_any( sub { _INSTANCE($_[1], 'PPI::Token::Attribute') and ! exists $_[1]->{_attribute} } ), 'No ->{_attribute} in PPI::Token::Attributes', ); } ##################################################################### # PPI::Statement Tests Test::Object->register( class => 'PPI::Document', tests => 1, code => \&valid_compound_type, ); sub valid_compound_type { my $document = shift; my $compound = $document->find('PPI::Statement::Compound') || []; is( scalar( grep { not defined $_->type } @$compound ), 0, 'All compound statements have defined ->type', ); } ##################################################################### # Does ->location work properly # As an aside, fixes #23788: PPI::Statement::location() returns undef for C<({})>. Test::Object->register( class => 'PPI::Document', tests => 1, code => \&defined_location, ); sub defined_location { my $document = shift; my $bad = $document->find( sub { not defined $_[1]->location } ); is( $bad, '', '->location always defined' ); } ##################################################################### # Process a .code/.dump file pair # plan: 2 + 14 * npairs sub run_testdir { my $pkg = shift; my $testdir = catdir(@_); # Does the test directory exist? ok( (-e $testdir and -d $testdir and -r $testdir), "Test directory $testdir found" ); # Find the .code test files local *TESTDIR; opendir( TESTDIR, $testdir ) or die "opendir: $!"; my @code = map { catfile( $testdir, $_ ) } sort grep { /\.code$/ } readdir(TESTDIR); closedir( TESTDIR ) or die "closedir: $!"; ok( scalar @code, 'Found at least one code file' ); foreach my $codefile ( @code ) { # Does the .code file have a matching .dump file my $dumpfile = $codefile; $dumpfile =~ s/\.code$/\.dump/; my $codename = $codefile; $codename =~ s/\.code$//; ok( (-f $dumpfile and -r $dumpfile), "$codename: Found matching .dump file" ); # Create the lexer and get the Document object my $document = PPI::Document->new( $codefile ); ok( $document, "$codename: Lexer->Document returns true" ); ok( _INSTANCE($document, 'PPI::Document'), "$codename: Object isa PPI::Document" ); my $rv; local *CODEFILE; SKIP: { skip "No Document to test", 12 unless $document; # Index locations ok( $document->index_locations, "$codename: ->index_locations ok" ); # Check standard things object_ok( $document ); # 7 tests contained within # Get the dump array ref for the Document object my $Dumper = PPI::Dumper->new( $document ); ok( _INSTANCE($Dumper, 'PPI::Dumper'), "$codename: Object isa PPI::Dumper" ); my @dump_list = $Dumper->list; ok( scalar @dump_list, "$codename: Got dump content from dumper" ); # Try to get the .dump file array local *DUMP; open( DUMP, '<', $dumpfile ) or die "open: $!"; my @content = ; close( DUMP ) or die "close: $!"; chomp @content; # Compare the two is_deeply( \@dump_list, \@content, "$codename: Generated dump matches stored dump" ); # Also, do a round-trip check $rv = open( CODEFILE, '<', $codefile ); ok( $rv, "$codename: Opened file" ); } SKIP: { unless ( $document and $rv ) { skip "Missing file", 1; } my $source = do { local $/ = undef; }; close CODEFILE; $source =~ s/(?:\015{1,2}\012|\015|\012)/\n/g; is( $document->serialize, $source, "$codename: Round-trip back to source was ok" ); } } } ##################################################################### # Process a .code/.dump file pair # plan: 2 + 14 * npairs sub increment_testdir { my $pkg = shift; my $testdir = catdir(@_); # Does the test directory exist? ok( (-e $testdir and -d $testdir and -r $testdir), "Test directory $testdir found" ); # Find the .code test files local *TESTDIR; opendir( TESTDIR, $testdir ) or die "opendir: $!"; my @code = map { catfile( $testdir, $_ ) } sort grep { /\.code$/ } readdir(TESTDIR); closedir( TESTDIR ) or die "closedir: $!"; ok( scalar @code, 'Found at least one code file' ); foreach my $codefile ( @code ) { # Does the .code file have a matching .dump file my $codename = $codefile; $codename =~ s/\.code$//; # Load the file local *CODEFILE; local $/ = undef; open( CODEFILE, '<', $codefile ) or die "open: $!"; my $buffer = ; close( CODEFILE ) or die "close: $!"; # Cover every possible transitional state in # the regression test code fragments. foreach my $chars ( 1 .. length($buffer) ) { my $string = substr( $buffer, 0, $chars ); my $document = eval { PPI::Document->new( \$string ); }; is( $@ => '', "$codename: $chars chars ok", ); is( ref($document) => 'PPI::Document', "$codename: $chars chars document", ); is( $document->serialize => $string, "$codename: $chars char roundtrip", ); } } } 1; PPI-1.220/t/ppi_token_quote_double.t0000755000175100010010000000441112425223007014243 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::Quote::Double use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 20; use Test::NoWarnings; use PPI; INTERPOLATIONS: { # Get a set of objects my $Document = PPI::Document->new(\<<'END_PERL'); "no interpolations" "no \@interpolations" "has $interpolation" "has @interpolation" "has \\@interpolation" "" # False content to test double-negation scoping END_PERL isa_ok( $Document, 'PPI::Document' ); my $strings = $Document->find('Token::Quote::Double'); is( scalar @{$strings}, 6, 'Found the 6 test strings' ); is( $strings->[0]->interpolations, '', 'String 1: No interpolations' ); is( $strings->[1]->interpolations, '', 'String 2: No interpolations' ); is( $strings->[2]->interpolations, 1, 'String 3: Has interpolations' ); is( $strings->[3]->interpolations, 1, 'String 4: Has interpolations' ); is( $strings->[4]->interpolations, 1, 'String 5: Has interpolations' ); is( $strings->[5]->interpolations, '', 'String 6: No interpolations' ); } SIMPLIFY: { my $Document = PPI::Document->new(\<<'END_PERL'); "no special characters" "has \"double\" quotes" "has 'single' quotes" "has $interpolation" "has @interpolation" "" END_PERL isa_ok( $Document, 'PPI::Document' ); my $strings = $Document->find('Token::Quote::Double'); is( scalar @{$strings}, 6, 'Found the 6 test strings' ); is( $strings->[0]->simplify, q<'no special characters'>, 'String 1: No special characters' ); is( $strings->[1]->simplify, q<"has \"double\" quotes">, 'String 2: Double quotes' ); is( $strings->[2]->simplify, q<"has 'single' quotes">, 'String 3: Single quotes' ); is( $strings->[3]->simplify, q<"has $interpolation">, 'String 3: Has interpolation' ); is( $strings->[4]->simplify, q<"has @interpolation">, 'String 4: Has interpolation' ); is( $strings->[5]->simplify, q<''>, 'String 6: Empty string' ); } STRING: { my $Document = PPI::Document->new( \'print "foo";' ); isa_ok( $Document, 'PPI::Document' ); my $Double = $Document->find_first('Token::Quote::Double'); isa_ok( $Double, 'PPI::Token::Quote::Double' ); is( $Double->string, 'foo', '->string returns as expected' ); } PPI-1.220/t/09_normal.t0000755000175100010010000000341712251445131011312 0ustar #!/usr/bin/perl # Testing of the normalization functions. # (only very basic at this point) use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 14; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use PPI; ##################################################################### # Creation and Manipulation SCOPE: { my $Document = PPI::Document->new(\'my $foo = bar();'); isa_ok( $Document, 'PPI::Document' ); my $Normal = $Document->normalized; isa_ok( $Normal, 'PPI::Document::Normalized' ); is( $Normal->version, $PPI::Normal::VERSION, '->version matches $VERSION' ); my $functions = $Normal->functions; is( ref $functions, 'ARRAY', '->functions returns an array ref' ); ok( scalar(@$functions), '->functions returns at least 1 function' ); } ##################################################################### # Basic Empiric Tests # Basic empiric testing SCOPE: { # The following should be equivalent my $Document1 = PPI::Document->new( \'my $foo = 1; # comment' ); my $Document2 = PPI::Document->new( \'my $foo=1 ;# different comment' ); my $Document3 = PPI::Document->new( \'sub foo { print "Hello World!\n"; }' ); isa_ok( $Document1, 'PPI::Document' ); isa_ok( $Document2, 'PPI::Document' ); isa_ok( $Document3, 'PPI::Document' ); my $Normal1 = $Document1->normalized; my $Normal2 = $Document2->normalized; my $Normal3 = $Document3->normalized; isa_ok( $Normal1, 'PPI::Document::Normalized' ); isa_ok( $Normal2, 'PPI::Document::Normalized' ); isa_ok( $Normal3, 'PPI::Document::Normalized' ); is( $Normal1->equal( $Normal2 ), 1, '->equal returns true for equivalent code' ); is( $Normal1->equal( $Normal3 ), '', '->equal returns false for different code' ); } PPI-1.220/t/ppi_token_dashedword.t0000755000175100010010000000142012310327137013677 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::DashedWord use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 10; use Test::NoWarnings; use PPI; LITERAL: { my @pairs = ( "-foo", '-foo', "-Foo::Bar", '-Foo::Bar', "-Foo'Bar", '-Foo::Bar', ); while ( @pairs ) { my $from = shift @pairs; my $to = shift @pairs; my $doc = PPI::Document->new( \"( $from => 1 );" ); isa_ok( $doc, 'PPI::Document' ); my $word = $doc->find_first('Token::DashedWord'); SKIP: { skip( "PPI::Token::DashedWord is deactivated", 2 ); isa_ok( $word, 'PPI::Token::DashedWord' ); is( $word && $word->literal, $to, "The source $from becomes $to ok" ); } } } PPI-1.220/t/ppi_token__quoteengine_full.t0000755000175100010010000000641012426751160015270 0ustar #!/usr/bin/perl # Unit testing for PPI::Token::_QuoteEngine::Full use strict; BEGIN { $| = 1; $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 94; use Test::NoWarnings; use PPI; 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 = PPI::Document->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 = PPI::Document->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 }, [ '//' ] ], [ 'mx', '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 = PPI::Document->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" ); } } PPI-1.220/t/07_token.t0000755000175100010010000001715112425223367011150 0ustar #!/usr/bin/perl # Formal unit tests for specific PPI::Token classes use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } # Execute the tests use Test::More tests => 447; use Test::NoWarnings; use File::Spec::Functions ':ALL'; use t::lib::PPI; use PPI; ##################################################################### # Code/Dump Testing # ntests = 2 + 12 * nfiles t::lib::PPI->run_testdir( catdir( 't', 'data', '07_token' ) ); ##################################################################### # PPI::Token::Symbol Unit Tests # Note: braces and the symbol() method are tested in regression.t SCOPE: { # Test both creation methods my $Token = PPI::Token::Symbol->new( '$foo' ); isa_ok( $Token, 'PPI::Token::Symbol' ); # Check the creation of a number of different values my @symbols = ( '$foo' => '$foo', '@foo' => '@foo', '$ foo' => '$foo', '$::foo' => '$main::foo', '@::foo' => '@main::foo', '$foo::bar' => '$foo::bar', '$ foo\'bar' => '$foo::bar', ); while ( @symbols ) { my ($value, $canon) = ( shift(@symbols), shift(@symbols) ); my $Symbol = PPI::Token::Symbol->new( $value ); isa_ok( $Symbol, 'PPI::Token::Symbol' ); is( $Symbol->content, $value, "Symbol '$value' returns ->content '$value'" ); is( $Symbol->canonical, $canon, "Symbol '$value' returns ->canonical '$canon'" ); } } ##################################################################### # PPI::Token::Number Unit Tests SCOPE: { my @examples = ( # code => base | '10f' | '10e' '0' => 10, '1' => 10, '10' => 10, '1_0' => 10, '.0' => '10f', '.0_0' => '10f', '-.0' => '10f', '0.' => '10f', '0.0' => '10f', '0.0_0' => '10f', '1_0.' => '10f', '.0e0' => '10e', '-.0e0' => '10e', '0.e1' => '10e', '0.0e-1' => '10e', '0.0e+1' => '10e', '0.0e-10' => '10e', '0.0e+10' => '10e', '0.0e100' => '10e', '1_0e1_0' => '10e', # Known to fail on 5.6.2 '0b' => 2, '0b0' => 2, '0b10' => 2, '0b1_0' => 2, '00' => 8, '01' => 8, '010' => 8, '01_0' => 8, '0x' => 16, '0x0' => 16, '0x10' => 16, '0x1_0' => 16, '0.0.0' => 256, '.0.0' => 256, '127.0.0.1' => 256, '1.1.1.1.1.1' => 256, ); while ( @examples ) { my $code = shift @examples; my $base = shift @examples; if ( $] >= 5.006 and $] < 5.008 and $code eq '1_0e1_0' ) { SKIP: { skip( 'Ignoring known-bad case on Perl 5.6.2', 5 ); } next; } my $exp = $base =~ s/e//; my $float = $exp || $base =~ s/f//; my $T = PPI::Tokenizer->new( \$code ); my $token = $T->get_token; is("$token", $code, "'$code' is a single token"); is($token->base, $base, "base of '$code' is $base"); if ($float) { ok($token->isa('PPI::Token::Number::Float'), "'$code' is ::Float"); } else { ok(!$token->isa('PPI::Token::Number::Float'), "'$code' not ::Float"); } if ($exp) { ok($token->isa('PPI::Token::Number::Exp'), "'$code' is ::Exp"); } else { ok(!$token->isa('PPI::Token::Number::Exp'), "'$code' not ::Exp"); } if ($base != 256) { $^W = 0; my $literal = eval $code; if ($@) { is($token->literal, undef, "literal('$code'), $@"); } else { cmp_ok($token->literal, '==', $literal, "literal('$code')"); } } } } foreach my $code ( '1.0._0', '1.0.0.0_0' ) { my $T = PPI::Tokenizer->new( \$code ); my $token = $T->get_token; isnt("$token", $code, 'tokenize bad version'); } foreach my $code ( '08', '09', '0778', '0779' ) { my $T = PPI::Tokenizer->new( \$code ); my $token = $T->get_token; isa_ok($token, 'PPI::Token::Number::Octal'); is("$token", $code, "tokenize bad octal '$code'"); ok($token->{_error} && $token->{_error} =~ m/octal/i, 'invalid octal number should trigger parse error'); is($token->literal, undef, "literal('$code') is undef"); } BINARY: { my @tests = ( # Good binary numbers { code => '0b0', error => 0, value => 0 }, { code => '0b1', error => 0, value => 1 }, { code => '0B1', error => 0, value => 1 }, { code => '0b101', error => 0, value => 5 }, { code => '0b1_1', error => 0, value => 3 }, { code => '0b1__1', error => 0, value => 3 }, # perl warns, but parses it { code => '0b1__1_', error => 0, value => 3 }, # perl warns, but parses it # Bad binary numbers { code => '0b2', error => 1, value => 0 }, { code => '0B2', error => 1, value => 0 }, { code => '0b012', error => 1, value => 0 }, { code => '0B012', error => 1, value => 0 }, { code => '0B0121', error => 1, value => 0 }, ); foreach my $test ( @tests ) { my $code = $test->{code}; my $T = PPI::Tokenizer->new( \$code ); my $token = $T->get_token; isa_ok($token, 'PPI::Token::Number::Binary'); if ( $test->{error} ) { ok($token->{_error} && $token->{_error} =~ m/binary/i, 'invalid binary number should trigger parse error'); is($token->literal, undef, "literal('$code') is undef"); } else { ok(!$token->{_error}, "no error for '$code'"); is($token->literal, $test->{value}, "literal('$code') is $test->{value}"); } is($token->content, $code, "parsed everything"); } } HEX: { my @tests = ( # Good hex numbers--entire thing goes in the token { code => '0x0', parsed => '0x0', value => 0 }, { code => '0X1', parsed => '0X1', value => 1 }, { code => '0x1', parsed => '0x1', value => 1 }, { code => '0x_1', parsed => '0x_1', value => 1 }, { code => '0x__1', parsed => '0x__1', value => 1 }, # perl warns, but parses it { code => '0x__1_', parsed => '0x__1_', value => 1 }, # perl warns, but parses it { code => '0X1', parsed => '0X1', value => 1 }, { code => '0xc', parsed => '0xc', value => 12 }, { code => '0Xc', parsed => '0Xc', value => 12 }, { code => '0XC', parsed => '0XC', value => 12 }, { code => '0xbeef', parsed => '0xbeef', value => 48879 }, { code => '0XbeEf', parsed => '0XbeEf', value => 48879 }, { code => '0x0e', parsed => '0x0e', value => 14 }, { code => '0x00000e', parsed => '0x00000e', value => 14 }, { code => '0x000_00e', parsed => '0x000_00e', value => 14 }, { code => '0x000__00e', parsed => '0x000__00e', value => 14 }, # perl warns, but parses it # Bad hex numbers--tokenizing stops when bad digit seen { code => '0x', parsed => '0x', value => 0 }, { code => '0X', parsed => '0X', value => 0 }, { code => '0xg', parsed => '0x', value => 0 }, { code => '0Xg', parsed => '0X', value => 0 }, { code => '0XG', parsed => '0X', value => 0 }, { code => '0x0g', parsed => '0x0', value => 0 }, { code => '0X0g', parsed => '0X0', value => 0 }, { code => '0X0G', parsed => '0X0', value => 0 }, { code => '0x1g', parsed => '0x1', value => 1 }, { code => '0x1g2', parsed => '0x1', value => 1 }, { code => '0x1_g', parsed => '0x1_', value => 1 }, ); foreach my $test ( @tests ) { my $code = $test->{code}; my $T = PPI::Tokenizer->new( \$code ); my $token = $T->get_token; isa_ok($token, 'PPI::Token::Number::Hex'); ok(!$token->{_error}, "no error for '$code' even on invalid digits"); is($token->content, $test->{parsed}, "correctly parsed everything expected"); is($token->literal, $test->{value}, "literal('$code') is $test->{value}"); } } PPI-1.220/t/ppi_statement_sub.t0000755000175100010010000000574512426751160013253 0ustar #!/usr/bin/perl # Test PPI::Statement::Sub use strict; BEGIN { $^W = 1; no warnings 'once'; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } use Test::More tests => 131; use Test::NoWarnings; use PPI; SUB_WORD_OPTIONAL: { # 'sub' is optional for these special subs. Make sure they're # recognized as subs and sub declarations. for my $name ( qw( AUTOLOAD DESTROY ) ) { for my $sub ( '', 'sub ' ) { # '{}' -- function definition # ';' -- function declaration # '' -- function declaration with missing semicolon for my $followed_by ( ' {}', '{}', ';', '' ) { test_sub_as( $sub, $name, $followed_by ); } } } # Through 1.218, the PPI statement AUTOLOAD and DESTROY would # gobble up everything after them until it hit an explicit # statement terminator. Make sure statements following them are # not gobbled. my $desc = 'regression: word+block not gobbling to statement terminator'; for my $word ( qw( AUTOLOAD DESTROY ) ) { my $Document = PPI::Document->new( \"$word {} sub foo {}" ); my $statements = $Document->find('Statement::Sub') || []; is( scalar(@$statements), 2, "$desc for $word + sub" ); $Document = PPI::Document->new( \"$word {} package;" ); $statements = $Document->find('Statement::Sub') || []; is( scalar(@$statements), 1, "$desc for $word + package" ); $statements = $Document->find('Statement::Package') || []; is( scalar(@$statements), 1, "$desc for $word + package" ); } } PROTOTYPE: { # Doesn't have to be as thorough as ppi_token_prototype.t, since # we're just making sure PPI::Token::Prototype->prototype gets # passed through correctly. for my $test ( [ '', undef ], [ '()', '' ], [ '( $*Z@ )', '$*Z@' ], ) { my ( $proto_text, $expected ) = @$test; my $Document = PPI::Document->new( \"sub foo $proto_text {}" ); isa_ok( $Document, 'PPI::Document', "$proto_text got document" ); my ( $sub_statement, $dummy ) = $Document->schildren(); isa_ok( $sub_statement, 'PPI::Statement::Sub', "$proto_text document child is a sub" ); is( $dummy, undef, "$proto_text document has exactly one child" ); is( $sub_statement->prototype, $expected, "$proto_text: prototype matches" ); } } sub test_sub_as { my ( $sub, $name, $followed_by ) = @_; my $code = "$sub$name$followed_by"; my $Document = PPI::Document->new( \$code ); isa_ok( $Document, 'PPI::Document', "$code: got document" ); my ( $sub_statement, $dummy ) = $Document->schildren; isa_ok( $sub_statement, 'PPI::Statement::Sub', "$code: document child is a sub" ); isnt( ref $sub_statement, 'PPI::Statement::Scheduled', "$code: not a PPI::Statement::Scheduled" ); is( $dummy, undef, "$code: document has exactly one child" ); ok( $sub_statement->reserved, "$code: is reserved" ); is( $sub_statement->name, $name, "$code: name() correct" ); if ( $followed_by =~ /}/ ) { isa_ok( $sub_statement->block, 'PPI::Structure::Block', "$code: has a block" ); } else { ok( !$sub_statement->block, "$code: has no block" ); } return; } PPI-1.220/t/26_bom.t0000755000175100010010000000070512425223367010603 0ustar #!/usr/bin/perl use strict; BEGIN { no warnings 'once'; $| = 1; $PPI::XS_DISABLE = 1; $PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER}; } # For each new item in t/data/08_regression add another 14 tests use Test::More tests => 21; use Test::NoWarnings; use t::lib::PPI; use PPI; ##################################################################### # Code/Dump Testing # ntests = 2 + 14 * nfiles t::lib::PPI->run_testdir(qw{ t data 26_bom }); PPI-1.220/xt/0000755000175100010010000000000012430470371007510 5ustar PPI-1.220/xt/author.t0000755000175100010010000000076712426751160011217 0ustar #!/usr/bin/perl use strict; BEGIN { $| = 1; $^W = 1; } my $MODULE = 'Test::Pod 1.44'; # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing module if ( !eval "use $MODULE; 1" ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } all_pod_files_ok(); PPI-1.220/xt/meta.t0000755000175100010010000000107312426751160010632 0ustar #!/usr/bin/perl # Test that our META.yml file matches the current specification. use strict; BEGIN { $| = 1; $^W = 1; } my $MODULE = 'Test::CPAN::Meta 0.17'; # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing module if ( !eval "use $MODULE; 1" ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } meta_yaml_ok(); PPI-1.220/xt/api.t0000755000175100010010000001674012251445131010456 0ustar #!/usr/bin/perl # Basic first pass API testing for PPI use strict; use Test::More; BEGIN { $| = 1; $PPI::XS_DISABLE = 1; $PPI::XS_DISABLE = 1; # Prevent warning if ( $ENV{RELEASE_TESTING} ) { plan( tests => 2931 ); } else { plan( skip_all => 'Author tests not required for installation' ); } } use File::Spec::Functions ':ALL'; use Test::NoWarnings; use Test::ClassAPI; use PPI; use PPI::Dumper; use PPI::Find; use PPI::Transform; # Ignore various imported or special functions $Test::ClassAPI::IGNORE{'DESTROY'}++; $Test::ClassAPI::IGNORE{'refaddr'}++; $Test::ClassAPI::IGNORE{'reftype'}++; $Test::ClassAPI::IGNORE{'blessed'}++; # Execute the tests Test::ClassAPI->execute('complete', 'collisions'); exit(0); # Now, define the API for the classes __DATA__ # Explicitly list the core classes PPI=class PPI::Tokenizer=class PPI::Lexer=class PPI::Dumper=class PPI::Find=class PPI::Transform=abstract PPI::Normal=class # The abstract PDOM classes PPI::Element=abstract PPI::Node=abstract PPI::Token=abstract PPI::Token::_QuoteEngine=abstract PPI::Token::_QuoteEngine::Simple=abstract PPI::Token::_QuoteEngine::Full=abstract PPI::Token::Quote=abstract PPI::Token::QuoteLike=abstract PPI::Token::Regexp=abstract PPI::Structure=abstract PPI::Statement=abstract ##################################################################### # PDOM Classes [PPI::Element] new=method clone=method parent=method descendant_of=method ancestor_of=method top=method document=method statement=method next_sibling=method snext_sibling=method previous_sibling=method sprevious_sibling=method first_token=method last_token=method next_token=method previous_token=method insert_before=method insert_after=method remove=method delete=method replace=method content=method tokens=method significant=method location=method line_number=method column_number=method visual_column_number=method logical_line_number=method logical_filename=method class=method [PPI::Node] PPI::Element=isa scope=method add_element=method elements=method first_element=method last_element=method children=method schildren=method child=method schild=method contains=method find=method find_any=method find_first=method remove_child=method prune=method [PPI::Token] PPI::Element=isa new=method add_content=method set_class=method set_content=method length=method [PPI::Token::Whitespace] PPI::Token=isa null=method tidy=method [PPI::Token::Pod] PPI::Token=isa lines=method merge=method [PPI::Token::Data] PPI::Token=isa handle=method [PPI::Token::End] PPI::Token=isa [PPI::Token::Comment] PPI::Token=isa line=method [PPI::Token::Word] PPI::Token=isa literal=method method_call=method [PPI::Token::Separator] PPI::Token::Word=isa [PPI::Token::Label] PPI::Token=isa [PPI::Token::Structure] PPI::Token=isa [PPI::Token::Number] PPI::Token=isa base=method literal=method [PPI::Token::Symbol] PPI::Token=isa canonical=method symbol=method raw_type=method symbol_type=method [PPI::Token::ArrayIndex] PPI::Token=isa [PPI::Token::Operator] PPI::Token=isa [PPI::Token::Magic] PPI::Token=isa PPI::Token::Symbol=isa [PPI::Token::Cast] PPI::Token=isa [PPI::Token::Prototype] PPI::Token=isa prototype=method [PPI::Token::Attribute] PPI::Token=isa identifier=method parameters=method [PPI::Token::DashedWord] PPI::Token=isa literal=method [PPI::Token::HereDoc] PPI::Token=isa heredoc=method terminator=method [PPI::Token::_QuoteEngine] [PPI::Token::_QuoteEngine::Simple] PPI::Token::_QuoteEngine=isa [PPI::Token::_QuoteEngine::Full] PPI::Token::_QuoteEngine=isa [PPI::Token::Quote] PPI::Token=isa string=method [PPI::Token::Quote::Single] PPI::Token=isa PPI::Token::Quote=isa literal=method [PPI::Token::Quote::Double] PPI::Token=isa PPI::Token::Quote=isa interpolations=method simplify=method [PPI::Token::Quote::Literal] PPI::Token=isa literal=method [PPI::Token::Quote::Interpolate] PPI::Token=isa [PPI::Token::QuoteLike] PPI::Token=isa [PPI::Token::QuoteLike::Backtick] PPI::Token=isa PPI::Token::_QuoteEngine::Simple=isa [PPI::Token::QuoteLike::Command] PPI::Token=isa PPI::Token::_QuoteEngine::Full=isa [PPI::Token::QuoteLike::Words] PPI::Token=isa PPI::Token::_QuoteEngine::Full=isa literal=method [PPI::Token::QuoteLike::Regexp] PPI::Token=isa PPI::Token::_QuoteEngine::Full=isa get_match_string=method get_substitute_string=method get_modifiers=method get_delimiters=method [PPI::Token::QuoteLike::Readline] PPI::Token=isa PPI::Token::_QuoteEngine::Full=isa [PPI::Token::Regexp] PPI::Token=isa PPI::Token::_QuoteEngine::Full=isa get_match_string=method get_substitute_string=method get_modifiers=method get_delimiters=method [PPI::Token::Regexp::Match] PPI::Token=isa [PPI::Token::Regexp::Substitute] PPI::Token=isa [PPI::Token::Regexp::Transliterate] PPI::Token=isa [PPI::Statement] PPI::Node=isa label=method specialized=method stable=method [PPI::Statement::Expression] PPI::Statement=isa [PPI::Statement::Package] PPI::Statement=isa namespace=method file_scoped=method [PPI::Statement::Include] PPI::Statement=isa type=method arguments=method module=method module_version=method pragma=method version=method version_literal=method [PPI::Statement::Include::Perl6] PPI::Statement::Include=isa perl6=method [PPI::Statement::Sub] PPI::Statement=isa name=method prototype=method block=method forward=method reserved=method [PPI::Statement::Scheduled] PPI::Statement::Sub=isa PPI::Statement=isa type=method block=method [PPI::Statement::Variable] PPI::Statement=isa PPI::Statement::Expression=isa type=method variables=method symbols=method [PPI::Statement::Compound] PPI::Statement=isa type=method [PPI::Statement::Given] PPI::Statement=isa [PPI::Statement::When] PPI::Statement=isa [PPI::Statement::Break] PPI::Statement=isa [PPI::Statement::Null] PPI::Statement=isa [PPI::Statement::Data] PPI::Statement=isa [PPI::Statement::End] PPI::Statement=isa [PPI::Statement::Unknown] PPI::Statement=isa [PPI::Structure] PPI::Node=isa braces=method complete=method start=method finish=method [PPI::Structure::Block] PPI::Structure=isa [PPI::Structure::Subscript] PPI::Structure=isa [PPI::Structure::Constructor] PPI::Structure=isa [PPI::Structure::Condition] PPI::Structure=isa [PPI::Structure::List] PPI::Structure=isa [PPI::Structure::For] PPI::Structure=isa [PPI::Structure::Given] PPI::Structure=isa [PPI::Structure::When] PPI::Structure=isa [PPI::Structure::Unknown] PPI::Structure=isa [PPI::Document] PPI::Node=isa get_cache=method set_cache=method load=method save=method readonly=method tab_width=method serialize=method hex_id=method index_locations=method flush_locations=method normalized=method complete=method errstr=method STORABLE_freeze=method STORABLE_thaw=method [PPI::Document::Fragment] PPI::Document=isa ##################################################################### # Non-PDOM Classes [PPI] [PPI::Tokenizer] new=method get_token=method all_tokens=method increment_cursor=method decrement_cursor=method [PPI::Lexer] new=method lex_file=method lex_source=method lex_tokenizer=method errstr=method [PPI::Dumper] new=method print=method string=method list=method [PPI::Find] new=method clone=method in=method start=method match=method finish=method errstr=method [PPI::Transform] new=method document=method apply=method file=method [PPI::Normal] register=method new=method layer=method process=method [PPI::Normal::Standard] import=method remove_insignificant_elements=method remove_useless_attributes=method remove_useless_pragma=method remove_statement_separator=method remove_useless_return=method [PPI::Document::Normalized] new=method version=method functions=method equal=method PPI-1.220/xt/pmv.t0000755000175100010010000000163612426751160010513 0ustar #!/usr/bin/perl # Test that our declared minimum Perl version matches our syntax use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'File::Find::Rule 0.32', 'File::Find::Rule::Perl 1.09', 'Perl::MinimumVersion 1.25', 'Test::MinimumVersion 0.101080', ); # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE ( @MODULES ) { if ( !eval "use $MODULE; 1" ) { $ENV{RELEASE_TESTING} ? die( "Failed to load required release-testing module $MODULE" ) : plan( skip_all => "$MODULE not available for testing" ); } } all_minimum_version_from_metayml_ok( { paths => [ grep { ! /14_charsets/ and ! /24_v6/ } File::Find::Rule->perl_file->in('.') ], } ); PPI-1.220/Changes0000755000175100010010000014013312430462336010357 0ustar Revision history for Perl extension PPI 1.220 Tue 11 Nov 2014 Summary: - incompatible behavior fixes on PPI::Statement::Sub->prototype - improved parsing of various syntax elements - code quality improvements - various small documentation fixes Details: - {} is now recognized as anonymous hash constructor instead of a code block after these operators: &&= //= || && // ? : (GitHub #36) (MOREGAN) - regex capture variables greater than $9 are now parsed completely, instead of being parsed as single digit captures with numbers after them (GitHub #38) (MOREGAN) - DESTROY and AUTOLOAD subs are now parsed even without the sub keyword (GitHub #39) (MOREGAN) - PPI::Statement::Sub->prototype behavior now matches its documentation, instead of returning the prototype string unchanged and still including the parens (GitHub #56) (MOREGAN) - PPI::Statement::Sub->prototype now returns undef on subs without a prototype, instead of returning an empty string (GitHub #56) (MOREGAN) - list of keywords which are not parsed as packages when followed by the Perl4 package separator ' has been increased (GitHub #77) (MOREGAN) - application of a number of Perl::Critic policies and documentation fixes (GitHub #53) (MOREGAN, MITHALDU) - automation of README.md generation for git (GitHub #86) (COWENS) - various small documentation fixes (Github #96) (MOREGAN) 1.218 Sat 16 Aug 2014 Summary: - Fixes for various parsing and documentation bugs - 1MB limit on input document size removed - Moved repository to GitHub: https://github.com/adamkennedy/PPI Details: - Stop directing bugs to rt.cpan.org (GitHub #40) (MOREGAN) - Fix documentation reference to List::Util (RT #75308) (RWSTAUNER) - Improve scalability of parsing long lines, and remove the size limit on documents PPI will parse (GitHub #5) (MITHALDU) - Speed up adding an element to an unlabeled statement. Allow inlining of some methods. (WOLFSAGE) - Expanded test coverage (DOLMEN, MOREGAN) - Convert inline tests to standalone tests (GitHub #12) (MOREGAN) - Fix for '1=>x' being parsed as x operator (GitHub #46) (MOREGAN) - Recognize that '1 x3' is the x operator followed by a 3 (RT #37892, GitHub #27) (MOREGAN) - Support all augmented assignment operators (<<=, ||=, etc.) (RT #68176, 71705) (MOREGAN) - Stop upper-case "=CUT" from terminating POD (RT #75039) (JAE) - Support upper-case digits in hex and binary numbers, including in the leading '0X' and '0B'. (RT #36540) (KRYDE, MOREGAN) - Fix float argument to range operator misparsed as version string (RT #45014) (MOREGAN) - Fix POD markup in PPI::Find (RT #51693) (FWIE) - Fix spelling of "Tom Christiansen" (RT #67264) (TADMC) - Fix a large raft of spelling and grammar errors (RT #85049) (David Steinbrunner, DOLMEN, MOREGAN) - Fix errors in documentation of the PPI::Element class hierarchy (RT #30863, 69026) (SJQUINNEY) - Prevent PPI::XSAccessor packages from hiding corresponding PPI packages in CPAN (RT #90792) (MITHALDU) - Recognize the formfeed character as whitespace (RT #67517) (WYANT) - Recognize regex match following 'return' (RT #27475) (ADAMK) - Fix missing dereference, length called on reference (RT #40103) (ADAMK) 1.215 Sat 26 Feb 2011 Summary: - No changes Details: - Confirmed new Perl::Critic works with 1.214_02, so we can release a new PPI now. 1.214_02 Mon 31 Jan 2011 Summary: - More minor fixes, preparing for production release Details: - Updated copyright year to 2011 (ADAMK) - Fixed RT #64247 bless {} probably contains a hash constructor (WYANT) - Backed out glob fix (WYANT) - Fixed RT #65199 Cast can trump braces in PPI::Token::Symbol->symbol (WYANT) 1.214_01 Thu 16 Dec 2010 Summary: - General fix release Details: - index_locations on an empty document no longer warns (WYANT) - Corrected a bug in line-spanning attribute support (WYANT) - Regression test for line-spanning attribute support (ADAMK) - Fixed #61305 return { foo => 1 } should parse curlys as hash constructor, not block (WYANT) - Fixed #63943 map and regexp confuse PPI? (ADAMK) 1.213 Tue 6 Jul 2010 Summary: - Targetted bug fix, no changes to parsing or normal usage Details: - Updated to Module::Install 1.00 - Updated module depednencies in xt author tests - Fixed extremely broken PPI::Token::Pod::merge and added test case 1.212 Sun 9 May 2010 Summary: - Minor bug fixes and development support Details: - Fixed #48819: Bug in ForLoop back-compatilbilty warning - Added support for $ENV{X_TOKENIZER} --> $PPI::Lexer::X_TOKENIZER 1.211_01 Sun 21 Feb 2010 Summary: - Experimentation support and bug fixes Details: - Upgraded to Module::Install 0.93 - Added support for $PPI::Lexer::X_TOKENIZER, so that alternate experimentatal tokenizers can be swapped in for testing. - Added an extra 14_charsets.t case to validate we handle byte order marks properly. - Moved author tests from t to xt to reduce spurious test failures in CPAN Testers, when the testing modules change across versions - Fixed #26082: scalar { %x } is misparsed - Fixed #26591: VMS patch for PPI 1.118 - Fixed #44862: PPI cannot parse "package Foo::100;" correctly - Fixed #54208: PPI::Token::Quote::Literal::literal is missing due to case-sensitivity error 1.210 Mon 15 Feb 2010 Summary: - Packaging fixes Details: - No functional changes - Upgrading to Module::Install 0.93 - Added missing test_requires dependency for Class::Inspector 1.209 Sat 6 Feb 2010 Summary: - Small optimisation release Details: - No functional changes - Upgrading to Module::Install 0.92 - Moved the Test::ClassAPI test to only run during RELEASE_TESTING to reduce the dependency load (and occasionally Test::ClassAPI seems to FAIL on CPAN Testers. 1.208 Thu 14 Jan 2010 Summary: - THIS IS THE 100TH RELEASE OF PPI! - Fixes some tiny issues, otherwise unchanged from 1.207_01 Details: - Don't assign '' to $^W, it generates a warning on Gentoo - Added missing PPI::Token::Regexp fix to Changes file - Updating Copyright to the new year (yet again) 1.207_01 Thu 10 Dec 2009 Summary: - This is a general bug fix and accuracy release Details: - Fixed #50309: literal() wrong result on "qw (a b c)" - PPI::Dumper no longer causes Elements to flush location data. Also it no longer disables location information for non-Documents. - +{ package => 1 } doesn't create a PPI::Statement::Package - PPI::Token::Regexp and PPI::Token::QuoteLike::Regexp how have methods for getting at the various components (delimiters, modifiers, match & substitution strings). 1.206 Sun 9 Aug 2009 Summary: - This is an optimisation release (1-2% speed up) (Using information uncovered by a Devel::NYTProf 3 alpha) Details: - Removing som superfluous 1; returns - Using defined and ref to avoid highly excessive calls to PPI::Util::TRUE 1.205 Mon 3 Aug 2009 Summary: - This is a production release Details: - No changes from 1.204_07 1.204_07 Fri 31 Jul 2009 Summary: - Minor tweaks Details: - Allow ::For and ::List to return true to ->isa(::ForLoop) and do a once-per-process warning when we do. - Fixed a bug in Class::XSAccessor prototype. 1.204_06 Wed 22 Jul 2009 Summary: - API Change Details: - Changing PPI::Structure::ForLoop to PPI::Structure::For 1.204_05 Tue 21 Jul 2009 Summary: - Bug fixes in preparation for production release Details: - There is no longer any real reason to bundle the testing modules except as a potential source of more bugs. - Removed quantifier ? on zero-length ^ in /^?for(?:each)?\z/ - Run-time load PPI::Document instal of compile-time loading it - Tweak a few load orders to get PPI::Util loaded earlier. - Fixed location access methods on PPI::Element - New PPI::Statement::Include::version_literal() method. 1.204_04 Thu 16 Jul 2009 Summary: - Dependency tweaks Details: - Because we bundle Test::ClassAPI, we need to explicitly match its dependencies. Bumped Params::Util to 1.00. - Bumped a couple of deps a couple of revisions to get better XS. 1.204_03 Tue 14 Jul 2009 Summary: - More bug fixing, clean up, and optimisation - Cleaning up contributed APIs - Adding some demonstration classes Details: - Implemented PPI::Transform::UpdateCopyright - Removed the use of 'use base' - Various minor simplifications - Renamed PPI::Statement::Switch to ::Given - Renamed PPI::Structure::WhenMatch to ::When - Converted the Lexer internals to use exception-based error handling. - Take advantage of the removal of all those "or return undef" to simplify the Lexer code, remove variable declarations, and inline calls to several hot-code-path functions. The Lexer should be significantly faster (FSDO "significant"). - The v6 key on Tokenizer broke support for Perl 5.6 (perl thought it was a numeric v-string) 1.204_02 Sun 10 May 2009 Summary: - Various bug fixing and stabilisation work - It's a perl 5.10 extravaganza! Details: - Updated Module::Install to 0.87 - Added Test::NoWarnings to the test suite - Added support for qw{foo} in addition to for ('foo') - Added support for vstrings again - Now supports the 5.10 "state" keyword. (As far as PPI is concerned it's a synonym for "my") - Now supports switch statements. - Now supports the smart match operator (~~). - Now supports keeping track of line numbers and file names as affected by the #line directive. - Now supports UNITCHECK blocks. - Statement::Include::module_version() implemented. - Statement::Include::arguments() implemented. - Statement::Variable::symbols() implemented. - Token::QuoteLike::Words::literal() implemented. - Token::Quote::Double::simplify() fixed. - Element line_number(), column_number(), visual_column_number(), logical_line_number(), and logical_filename() implemented. - Support for Unicode byte order marks (PPI::Token::BOM) added. - Token::Word::method_call() implemented. - Element::descendant_of() and Element::ancestor_of() implemented. - Statement::specialized() implemented. - Now can handle files named "0". (Perl::Critic got a complaint about this) - foreach loop variables can be declared using "our". - Much more comprehensive testing of compound statement detection. 1.204_01 Sun 18 May 2008 Summary: - Unicode cleanup and bug fixing - Taking the opportunity to do some house cleaning while the code base is relatively stable, before things get crazy again. Details: - For completeness sake, add support for empty documents - Moved capability detection into PPI::Util - POD test script now skips on install properly - Removed 200 lines of old dead "rawinput" code from PPI::Tokenizer - 100% of PPI::Tokenizer is now exception-driven - Workaround for "RT#35917 - charsets.t eats all available VM" (unicode bug in 5.8.6, works in 5.8.8) - Temporarily disable round-trip testing of 14_charset.t 1.203 Wed 14 May 2008 Summary: - No change, switching to production version 1.202_03 Wed 14 May 2008 Summary: - Initial Perl 6 support - Bug fixes and final 1.203 release candidate - I finally catch up with all the failing test cases that Chris Dolan keeps commiting :) Details: - Adding initial support for "use v6-alpha;" - Adding new class Perl::Statement::Include::Perl6 - Adding a test on the KindaPerl6::Grammar, which triggered a bug in the tokenizer during CPAN::Metrics tinderboxing. - All open() calls now use three-argument form - Upgrading explicit Perl dependency to 5.006, because of the previous item. - Better support for labels, including tricky ones like "BEGIN : { ... }" 1.202_02 Wed 2 Jan 2008 Summary: - Back-compatibility and 1.203 release candidate Details: - Removing the use of use base 'Exporter'; - Updating Test::SubCalls dep to 1.07 to get the use base 'Exporter' fix for that too. 1.202_01 Tue 20 Nov 2007 Summary: - Minor bug fix release Details: - RT #30469: calling length() on PPI::Token gives error - 14_charsets.t was incorrectly skipping in situations that it should have been running. 1.201 Mon 22 Oct 2007 Summary: - Minor bug fix release Details: - The internal exception class PPI::Exception::ParserTimeout was inheriting from itself. 1.200 Mon 15 Oct 2007 Summary: - Production Release Details: - Zero changes from 1.199_07 - Updated version from 1.199_07 to 1.200 1.199_07 Fri 12 Oct 2007 Summary: - This is the third release candidate for 1.200 - Minor tweak Details: - Changed the way to detect Perl 5.6 to ignore the 1_0e1_0 failure 1.199_06 Wed 10 Oct 2007 Summary: - This is the second release candidate for 1.200 - Some small bug fixes Details: - Remove -w from test scripts to allow taint'enabled testing - Skip the failing 1_0e1_0 test on Perl 5.6.2 1.199_05 Tue 9 Oct 2007 Summary: - This is the first release candidate for 1.200 - Fix some parser corner cases Details: - Fixed parsing of %!, $^\w, and %^H - Fixed parsing of @{$foo}-1 - Fixed parsing of <$fh1>, <$fh2> 1.199_04 Summary: - Build tweaks - More regression changes Details: - Increasing List::Util dependency to 1.19 (Removes a memory leak on Win32) 1.199_03 Thu 12 Jul 2007 Summary: - Support for a few more rare/legacy Perl syntax - Tokenizer simplification, optimization and exception'ification Details: - Added support for the <<\EOF heredoc style - Always create ->{type} in full-quote sections - Converted more of the Tokenizer to use exceptions - Optimized away a bunch of now-unneeded "or return undef" - Optimized _set_token_class down to a single statement - Inlined _set_token_class out of existence - Cache and fast-clone PPI::Token::Whitespace->null - Removed some superfluous parameter checks on private methods, for conditions that would cause explosions and be noticed anyway. - Removed the fancy options from PPI::Token::new - More consistent structure of incomplete quotes 1.199_02 Mon 5 Mar 2007 Summary: - Added parser timeout support - Fixing various regression cases - Adding some housekeeping tweaks Details: - Created PPI::Exception with an eye to moving towards using exceptions more for error handling (for speed). The goal is to get rid of the "or return undef"s. - Added the timeout param to the PPI::Document constructor which uses alarm to implement basic timeout support. This should help when parsing a large corpus on Unix. (Not available on Win32) - Fixed incorrect location() for PPI::Structure instances. - Adding better parsing of hash constructors. - Pushing Clone dependency to 0.22 to get closer to taint support) - Pushing deps on bundled test modules to prevent accidentally bundling old versions. 1.199_01 Tue 31 Oct 2006 Summary: - Improved lexing correctness - Partial implementation of literal - Initial implementation of Number classes (Chris Dolan) Details: - Split out PPI::Token::Number subclasses - Implement numbers with exponential notation - Implement literal() for ::Number classes (except ::Version) - Implement literal() for ::Token::Quote::Single - Added -T for inline tests - Add tests for nested statements and nested structures - Fixed some bugs as a result - Improved detection of the correct curly brace structure types 1.118 Fri 22 Sep 2006 Summary: - Better 5.10 support - Fixing various (mostly parsing) bugs Details: - Upgraded to Module::Install 0.64 - Improving support for dor and added //= operators - Fixed parsing of binary, octal and hex numbers - Fixed parsing of /= and *= - Fixed #21571 symbol() returns just sigil with adjacent braces - Fixed #21575 variables() chokes on list with whitespace - Fixed #20480 (Misparse of some floating-point numbers.) - Fixed #19999: Make test fails (undeclared global variable $document) under Perl 5.6.2 (or at least, I think I have. This needs double-checking on Perl 5.6.2) - Partially Fixed #16952: [PATCH] Speed up tokenizer char-by-char (Did not apply the patch, but fixed a bug noted as an aside in the report) - PPI::Document::File was returning a plain PPI::Document object, fixed. - FINALLY added some basic POD for PPI::Structure, the one class I somehow keep forgetting to do. 1.117 Sat 02 Sep 2006 Summary: - Fixing bugs introduced in 1.116 Details: - Simple compound statements "{ 1 }" were not end-detecting properly - The new handling for the "-" character was shortcutting naively - Labelled compound statements were not end-detecting properly - { package => 1 } was treating package incorrectly - Fixed bugs in test cases submitted by the Perl::Critic team - Added a number of extra test cases, and introduced Test::Object based testing for PPI::Document objects. 1.116 Thu 31 Aug 2006 Summary: - PPI::Document::File first release - Adding readonly attribute - Fixed various accumulated bugs Details: - Upgraded to Module::Install 0.63 - Add a new file-only subclass of PPI::Document - Added the readonly attribute to the PPI::Document->new constructor - Added method PPI::Document->readonly method - 'goto' is a PPI::Statement::Break - Re-fixed #19629: End of list mistakenly seen as end of statement - Applied #16892: [PATCH] docs and comments - Fixed #16815 (location of Structure::List is not defined.) - Fixed misparsing of C< 1-1 > - Fixed #18413: PPI::Node prune() implementation broken - Fixed #20428 (minor doc bug in PPI::Token::Symbol) - Resolved NOTABUG #20031 (PPI installation) - Resolved NOTABUG #20038 (PPI installation) - Fixed #19883: 'package' bareword used as hash key is detected as package statement - Fixed #19629: End of list mistakenly seen as end of statement - Fixed #15043: (no description) # He wanted PPI::Document::File 1.115 Sat 03 Jun 2006 Summary: - Fixing rt.cpan.org bugs Details: - Fixed #19614: Suspicious code in PPI::Structure - Fixed #16831: until () { } not parsed as compound statement - NOTABUG #16834: "$a = 1 if ($a == 2)" vs "$a = 1 if $a == 2" - Fixed #19629: End of list mistakenly seen as end of statement - Fixed #18413: PPI::Node prune() implementation broken 1.114 Thu 25 May 2006 Summary: - This release addresses only dependency issues Details: - Changed over from IO::Scalar to IO::String - Added a dependency on Task::Weaken so that we can make various not-so-clueful downstream packagers play nicely. 1.113 Wed 10 May 2006 Summary: - This release contains only build-time changes Details: - Upgraded to Module::Install 0.62 - No features() used in this dist, so removing auto_install 1.112 Mon 24 Apr 2006 Summary: - Emergency release to fix a bug that prevents install on perl > 5.8.4 Details: - Small typo in the unicode-specific section of 14_charsets.t prevents tests passing for anyone with a unicode-sane Perl version. - Added a test for strange locales that can't handle unicode, and skip the unicode tests. 1.111 Sat 22 Apr 2006 General - Moved from SourceForge CVS to new collaborative SVN repository - Fixed regressions other people had added since 1.110 - Upgraded to Module::Install 0.62 Details: - SourceForge was too hard to get into, so moved to specially designed new SVN repository to make it easy for others to help out. - Moved t.data to t/data in line with current style and to reduce complexity. - Fixed t/data/08_regression/11_multiply_vs_glob_cast (added by unknown) - Fixed t/data/08_regression/12_pow (added by unknown) - Removed every use of UNIVERSAL::isa in the tests - Upgraded to Module::Install 0.62 (my private prerelease) 1.110 Fri Jan 27 2005 General - Added test support for the third location component (Arjen Laarhoven) - Various bug fixes (Releasing early with only small changes at the request of Perl::Critic) Details: - Fixed CPAN #16924: PPI::Statement::Sub.pm fix to use Params::Util line to resolve _INSTANCE error - Fixed CPAN #16837: typo in PPI::Statement::Expression POD - Fixed CPAN #16973: PPI 1.109 shouldn't require List::Util 1.18 (We do need 1.18 to avoid a leak, but it doesn't work everywhere) - Fixed CPAN #16814: _INSTANCE method not defined in PPI::Statement::Sub (dupe) - Arjen Laarhoven added to CVS committers - Added a third element to ->location return arrayref that contains the visual starting column of the token, taking into account tabbing. 1.109 Fri Dec 30 2005 Summary: - Various bug fixes - Minor structural cleanup Details: - Removed every single use of UNIVERSAL::isa - PPI::Normal was quite broken, cleaned it up - Fixed PPI::Normal::Standard::remove_statement_separator - Fixed CPAN #16674 PPI::Token::Quote::Double->interpolations (awigley) - Fixed CPAN #15131 PPI::Node->find() behavior not completely documented (Jeffrey Thalhammer) - Fixed CPAN 13743 PPI::Statement::Scheduled api (johanl) - PPI::Statement::Scheduled is now a subclass of PPI::Statement::Sub - Removed breaking circular include in PPI::Util - Removed an 'our' variable in t/04_element.t that created a 5.6.0 dependency - Only do the PPI::Cache tests that use Test::SubCalls if >= 5.006 - (Except for File::Remove, we should ACTUALLY depend on 5.005 now) - Fixed CPAN #16671 $_ is not localized (JPIERCE) (I missed an unlocaled $_ hiding in the Node object destructor) 1.108 Thu Dec 15 2005 Summary: - Fixing of some very minor bugs Details: - 8 wasn't an illegal character in an octal number (fixed) - Two <= 5.8.5) (not pre-checked and enforced yet, but will be) - Starting new generation of "exhaustive" testing Details: - Added 20_tokenizer_regressions, which tests all detectably-failing 3-or-less character long Perl programs (not inclusive of latin-1 or Unicode). (Audrey Tang) - Fixed bug for incomplete quotes at EOF (there may be a few more similar cases) - Fixed bug with $'0 (where 0 is only legal after ::) - No longer die for illegal chars in hex/bin number types (Attach the error to $token->{_warning} instead) - Caught a number of cases with trailing colons for $things (Both at EOF and end of token) - Convert [^\W\d]\w* to (?!\d)\w+ to improve unicode support in symbols etc (Audrey Tang) - Miscellaneous doc bugs in the SYNOPSIS (Audrey Tang) 1.104 Thu Nov 10 2005 General - No change to code - Both List::Util and List::MoreUtil contain memory leaks, and we use them extensively. Pushed the dependencies up to versions with the memory leaks fixed. 1.103 Thu Oct 6 2005 General - Small bug fix that shouldn't have escaped Details: - Changed md5hex_file to act more like the PPI::Documeny way. That is, localise and THEN convert to \015 1.102 Wed Oct 5 2005 General - Small things to support Perl::Metrics Details: - Added undocumented PPI::Util::md5hex_file function 1.101 Thu Sep 29 2005 General - Bug fix release Details: - Fixed CPAN bug #14436 and #14440, misparse for my ($foo) ... - Added an self-analysis test script for PPI-testable problems - Fixed some minor bugs it threw up. 1.100_03 General - Major bug fixing - Some additions to help simplify Perl::Metrics Details: - A whole bunch (practically all) of the sibling code was breaking under non-trivial use. Fixed, with a number of new tests added. - Added function PPI::Util::md5hex - Added method PPI::Document::hex_id 1.100_02 General - Various bug fixes - Completed the first version of PPI::Cache Details: - Expanded round-trip testing coverage to all the lexer and regression test files - 06_round_trip.t wasn't doing the round-trip test properly. Fortunately, this only resulted in false failures, so no actual damage was done as a result of this. 1.100_01 Sat Sep 03 2005 Summary: - Added integrated cache support Details: - Added PPI::Cache class - Removed warning in 99_pod.t - Added a common PPI::Util::_slurp function - PPI::Document can be given a cache to use 1.003 Tue Aug 18 2005 Summary: - Bug fix release Details: - Add support for 'for $foo () {}' - Add support for 'for my $foo () {}' - Fixed bug where "'Hello..." crashed the Tokenizer - Fixed bug where '"Hello...' crashed the Tokenizer - Fixed bug where 's' crashed the Tokenizer 1.002 Thu Jul 14 2005 Summary: - Bug fix release Details: - Fixed CPAN #13655 - insert_before and insert_after broken. 1.001 Tue Jul 12 2005 Summary: - Turning on Test::Inline scripts Details: - Bug fix: ->string returns wrong for qq and all braced quotes - Added Test::Inline 2.100-type inline2test.conf and inline2test.tpl files - Added t/ppi_token__quoteengine_full.t - Added t/ppi_token_quote_single.t - Added t/ppi_token_quote_double.t - Added t/ppi_token_quote_literal.t - Added t/ppi_token_quote_interpolate.t 1.000 Sat Jul 9 2005 Summary: - FIRST PRODUCTION RELEASE - Finalising POD, corrected the Copyright dates - Rewrote much of the main PPI.pm docs - Removing more unneeded dependencies - Added native Storable support Details: - Removed dependency on Class::Inspector - Added build dependency on Class::Inspector and include() it (although it's still needed at build time, this still does manage to reduce the number of files to download by one more) - Added PPI::Document::STORABLE_freeze and PPI::Document::STORABLE_thaw 0.996 Fri Jul 8 2005 Summary: - RELEASE CANDIDATE 2 - Clearing all remaining RT bugs - Removing and inlining dependencies Details: - Resolved PDOM bug CPAN #13454 ( while ( $s = $s->sprevious_sibling ) infinite loops ) Mental Note: Doing an auto-decrement in an array subscript is BAD - Resolved Lexer bug CPAN #13425 ( $p{package} creates a PPI::Statement::Package ) Added smarts to resolve word-started statements as ::Expression in subscripts - Resolved PDOM bug CPAN #13326 ( problems in index_locations ) Patch and comprehensive additional tests provided by johanl[ÄT]DarSerMan.com - Removed dependency on Class::Autouse. Just load Tokenizer and Lexer up front. - Removed dependency on File::Slurp. Only use it 3 times and it's not worth it when almost all the files we will read are under 50k. 0.995 Sun Jul 3 2005 Summary: - RELEASE CANDIDATE 1 - Added some internals to help with XML compatibility - Completed primary POD docs - Completed first versions of insert_before and insert_after - Removed last uses of _isa - Added final missing POD docs Details: - Added convenience method PPI::Element::class - Added docs for all PPI::Structure classes - Added additional tests to check for ::Unknown classes - Added PPI::Document::insert_before to return an error - Added PPI::Document::insert_after to return an error - Added PPI::Document::replace to return an error - Removed a number of unneeded UNIVERSAL::isa imports - Removed PPI::Token::_isa before anyone starts using it. It was hacky and unsuitable to a production release 0.994 skipped 0.993 Tue Jun 21 2005 Summary: - Various minor code, packaging and POD cleanups Details: - Corrected a POD bug in PPI::Dumper - Upgraded PPI::Dumper param checking to Params::Util - Restored PPI::Element->clone to using Clone::clone ( 0.17+ ) - Removed dependency on Storable - Until it fixes the problem, explicitly include ExtUtils::AutoInstall 0.992 Sun Jun 12 2005 Summary: - Added the PPI::Transform API 0.991 Fri Jun 10 2005 - Typo. I wasn't dieing on newlines to PPI::Document->new( string ) correctly, and thus dieing without the API CHANGE message. This was confusing people as to why. 0.990 Wed Jun 8 2005 Summary: - Last version (hopefully) to make API changes - Slight API shuffle in the constructors - Completed all PPI::Statement::* API documentation - Enabled latin-1 support in the appropriate places 0.906 Thu Apr 28 2005 Summary: - Completed location support and added related unit tests - Added API for future support of tab widths Details: - Removed PPI::Element::_line - Removed PPI::Element::_col - Fixed bugs in PPI::Document::index_location - Fixed bugs in PPI::Element::location - Added 12_location.t unit test - Added PPI::Document::tab_width method - Added PPI::Normal::Standard::remove_useless_attributes (to remove the ->{tab_width} attributes and later other things) 0.905 Wed Apr 20 2005 Summary: - Completely forgot to write unit tests for PPI::Util, and a bug slipped in. Fixed and added tests Details: - Fixed bug in PPI::Util::_Document - Added 11_util.t 0.904 Wed Apr 20 2005 Summary: - Improvements to PPI::Normal - Method renaming to parse-time PDOM private methods - Various bug fixes and POD tweaks - Added PPI::Util Details: - Partly added Layer 2 to PPI::Normal - Added function PPI::Normal::Standard::remove_useless_pragma - Added function PPI::Normal::Standard::remove_statement_separator - Added function PPI::Normal::Standard::remove_useless_return - Renamed _on_line_start to __TOKENIZER__on_line_start - Renamed _on_line_end to __TOKENIZER__on_line_end - Renamed _on_char to __TOKENIZER__on_char - Renamed _scan_for_end to __TOKENIZER__scan_for_end - Renamed _commit to __TOKENIZER__commit - Renamed _is_an_attribute to __TOKENIZER__is_an_attribute - Renamed _literal to __TOKENIZER__literal - Renamed _opposite to __LEXER__opposite - Fixed bug in PPI::Statement::Package::namespace - Added unit tests for PPI::Statement::Package - Added (currently mostly internal) PPI::Util - Added exportable function PPI::Util::_Document 0.903 Fri Mar 25 2005 Summary: - PPI::Document and other PPI::Node-subclasses will now implicitly DESTROY correctly. - Now that PPI.pm is just a module loader, merge the main documentation from PPI::Manual back into it again. Details: - Added use of Scalar::Util::weaken for all %_PARENT writes - Uncovered critical bug in Clone, so we use Storable::dclone for now, until Clone is fixed. This resolves rt.cpan.org #11552 - Added dependency on Storable 1.13 - Moved all PPI::Manual content to PPI and relinked This resolves rt.cpan.org #11803 - Removed lib/PPI/Manual.pod - Added the standard 99_pod.t to check POD - Fixed a POD bug in Element.pm 0.902 Sun Feb 6 2005 Summary: - Added Document Normalization functions from old Perl::Compare (although it is very very limited in function at this point) Details: - Added class PPI::Normal - Added class PPI::Normal::Standard - Added class PPI::Document::Normalized - Added method PPI::Document->normalize - Bug: ->clone was going to all the trouble to build a clone, but then returning the original :( Fixed 0.901 Sat Jan 29 2005 Summary: - Moved all up-to-date code over to SourceForge - Various fixes to allow the release of File::Find::Rule::PPI Details: - Got all modules synchronising their versions correctly - Moved to SourceForge CVS repository - Changed all files over to the new CVS directory layout - Fixed bug in PPI::Node::find_first - Added unit tests for PPI::Node::find_first - Added unit tests for PPI::Node::find_any - Added a stub and docs for PPI::Statement::stable 0.900 Mon Jan 17 2005 Summary: - Final removal of PPI::Base - Completed majority of crash bugs in the Tokenizer Details: - Fixed Tokenizer Bug C< @foo = < seen as ::Readline - Fixed Tokenizer Bug C< (< seen as ::Readline - Fixed Tokenizer Bug C< q'foo bar' > parsed incorrectly - Fixed bug in PPI::Token::_QuoteEngine::_scan_quote_like_operator_gap - Fixed Tokenizer Bug C< $foo:'' > sees symbol $foo:' - Fixed Tokenizer Bug C< $#arrayindex > was seen as a Symbol - Fixed Tokenizer Bug C< %2 > was seen as a Symbol - Fixed Tokenizer Bug C< &64 > was seen as a Symbol - Fixed Tokenizer Bug C< $::| > is actually a Magic - Fixed Tokenizer Bug C< @0 > is a Magic - Deleted PPI::Base - Added $PPI::Element::errstr - Added basic private error methods to PPI::Element - PPI::Element::significant now returns '' as false - PPI::XS - Added all C methods 0.846 Mon Jan 17 2005 Summary: - Added proper support for - Last release before beta 1 if all looks good Details: - Added class PPI::Token::QuoteLike::Readline - Added t.data/05_lexer_practical/10_readline.code/dump - Added support for <> - A few other minor bug fixes 0.845 Sat Jan 15 2005 Summary: - Adding integration with PPI::XS, autoloading if installed Details: - Added $PPI::XS_COMPATIBLE and $PPI::XS_EXCLUDE variables to guide integration - Don't autoload PPI::Document, always load - Load in PPI::XS whenever it is installed - Loading and depending on Class::Inspector - PPI::Element::significant implemented in XS (as a trial) 0.844 Fri Jan 14 2005 Summary: - Found a massive performance bug when parsing large perl constructs - Fixed some install problems Details: - PPI::Node::schild was copying the entire of it's child array each call. This was causing massive slowdowns when ->{children} got large. Fixed. - The core tests still expect Transform to be in the core. Fixed. 0.843 Tue Jan 12 2005 Summary: - Starting the process of removing PPI::Base. It only does does error handling now, which will be split up. - Fixing some packaging and "play well with others" issues Details: - Randal Schwartz pointed out t/06... wouldn't working for him. It appears when Test::More bug CPAN #8385 was fixed, we broke. - We now include build-time-only dependencies in the installer - Although unusable, PPI::Document::Normalized's version fell out of sync with the rest of the distribution. Fixed. - PPI::Tokenizer no longer inherits from PPI::Base - Added class variable $PPI::Tokenizer::errstr - Added class method PPI::Tokenizer->errstr - Fixed Tokenizer Bug: C< y => 1 > was being seen as a regex - Fixed Tokenizer Bug: C< <<''; > was dying because I expected at least one character - Fixed Tokenizer Bug: C< $foo->{s} > was being seen as a regex 0.842 Tue Jan 11 2005 Summary: - Lots of debugging based on Tinderbox results Details: - Fixed MANIFEST.SKIP to removed PPI::Transform and PPI::Tinderbox from the core PPI distribution (like they should be) - Optimised the previous #9582 to not have to run for EVERY word, only those where it might be needed. - Corrected a use of QuoteLike::Execute to QuoteLike::Backtick - Fixed CPAN #9598 Tokenizer Bug: C< qx( $command ) > - Fixed CPAN #9614 Tokenizer Bug: C< $foo << 16 > - Set the properly includive regex for << '...' here-doc - Added an very early filter to prevent non-basic chars going in 0.841 Mon Jan 10 2005 Summary: - Completed much more documentation on the core classes - PPI::Tester back in sync again (separate distribution) - PPI::Processor and PPI::Tinderbox completed (separate distribution) Details: - Documented PPI::Tokenizer - PPI::Document->new( $source ) added as a convenience - PPI::Lexer::lex_file can now be called statically - PPI::Lexer::lex_source can now be called statically - PPI::Lexer::lex_tokenizer can now be called statically - Fixed a small bug in PPI::Dumper::print - Fixed CPAN #9582 Tokenizer Bug: C< sub y { } # Comment > - Fixed similar case with C< foo->y() > 0.840 Thu Dec 21 2004 Summary: - Changed the PPI summary to no longer use the devisive word "parse" Now: "PPI - Analyze and manipulate Perl code without using perl itself" - Total rewrite of all the ->location code - Upgrading MakeFile.PL to Module::Install - Fixed #CPAN 8752 (a round-trip edge case bug) - Added 08_regression.t to do code/dump regression testing for lexer bugs - Completed (hopefully) HereDocs conversion to a single complex token - PPI is now compatible with prefork.pm (although not dependant) Details: - Added PPI::Node::find_first object method - Changed PPI::Node::find_any to just call PPI::Node::find_first - Added PPI::Element::first_token object method - Added PPI::Element::last_token object method - Made a partial-removal-capable PPI::Element::_flush_locations - PPI::Document::flush_locations uses PPI::Element::_flush_locations - PPI::Document::index_locations is here-doc sane - Added PPI::Token::HereDoc::heredoc object method - Added PPI::Token::HereDoc::terminator object method - Documented PPI::Token::HereDoc - Added a HereDoc code/dump test to 05_lexer_practical.t - Added PPI::Document::serialize, which replaces the use of ->content for generating the actual string to write out to files when saving Documents. - File::Spec reduced from dependency to build dependency - Updated Test::ClassAPI dependency to newest version - Enabled API collision detection in 02_api.t - Updated Class::Autouse dependency to newest version 0.840_01 Tue Dec 21 2004 Summary: - Perl Foundation Funding Commences - Changes separated into General and Details from here on - Complete re-organisation of the quote-like token classes. Any and all code that works with quotes will be broken. - Gave up on the old PPI::Query code and wrote a complete new and much thinner implementation based roughly on the API of File::Find::Rule. PPI::Find uses the &wanted function (which also has a slightly different API to the old one) but has the ->in style search methods. It should be relatively easy for someone to write PPI::Find::Rule on top of it. - PPI::Transform is thus temporarily stale Details: - Introduced a bug for C< foreach $foo () > and caught/fixed it during the changeover. - Changed PPI::Lexer::Dump to PPI::Dumper - API Freeze PPI::Find - API Freeze PPI::Dumper - Documented PPI::Find - Documented PPI::Dumper 0.831 Fri Nov 5 2004 - Overloaded PPI::Document bool => true - Overloaded PPI::Document "" => content (That is, ::Documents stringify to their content) - Fixed PPI::Document::save - Merged Leon Brocard's docs patch - Cleaned up PPI::Node::_condition and documented conditions better (fixed #7799) - Allow dropping of the initial PPI:: in class search conditions - Fixed two instances of File::Slurp::read_file being called as a method 0.830 Mon Sep 27 2004 - Added PPI::Statement::Package::file_scoped object method - Handle potentially dangerous C< sub foo ($$ > safer - Resolve C< sub BEGIN { } > to PPI::Statement::Scheduled correctly - Resolve C< sub () { 1 }; > to PPI::Statement correctly - API Freeze PPI::Statement::Package - API Freeze PPI::Statement::Scheduled - API Freeze PPI::Statement::Sub - Documented PPI::Statement - Documented PPI::Statement::Package - Documented PPI::Statement::Scheduled - Documented PPI::Statement::Sub - Documented PPI::Document::Fragment 0.829 Sat Sep 25 2004 - BREAKS API COMPATIBILITY - Changed PPI::Token::SubPrototype to PPI::Token::Prototype - Added PPI::Token::Prototype::prototype object method - Added PPI::Statement::Sub::prototype object method - Added PPI::Statement::Sub::block object method - Fixed PPI::Statement::Include::version 0.828 Sun Aug 8 2004 - BREAKS API COMPATIBILITY - Changed PPI::Token::DashedBareword to PPI::Token::Quote::Dashed - Changed PPI::Token::Bareword to PPI::Token::Word - Vastly improved PPI::Manual 0.827 Thu Aug 5 2004 - Added PPI::Token::Separator class ( for __DATA__ and __END__ ) - Added better Tokenizer handling of __DATA__ and __END__ - Added better Lexer handling of __DATA__ and __END__ - Fixed some version inconsistencies 0.826 Sat Jul 31 2004 - Added PPI::Element::statement object method - Added PPI::Transform abstract class - Sped up the 'bool' overload for PPI::Element - Added PPI::Element::snext_sibling object method - Added PPI::Element::sprevious_sibling object method - Added PPI::Element::insert_before object method placeholder - Added PPI::Element::insert_after object method placeholder - Changed {elements} to {children} to match PPI::Node definitions - Added PPI::Node::first_element object method - Added PPI::Node::last_element object method - Added PPI::Element::next_token object method - Added PPI::Element::previous_token object method - Added PPI::Token::Symbol::symbol object method 0.825 Mon Jul 26 2004 - Added PPI::Statement::Include::type object method - Added PPI::Statement::Include::module object method - Added PPI::Statement::Include::pragma object method - Added PPI::Statement::Include::version object method - Overloaded == as "the same object" for PPI::Element - Overloaded eq as "->content is the same" for PPI::Element - Overloaded bool as always true, to prevent an error - Added PPI::Statement::Package::namespace object method - 100% round-trip safe. What goes in, will come out. - Reduced leaks by 95%. Process size 30meg after 5000 files. Still some leaks remaining when Lexing errors out. - Separated largest Tokens into their own files. This aligns token class structure with that of ::Statement and ::Structure - Rewrote PPI::Node::DESTROY several times while hunting down more leaks - Fixed Tokenizer crash on empty subroutine prototypes such as C< sub foo() {} > - Treat unexpected braces as an implicit close, to make the lexer more resilient - Added PPI::Statement::UnmatchedBrace (name suggested by Abhijit Menon-Sen) to handle closing braces found at the base of a Document. - Enabled foo'bar package notation again. - Getting close to the first 0.900 series beta release 0.824 Wed Jul 21 2004 - Removed a 6 meg tmon.out file I accidentally bundled 0.823 Wed Jul 21 2004 - Added PPI::Document::Fragment class - Added PPI::Node::schildren object method - Completed compound statement parsing - Lexer is now officially feature complete 0.822 Wed Jul 21 2004 - Filling out the API test as much as possible - Added PPI::Statement::label object method - Moved PPI::Structure::elements object method to PPI::Node::elements - Re-organised statement parsing to better implement ::Compound statements - Added PPI::Statement::Data class - Added PPI::Statement::End class - Re-organised the _lex_statement, _statement_continues stuff, ready for while - Added PPI::Lexer::_lex_statement_end to handle PPI::Statement::End properly - Organising 02_api.t was getting hard, so added implicit Module=class to Test::ClassAPI 0.821 Mon Jul 19 2004 - Cleaned up test data files directories - Added PPI::Statement::Variable::type object method - Added PPI::Statement::Variable::variables object method - Added some more classes to the API testing - Started 07_tokens.t for testing particular token classes - Added PPI::Token::Symbol::canonical object method (and tests) - PPI::Token::Magic now ISA PPI::Token::Symbol - PPI::Element::clone now fixes _PARENT links for Nodes 0.820 Mon Jul 19 2004 - Added Round-Trip-Safe testing for all PPI files - Added PPI::Node::find_any object method - Added PPI::Node::contains object method - Continuing the never ending addition of tests - Structure open and close brace tokens now see the Structure as their parent - Removed the sample application, to streamline the core install - Removed dependencies for the sample application - Removed custom META.yml, as now no longer needed 0.819 Mon Jul 14 2004 - Many parts of PPI are VASTLY changed in this revision - Breaks API compatibility heavily - Adds dependency on List::MoreUtils - Added PPI::Lexer support for CHECK blocks - Added PPI::Document::load method - Added PPI::Document::save method - Added PPI::Document::index_locations method - Added PPI::Document::flush_locations method - Added PPI::Element::top method - Added PPI::Element::document method - Renamed PPI::Element::extract -> PPI::Element::remove - Added test script for element-y stuff - Optimisation across the board using List::Any - Added PPI::Node::first_child method - Added PPI::Node::last_child method - Added PPI::Element::clone method - Removed Filehandle support from PPI::Tokenizer, to allow the ability to rollback source lines into the buffer if needed. - Added POD documentation for PPI::Element - Added POD documentation for PPI::Node - Added POD documentation for PPI::Document 0.818 Mon Jul 5 2004 - Changed lib/PPI/Manual.pm to lib/PPI/Manual.pod - Added documentation for PPI::Lexer - Fixed the misparsing of s{//}{\} - More clues added for deciding "slash or regex" - Removed PPI::Batch from the default distribution - Replaced File::Flat with File::Slurp to reduce dependencies 0.817 Thu Jul 1 2004 - Fixed the misparsing of $#{ } - Changed PPI::ParentElement to PPI::Node and moved it to it's own file - Changed PPI::Common to PPI::Base - Fixed PPI::Node::find - Added PPI::Node::prune - Started to add a little more class structure documentation - Tried to make the DESTROY sequence of events work better 0.816 Tue Jun 29 2004 - Solved the "last token in file parses wrong" bug 0.815 Sun Jun 27 2004 - Fixed a bug with the detection of @- and @+ - Added support for @* - Added missing classmap entry for ^ to ::Token::WhiteSpace - Added support for arcane "foo"x10 idiosyncracy 0.814 Sat Jun 26 2004 - Added the PPI tester, a desktop-based interactive debugger, which should greatly accelerate finding and fixing both ::Tokenizer and ::Lexer bugs. This will probably end up as a separate distribution though, as it has a dependency on wxPerl. - Fixed the misparsing of Foo::Bar::Baz - Fixed the misparsing of *100 - Fixed the misparsing of Class::->method properly, or rather Foo:: - Tokenizer correctly identifies labels - Changed PPI::Statement::Flow to PPI::Statement::Compound - Removed the extra null whitespace token appearing after a bareword at the end of a file. - -X operator are recognised correctly, although not at end of file - Lexer detects subroutine and if () statement ends correctly 0.813 Sat Jun 26 2004 - PPI::Lexer is now structurally complete 0.812 Tue Jun 22 2004 - No changes to PPI itself. - With the addition of Test::ClassAPI 'complete' support, upgraded 02_api.t to use it. Fixed a few small house-keeping bugs. 0.811 Mon Jun 21 2004 - Added support for subroutine attributes - Fixed some problems with anonymous subroutines and prototypes - $#$foo parses as (Cast,Symbol) now, not (Magic,Symbol) 0.810 Mon Jun 14 2004 - Recognise the _ magic filehandle 0.809 Sat Apr 17 2004 - No changes to PPI itself. Set the correct number of tests to match changes to Test::ClassAPI 0.808 Sat Apr 17 2004 - No changes to PPI itself. Upgraded 02_api.t to match changes to Test::ClassAPI 0.807 Sat Apr 3 2004 - Added a manual META.yml file to stop the bundled private AppLib library from being indexed by CPAN 0.806 Mon Mar 22 2004 - The $} magic variable is now supported - Fixed a "tight sub property" bug ( sub foo:lvalue ) 0.805 Sun Sep 28 2003 - The maximum line length regressed, reseting it to 5000. - In PPI::Format::HTML, not any parsing error causing a premature end of tokenizer by adding it in a comment at the end of the file. 0.804 Sat Sep 06 2003 - Statement and Structure resolution preliminarily work. Some basic types of statements and structures are identified. - PPI::Format::Apache has been separated into a different module 0.803 Sat Sep 06 2003 - Added very long line protection support. Maximum line length is now 5000. - Added bug fixes to the Lexer so that block tree building works mostly OK again, without adding broken duplicate tokens. - Added the PPI::Lexer::Dump module, to do Lexer object dumps. 0.802 Sat Aug 23 2003 - PPI::Format::HTML sends the correct content headers 0.801 Fri Aug 22 2003 - Moved to a new numbering scheme to get more room before 1.0 - Always fully load when called under mod_perl - Add mod_perl hook to PPI::Format::HTML 0.8 Fixes to the quote parsing engine 0.7 Fixed some minor bugs 0.6 Fixed POD, fixed version number, included $'a as a symbol 0.5 Missing 0.4 Mon Dec 23 10:24:21 - Some more minor parsing fixes in Tokenizer - Completely changed the API from doThis to do_this style - Changed API to indicate private methods properly 0.3 Tue Dec 17 10:29:27 - Restructured a little bit - Fixed some mis-parsing cases 0.2 Unknown - Added test script 0.1 Thu Dec 06 16:50:23 2002 - original version PPI-1.220/LICENSE0000755000175100010010000004737112367540360010106 0ustar Terms of Perl itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" ---------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS ---------------------------------------------------------------------------- The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End PPI-1.220/inc/0000755000175100010010000000000012430470371007626 5ustar PPI-1.220/inc/Module/0000755000175100010010000000000012430470371011053 5ustar PPI-1.220/inc/Module/Install.pm0000755000175100010010000003021712430470350013022 0ustar #line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.006; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.14'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::getcwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split /\n/, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; binmode FH; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. PPI-1.220/inc/Module/Install/0000755000175100010010000000000012430470371012461 5ustar PPI-1.220/inc/Module/Install/Can.pm0000755000175100010010000000615712430470351013532 0ustar #line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 PPI-1.220/inc/Module/Install/Win32.pm0000755000175100010010000000340312430470351013722 0ustar #line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; PPI-1.220/inc/Module/Install/Base.pm0000755000175100010010000000214712430470350013675 0ustar #line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.14'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 PPI-1.220/inc/Module/Install/WriteAll.pm0000755000175100010010000000237612430470351014553 0ustar #line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; PPI-1.220/inc/Module/Install/With.pm0000755000175100010010000000225412430470351013736 0ustar #line 1 package Module::Install::With; # See POD at end for docs use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } #line 21 ##################################################################### # Installer Target # Are we targeting ExtUtils::MakeMaker (running as Makefile.PL) sub eumm { !! ($0 =~ /Makefile.PL$/i); } # You should not be using this, but we'll keep the hook anyways sub mb { !! ($0 =~ /Build.PL$/i); } ##################################################################### # Testing and Configuration Contexts #line 53 sub interactive { # Treat things interactively ONLY based on input !! (-t STDIN and ! automated_testing()); } #line 71 sub automated_testing { !! $ENV{AUTOMATED_TESTING}; } #line 90 sub release_testing { !! $ENV{RELEASE_TESTING}; } sub author_context { !! $Module::Install::AUTHOR; } ##################################################################### # Operating System Convenience #line 118 sub win32 { !! ($^O eq 'MSWin32'); } #line 135 sub winlike { !! ($^O eq 'MSWin32' or $^O eq 'cygwin'); } 1; #line 163 PPI-1.220/inc/Module/Install/ReadmeFromPod.pm0000755000175100010010000000646112430470350015512 0ustar #line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); use IO::All -binary; use Capture::Tiny 'capture'; $VERSION = '0.22'; sub readme_from { my $self = shift; return unless $self->is_admin; # Input file my $in_file = shift || $self->_all_from or die "Can't determine file to make readme_from"; # Get optional arguments my ($clean, $format, $out_file, $options); my $args = shift; if ( ref $args ) { # Arguments are in a hashref if ( ref($args) ne 'HASH' ) { die "Expected a hashref but got a ".ref($args)."\n"; } else { $clean = $args->{'clean'}; $format = $args->{'format'}; $out_file = $args->{'output_file'}; $options = $args->{'options'}; } } else { # Arguments are in a list $clean = $args; $format = shift; $out_file = shift; $options = \@_; } # Default values; $clean ||= 0; $format ||= 'txt'; # Generate README print "readme_from $in_file to $format\n"; if ($format =~ m/te?xt/) { $out_file = $self->_readme_txt($in_file, $out_file, $options); } elsif ($format =~ m/html?/) { $out_file = $self->_readme_htm($in_file, $out_file, $options); } elsif ($format eq 'man') { $out_file = $self->_readme_man($in_file, $out_file, $options); } elsif ($format eq 'pdf') { $out_file = $self->_readme_pdf($in_file, $out_file, $options); } if ($clean) { $self->clean_files($out_file); } return 1; } sub _readme_txt { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README'; require Pod::Text; my $parser = Pod::Text->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _readme_htm { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.htm'; require Pod::Html; my ($o) = capture { Pod::Html::pod2html( "--infile=$in_file", "--outfile=-", @$options, ); }; io->file($out_file)->print($o); # Remove temporary files if needed for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') { if (-e $file) { unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n"; } } return $out_file; } sub _readme_man { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.1'; require Pod::Man; my $parser = Pod::Man->new( @$options ); my $io = io->file($out_file)->open(">"); my $out_fh = $io->io_handle; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); return $out_file; } sub _readme_pdf { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.pdf'; eval { require App::pod2pdf; } or die "Could not generate $out_file because pod2pdf could not be found\n"; my $parser = App::pod2pdf->new( @$options ); $parser->parse_from_file($in_file); my ($o) = capture { $parser->output }; io->file($out_file)->print($o); return $out_file; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 259 PPI-1.220/inc/Module/Install/Fetch.pm0000755000175100010010000000462712430470351014062 0ustar #line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; PPI-1.220/inc/Module/Install/Makefile.pm0000755000175100010010000002743712430470350014551 0ustar #line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-separated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 PPI-1.220/inc/Module/Install/Metadata.pm0000755000175100010010000004330212430470350014541 0ustar #line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) [\s|;]* /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashes delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; PPI-1.220/MANIFEST0000755000175100010010000002234212430470365010217 0ustar Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/ReadmeFromPod.pm inc/Module/Install/Win32.pm inc/Module/Install/With.pm inc/Module/Install/WriteAll.pm lib/PPI.pm lib/PPI/Cache.pm lib/PPI/Document.pm lib/PPI/Document/File.pm lib/PPI/Document/Fragment.pm lib/PPI/Document/Normalized.pm lib/PPI/Dumper.pm lib/PPI/Element.pm lib/PPI/Exception.pm lib/PPI/Exception/ParserRejection.pm lib/PPI/Exception/ParserTimeout.pm lib/PPI/Find.pm lib/PPI/Lexer.pm lib/PPI/Node.pm lib/PPI/Normal.pm lib/PPI/Normal/Standard.pm lib/PPI/Statement.pm lib/PPI/Statement/Break.pm lib/PPI/Statement/Compound.pm lib/PPI/Statement/Data.pm lib/PPI/Statement/End.pm lib/PPI/Statement/Expression.pm lib/PPI/Statement/Given.pm lib/PPI/Statement/Include.pm lib/PPI/Statement/Include/Perl6.pm lib/PPI/Statement/Null.pm lib/PPI/Statement/Package.pm lib/PPI/Statement/Scheduled.pm lib/PPI/Statement/Sub.pm lib/PPI/Statement/Unknown.pm lib/PPI/Statement/UnmatchedBrace.pm lib/PPI/Statement/Variable.pm lib/PPI/Statement/When.pm lib/PPI/Structure.pm lib/PPI/Structure/Block.pm lib/PPI/Structure/Condition.pm lib/PPI/Structure/Constructor.pm lib/PPI/Structure/For.pm lib/PPI/Structure/Given.pm lib/PPI/Structure/List.pm lib/PPI/Structure/Subscript.pm lib/PPI/Structure/Unknown.pm lib/PPI/Structure/When.pm lib/PPI/Token.pm lib/PPI/Token/_QuoteEngine.pm lib/PPI/Token/_QuoteEngine/Full.pm lib/PPI/Token/_QuoteEngine/Simple.pm lib/PPI/Token/ArrayIndex.pm lib/PPI/Token/Attribute.pm lib/PPI/Token/BOM.pm lib/PPI/Token/Cast.pm lib/PPI/Token/Comment.pm lib/PPI/Token/DashedWord.pm lib/PPI/Token/Data.pm lib/PPI/Token/End.pm lib/PPI/Token/HereDoc.pm lib/PPI/Token/Label.pm lib/PPI/Token/Magic.pm lib/PPI/Token/Number.pm lib/PPI/Token/Number/Binary.pm lib/PPI/Token/Number/Exp.pm lib/PPI/Token/Number/Float.pm lib/PPI/Token/Number/Hex.pm lib/PPI/Token/Number/Octal.pm lib/PPI/Token/Number/Version.pm lib/PPI/Token/Operator.pm lib/PPI/Token/Pod.pm lib/PPI/Token/Prototype.pm lib/PPI/Token/Quote.pm lib/PPI/Token/Quote/Double.pm lib/PPI/Token/Quote/Interpolate.pm lib/PPI/Token/Quote/Literal.pm lib/PPI/Token/Quote/Single.pm lib/PPI/Token/QuoteLike.pm lib/PPI/Token/QuoteLike/Backtick.pm lib/PPI/Token/QuoteLike/Command.pm lib/PPI/Token/QuoteLike/Readline.pm lib/PPI/Token/QuoteLike/Regexp.pm lib/PPI/Token/QuoteLike/Words.pm lib/PPI/Token/Regexp.pm lib/PPI/Token/Regexp/Match.pm lib/PPI/Token/Regexp/Substitute.pm lib/PPI/Token/Regexp/Transliterate.pm lib/PPI/Token/Separator.pm lib/PPI/Token/Structure.pm lib/PPI/Token/Symbol.pm lib/PPI/Token/Unknown.pm lib/PPI/Token/Whitespace.pm lib/PPI/Token/Word.pm lib/PPI/Tokenizer.pm lib/PPI/Transform.pm lib/PPI/Transform/UpdateCopyright.pm lib/PPI/Util.pm lib/PPI/XSAccessor.pm LICENSE Makefile.PL MANIFEST This list of files META.yml README README.md t/01_compile.t t/03_document.t t/04_element.t t/05_lexer.t t/06_round_trip.t t/07_token.t t/08_regression.t t/09_normal.t t/10_statement.t t/11_util.t t/12_location.t t/13_data.t t/14_charsets.t t/15_transform.t t/16_xml.t t/17_storable.t t/18_cache.t t/19_selftesting.t t/20_tokenizer_regression.t t/21_exhaustive.t t/22_readonly.t t/23_file.t t/24_v6.t t/25_increment.t t/26_bom.t t/27_complete.t t/28_foreach_qw.t t/data/03_document/empty.dat t/data/03_document/test.dat t/data/05_lexer/01_simpleassign.code t/data/05_lexer/01_simpleassign.dump t/data/05_lexer/02_END.code t/data/05_lexer/02_END.dump t/data/05_lexer/03_subroutine_attributes.code t/data/05_lexer/03_subroutine_attributes.dump t/data/05_lexer/04_anonymous_subroutines.code t/data/05_lexer/04_anonymous_subroutines.dump t/data/05_lexer/05_compound_loops.code t/data/05_lexer/05_compound_loops.dump t/data/05_lexer/06_subroutine_prototypes.code t/data/05_lexer/06_subroutine_prototypes.dump t/data/05_lexer/07_unmatched_braces.code t/data/05_lexer/07_unmatched_braces.dump t/data/05_lexer/08_subroutines.code t/data/05_lexer/08_subroutines.dump t/data/05_lexer/09_heredoc.code t/data/05_lexer/09_heredoc.dump t/data/05_lexer/10_readline.code t/data/05_lexer/10_readline.dump t/data/05_lexer/11_dor.code t/data/05_lexer/11_dor.dump t/data/05_lexer/12_switch.code t/data/05_lexer/12_switch.dump t/data/07_token/exp.code t/data/07_token/exp.dump t/data/07_token/hex.code t/data/07_token/hex.dump t/data/07_token/range_operator.code t/data/07_token/range_operator.dump t/data/07_token/smart_match.code t/data/07_token/smart_match.dump t/data/08_regression/01_rt_cpan_19629.code t/data/08_regression/01_rt_cpan_19629.dump t/data/08_regression/01_rt_cpan_19629b.code t/data/08_regression/01_rt_cpan_19629b.dump t/data/08_regression/02_rt_cpan_9582.code t/data/08_regression/02_rt_cpan_9582.dump t/data/08_regression/03_rt_cpan_9614.code t/data/08_regression/03_rt_cpan_9614.dump t/data/08_regression/04_tinderbox.code t/data/08_regression/04_tinderbox.dump t/data/08_regression/05_rt_cpan_13425.code t/data/08_regression/05_rt_cpan_13425.dump t/data/08_regression/06_partial_quote_double.code t/data/08_regression/06_partial_quote_double.dump t/data/08_regression/07_partial_quote_single.code t/data/08_regression/07_partial_quote_single.dump t/data/08_regression/08_partial_regex_substitution.code t/data/08_regression/08_partial_regex_substitution.dump t/data/08_regression/09_for_var.code t/data/08_regression/09_for_var.dump t/data/08_regression/10_leading_regexp.code t/data/08_regression/10_leading_regexp.dump t/data/08_regression/11_multiply_vs_glob_cast.code t/data/08_regression/11_multiply_vs_glob_cast.dump t/data/08_regression/12_pow.code t/data/08_regression/12_pow.dump t/data/08_regression/13_goto.code t/data/08_regression/13_goto.dump t/data/08_regression/14_minus.code t/data/08_regression/14_minus.dump t/data/08_regression/14b_minus.code t/data/08_regression/14b_minus.dump t/data/08_regression/15_dash_t.code t/data/08_regression/15_dash_t.dump t/data/08_regression/16_sub_declaration.code t/data/08_regression/16_sub_declaration.dump t/data/08_regression/17_scope.code t/data/08_regression/17_scope.dump t/data/08_regression/18_decimal_point.code t/data/08_regression/18_decimal_point.dump t/data/08_regression/19_long_operators.code t/data/08_regression/19_long_operators.dump t/data/08_regression/19_long_operators2.code t/data/08_regression/19_long_operators2.dump t/data/08_regression/20_hash_constructor.code t/data/08_regression/20_hash_constructor.dump t/data/08_regression/21_list_of_refs.code t/data/08_regression/21_list_of_refs.dump t/data/08_regression/22_hash_vs_brace.code t/data/08_regression/22_hash_vs_brace.dump t/data/08_regression/23_rt_cpan_8752.code t/data/08_regression/23_rt_cpan_8752.dump t/data/08_regression/24_compound.code t/data/08_regression/24_compound.dump t/data/08_regression/25_hash_block.code t/data/08_regression/25_hash_block.dump t/data/08_regression/26_rt_cpan_23253.code t/data/08_regression/26_rt_cpan_23253.dump t/data/08_regression/27_constant_hash.code t/data/08_regression/27_constant_hash.dump t/data/08_regression/28_backref_style_heredoc.code t/data/08_regression/28_backref_style_heredoc.dump t/data/08_regression/29_chained_casts.code t/data/08_regression/29_chained_casts.dump t/data/08_regression/29_magic_carat.code t/data/08_regression/29_magic_carat.dump t/data/08_regression/30_hash_bang.code t/data/08_regression/30_hash_bang.dump t/data/08_regression/31_hash_carat_H.code t/data/08_regression/31_hash_carat_H.dump t/data/08_regression/32_readline.code t/data/08_regression/32_readline.dump t/data/08_regression/33_magic_carat_long.code t/data/08_regression/33_magic_carat_long.dump t/data/08_regression/34_attr_whitespace.code t/data/08_regression/34_attr_whitespace.dump t/data/08_regression/35_attr_perlsub.code t/data/08_regression/35_attr_perlsub.dump t/data/08_regression/36_begin_label.code t/data/08_regression/36_begin_label.dump t/data/08_regression/37_partial_prototype.code t/data/08_regression/37_partial_prototype.dump t/data/08_regression/38_multiply.code t/data/08_regression/38_multiply.dump t/data/08_regression/39_foreach_our.code t/data/08_regression/39_foreach_our.dump t/data/08_regression/40_foreach_eval.code t/data/08_regression/40_foreach_eval.dump t/data/08_regression/41_scalar_hash.code t/data/08_regression/41_scalar_hash.dump t/data/08_regression/42_numeric_package.code t/data/08_regression/42_numeric_package.dump t/data/08_regression/43_nonblock_map.code t/data/08_regression/43_nonblock_map.dump t/data/11_util/test.pm t/data/13_data/Foo.pm t/data/15_transform/sample1.pm t/data/15_transform/sample1.pm_out t/data/24_v6/Grammar.pm t/data/24_v6/Simple.pm t/data/26_bom/utf8.code t/data/26_bom/utf8.dump t/data/27_complete/01y_helloworld.code t/data/27_complete/02n_helloworld.code t/data/basic.pl t/data/test2.txt t/interactive.t t/lib/PPI.pm t/ppi_element.t t/ppi_lexer.t t/ppi_node.t t/ppi_normal.t t/ppi_statement.t t/ppi_statement_compound.t t/ppi_statement_include.t t/ppi_statement_package.t t/ppi_statement_scheduled.t t/ppi_statement_sub.t t/ppi_statement_variable.t t/ppi_token__quoteengine_full.t t/ppi_token_dashedword.t t/ppi_token_magic.t t/ppi_token_number_version.t t/ppi_token_operator.t t/ppi_token_pod.t t/ppi_token_prototype.t t/ppi_token_quote.t t/ppi_token_quote_double.t t/ppi_token_quote_interpolate.t t/ppi_token_quote_literal.t t/ppi_token_quote_single.t t/ppi_token_quotelike_words.t t/ppi_token_word.t xt/api.t xt/author.t xt/meta.t xt/pmv.t PPI-1.220/README0000755000175100010010000007710512430470351007750 0ustar NAME PPI - Parse, Analyze and Manipulate Perl (without perl) SYNOPSIS use PPI; # Create a new empty document my $Document = PPI::Document->new; # Create a document from source $Document = PPI::Document->new(\'print "Hello World!\n"'); # Load a Document from a file $Document = PPI::Document->new('Module.pm'); # Does it contain any POD? if ( $Document->find_any('PPI::Token::Pod') ) { print "Module contains POD\n"; } # Get the name of the main package $pkg = $Document->find_first('PPI::Statement::Package')->namespace; # Remove all that nasty documentation $Document->prune('PPI::Token::Pod'); $Document->prune('PPI::Token::Comment'); # Save the file $Document->save('Module.pm.stripped'); DESCRIPTION About this Document This is the PPI manual. It describes its reason for existing, its general structure, its use, an overview of the API, and provides a few implementation samples. Background The ability to read, and manipulate Perl (the language) programmatically other than with perl (the application) was one that caused difficulty for a long time. The cause of this problem was Perl's complex and dynamic grammar. Although there is typically not a huge diversity in the grammar of most Perl code, certain issues cause large problems when it comes to parsing. Indeed, quite early in Perl's history Tom Christiansen introduced the Perl community to the quote *"Nothing but perl can parse Perl"*, or as it is more often stated now as a truism: "Only perl can parse Perl" One example of the sorts of things the prevent Perl being easily parsed are function signatures, as demonstrated by the following. @result = (dothis $foo, $bar); # Which of the following is it equivalent to? @result = (dothis($foo), $bar); @result = dothis($foo, $bar); The first line above can be interpreted in two different ways, depending on whether the &dothis function is expecting one argument, or two, or several. A "code parser" (something that parses for the purpose of execution) such as perl needs information that is not found in the immediate vicinity of the statement being parsed. The information might not just be elsewhere in the file, it might not even be in the same file at all. It might also not be able to determine this information without the prior execution of a "BEGIN {}" block, or the loading and execution of one or more external modules. Or worse the &dothis function may not even have been written yet. When parsing Perl as code, you must also execute it Even perl itself never really fully understands the structure of the source code after and indeed as it processes it, and in that sense doesn't "parse" Perl source into anything remotely like a structured document. This makes it of no real use for any task that needs to treat the source code as a document, and do so reliably and robustly. For more information on why it is impossible to parse perl, see Randal Schwartz's seminal response to the question of "Why can't you parse Perl". The purpose of PPI is not to parse Perl *Code*, but to parse Perl *Documents*. By treating the problem this way, we are able to parse a single file containing Perl source code "isolated" from any other resources, such as libraries upon which the code may depend, and without needing to run an instance of perl alongside or inside the parser. Historically, using an embedded perl parser was widely considered to be the most likely avenue for finding a solution to "Parse::Perl". It was investigated from time to time and attempts have generally failed or suffered from sufficiently bad corner cases that they were abandoned. What Does PPI Stand For? "PPI" is an acronym for the longer original module name "Parse::Perl::Isolated". And in the spirit or the silly acronym games played by certain unnamed Open Source projects you may have *hurd* of, it also a reverse backronym of "I Parse Perl". Of course, I could just be lying and have just made that second bit up 10 minutes before the release of PPI 1.000. Besides, all the cool Perl packages have TLAs (Three Letter Acronyms). It's a rule or something. Why don't you just think of it as the Perl Parsing Interface for simplicity. The original name was shortened to prevent the author (and you the users) from contracting RSI by having to type crazy things like "Parse::Perl::Isolated::Token::QuoteLike::Backtick" 100 times a day. In acknowledgment that someone may some day come up with a valid solution for the grammar problem it was decided at the commencement of the project to leave the "Parse::Perl" namespace free for any such effort. Since that time I've been able to prove to my own satisfaction that it is truly impossible to accurately parse Perl as both code and document at once. For the academics, parsing Perl suffers from the "Halting Problem". With this in mind "Parse::Perl" has now been co-opted as the title for the SourceForge project that publishes PPI and a large collection of other applications and modules related to the (document) parsing of Perl source code. You can find this project at , however we no longer use the SourceForge CVS server. Instead, the current development version of PPI is available via SVN at . Why Parse Perl? Once you can accept that we will never be able to parse Perl well enough to meet the standards of things that treat Perl as code, it is worth re-examining "why" we want to "parse" Perl at all. What are the things that people might want a "Perl parser" for. Documentation Analyzing the contents of a Perl document to automatically generate documentation, in parallel to, or as a replacement for, POD documentation. Allow an indexer to locate and process all the comments and documentation from code for "full text search" applications. Structural and Quality Analysis Determine quality or other metrics across a body of code, and identify situations relating to particular phrases, techniques or locations. Index functions, variables and packages within Perl code, and doing search and graph (in the node/edge sense) analysis of large code bases. Refactoring Make structural, syntax, or other changes to code in an automated manner, either independently or in assistance to an editor. This sort of task list includes backporting, forward porting, partial evaluation, "improving" code, or whatever. All the sort of things you'd want from a Perl::Editor. Layout Change the layout of code without changing its meaning. This includes techniques such as tidying (like perltidy), obfuscation, compressing and "squishing", or to implement formatting preferences or policies. Presentation This includes methods of improving the presentation of code, without changing the content of the code. Modify, improve, syntax colour etc the presentation of a Perl document. Generating "IntelliText"-like functions. If we treat this as a baseline for the sort of things we are going to have to build on top of Perl, then it becomes possible to identify a standard for how good a Perl parser needs to be. How good is Good Enough(TM) PPI seeks to be good enough to achieve all of the above tasks, or to provide a sufficiently good API on which to allow others to implement modules in these and related areas. However, there are going to be limits to this process. Because PPI cannot adapt to changing grammars, any code written using source filters should not be assumed to be parsable. At one extreme, this includes anything munged by Acme::Bleach, as well as (arguably) more common cases like Switch. We do not pretend to be able to always parse code using these modules, although as long as it still follows a format that looks like Perl syntax, it may be possible to extend the lexer to handle them. The ability to extend PPI to handle lexical additions to the language is on the drawing board to be done some time post-1.0 The goal for success was originally to be able to successfully parse 99% of all Perl documents contained in CPAN. This means the entire file in each case. PPI has succeeded in this goal far beyond the expectations of even the author. At time of writing there are only 28 non-Acme Perl modules in CPAN that PPI is incapable of parsing. Most of these are so badly broken they do not compile as Perl code anyway. So unless you are actively going out of your way to break PPI, you should expect that it will handle your code just fine. Internationalisation PPI provides partial support for internationalisation and localisation. Specifically, it allows the use characters from the Latin-1 character set to be used in quotes, comments, and POD. Primarily, this covers languages from Europe and South America. PPI does not currently provide support for Unicode, although there is an initial implementation available in a development branch from CVS. If you need Unicode support, and would like to help stress test the Unicode support so we can move it to the main branch and enable it in the main release should contact the author. (contact details below) Round Trip Safe When PPI parses a file it builds everything into the model, including whitespace. This is needed in order to make the Document fully "Round Trip" safe. The general concept behind a "Round Trip" parser is that it knows what it is parsing is somewhat uncertain, and so expects to get things wrong from time to time. In the cases where it parses code wrongly the tree will serialize back out to the same string of code that was read in, repairing the parser's mistake as it heads back out to the file. The end result is that if you parse in a file and serialize it back out without changing the tree, you are guaranteed to get the same file you started with. PPI does this correctly and reliably for 100% of all known cases. What goes in, will come out. Every time. The one minor exception at this time is that if the newlines for your file are wrong (meaning not matching the platform newline format), PPI will localise them for you. (It isn't to be convenient, supporting arbitrary newlines would make some of the code more complicated) Better control of the newline type is on the wish list though, and anyone wanting to help out is encouraged to contact the author. IMPLEMENTATION General Layout PPI is built upon two primary "parsing" components, PPI::Tokenizer and PPI::Lexer, and a large tree of about 50 classes which implement the various the *Perl Document Object Model* (PDOM). The PDOM is conceptually similar in style and intent to the regular DOM or other code Abstract Syntax Trees (ASTs), but contains some differences to handle perl-specific cases, and to assist in treating the code as a document. Please note that it is not an implementation of the official Document Object Model specification, only somewhat similar to it. On top of the Tokenizer, Lexer and the classes of the PDOM, sit a number of classes intended to make life a little easier when dealing with PDOM trees. Both the major parsing components were hand-coded from scratch with only plain Perl code and a few small utility modules. There are no grammar or patterns mini-languages, no YACC or LEX style tools and only a small number of regular expressions. This is primarily because of the sheer volume of accumulated cruft that exists in Perl. Not even perl itself is capable of parsing Perl documents (remember, it just parses and executes it as code). As a result, PPI needed to be cruftier than perl itself. Feel free to shudder at this point, and hope you never have to understand the Tokenizer codebase. Speaking of which... The Tokenizer The Tokenizer takes source code and converts it into a series of tokens. It does this using a slow but thorough character by character manual process, rather than using a pattern system or complex regexes. Or at least it does so conceptually. If you were to actually trace the code you would find it's not truly character by character due to a number of regexps and optimisations throughout the code. This lets the Tokenizer "skip ahead" when it can find shortcuts, so it tends to jump around a line a bit wildly at times. In practice, the number of times the Tokenizer will actually move the character cursor itself is only about 5% - 10% higher than the number of tokens contained in the file. This makes it about as optimal as it can be made without implementing it in something other than Perl. In 2001 when PPI was started, this structure made PPI quite slow, and not really suitable for interactive tasks. This situation has improved greatly with multi-gigahertz processors, but can still be painful when working with very large files. The target parsing rate for PPI is about 5000 lines per gigacycle. It is currently believed to be at about 1500, and main avenue for making it to the target speed has now become PPI::XS, a drop-in XS accelerator for PPI. Since PPI::XS has only just gotten off the ground and is currently only at proof-of-concept stage, this may take a little while. Anyone interested in helping out with PPI::XS is highly encouraged to contact the author. In fact, the design of PPI::XS means it's possible to port one function at a time safely and reliably. So every little bit will help. The Lexer The Lexer takes a token stream, and converts it to a lexical tree. Because we are parsing Perl documents this includes whitespace, comments, and all number of weird things that have no relevance when code is actually executed. An instantiated PPI::Lexer consumes PPI::Tokenizer objects and produces PPI::Document objects. However you should probably never be working with the Lexer directly. You should just be able to create PPI::Document objects and work with them directly. The Perl Document Object Model The PDOM is a structured collection of data classes that together provide a correct and scalable model for documents that follow the standard Perl syntax. The PDOM Class Tree The following lists all of the 67 current PDOM classes, listing with indentation based on inheritance. PPI::Element PPI::Node PPI::Document PPI::Document::Fragment PPI::Statement PPI::Statement::Package PPI::Statement::Include PPI::Statement::Sub PPI::Statement::Scheduled PPI::Statement::Compound PPI::Statement::Break PPI::Statement::Given PPI::Statement::When PPI::Statement::Data PPI::Statement::End PPI::Statement::Expression PPI::Statement::Variable PPI::Statement::Null PPI::Statement::UnmatchedBrace PPI::Statement::Unknown PPI::Structure PPI::Structure::Block PPI::Structure::Subscript PPI::Structure::Constructor PPI::Structure::Condition PPI::Structure::List PPI::Structure::For PPI::Structure::Given PPI::Structure::When PPI::Structure::Unknown PPI::Token PPI::Token::Whitespace PPI::Token::Comment PPI::Token::Pod PPI::Token::Number PPI::Token::Number::Binary PPI::Token::Number::Octal PPI::Token::Number::Hex PPI::Token::Number::Float PPI::Token::Number::Exp PPI::Token::Number::Version PPI::Token::Word PPI::Token::DashedWord PPI::Token::Symbol PPI::Token::Magic PPI::Token::ArrayIndex PPI::Token::Operator PPI::Token::Quote PPI::Token::Quote::Single PPI::Token::Quote::Double PPI::Token::Quote::Literal PPI::Token::Quote::Interpolate PPI::Token::QuoteLike PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Regexp PPI::Token::QuoteLike::Words PPI::Token::QuoteLike::Readline PPI::Token::Regexp PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute PPI::Token::Regexp::Transliterate PPI::Token::HereDoc PPI::Token::Cast PPI::Token::Structure PPI::Token::Label PPI::Token::Separator PPI::Token::Data PPI::Token::End PPI::Token::Prototype PPI::Token::Attribute PPI::Token::Unknown To summarize the above layout, all PDOM objects inherit from the PPI::Element class. Under this are PPI::Token, strings of content with a known type, and PPI::Node, syntactically significant containers that hold other Elements. The three most important of these are the PPI::Document, the PPI::Statement and the PPI::Structure classes. The Document, Statement and Structure At the top of all complete PDOM trees is a PPI::Document object. It represents a complete file of Perl source code as you might find it on disk. There are some specialised types of document, such as PPI::Document::File and PPI::Document::Normalized but for the purposes of the PDOM they are all just considered to be the same thing. Each Document will contain a number of Statements, Structures and Tokens. A PPI::Statement is any series of Tokens and Structures that are treated as a single contiguous statement by perl itself. You should note that a Statement is as close as PPI can get to "parsing" the code in the sense that perl-itself parses Perl code when it is building the op-tree. Because of the isolation and Perl's syntax, it is provably impossible for PPI to accurately determine precedence of operators or which tokens are implicit arguments to a sub call. So rather than lead you on with a bad guess that has a strong chance of being wrong, PPI does not attempt to determine precedence or sub parameters at all. At a fundamental level, it only knows that this series of elements represents a single Statement as perl sees it, but it can do so with enough certainty that it can be trusted. However, for specific Statement types the PDOM is able to derive additional useful information about their meaning. For the best, most useful, and most heavily used example, see PPI::Statement::Include. A PPI::Structure is any series of tokens contained within matching braces. This includes code blocks, conditions, function argument braces, anonymous array and hash constructors, lists, scoping braces and all other syntactic structures represented by a matching pair of braces, including (although it may not seem obvious at first) "" braces. Each Structure contains none, one, or many Tokens and Structures (the rules for which vary for the different Structure subclasses) Under the PDOM structure rules, a Statement can never directly contain another child Statement, a Structure can never directly contain another child Structure, and a Document can never contain another Document anywhere in the tree. Aside from these three rules, the PDOM tree is extremely flexible. The PDOM at Work To demonstrate the PDOM in use lets start with an example showing how the tree might look for the following chunk of simple Perl code. #!/usr/bin/perl print( "Hello World!" ); exit(); Translated into a PDOM tree it would have the following structure (as shown via the included PPI::Dumper). PPI::Document PPI::Token::Comment '#!/usr/bin/perl\n' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Quote::Double '"Hello World!"' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'exit' PPI::Structure::List ( ... ) PPI::Token::Structure ';' PPI::Token::Whitespace '\n' Please note that in this example, strings are only listed for the actual PPI::Token that contains that string. Structures are listed with the type of brace characters it represents noted. The PPI::Dumper module can be used to generate similar trees yourself. We can make that PDOM dump a little easier to read if we strip out all the whitespace. Here it is again, sans the distracting whitespace tokens. PPI::Document PPI::Token::Comment '#!/usr/bin/perl\n' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Quote::Double '"Hello World!"' PPI::Token::Structure ';' PPI::Statement PPI::Token::Word 'exit' PPI::Structure::List ( ... ) PPI::Token::Structure ';' As you can see, the tree can get fairly deep at time, especially when every isolated token in a bracket becomes its own statement. This is needed to allow anything inside the tree the ability to grow. It also makes the search and analysis algorithms much more flexible. Because of the depth and complexity of PDOM trees, a vast number of very easy to use methods have been added wherever possible to help people working with PDOM trees do normal tasks relatively quickly and efficiently. Overview of the Primary Classes The main PPI classes, and links to their own documentation, are listed here in alphabetical order. PPI::Document The Document object, the root of the PDOM. PPI::Document::Fragment A cohesive fragment of a larger Document. Although not of any real current use, it is needed for use in certain internal tree manipulation algorithms. For example, doing things like cut/copy/paste etc. Very similar to a PPI::Document, but has some additional methods and does not represent a lexical scope boundary. A document fragment is also non-serializable, and so cannot be written out to a file. PPI::Dumper A simple class for dumping readable debugging versions of PDOM structures, such as in the demonstration above. PPI::Element The Element class is the abstract base class for all objects within the PDOM PPI::Find Implements an instantiable object form of a PDOM tree search. PPI::Lexer The PPI Lexer. Converts Token streams into PDOM trees. PPI::Node The Node object, the abstract base class for all PDOM objects that can contain other Elements, such as the Document, Statement and Structure objects. PPI::Statement The base class for all Perl statements. Generic "evaluate for side-effects" statements are of this actual type. Other more interesting statement types belong to one of its children. See it's own documentation for a longer description and list of all of the different statement types and sub-classes. PPI::Structure The abstract base class for all structures. A Structure is a language construct consisting of matching braces containing a set of other elements. See the PPI::Structure documentation for a description and list of all of the different structure types and sub-classes. PPI::Token A token is the basic unit of content. At its most basic, a Token is just a string tagged with metadata (its class, and some additional flags in some cases). PPI::Token::_QuoteEngine The PPI::Token::Quote and PPI::Token::QuoteLike classes provide abstract base classes for the many and varied types of quote and quote-like things in Perl. However, much of the actual quote login is implemented in a separate quote engine, based at PPI::Token::_QuoteEngine. Classes that inherit from PPI::Token::Quote, PPI::Token::QuoteLike and PPI::Token::Regexp are generally parsed only by the Quote Engine. PPI::Tokenizer The PPI Tokenizer. One Tokenizer consumes a chunk of text and provides access to a stream of PPI::Token objects. The Tokenizer is very very complicated, to the point where even the author treads carefully when working with it. Most of the complication is the result of optimizations which have tripled the tokenization speed, at the expense of maintainability. We cope with the spaghetti by heavily commenting everything. PPI::Transform The Perl Document Transformation API. Provides a standard interface and abstract base class for objects and classes that manipulate Documents. INSTALLING The core PPI distribution is pure Perl and has been kept as tight as possible and with as few dependencies as possible. It should download and install normally on any platform from within the CPAN and CPANPLUS applications, or directly using the distribution tarball. If installing by hand, you may need to install a few small utility modules first. The exact ones will depend on your version of perl. There are no special install instructions for PPI, and the normal "Perl Makefile.PL", "make", "make test", "make install" instructions apply. EXTENDING The PPI namespace itself is reserved for the sole use of the modules under the umbrella of the "Parse::Perl" SourceForge project. You are recommended to use the PPIx:: namespace for PPI-specific modifications or prototypes thereof, or Perl:: for modules which provide a general Perl language-related functions. If what you wish to implement looks like it fits into PPIx:: namespace, you should consider contacting the "Parse::Perl" mailing list (detailed on the SourceForge site) first, as what you want may already be in progress, or you may wish to consider joining the team and doing it within the "Parse::Perl" project itself. TO DO - Many more analysis and utility methods for PDOM classes - Creation of a PPI::Tutorial document - Add many more key functions to PPI::XS - We can always write more and better unit tests - Complete the full implementation of ->literal (1.200) - Full understanding of scoping (due 1.300) SUPPORT This module is stored in an Open Repository at the following address. Write access to the repository is made available automatically to any published CPAN author, and to most other volunteers on request. If you are able to submit your bug report in the form of new (failing) unit tests, or can apply your fix directly instead of submitting a patch, you are strongly encouraged to do so, as the author currently maintains over 100 modules and it can take some time to deal with non-"Critical" bug reports or patches. This will also guarantee that your issue will be addressed in the next release of the module. For large changes though, please consider creating a branch so that they can be properly reviewed and trialed before being applied to the trunk. If you cannot provide a direct test or fix, or don't have time to do so, then regular bug reports are still accepted and appreciated via the GitHub bug tracker. For other issues or questions, contact the "Parse::Perl" project mailing list. For commercial or media-related enquiries, or to have your SVN commit bit enabled, contact the author. AUTHOR Adam Kennedy ACKNOWLEDGMENTS A huge thank you to Phase N Australia () for permitting the original open sourcing and release of this distribution from what was originally several thousand hours of commercial work. Another big thank you to The Perl Foundation () for funding for the final big refactoring and completion run. Also, to the various co-maintainers that have contributed both large and small with tests and patches and especially to those rare few who have deep-dived into the guts to (gasp) add a feature. - Dan Brook : PPIx::XPath, Acme::PerlML - Audrey Tang : "Line Noise" Testing - Arjen Laarhoven : Three-element ->location support - Elliot Shank : Perl 5.10 support, five-element ->location And finally, thanks to those brave ( and foolish :) ) souls willing to dive in and use, test drive and provide feedback on PPI before version 1.000, in some cases before it made it to beta quality, and still did extremely distasteful things (like eating 50 meg of RAM a second). I owe you all a beer. Corner me somewhere and collect at your convenience. If I missed someone who wasn't in my email history, thank you too :) # In approximate order of appearance - Claes Jacobsson - Michael Schwern - Jeff T. Parsons - CPAN Author "CHOCOLATEBOY" - Robert Rotherberg - CPAN Author "PODMASTER" - Richard Soderberg - Nadim ibn Hamouda el Khemir - Graciliano M. P. - Leon Brocard - Jody Belka - Curtis Ovid - Yuval Kogman - Michael Schilli - Slaven Rezic - Lars Thegler - Tony Stubblebine - Tatsuhiko Miyagawa - CPAN Author "CHROMATIC" - Matisse Enzer - Roy Fulbright - Dan Brook - Johnny Lee - Johan Lindstrom And to single one person out, thanks go to Randal Schwartz who spent a great number of hours in IRC over a critical 6 month period explaining why Perl is impossibly unparsable and constantly shoving evil and ugly corner cases in my face. He remained a tireless devil's advocate, and without his support this project genuinely could never have been completed. So for my schooling in the Deep Magiks, you have my deepest gratitude Randal. COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. PPI-1.220/README.md0000755000175100010010000010161712430470351010343 0ustar # NAME PPI - Parse, Analyze and Manipulate Perl (without perl) # SYNOPSIS use PPI; # Create a new empty document my $Document = PPI::Document->new; # Create a document from source $Document = PPI::Document->new(\'print "Hello World!\n"'); # Load a Document from a file $Document = PPI::Document->new('Module.pm'); # Does it contain any POD? if ( $Document->find_any('PPI::Token::Pod') ) { print "Module contains POD\n"; } # Get the name of the main package $pkg = $Document->find_first('PPI::Statement::Package')->namespace; # Remove all that nasty documentation $Document->prune('PPI::Token::Pod'); $Document->prune('PPI::Token::Comment'); # Save the file $Document->save('Module.pm.stripped'); # DESCRIPTION ## About this Document This is the PPI manual. It describes its reason for existing, its general structure, its use, an overview of the API, and provides a few implementation samples. ## Background The ability to read, and manipulate Perl (the language) programmatically other than with perl (the application) was one that caused difficulty for a long time. The cause of this problem was Perl's complex and dynamic grammar. Although there is typically not a huge diversity in the grammar of most Perl code, certain issues cause large problems when it comes to parsing. Indeed, quite early in Perl's history Tom Christiansen introduced the Perl community to the quote _"Nothing but perl can parse Perl"_, or as it is more often stated now as a truism: **"Only perl can parse Perl"** One example of the sorts of things the prevent Perl being easily parsed are function signatures, as demonstrated by the following. @result = (dothis $foo, $bar); # Which of the following is it equivalent to? @result = (dothis($foo), $bar); @result = dothis($foo, $bar); The first line above can be interpreted in two different ways, depending on whether the `&dothis` function is expecting one argument, or two, or several. A "code parser" (something that parses for the purpose of execution) such as perl needs information that is not found in the immediate vicinity of the statement being parsed. The information might not just be elsewhere in the file, it might not even be in the same file at all. It might also not be able to determine this information without the prior execution of a `BEGIN {}` block, or the loading and execution of one or more external modules. Or worse the &dothis function may not even have been written yet. **When parsing Perl as code, you must also execute it** Even perl itself never really fully understands the structure of the source code after and indeed **as** it processes it, and in that sense doesn't "parse" Perl source into anything remotely like a structured document. This makes it of no real use for any task that needs to treat the source code as a document, and do so reliably and robustly. For more information on why it is impossible to parse perl, see Randal Schwartz's seminal response to the question of "Why can't you parse Perl". [http://www.perlmonks.org/index.pl?node\_id=44722](http://www.perlmonks.org/index.pl?node_id=44722) The purpose of PPI is **not** to parse Perl _Code_, but to parse Perl _Documents_. By treating the problem this way, we are able to parse a single file containing Perl source code "isolated" from any other resources, such as libraries upon which the code may depend, and without needing to run an instance of perl alongside or inside the parser. Historically, using an embedded perl parser was widely considered to be the most likely avenue for finding a solution to `Parse::Perl`. It was investigated from time to time and attempts have generally failed or suffered from sufficiently bad corner cases that they were abandoned. ## What Does PPI Stand For? `PPI` is an acronym for the longer original module name `Parse::Perl::Isolated`. And in the spirit or the silly acronym games played by certain unnamed Open Source projects you may have _hurd_ of, it also a reverse backronym of "I Parse Perl". Of course, I could just be lying and have just made that second bit up 10 minutes before the release of PPI 1.000. Besides, **all** the cool Perl packages have TLAs (Three Letter Acronyms). It's a rule or something. Why don't you just think of it as the **Perl Parsing Interface** for simplicity. The original name was shortened to prevent the author (and you the users) from contracting RSI by having to type crazy things like `Parse::Perl::Isolated::Token::QuoteLike::Backtick` 100 times a day. In acknowledgment that someone may some day come up with a valid solution for the grammar problem it was decided at the commencement of the project to leave the `Parse::Perl` namespace free for any such effort. Since that time I've been able to prove to my own satisfaction that it **is** truly impossible to accurately parse Perl as both code and document at once. For the academics, parsing Perl suffers from the "Halting Problem". With this in mind `Parse::Perl` has now been co-opted as the title for the SourceForge project that publishes PPI and a large collection of other applications and modules related to the (document) parsing of Perl source code. You can find this project at [http://sf.net/projects/parseperl](http://sf.net/projects/parseperl), however we no longer use the SourceForge CVS server. Instead, the current development version of PPI is available via SVN at [http://svn.ali.as/cpan/trunk/PPI/](http://svn.ali.as/cpan/trunk/PPI/). ## Why Parse Perl? Once you can accept that we will never be able to parse Perl well enough to meet the standards of things that treat Perl as code, it is worth re-examining `why` we want to "parse" Perl at all. What are the things that people might want a "Perl parser" for. - Documentation Analyzing the contents of a Perl document to automatically generate documentation, in parallel to, or as a replacement for, POD documentation. Allow an indexer to locate and process all the comments and documentation from code for "full text search" applications. - Structural and Quality Analysis Determine quality or other metrics across a body of code, and identify situations relating to particular phrases, techniques or locations. Index functions, variables and packages within Perl code, and doing search and graph (in the node/edge sense) analysis of large code bases. - Refactoring Make structural, syntax, or other changes to code in an automated manner, either independently or in assistance to an editor. This sort of task list includes backporting, forward porting, partial evaluation, "improving" code, or whatever. All the sort of things you'd want from a [Perl::Editor](https://metacpan.org/pod/Perl::Editor). - Layout Change the layout of code without changing its meaning. This includes techniques such as tidying (like [perltidy](https://metacpan.org/pod/perltidy)), obfuscation, compressing and "squishing", or to implement formatting preferences or policies. - Presentation This includes methods of improving the presentation of code, without changing the content of the code. Modify, improve, syntax colour etc the presentation of a Perl document. Generating "IntelliText"-like functions. If we treat this as a baseline for the sort of things we are going to have to build on top of Perl, then it becomes possible to identify a standard for how good a Perl parser needs to be. ## How good is Good Enough(TM) PPI seeks to be good enough to achieve all of the above tasks, or to provide a sufficiently good API on which to allow others to implement modules in these and related areas. However, there are going to be limits to this process. Because PPI cannot adapt to changing grammars, any code written using source filters should not be assumed to be parsable. At one extreme, this includes anything munged by [Acme::Bleach](https://metacpan.org/pod/Acme::Bleach), as well as (arguably) more common cases like [Switch](https://metacpan.org/pod/Switch). We do not pretend to be able to always parse code using these modules, although as long as it still follows a format that looks like Perl syntax, it may be possible to extend the lexer to handle them. The ability to extend PPI to handle lexical additions to the language is on the drawing board to be done some time post-1.0 The goal for success was originally to be able to successfully parse 99% of all Perl documents contained in CPAN. This means the entire file in each case. PPI has succeeded in this goal far beyond the expectations of even the author. At time of writing there are only 28 non-Acme Perl modules in CPAN that PPI is incapable of parsing. Most of these are so badly broken they do not compile as Perl code anyway. So unless you are actively going out of your way to break PPI, you should expect that it will handle your code just fine. ## Internationalisation PPI provides partial support for internationalisation and localisation. Specifically, it allows the use characters from the Latin-1 character set to be used in quotes, comments, and POD. Primarily, this covers languages from Europe and South America. PPI does **not** currently provide support for Unicode, although there is an initial implementation available in a development branch from CVS. If you need Unicode support, and would like to help stress test the Unicode support so we can move it to the main branch and enable it in the main release should contact the author. (contact details below) ## Round Trip Safe When PPI parses a file it builds **everything** into the model, including whitespace. This is needed in order to make the Document fully "Round Trip" safe. The general concept behind a "Round Trip" parser is that it knows what it is parsing is somewhat uncertain, and so **expects** to get things wrong from time to time. In the cases where it parses code wrongly the tree will serialize back out to the same string of code that was read in, repairing the parser's mistake as it heads back out to the file. The end result is that if you parse in a file and serialize it back out without changing the tree, you are guaranteed to get the same file you started with. PPI does this correctly and reliably for 100% of all known cases. **What goes in, will come out. Every time.** The one minor exception at this time is that if the newlines for your file are wrong (meaning not matching the platform newline format), PPI will localise them for you. (It isn't to be convenient, supporting arbitrary newlines would make some of the code more complicated) Better control of the newline type is on the wish list though, and anyone wanting to help out is encouraged to contact the author. # IMPLEMENTATION ## General Layout PPI is built upon two primary "parsing" components, [PPI::Tokenizer](https://metacpan.org/pod/PPI::Tokenizer) and [PPI::Lexer](https://metacpan.org/pod/PPI::Lexer), and a large tree of about 50 classes which implement the various the _Perl Document Object Model_ (PDOM). The PDOM is conceptually similar in style and intent to the regular DOM or other code Abstract Syntax Trees (ASTs), but contains some differences to handle perl-specific cases, and to assist in treating the code as a document. Please note that it is **not** an implementation of the official Document Object Model specification, only somewhat similar to it. On top of the Tokenizer, Lexer and the classes of the PDOM, sit a number of classes intended to make life a little easier when dealing with PDOM trees. Both the major parsing components were hand-coded from scratch with only plain Perl code and a few small utility modules. There are no grammar or patterns mini-languages, no YACC or LEX style tools and only a small number of regular expressions. This is primarily because of the sheer volume of accumulated cruft that exists in Perl. Not even perl itself is capable of parsing Perl documents (remember, it just parses and executes it as code). As a result, PPI needed to be cruftier than perl itself. Feel free to shudder at this point, and hope you never have to understand the Tokenizer codebase. Speaking of which... ## The Tokenizer The Tokenizer takes source code and converts it into a series of tokens. It does this using a slow but thorough character by character manual process, rather than using a pattern system or complex regexes. Or at least it does so conceptually. If you were to actually trace the code you would find it's not truly character by character due to a number of regexps and optimisations throughout the code. This lets the Tokenizer "skip ahead" when it can find shortcuts, so it tends to jump around a line a bit wildly at times. In practice, the number of times the Tokenizer will **actually** move the character cursor itself is only about 5% - 10% higher than the number of tokens contained in the file. This makes it about as optimal as it can be made without implementing it in something other than Perl. In 2001 when PPI was started, this structure made PPI quite slow, and not really suitable for interactive tasks. This situation has improved greatly with multi-gigahertz processors, but can still be painful when working with very large files. The target parsing rate for PPI is about 5000 lines per gigacycle. It is currently believed to be at about 1500, and main avenue for making it to the target speed has now become [PPI::XS](https://metacpan.org/pod/PPI::XS), a drop-in XS accelerator for PPI. Since [PPI::XS](https://metacpan.org/pod/PPI::XS) has only just gotten off the ground and is currently only at proof-of-concept stage, this may take a little while. Anyone interested in helping out with [PPI::XS](https://metacpan.org/pod/PPI::XS) is **highly** encouraged to contact the author. In fact, the design of [PPI::XS](https://metacpan.org/pod/PPI::XS) means it's possible to port one function at a time safely and reliably. So every little bit will help. ## The Lexer The Lexer takes a token stream, and converts it to a lexical tree. Because we are parsing Perl **documents** this includes whitespace, comments, and all number of weird things that have no relevance when code is actually executed. An instantiated [PPI::Lexer](https://metacpan.org/pod/PPI::Lexer) consumes [PPI::Tokenizer](https://metacpan.org/pod/PPI::Tokenizer) objects and produces [PPI::Document](https://metacpan.org/pod/PPI::Document) objects. However you should probably never be working with the Lexer directly. You should just be able to create [PPI::Document](https://metacpan.org/pod/PPI::Document) objects and work with them directly. ## The Perl Document Object Model The PDOM is a structured collection of data classes that together provide a correct and scalable model for documents that follow the standard Perl syntax. ## The PDOM Class Tree The following lists all of the 67 current PDOM classes, listing with indentation based on inheritance. PPI::Element PPI::Node PPI::Document PPI::Document::Fragment PPI::Statement PPI::Statement::Package PPI::Statement::Include PPI::Statement::Sub PPI::Statement::Scheduled PPI::Statement::Compound PPI::Statement::Break PPI::Statement::Given PPI::Statement::When PPI::Statement::Data PPI::Statement::End PPI::Statement::Expression PPI::Statement::Variable PPI::Statement::Null PPI::Statement::UnmatchedBrace PPI::Statement::Unknown PPI::Structure PPI::Structure::Block PPI::Structure::Subscript PPI::Structure::Constructor PPI::Structure::Condition PPI::Structure::List PPI::Structure::For PPI::Structure::Given PPI::Structure::When PPI::Structure::Unknown PPI::Token PPI::Token::Whitespace PPI::Token::Comment PPI::Token::Pod PPI::Token::Number PPI::Token::Number::Binary PPI::Token::Number::Octal PPI::Token::Number::Hex PPI::Token::Number::Float PPI::Token::Number::Exp PPI::Token::Number::Version PPI::Token::Word PPI::Token::DashedWord PPI::Token::Symbol PPI::Token::Magic PPI::Token::ArrayIndex PPI::Token::Operator PPI::Token::Quote PPI::Token::Quote::Single PPI::Token::Quote::Double PPI::Token::Quote::Literal PPI::Token::Quote::Interpolate PPI::Token::QuoteLike PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Regexp PPI::Token::QuoteLike::Words PPI::Token::QuoteLike::Readline PPI::Token::Regexp PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute PPI::Token::Regexp::Transliterate PPI::Token::HereDoc PPI::Token::Cast PPI::Token::Structure PPI::Token::Label PPI::Token::Separator PPI::Token::Data PPI::Token::End PPI::Token::Prototype PPI::Token::Attribute PPI::Token::Unknown To summarize the above layout, all PDOM objects inherit from the [PPI::Element](https://metacpan.org/pod/PPI::Element) class. Under this are [PPI::Token](https://metacpan.org/pod/PPI::Token), strings of content with a known type, and [PPI::Node](https://metacpan.org/pod/PPI::Node), syntactically significant containers that hold other Elements. The three most important of these are the [PPI::Document](https://metacpan.org/pod/PPI::Document), the [PPI::Statement](https://metacpan.org/pod/PPI::Statement) and the [PPI::Structure](https://metacpan.org/pod/PPI::Structure) classes. ## The Document, Statement and Structure At the top of all complete PDOM trees is a [PPI::Document](https://metacpan.org/pod/PPI::Document) object. It represents a complete file of Perl source code as you might find it on disk. There are some specialised types of document, such as [PPI::Document::File](https://metacpan.org/pod/PPI::Document::File) and [PPI::Document::Normalized](https://metacpan.org/pod/PPI::Document::Normalized) but for the purposes of the PDOM they are all just considered to be the same thing. Each Document will contain a number of **Statements**, **Structures** and **Tokens**. A [PPI::Statement](https://metacpan.org/pod/PPI::Statement) is any series of Tokens and Structures that are treated as a single contiguous statement by perl itself. You should note that a Statement is as close as PPI can get to "parsing" the code in the sense that perl-itself parses Perl code when it is building the op-tree. Because of the isolation and Perl's syntax, it is provably impossible for PPI to accurately determine precedence of operators or which tokens are implicit arguments to a sub call. So rather than lead you on with a bad guess that has a strong chance of being wrong, PPI does not attempt to determine precedence or sub parameters at all. At a fundamental level, it only knows that this series of elements represents a single Statement as perl sees it, but it can do so with enough certainty that it can be trusted. However, for specific Statement types the PDOM is able to derive additional useful information about their meaning. For the best, most useful, and most heavily used example, see [PPI::Statement::Include](https://metacpan.org/pod/PPI::Statement::Include). A [PPI::Structure](https://metacpan.org/pod/PPI::Structure) is any series of tokens contained within matching braces. This includes code blocks, conditions, function argument braces, anonymous array and hash constructors, lists, scoping braces and all other syntactic structures represented by a matching pair of braces, including (although it may not seem obvious at first) `` braces. Each Structure contains none, one, or many Tokens and Structures (the rules for which vary for the different Structure subclasses) Under the PDOM structure rules, a Statement can **never** directly contain another child Statement, a Structure can **never** directly contain another child Structure, and a Document can **never** contain another Document anywhere in the tree. Aside from these three rules, the PDOM tree is extremely flexible. ## The PDOM at Work To demonstrate the PDOM in use lets start with an example showing how the tree might look for the following chunk of simple Perl code. #!/usr/bin/perl print( "Hello World!" ); exit(); Translated into a PDOM tree it would have the following structure (as shown via the included [PPI::Dumper](https://metacpan.org/pod/PPI::Dumper)). PPI::Document PPI::Token::Comment '#!/usr/bin/perl\n' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Quote::Double '"Hello World!"' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'exit' PPI::Structure::List ( ... ) PPI::Token::Structure ';' PPI::Token::Whitespace '\n' Please note that in this example, strings are only listed for the **actual** [PPI::Token](https://metacpan.org/pod/PPI::Token) that contains that string. Structures are listed with the type of brace characters it represents noted. The [PPI::Dumper](https://metacpan.org/pod/PPI::Dumper) module can be used to generate similar trees yourself. We can make that PDOM dump a little easier to read if we strip out all the whitespace. Here it is again, sans the distracting whitespace tokens. PPI::Document PPI::Token::Comment '#!/usr/bin/perl\n' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Quote::Double '"Hello World!"' PPI::Token::Structure ';' PPI::Statement PPI::Token::Word 'exit' PPI::Structure::List ( ... ) PPI::Token::Structure ';' As you can see, the tree can get fairly deep at time, especially when every isolated token in a bracket becomes its own statement. This is needed to allow anything inside the tree the ability to grow. It also makes the search and analysis algorithms much more flexible. Because of the depth and complexity of PDOM trees, a vast number of very easy to use methods have been added wherever possible to help people working with PDOM trees do normal tasks relatively quickly and efficiently. ## Overview of the Primary Classes The main PPI classes, and links to their own documentation, are listed here in alphabetical order. - [PPI::Document](https://metacpan.org/pod/PPI::Document) The Document object, the root of the PDOM. - [PPI::Document::Fragment](https://metacpan.org/pod/PPI::Document::Fragment) A cohesive fragment of a larger Document. Although not of any real current use, it is needed for use in certain internal tree manipulation algorithms. For example, doing things like cut/copy/paste etc. Very similar to a [PPI::Document](https://metacpan.org/pod/PPI::Document), but has some additional methods and does not represent a lexical scope boundary. A document fragment is also non-serializable, and so cannot be written out to a file. - [PPI::Dumper](https://metacpan.org/pod/PPI::Dumper) A simple class for dumping readable debugging versions of PDOM structures, such as in the demonstration above. - [PPI::Element](https://metacpan.org/pod/PPI::Element) The Element class is the abstract base class for all objects within the PDOM - [PPI::Find](https://metacpan.org/pod/PPI::Find) Implements an instantiable object form of a PDOM tree search. - [PPI::Lexer](https://metacpan.org/pod/PPI::Lexer) The PPI Lexer. Converts Token streams into PDOM trees. - [PPI::Node](https://metacpan.org/pod/PPI::Node) The Node object, the abstract base class for all PDOM objects that can contain other Elements, such as the Document, Statement and Structure objects. - [PPI::Statement](https://metacpan.org/pod/PPI::Statement) The base class for all Perl statements. Generic "evaluate for side-effects" statements are of this actual type. Other more interesting statement types belong to one of its children. See it's own documentation for a longer description and list of all of the different statement types and sub-classes. - [PPI::Structure](https://metacpan.org/pod/PPI::Structure) The abstract base class for all structures. A Structure is a language construct consisting of matching braces containing a set of other elements. See the [PPI::Structure](https://metacpan.org/pod/PPI::Structure) documentation for a description and list of all of the different structure types and sub-classes. - [PPI::Token](https://metacpan.org/pod/PPI::Token) A token is the basic unit of content. At its most basic, a Token is just a string tagged with metadata (its class, and some additional flags in some cases). - [PPI::Token::\_QuoteEngine](https://metacpan.org/pod/PPI::Token::_QuoteEngine) The [PPI::Token::Quote](https://metacpan.org/pod/PPI::Token::Quote) and [PPI::Token::QuoteLike](https://metacpan.org/pod/PPI::Token::QuoteLike) classes provide abstract base classes for the many and varied types of quote and quote-like things in Perl. However, much of the actual quote login is implemented in a separate quote engine, based at [PPI::Token::\_QuoteEngine](https://metacpan.org/pod/PPI::Token::_QuoteEngine). Classes that inherit from [PPI::Token::Quote](https://metacpan.org/pod/PPI::Token::Quote), [PPI::Token::QuoteLike](https://metacpan.org/pod/PPI::Token::QuoteLike) and [PPI::Token::Regexp](https://metacpan.org/pod/PPI::Token::Regexp) are generally parsed only by the Quote Engine. - [PPI::Tokenizer](https://metacpan.org/pod/PPI::Tokenizer) The PPI Tokenizer. One Tokenizer consumes a chunk of text and provides access to a stream of [PPI::Token](https://metacpan.org/pod/PPI::Token) objects. The Tokenizer is very very complicated, to the point where even the author treads carefully when working with it. Most of the complication is the result of optimizations which have tripled the tokenization speed, at the expense of maintainability. We cope with the spaghetti by heavily commenting everything. - [PPI::Transform](https://metacpan.org/pod/PPI::Transform) The Perl Document Transformation API. Provides a standard interface and abstract base class for objects and classes that manipulate Documents. # INSTALLING The core PPI distribution is pure Perl and has been kept as tight as possible and with as few dependencies as possible. It should download and install normally on any platform from within the CPAN and CPANPLUS applications, or directly using the distribution tarball. If installing by hand, you may need to install a few small utility modules first. The exact ones will depend on your version of perl. There are no special install instructions for PPI, and the normal `Perl Makefile.PL`, `make`, `make test`, `make install` instructions apply. # EXTENDING The PPI namespace itself is reserved for the sole use of the modules under the umbrella of the `Parse::Perl` SourceForge project. [http://sf.net/projects/parseperl](http://sf.net/projects/parseperl) You are recommended to use the PPIx:: namespace for PPI-specific modifications or prototypes thereof, or Perl:: for modules which provide a general Perl language-related functions. If what you wish to implement looks like it fits into PPIx:: namespace, you should consider contacting the `Parse::Perl` mailing list (detailed on the SourceForge site) first, as what you want may already be in progress, or you may wish to consider joining the team and doing it within the `Parse::Perl` project itself. # TO DO \- Many more analysis and utility methods for PDOM classes \- Creation of a PPI::Tutorial document \- Add many more key functions to PPI::XS \- We can **always** write more and better unit tests \- Complete the full implementation of ->literal (1.200) \- Full understanding of scoping (due 1.300) # SUPPORT This module is stored in an Open Repository at the following address. [http://svn.ali.as/cpan/trunk/PPI](http://svn.ali.as/cpan/trunk/PPI) Write access to the repository is made available automatically to any published CPAN author, and to most other volunteers on request. If you are able to submit your bug report in the form of new (failing) unit tests, or can apply your fix directly instead of submitting a patch, you are **strongly** encouraged to do so, as the author currently maintains over 100 modules and it can take some time to deal with non-"Critical" bug reports or patches. This will also guarantee that your issue will be addressed in the next release of the module. For large changes though, please consider creating a branch so that they can be properly reviewed and trialed before being applied to the trunk. If you cannot provide a direct test or fix, or don't have time to do so, then regular bug reports are still accepted and appreciated via the GitHub bug tracker. [https://github.com/adamkennedy/PPI/issues](https://github.com/adamkennedy/PPI/issues) For other issues or questions, contact the `Parse::Perl` project mailing list. For commercial or media-related enquiries, or to have your SVN commit bit enabled, contact the author. # AUTHOR Adam Kennedy # ACKNOWLEDGMENTS A huge thank you to Phase N Australia ([http://phase-n.com/](http://phase-n.com/)) for permitting the original open sourcing and release of this distribution from what was originally several thousand hours of commercial work. Another big thank you to The Perl Foundation ([http://www.perlfoundation.org/](http://www.perlfoundation.org/)) for funding for the final big refactoring and completion run. Also, to the various co-maintainers that have contributed both large and small with tests and patches and especially to those rare few who have deep-dived into the guts to (gasp) add a feature. - Dan Brook : PPIx::XPath, Acme::PerlML - Audrey Tang : "Line Noise" Testing - Arjen Laarhoven : Three-element ->location support - Elliot Shank : Perl 5.10 support, five-element ->location And finally, thanks to those brave ( and foolish :) ) souls willing to dive in and use, test drive and provide feedback on PPI before version 1.000, in some cases before it made it to beta quality, and still did extremely distasteful things (like eating 50 meg of RAM a second). I owe you all a beer. Corner me somewhere and collect at your convenience. If I missed someone who wasn't in my email history, thank you too :) # In approximate order of appearance - Claes Jacobsson - Michael Schwern - Jeff T. Parsons - CPAN Author "CHOCOLATEBOY" - Robert Rotherberg - CPAN Author "PODMASTER" - Richard Soderberg - Nadim ibn Hamouda el Khemir - Graciliano M. P. - Leon Brocard - Jody Belka - Curtis Ovid - Yuval Kogman - Michael Schilli - Slaven Rezic - Lars Thegler - Tony Stubblebine - Tatsuhiko Miyagawa - CPAN Author "CHROMATIC" - Matisse Enzer - Roy Fulbright - Dan Brook - Johnny Lee - Johan Lindstrom And to single one person out, thanks go to Randal Schwartz who spent a great number of hours in IRC over a critical 6 month period explaining why Perl is impossibly unparsable and constantly shoving evil and ugly corner cases in my face. He remained a tireless devil's advocate, and without his support this project genuinely could never have been completed. So for my schooling in the Deep Magiks, you have my deepest gratitude Randal. # COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. PPI-1.220/Makefile.PL0000755000175100010010000000277012430461105011033 0ustar use strict; use warnings; use inc::Module::Install 1.10; all_from 'lib/PPI.pm'; # This code is only needed by author to generate README and README.md eval { eval "use Module::Install::ReadmeFromPod 0.22"; eval "use Pod::Markdown 2.002"; my $pod = 'lib/PPI.pm'; readme_from $pod; # Module::Install::ReadmeFromPod my $parser = Pod::Markdown->new; open my $in, "<", $pod; open my $out, ">", "README.md"; if ($parser and $in and $out) { $parser->parse_from_filehandle($in); print $out $parser->as_markdown; } }; requires 'Clone' => '0.30'; requires 'File::Spec' => win32() ? '3.2701' : '0.84'; requires 'IO::String' => '1.07'; requires 'List::MoreUtils' => '0.16'; requires 'List::Util' => '1.20'; requires 'Params::Util' => '1.00'; # Modules needed for PPI::Cache requires 'Digest::MD5' => '2.35'; requires 'Storable' => '2.17'; # Test-time dependencies (bundle as many as we can) test_requires 'Class::Inspector' => '1.22'; test_requires 'File::Remove' => '1.42'; test_requires 'Test::More' => '0.86'; test_requires 'Test::NoWarnings' => '0.084'; test_requires 'Test::Object' => '0.07'; test_requires 'Test::SubCalls' => '1.07'; # Force the existence of the weaken function # (which some distributions annoyingly don't have) requires 'Task::Weaken'; homepage 'https://github.com/adamkennedy/PPI'; bugtracker 'https://github.com/adamkennedy/PPI/issues'; repository 'https://github.com/adamkennedy/PPI'; no_index 'directory' => qw{ inc t xt }; WriteAll; PPI-1.220/lib/0000755000175100010010000000000012430470371007623 5ustar PPI-1.220/lib/PPI.pm0000755000175100010010000007477612430462144010640 0ustar package PPI; # See POD at end for documentation use 5.006; use strict; # Set the version for CPAN use vars qw{$VERSION $XS_COMPATIBLE @XS_EXCLUDE}; BEGIN { $VERSION = '1.220'; $XS_COMPATIBLE = '0.845'; @XS_EXCLUDE = (); } # Load everything use PPI::Util (); use PPI::Exception (); use PPI::Element (); use PPI::Token (); use PPI::Statement (); use PPI::Structure (); use PPI::Document (); use PPI::Document::File (); use PPI::Document::Fragment (); use PPI::Document::Normalized (); use PPI::Normal (); use PPI::Tokenizer (); use PPI::Lexer (); # If it is installed, load in PPI::XS die if !$PPI::XS_DISABLE and !eval { require PPI::XS; 1 } and $@ !~ /^Can't locate .*? at /; # ignore failure to load if not installed 1; __END__ =pod =head1 NAME PPI - Parse, Analyze and Manipulate Perl (without perl) =head1 SYNOPSIS use PPI; # Create a new empty document my $Document = PPI::Document->new; # Create a document from source $Document = PPI::Document->new(\'print "Hello World!\n"'); # Load a Document from a file $Document = PPI::Document->new('Module.pm'); # Does it contain any POD? if ( $Document->find_any('PPI::Token::Pod') ) { print "Module contains POD\n"; } # Get the name of the main package $pkg = $Document->find_first('PPI::Statement::Package')->namespace; # Remove all that nasty documentation $Document->prune('PPI::Token::Pod'); $Document->prune('PPI::Token::Comment'); # Save the file $Document->save('Module.pm.stripped'); =head1 DESCRIPTION =head2 About this Document This is the PPI manual. It describes its reason for existing, its general structure, its use, an overview of the API, and provides a few implementation samples. =head2 Background The ability to read, and manipulate Perl (the language) programmatically other than with perl (the application) was one that caused difficulty for a long time. The cause of this problem was Perl's complex and dynamic grammar. Although there is typically not a huge diversity in the grammar of most Perl code, certain issues cause large problems when it comes to parsing. Indeed, quite early in Perl's history Tom Christiansen introduced the Perl community to the quote I<"Nothing but perl can parse Perl">, or as it is more often stated now as a truism: B<"Only perl can parse Perl"> One example of the sorts of things the prevent Perl being easily parsed are function signatures, as demonstrated by the following. @result = (dothis $foo, $bar); # Which of the following is it equivalent to? @result = (dothis($foo), $bar); @result = dothis($foo, $bar); The first line above can be interpreted in two different ways, depending on whether the C<&dothis> function is expecting one argument, or two, or several. A "code parser" (something that parses for the purpose of execution) such as perl needs information that is not found in the immediate vicinity of the statement being parsed. The information might not just be elsewhere in the file, it might not even be in the same file at all. It might also not be able to determine this information without the prior execution of a C block, or the loading and execution of one or more external modules. Or worse the &dothis function may not even have been written yet. B Even perl itself never really fully understands the structure of the source code after and indeed B it processes it, and in that sense doesn't "parse" Perl source into anything remotely like a structured document. This makes it of no real use for any task that needs to treat the source code as a document, and do so reliably and robustly. For more information on why it is impossible to parse perl, see Randal Schwartz's seminal response to the question of "Why can't you parse Perl". L The purpose of PPI is B to parse Perl I, but to parse Perl I. By treating the problem this way, we are able to parse a single file containing Perl source code "isolated" from any other resources, such as libraries upon which the code may depend, and without needing to run an instance of perl alongside or inside the parser. Historically, using an embedded perl parser was widely considered to be the most likely avenue for finding a solution to C. It was investigated from time to time and attempts have generally failed or suffered from sufficiently bad corner cases that they were abandoned. =head2 What Does PPI Stand For? C is an acronym for the longer original module name C. And in the spirit or the silly acronym games played by certain unnamed Open Source projects you may have I of, it also a reverse backronym of "I Parse Perl". Of course, I could just be lying and have just made that second bit up 10 minutes before the release of PPI 1.000. Besides, B the cool Perl packages have TLAs (Three Letter Acronyms). It's a rule or something. Why don't you just think of it as the B for simplicity. The original name was shortened to prevent the author (and you the users) from contracting RSI by having to type crazy things like C 100 times a day. In acknowledgment that someone may some day come up with a valid solution for the grammar problem it was decided at the commencement of the project to leave the C namespace free for any such effort. Since that time I've been able to prove to my own satisfaction that it B truly impossible to accurately parse Perl as both code and document at once. For the academics, parsing Perl suffers from the "Halting Problem". With this in mind C has now been co-opted as the title for the SourceForge project that publishes PPI and a large collection of other applications and modules related to the (document) parsing of Perl source code. You can find this project at L, however we no longer use the SourceForge CVS server. Instead, the current development version of PPI is available via SVN at L. =head2 Why Parse Perl? Once you can accept that we will never be able to parse Perl well enough to meet the standards of things that treat Perl as code, it is worth re-examining C we want to "parse" Perl at all. What are the things that people might want a "Perl parser" for. =over 4 =item Documentation Analyzing the contents of a Perl document to automatically generate documentation, in parallel to, or as a replacement for, POD documentation. Allow an indexer to locate and process all the comments and documentation from code for "full text search" applications. =item Structural and Quality Analysis Determine quality or other metrics across a body of code, and identify situations relating to particular phrases, techniques or locations. Index functions, variables and packages within Perl code, and doing search and graph (in the node/edge sense) analysis of large code bases. =item Refactoring Make structural, syntax, or other changes to code in an automated manner, either independently or in assistance to an editor. This sort of task list includes backporting, forward porting, partial evaluation, "improving" code, or whatever. All the sort of things you'd want from a L. =item Layout Change the layout of code without changing its meaning. This includes techniques such as tidying (like L), obfuscation, compressing and "squishing", or to implement formatting preferences or policies. =item Presentation This includes methods of improving the presentation of code, without changing the content of the code. Modify, improve, syntax colour etc the presentation of a Perl document. Generating "IntelliText"-like functions. =back If we treat this as a baseline for the sort of things we are going to have to build on top of Perl, then it becomes possible to identify a standard for how good a Perl parser needs to be. =head2 How good is Good Enough(TM) PPI seeks to be good enough to achieve all of the above tasks, or to provide a sufficiently good API on which to allow others to implement modules in these and related areas. However, there are going to be limits to this process. Because PPI cannot adapt to changing grammars, any code written using source filters should not be assumed to be parsable. At one extreme, this includes anything munged by L, as well as (arguably) more common cases like L. We do not pretend to be able to always parse code using these modules, although as long as it still follows a format that looks like Perl syntax, it may be possible to extend the lexer to handle them. The ability to extend PPI to handle lexical additions to the language is on the drawing board to be done some time post-1.0 The goal for success was originally to be able to successfully parse 99% of all Perl documents contained in CPAN. This means the entire file in each case. PPI has succeeded in this goal far beyond the expectations of even the author. At time of writing there are only 28 non-Acme Perl modules in CPAN that PPI is incapable of parsing. Most of these are so badly broken they do not compile as Perl code anyway. So unless you are actively going out of your way to break PPI, you should expect that it will handle your code just fine. =head2 Internationalisation PPI provides partial support for internationalisation and localisation. Specifically, it allows the use characters from the Latin-1 character set to be used in quotes, comments, and POD. Primarily, this covers languages from Europe and South America. PPI does B currently provide support for Unicode, although there is an initial implementation available in a development branch from CVS. If you need Unicode support, and would like to help stress test the Unicode support so we can move it to the main branch and enable it in the main release should contact the author. (contact details below) =head2 Round Trip Safe When PPI parses a file it builds B into the model, including whitespace. This is needed in order to make the Document fully "Round Trip" safe. The general concept behind a "Round Trip" parser is that it knows what it is parsing is somewhat uncertain, and so B to get things wrong from time to time. In the cases where it parses code wrongly the tree will serialize back out to the same string of code that was read in, repairing the parser's mistake as it heads back out to the file. The end result is that if you parse in a file and serialize it back out without changing the tree, you are guaranteed to get the same file you started with. PPI does this correctly and reliably for 100% of all known cases. B The one minor exception at this time is that if the newlines for your file are wrong (meaning not matching the platform newline format), PPI will localise them for you. (It isn't to be convenient, supporting arbitrary newlines would make some of the code more complicated) Better control of the newline type is on the wish list though, and anyone wanting to help out is encouraged to contact the author. =head1 IMPLEMENTATION =head2 General Layout PPI is built upon two primary "parsing" components, L and L, and a large tree of about 50 classes which implement the various the I (PDOM). The PDOM is conceptually similar in style and intent to the regular DOM or other code Abstract Syntax Trees (ASTs), but contains some differences to handle perl-specific cases, and to assist in treating the code as a document. Please note that it is B an implementation of the official Document Object Model specification, only somewhat similar to it. On top of the Tokenizer, Lexer and the classes of the PDOM, sit a number of classes intended to make life a little easier when dealing with PDOM trees. Both the major parsing components were hand-coded from scratch with only plain Perl code and a few small utility modules. There are no grammar or patterns mini-languages, no YACC or LEX style tools and only a small number of regular expressions. This is primarily because of the sheer volume of accumulated cruft that exists in Perl. Not even perl itself is capable of parsing Perl documents (remember, it just parses and executes it as code). As a result, PPI needed to be cruftier than perl itself. Feel free to shudder at this point, and hope you never have to understand the Tokenizer codebase. Speaking of which... =head2 The Tokenizer The Tokenizer takes source code and converts it into a series of tokens. It does this using a slow but thorough character by character manual process, rather than using a pattern system or complex regexes. Or at least it does so conceptually. If you were to actually trace the code you would find it's not truly character by character due to a number of regexps and optimisations throughout the code. This lets the Tokenizer "skip ahead" when it can find shortcuts, so it tends to jump around a line a bit wildly at times. In practice, the number of times the Tokenizer will B move the character cursor itself is only about 5% - 10% higher than the number of tokens contained in the file. This makes it about as optimal as it can be made without implementing it in something other than Perl. In 2001 when PPI was started, this structure made PPI quite slow, and not really suitable for interactive tasks. This situation has improved greatly with multi-gigahertz processors, but can still be painful when working with very large files. The target parsing rate for PPI is about 5000 lines per gigacycle. It is currently believed to be at about 1500, and main avenue for making it to the target speed has now become L, a drop-in XS accelerator for PPI. Since L has only just gotten off the ground and is currently only at proof-of-concept stage, this may take a little while. Anyone interested in helping out with L is B encouraged to contact the author. In fact, the design of L means it's possible to port one function at a time safely and reliably. So every little bit will help. =head2 The Lexer The Lexer takes a token stream, and converts it to a lexical tree. Because we are parsing Perl B this includes whitespace, comments, and all number of weird things that have no relevance when code is actually executed. An instantiated L consumes L objects and produces L objects. However you should probably never be working with the Lexer directly. You should just be able to create L objects and work with them directly. =head2 The Perl Document Object Model The PDOM is a structured collection of data classes that together provide a correct and scalable model for documents that follow the standard Perl syntax. =head2 The PDOM Class Tree The following lists all of the 67 current PDOM classes, listing with indentation based on inheritance. PPI::Element PPI::Node PPI::Document PPI::Document::Fragment PPI::Statement PPI::Statement::Package PPI::Statement::Include PPI::Statement::Sub PPI::Statement::Scheduled PPI::Statement::Compound PPI::Statement::Break PPI::Statement::Given PPI::Statement::When PPI::Statement::Data PPI::Statement::End PPI::Statement::Expression PPI::Statement::Variable PPI::Statement::Null PPI::Statement::UnmatchedBrace PPI::Statement::Unknown PPI::Structure PPI::Structure::Block PPI::Structure::Subscript PPI::Structure::Constructor PPI::Structure::Condition PPI::Structure::List PPI::Structure::For PPI::Structure::Given PPI::Structure::When PPI::Structure::Unknown PPI::Token PPI::Token::Whitespace PPI::Token::Comment PPI::Token::Pod PPI::Token::Number PPI::Token::Number::Binary PPI::Token::Number::Octal PPI::Token::Number::Hex PPI::Token::Number::Float PPI::Token::Number::Exp PPI::Token::Number::Version PPI::Token::Word PPI::Token::DashedWord PPI::Token::Symbol PPI::Token::Magic PPI::Token::ArrayIndex PPI::Token::Operator PPI::Token::Quote PPI::Token::Quote::Single PPI::Token::Quote::Double PPI::Token::Quote::Literal PPI::Token::Quote::Interpolate PPI::Token::QuoteLike PPI::Token::QuoteLike::Backtick PPI::Token::QuoteLike::Command PPI::Token::QuoteLike::Regexp PPI::Token::QuoteLike::Words PPI::Token::QuoteLike::Readline PPI::Token::Regexp PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute PPI::Token::Regexp::Transliterate PPI::Token::HereDoc PPI::Token::Cast PPI::Token::Structure PPI::Token::Label PPI::Token::Separator PPI::Token::Data PPI::Token::End PPI::Token::Prototype PPI::Token::Attribute PPI::Token::Unknown To summarize the above layout, all PDOM objects inherit from the L class. Under this are L, strings of content with a known type, and L, syntactically significant containers that hold other Elements. The three most important of these are the L, the L and the L classes. =head2 The Document, Statement and Structure At the top of all complete PDOM trees is a L object. It represents a complete file of Perl source code as you might find it on disk. There are some specialised types of document, such as L and L but for the purposes of the PDOM they are all just considered to be the same thing. Each Document will contain a number of B, B and B. A L is any series of Tokens and Structures that are treated as a single contiguous statement by perl itself. You should note that a Statement is as close as PPI can get to "parsing" the code in the sense that perl-itself parses Perl code when it is building the op-tree. Because of the isolation and Perl's syntax, it is provably impossible for PPI to accurately determine precedence of operators or which tokens are implicit arguments to a sub call. So rather than lead you on with a bad guess that has a strong chance of being wrong, PPI does not attempt to determine precedence or sub parameters at all. At a fundamental level, it only knows that this series of elements represents a single Statement as perl sees it, but it can do so with enough certainty that it can be trusted. However, for specific Statement types the PDOM is able to derive additional useful information about their meaning. For the best, most useful, and most heavily used example, see L. A L is any series of tokens contained within matching braces. This includes code blocks, conditions, function argument braces, anonymous array and hash constructors, lists, scoping braces and all other syntactic structures represented by a matching pair of braces, including (although it may not seem obvious at first) CREADLINEE> braces. Each Structure contains none, one, or many Tokens and Structures (the rules for which vary for the different Structure subclasses) Under the PDOM structure rules, a Statement can B directly contain another child Statement, a Structure can B directly contain another child Structure, and a Document can B contain another Document anywhere in the tree. Aside from these three rules, the PDOM tree is extremely flexible. =head2 The PDOM at Work To demonstrate the PDOM in use lets start with an example showing how the tree might look for the following chunk of simple Perl code. #!/usr/bin/perl print( "Hello World!" ); exit(); Translated into a PDOM tree it would have the following structure (as shown via the included L). PPI::Document PPI::Token::Comment '#!/usr/bin/perl\n' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ) PPI::Token::Whitespace ' ' PPI::Statement::Expression PPI::Token::Quote::Double '"Hello World!"' PPI::Token::Whitespace ' ' PPI::Token::Structure ';' PPI::Token::Whitespace '\n' PPI::Token::Whitespace '\n' PPI::Statement PPI::Token::Word 'exit' PPI::Structure::List ( ... ) PPI::Token::Structure ';' PPI::Token::Whitespace '\n' Please note that in this example, strings are only listed for the B L that contains that string. Structures are listed with the type of brace characters it represents noted. The L module can be used to generate similar trees yourself. We can make that PDOM dump a little easier to read if we strip out all the whitespace. Here it is again, sans the distracting whitespace tokens. PPI::Document PPI::Token::Comment '#!/usr/bin/perl\n' PPI::Statement PPI::Token::Word 'print' PPI::Structure::List ( ... ) PPI::Statement::Expression PPI::Token::Quote::Double '"Hello World!"' PPI::Token::Structure ';' PPI::Statement PPI::Token::Word 'exit' PPI::Structure::List ( ... ) PPI::Token::Structure ';' As you can see, the tree can get fairly deep at time, especially when every isolated token in a bracket becomes its own statement. This is needed to allow anything inside the tree the ability to grow. It also makes the search and analysis algorithms much more flexible. Because of the depth and complexity of PDOM trees, a vast number of very easy to use methods have been added wherever possible to help people working with PDOM trees do normal tasks relatively quickly and efficiently. =head2 Overview of the Primary Classes The main PPI classes, and links to their own documentation, are listed here in alphabetical order. =over 4 =item L The Document object, the root of the PDOM. =item L A cohesive fragment of a larger Document. Although not of any real current use, it is needed for use in certain internal tree manipulation algorithms. For example, doing things like cut/copy/paste etc. Very similar to a L, but has some additional methods and does not represent a lexical scope boundary. A document fragment is also non-serializable, and so cannot be written out to a file. =item L A simple class for dumping readable debugging versions of PDOM structures, such as in the demonstration above. =item L The Element class is the abstract base class for all objects within the PDOM =item L Implements an instantiable object form of a PDOM tree search. =item L The PPI Lexer. Converts Token streams into PDOM trees. =item L The Node object, the abstract base class for all PDOM objects that can contain other Elements, such as the Document, Statement and Structure objects. =item L The base class for all Perl statements. Generic "evaluate for side-effects" statements are of this actual type. Other more interesting statement types belong to one of its children. See it's own documentation for a longer description and list of all of the different statement types and sub-classes. =item L The abstract base class for all structures. A Structure is a language construct consisting of matching braces containing a set of other elements. See the L documentation for a description and list of all of the different structure types and sub-classes. =item L A token is the basic unit of content. At its most basic, a Token is just a string tagged with metadata (its class, and some additional flags in some cases). =item L The L and L classes provide abstract base classes for the many and varied types of quote and quote-like things in Perl. However, much of the actual quote login is implemented in a separate quote engine, based at L. Classes that inherit from L, L and L are generally parsed only by the Quote Engine. =item L The PPI Tokenizer. One Tokenizer consumes a chunk of text and provides access to a stream of L objects. The Tokenizer is very very complicated, to the point where even the author treads carefully when working with it. Most of the complication is the result of optimizations which have tripled the tokenization speed, at the expense of maintainability. We cope with the spaghetti by heavily commenting everything. =item L The Perl Document Transformation API. Provides a standard interface and abstract base class for objects and classes that manipulate Documents. =back =head1 INSTALLING The core PPI distribution is pure Perl and has been kept as tight as possible and with as few dependencies as possible. It should download and install normally on any platform from within the CPAN and CPANPLUS applications, or directly using the distribution tarball. If installing by hand, you may need to install a few small utility modules first. The exact ones will depend on your version of perl. There are no special install instructions for PPI, and the normal C, C, C, C instructions apply. =head1 EXTENDING The PPI namespace itself is reserved for the sole use of the modules under the umbrella of the C SourceForge project. L You are recommended to use the PPIx:: namespace for PPI-specific modifications or prototypes thereof, or Perl:: for modules which provide a general Perl language-related functions. If what you wish to implement looks like it fits into PPIx:: namespace, you should consider contacting the C mailing list (detailed on the SourceForge site) first, as what you want may already be in progress, or you may wish to consider joining the team and doing it within the C project itself. =head1 TO DO - Many more analysis and utility methods for PDOM classes - Creation of a PPI::Tutorial document - Add many more key functions to PPI::XS - We can B write more and better unit tests - Complete the full implementation of -Eliteral (1.200) - Full understanding of scoping (due 1.300) =head1 SUPPORT This module is stored in an Open Repository at the following address. L Write access to the repository is made available automatically to any published CPAN author, and to most other volunteers on request. If you are able to submit your bug report in the form of new (failing) unit tests, or can apply your fix directly instead of submitting a patch, you are B encouraged to do so, as the author currently maintains over 100 modules and it can take some time to deal with non-"Critical" bug reports or patches. This will also guarantee that your issue will be addressed in the next release of the module. For large changes though, please consider creating a branch so that they can be properly reviewed and trialed before being applied to the trunk. If you cannot provide a direct test or fix, or don't have time to do so, then regular bug reports are still accepted and appreciated via the GitHub bug tracker. L For other issues or questions, contact the C project mailing list. For commercial or media-related enquiries, or to have your SVN commit bit enabled, contact the author. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 ACKNOWLEDGMENTS A huge thank you to Phase N Australia (L) for permitting the original open sourcing and release of this distribution from what was originally several thousand hours of commercial work. Another big thank you to The Perl Foundation (L) for funding for the final big refactoring and completion run. Also, to the various co-maintainers that have contributed both large and small with tests and patches and especially to those rare few who have deep-dived into the guts to (gasp) add a feature. - Dan Brook : PPIx::XPath, Acme::PerlML - Audrey Tang : "Line Noise" Testing - Arjen Laarhoven : Three-element ->location support - Elliot Shank : Perl 5.10 support, five-element ->location And finally, thanks to those brave ( and foolish :) ) souls willing to dive in and use, test drive and provide feedback on PPI before version 1.000, in some cases before it made it to beta quality, and still did extremely distasteful things (like eating 50 meg of RAM a second). I owe you all a beer. Corner me somewhere and collect at your convenience. If I missed someone who wasn't in my email history, thank you too :) # In approximate order of appearance - Claes Jacobsson - Michael Schwern - Jeff T. Parsons - CPAN Author "CHOCOLATEBOY" - Robert Rotherberg - CPAN Author "PODMASTER" - Richard Soderberg - Nadim ibn Hamouda el Khemir - Graciliano M. P. - Leon Brocard - Jody Belka - Curtis Ovid - Yuval Kogman - Michael Schilli - Slaven Rezic - Lars Thegler - Tony Stubblebine - Tatsuhiko Miyagawa - CPAN Author "CHROMATIC" - Matisse Enzer - Roy Fulbright - Dan Brook - Johnny Lee - Johan Lindstrom And to single one person out, thanks go to Randal Schwartz who spent a great number of hours in IRC over a critical 6 month period explaining why Perl is impossibly unparsable and constantly shoving evil and ugly corner cases in my face. He remained a tireless devil's advocate, and without his support this project genuinely could never have been completed. So for my schooling in the Deep Magiks, you have my deepest gratitude Randal. =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/0000755000175100010010000000000012430470371010253 5ustar PPI-1.220/lib/PPI/Cache.pm0000755000175100010010000001422212430462144011617 0ustar package PPI::Cache; =pod =head1 NAME PPI::Cache - The PPI Document Caching Layer =head1 SYNOPSIS # Set the cache use PPI::Cache path => '/var/cache/ppi-cache'; # Manually create a cache my $Cache = PPI::Cache->new( path => '/var/cache/perl/class-PPI', readonly => 1, ); =head1 DESCRIPTION C provides the default caching functionality for L. It integrates automatically with L itself. Once enabled, any attempt to load a document from the filesystem will be cached via cache. Please note that creating a L from raw source or something other object will B be cached. =head2 Using PPI::Cache The most common way of using C is to provide parameters to the C statement at the beginning of your program. # Load the class but do not set a cache use PPI::Cache; # Use a fairly normal cache location use PPI::Cache path => '/var/cache/ppi-cache'; Any of the arguments that can be provided to the C constructor can also be provided to C. =head1 METHODS =cut use strict; use Carp (); use File::Spec (); use File::Path (); use Storable (); use Digest::MD5 (); use Params::Util qw{_INSTANCE _SCALAR}; use PPI::Document (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } use constant VMS => !! ( $^O eq 'VMS' ); sub import { my $class = ref $_[0] ? ref shift : shift; return 1 unless @_; # Create a cache from the params provided my $cache = $class->new(@_); # Make PPI::Document use it unless ( PPI::Document->set_cache( $cache ) ) { Carp::croak("Failed to set cache in PPI::Document"); } 1; } ##################################################################### # Constructor and Accessors =pod =head2 new param => $value, ... The C constructor creates a new standalone cache object. It takes a number of parameters to control the cache. =over =item path The C param sets the base directory for the cache. It must already exist, and must be writable. =item readonly The C param is a true/false flag that allows the use of an existing cache by a less-privileged user (such as the web user). Existing documents will be retrieved from the cache, but new documents will not be written to it. =back Returns a new C object, or dies on error. =cut sub new { my $class = shift; my %params = @_; # Path should exist and be usable my $path = $params{path} or Carp::croak("Cannot create PPI::Cache, no path provided"); unless ( -d $path ) { Carp::croak("Cannot create PPI::Cache, path does not exist"); } unless ( -r $path and -x $path ) { Carp::croak("Cannot create PPI::Cache, no read permissions for path"); } if ( ! $params{readonly} and ! -w $path ) { Carp::croak("Cannot create PPI::Cache, no write permissions for path"); } # Create the basic object my $self = bless { path => $path, readonly => !! $params{readonly}, }, $class; $self; } =pod =head2 path The C accessor returns the path on the local filesystem that is the root of the cache. =cut sub path { $_[0]->{path} } =pod =head2 readonly The C accessor returns true if documents should not be written to the cache. =cut sub readonly { $_[0]->{readonly} } ##################################################################### # PPI::Cache Methods =pod =head2 get_document $md5sum | \$source The C method checks to see if a Document is stored in the cache and retrieves it if so. =cut sub get_document { my $self = ref $_[0] ? shift : Carp::croak('PPI::Cache::get_document called as static method'); my $md5hex = $self->_md5hex(shift) or return undef; $self->_load($md5hex); } =pod =head2 store_document $Document The C method takes a L as argument and explicitly adds it to the cache. Returns true if saved, or C (or dies) on error. FIXME (make this return either one or the other, not both) =cut sub store_document { my $self = shift; my $Document = _INSTANCE(shift, 'PPI::Document') or return undef; # Shortcut if we are readonly return 1 if $self->readonly; # Find the filename to save to my $md5hex = $Document->hex_id or return undef; # Store the file $self->_store( $md5hex, $Document ); } ##################################################################### # Support Methods # Store an arbitrary PPI::Document object (using Storable) to a particular # path within the cache filesystem. sub _store { my ($self, $md5hex, $object) = @_; my ($dir, $file) = $self->_paths($md5hex); # Save the file File::Path::mkpath( $dir, 0, 0755 ) unless -d $dir; if ( VMS ) { Storable::lock_nstore( $object, $file ); } else { Storable::nstore( $object, $file ); } } # Load an arbitrary object (using Storable) from a particular # path within the cache filesystem. sub _load { my ($self, $md5hex) = @_; my (undef, $file) = $self->_paths($md5hex); # Load the file return '' unless -f $file; my $object = VMS ? Storable::retrieve( $file ) : Storable::lock_retrieve( $file ); # Security check unless ( _INSTANCE($object, 'PPI::Document') ) { Carp::croak("Security Violation: Object in '$file' is not a PPI::Document"); } $object; } # Convert a md5 to a dir and file name sub _paths { my $self = shift; my $md5hex = lc shift; my $dir = File::Spec->catdir( $self->path, substr($md5hex, 0, 1), substr($md5hex, 0, 2) ); my $file = File::Spec->catfile( $dir, $md5hex . '.ppi' ); return ($dir, $file); } # Check a md5hex param sub _md5hex { my $either = shift; my $it = _SCALAR($_[0]) ? PPI::Util::md5hex(${$_[0]}) : $_[0]; return (defined $it and ! ref $it and $it =~ /^[a-f0-9]{32}\z/si) ? lc $it : undef; } 1; =pod =head1 TO DO - Finish the basic functionality - Add support for use PPI::Cache auto-setting $PPI::Document::CACHE =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/0000755000175100010010000000000012430470371012217 5ustar PPI-1.220/lib/PPI/Statement/Break.pm0000755000175100010010000000264412430462144013611 0ustar package PPI::Statement::Break; =pod =head1 NAME PPI::Statement::Break - Statements which break out of normal statement flow =head1 SYNOPSIS last; goto FOO; next if condition(); return $foo; redo; =head1 INHERITANCE PPI::Statement::Break isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C is intended to represent statements that break out of the normal statement flow control. This covers the basic types C<'redo'>, C<'goto'>, C<'next'>, C<'last'> and C<'return'>. =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. However, it is expected to gain methods for identifying the line to break to, or the structure to break out of. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } 1; =pod =head1 TO DO - Add the methods to identify the break target - Add some proper unit testing =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Unknown.pm0000755000175100010010000000276312430462144014226 0ustar package PPI::Statement::Unknown; =pod =head1 NAME PPI::Statement::Unknown - An unknown or transient statement =head1 INHERITANCE PPI::Statement::Unknown isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION The C class is used primarily during the lexing process to hold elements that are known to be statement, but for which the exact C of statement is as yet unknown, and requires further tokens in order to resolve the correct type. They should not exist in a fully parse B document, and if any exists they indicate either a problem in Document, or possibly (by allowing it to get through unresolved) a bug in L. =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # If one of these ends up in the final document, # we're pretty much screwed. Just call it a day. sub _complete () { 1 } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/UnmatchedBrace.pm0000755000175100010010000000331612430462144015427 0ustar package PPI::Statement::UnmatchedBrace; =pod =head1 NAME PPI::Statement::UnmatchedBrace - Isolated unmatched brace =head1 SYNOPSIS sub foo { 1; } } # <--- This is an unmatched brace =head1 INHERITANCE PPI::Statement::UnmatchedBrace isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION The C class is a miscellaneous utility class. Objects of this type should be rare, or not exist at all in normal valid L objects. It can be either a round ')', square ']' or curly '}' brace, this class does not distinguish. Objects of this type are only allocated at a structural level, not a lexical level (as they are lexically invalid anyway). The presence of a C indicated a broken or invalid document. Or maybe a bug in PPI, but B more likely a broken Document. :) =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # Once we've hit a naked unmatched brace we can never truly be complete. # So instead we always just call it a day... sub _complete () { 1 } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Package.pm0000755000175100010010000000573012430462144014117 0ustar package PPI::Statement::Package; =pod =head1 NAME PPI::Statement::Package - A package statement =head1 INHERITANCE PPI::Statement::Package isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION Most L subclasses are assigned based on the value of the first token or word found in the statement. When PPI encounters a statement starting with 'package', it converts it to a C object. When working with package statements, please remember that packages only exist within their scope, and proper support for scoping has yet to be completed in PPI. However, if the immediate parent of the package statement is the top level L object, then it can be considered to define everything found until the next top-level "file scoped" package statement. A file may, however, contain nested temporary package, in which case you are mostly on your own :) =head1 METHODS C has a number of methods in addition to the standard L, L and L methods. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } =pod =head2 namespace Most package declarations are simple, and just look something like package Foo::Bar; The C method returns the name of the declared package, in the above case 'Foo::Bar'. It returns this exactly as written and does not attempt to clean up or resolve things like ::Foo to main::Foo. If the package statement is done any different way, it returns false. =cut sub namespace { my $self = shift; my $namespace = $self->schild(1) or return ''; $namespace->isa('PPI::Token::Word') ? $namespace->content : ''; } =pod =head2 file_scoped Regardless of whether it is named or not, the C method will test to see if the package declaration is a top level "file scoped" statement or not, based on its location. In general, returns true if it is a "file scoped" package declaration with an immediate parent of the top level Document, or false if not. Note that if the PPI DOM tree B have a PPI::Document object at as the root element, this will return false. Likewise, it will also return false if the root element is a L, as a fragment of a file does not represent a scope. =cut sub file_scoped { my $self = shift; my ($Parent, $Document) = ($self->parent, $self->top); $Parent and $Document and $Parent == $Document and $Document->isa('PPI::Document') and ! $Document->isa('PPI::Document::Fragment'); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Sub.pm0000755000175100010010000001020312430462144013304 0ustar package PPI::Statement::Sub; =pod =head1 NAME PPI::Statement::Sub - Subroutine declaration =head1 INHERITANCE PPI::Statement::Sub isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION Except for the special BEGIN, CHECK, UNITCHECK, INIT, and END subroutines (which are part of L) all subroutine declarations are lexed as a PPI::Statement::Sub object. Primarily, this means all of the various C statements, but also forward declarations such as C or C. It B include anonymous subroutines, as these are merely part of a normal statement. =head1 METHODS C has a number of methods in addition to the standard L, L and L methods. =cut use strict; use List::Util (); use Params::Util qw{_INSTANCE}; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # Lexer clue sub __LEXER__normal() { '' } sub _complete { my $child = $_[0]->schild(-1); return !! ( defined $child and $child->isa('PPI::Structure::Block') and $child->complete ); } ##################################################################### # PPI::Statement::Sub Methods =pod =head2 name The C method returns the name of the subroutine being declared. In some rare cases such as a naked C at the end of the file, this may return false. =cut sub name { my ($self) = @_; # Usually the second token is the name. my $token = $self->schild(1); return $token->content if defined $token and $token->isa('PPI::Token::Word'); # In the case of special subs whose 'sub' can be omitted (AUTOLOAD # or DESTROY), the name will be the first token. $token = $self->schild(0); return $token->content if defined $token and $token->isa('PPI::Token::Word'); return ''; } =pod =head2 prototype If it has one, the C method returns the subroutine's prototype. It is returned in the same format as L, cleaned and removed from its brackets. Returns the subroutine's prototype, or undef if the subroutine does not define one. Note that when the sub has an empty prototype (C<()>) the return is an empty string. =cut sub prototype { my $self = shift; my $Prototype = List::Util::first { _INSTANCE($_, 'PPI::Token::Prototype') } $self->children; defined($Prototype) ? $Prototype->prototype : undef; } =pod =head2 block With its name and implementation shared with L, the C method finds and returns the actual Structure object of the code block for this subroutine. Returns false if this is a forward declaration, or otherwise does not have a code block. =cut sub block { my $self = shift; my $lastchild = $self->schild(-1) or return ''; $lastchild->isa('PPI::Structure::Block') and $lastchild; } =pod =head2 forward The C method returns true if the subroutine declaration is a forward declaration. That is, it returns false if the subroutine has a code block, or true if it does not. =cut sub forward { ! shift->block; } =pod =head2 reserved The C method provides a convenience method for checking to see if this is a special reserved subroutine. It does not check against any particular list of reserved sub names, but just returns true if the name is all uppercase, as defined in L. Note that in the case of BEGIN, CHECK, UNITCHECK, INIT and END, these will be defined as L objects, not subroutines. Returns true if it is a special reserved subroutine, or false if not. =cut sub reserved { my $self = shift; my $name = $self->name or return ''; $name eq uc $name; } 1; =pod =head1 TO DO - Write unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Variable.pm0000755000175100010010000001017012430462144014303 0ustar package PPI::Statement::Variable; =pod =head1 NAME PPI::Statement::Variable - Variable declaration statements =head1 SYNOPSIS # All of the following are variable declarations my $foo = 1; my ($foo, $bar) = (1, 2); our $foo = 1; local $foo; local $foo = 1; LABEL: my $foo = 1; =head1 INHERITANCE PPI::Statement::Variable isa PPI::Statement::Expression isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION The main intent of the C class is to describe simple statements that explicitly declare new local or global variables. Note that this does not make it exclusively the only place where variables are defined, and later on you should expect that the C method will migrate deeper down the tree to either L or L to recognise this fact, but for now it stays here. =head1 METHODS =cut use strict; use Params::Util qw{_INSTANCE}; use PPI::Statement::Expression (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement::Expression'; } =pod =head2 type The C method checks and returns the declaration type of the statement, which will be one of 'my', 'local', 'our', or 'state'. Returns a string of the type, or C if the type cannot be detected (which is probably a bug). =cut sub type { my $self = shift; # Get the first significant child my @schild = grep { $_->significant } $self->children; # Ignore labels shift @schild if _INSTANCE($schild[0], 'PPI::Token::Label'); # Get the type (_INSTANCE($schild[0], 'PPI::Token::Word') and $schild[0]->content =~ /^(my|local|our|state)$/) ? $schild[0]->content : undef; } =pod =head2 variables As for several other PDOM Element types that can declare variables, the C method returns a list of the canonical forms of the variables defined by the statement. Returns a list of the canonical string forms of variables, or the null list if it is unable to find any variables. =cut sub variables { map { $_->canonical } $_[0]->symbols; } =pod =head2 symbols Returns a list of the variables defined by the statement, as Ls. =cut sub symbols { my $self = shift; # Get the children we care about my @schild = grep { $_->significant } $self->children; shift @schild if _INSTANCE($schild[0], 'PPI::Token::Label'); # If the second child is a symbol, return its name if ( _INSTANCE($schild[1], 'PPI::Token::Symbol') ) { return $schild[1]; } # If it's a list, return as a list if ( _INSTANCE($schild[1], 'PPI::Structure::List') ) { my $Expression = $schild[1]->schild(0); $Expression and $Expression->isa('PPI::Statement::Expression') or return (); # my and our are simpler than local if ( $self->type eq 'my' or $self->type eq 'our' or $self->type eq 'state' ) { return grep { $_->isa('PPI::Token::Symbol') } $Expression->schildren; } # Local is much more icky (potentially). # Not that we are actually going to deal with it now, # but having this separate is likely going to be needed # for future bug reports about local() things. # This is a slightly better way to check. return grep { $self->_local_variable($_) } grep { $_->isa('PPI::Token::Symbol') } $Expression->schildren; } # erm... this is unexpected (); } sub _local_variable { my ($self, $el) = @_; # The last symbol should be a variable my $n = $el->snext_sibling or return 1; my $p = $el->sprevious_sibling; if ( ! $p or $p eq ',' ) { # In the middle of a list return 1 if $n eq ','; # The first half of an assignment return 1 if $n eq '='; } # Lets say no for know... additional work # should go here. return ''; } 1; =pod =head1 TO DO - Write unit tests for this =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Compound.pm0000755000175100010010000001073712430462144014353 0ustar package PPI::Statement::Compound; =pod =head1 NAME PPI::Statement::Compound - Describes all compound statements =head1 SYNOPSIS # A compound if statement if ( foo ) { bar(); } else { baz(); } # A compound loop statement foreach ( @list ) { bar($_); } =head1 INHERITANCE PPI::Statement::Compound isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C objects are used to describe all current forms of compound statements, as described in L. This covers blocks using C, C, C, C, C, and C. Please note this does B cover "simple" statements with trailing conditions. Please note also that "do" is also not part of a compound statement. # This is NOT a compound statement my $foo = 1 if $condition; # This is also not a compound statement do { ... } until $condition; =head1 METHODS C has a number of methods in addition to the standard L, L and L methods. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA %TYPES}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; # Keyword type map %TYPES = ( 'if' => 'if', 'unless' => 'if', 'while' => 'while', 'until' => 'while', 'for' => 'for', 'foreach' => 'foreach', ); } # Lexer clues sub __LEXER__normal() { '' } ##################################################################### # PPI::Statement::Compound analysis methods =pod =head2 type The C method returns the syntactic type of the compound statement. There are four basic compound statement types. The C<'if'> type includes all variations of the if and unless statements, including any C<'elsif'> or C<'else'> parts of the compound statement. The C<'while'> type describes the standard while and until statements, but again does B describes simple statements with a trailing while. The C<'for'> type covers the C-style for loops, regardless of whether they were declared using C<'for'> or C<'foreach'>. The C<'foreach'> type covers loops that iterate over collections, regardless of whether they were declared using C<'for'> or C<'foreach'>. All of the compounds are a variation on one of these four. Returns the simple string C<'if'>, C<'for'>, C<'foreach'> or C<'while'>, or C if the type cannot be determined. =cut sub type { my $self = shift; my $p = 0; # Child position my $Element = $self->schild($p) or return undef; # A labelled statement if ( $Element->isa('PPI::Token::Label') ) { $Element = $self->schild(++$p) or return 'label'; } # Most simple cases my $content = $Element->content; if ( $content =~ /^for(?:each)?\z/ ) { $Element = $self->schild(++$p) or return $content; if ( $Element->isa('PPI::Token') ) { return 'foreach' if $Element->content =~ /^my|our|state\z/; return 'foreach' if $Element->isa('PPI::Token::Symbol'); return 'foreach' if $Element->isa('PPI::Token::QuoteLike::Words'); } if ( $Element->isa('PPI::Structure::List') ) { return 'foreach'; } return 'for'; } return $TYPES{$content} if $Element->isa('PPI::Token::Word'); return 'continue' if $Element->isa('PPI::Structure::Block'); # Unknown (shouldn't exist?) undef; } ##################################################################### # PPI::Node Methods sub scope() { 1 } ##################################################################### # PPI::Element Methods sub _complete { my $self = shift; my $type = $self->type or die "Illegal compound statement type"; # Check the different types of compound statements if ( $type eq 'if' ) { # Unless the last significant child is a complete # block, it must be incomplete. my $child = $self->schild(-1) or return ''; $child->isa('PPI::Structure') or return ''; $child->braces eq '{}' or return ''; $child->_complete or return ''; # It can STILL be } elsif ( $type eq 'while' ) { die "CODE INCOMPLETE"; } else { die "CODE INCOMPLETE"; } } 1; =pod =head1 TO DO - Write unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/When.pm0000755000175100010010000000306512430462144013464 0ustar package PPI::Statement::When; =pod =head1 NAME PPI::Statement::When - A when statement =head1 SYNOPSIS foreach ( qw/ foo bar baz / ) { when ( m/b/ ) { boing($_); } when ( m/f/ ) { boom($_); } default { tchak($_); } } =head1 INHERITANCE PPI::Statement::When isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C objects are used to describe when and default statements, as described in L. =head1 METHODS C has no methods beyond those provided by the standard L, L and L methods. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # Lexer clues sub __LEXER__normal() { '' } sub _complete { my $child = $_[0]->schild(-1); return !! ( defined $child and $child->isa('PPI::Structure::Block') and $child->complete ); } ##################################################################### # PPI::Node Methods sub scope() { 1; } 1; =pod =head1 TO DO - Write unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Null.pm0000755000175100010010000000267412430462144013502 0ustar package PPI::Statement::Null; =pod =head1 NAME PPI::Statement::Null - A useless null statement =head1 SYNOPSIS my $foo = 1; ; # <-- Null statement my $bar = 1; =head1 INHERITANCE PPI::Statement::Null isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C is a utility class designed to handle situations where PPI encounters a naked statement separator. Although strictly speaking, the semicolon is a statement B and not a statement B, PPI considers a semicolon to be a statement terminator under most circumstances. In any case, the null statement has no purpose, and can be safely deleted with no ill effect. =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # A null statement is not significant sub significant() { '' } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/End.pm0000755000175100010010000000267412430462144013276 0ustar package PPI::Statement::End; =pod =head1 NAME PPI::Statement::End - Content after the __END__ of a module =head1 SYNOPSIS # This is normal content __END__ This is part of an PPI::Statement::End statement =pod This is not part of the ::End statement, it's POD =cut This is another PPI::Statement::End statement =head1 INHERITANCE PPI::Statement::End isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C is a utility class designed to serve as a contained for all of the content after the __END__ tag in a file. It doesn't cover the ENTIRE of the __END__ section, and can be interspersed with L tokens. =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # Once we have an __END__ we're done sub _complete () { 1 } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Given.pm0000755000175100010010000000264012430462144013631 0ustar package PPI::Statement::Given; =pod =head1 NAME PPI::Statement::Given - A given-when statement =head1 SYNOPSIS given ( foo ) { say $_; } =head1 INHERITANCE PPI::Statement::Given isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C objects are used to describe switch statements, as described in L. =head1 METHODS C has no methods beyond those provided by the standard L, L and L methods. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # Lexer clues sub __LEXER__normal() { '' } sub _complete { my $child = $_[0]->schild(-1); return !! ( defined $child and $child->isa('PPI::Structure::Block') and $child->complete ); } ##################################################################### # PPI::Node Methods sub scope() { 1 } 1; =pod =head1 TO DO - Write unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Data.pm0000755000175100010010000000274212430462144013435 0ustar package PPI::Statement::Data; =pod =head1 NAME PPI::Statement::Data - The __DATA__ section of a file =head1 SYNOPSIS # Normal content __DATA__ This: data is: part of: the PPI::Statement::Data: object =head1 INHERITANCE PPI::Statement::Compound isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION C is a utility class designed to hold content in the __DATA__ section of a file. It provides a single statement to hold B of the data. =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. However, it is expected to gain methods for accessing the data directly, (as a filehandle for example) just as you would access the data in the Perl code itself. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } # Data is never complete sub _complete () { '' } 1; =pod =head1 TO DO - Add the methods to read in the data - Add some proper unit testing =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Expression.pm0000755000175100010010000000241012430462144014713 0ustar package PPI::Statement::Expression; =pod =head1 NAME PPI::Statement::Expression - A generic and non-specialised statement =head1 SYNOPSIS $foo = bar; ("Hello World!"); do_this(); =head1 INHERITANCE PPI::Statement::Expression isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION A C is a normal statement that is evaluated, may or may not assign, may or may not have side effects, and has no special or redeeming features whatsoever. It provides a default for all statements that don't fit into any other classes. =head1 METHODS C has no additional methods beyond the default ones provided by L, L and L. =cut use strict; use PPI::Statement (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Include.pm0000755000175100010010000001342512430462144014147 0ustar package PPI::Statement::Include; =pod =head1 NAME PPI::Statement::Include - Statements that include other code =head1 SYNOPSIS # The following are all includes use 5.006; use strict; use My::Module; use constant FOO => 'Foo'; require Foo::Bar; require "Foo/Bar.pm"; require $foo if 1; no strict 'refs'; =head1 INHERITANCE PPI::Statement::Include isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION Despite its name, the C class covers a number of different types of statement that cover all statements starting with C, C and C. But basically, they cover three situations. Firstly, a dependency on a particular version of perl (for which the C method returns true), a pragma (for which the C method returns true), or the loading (and unloading via no) of modules. =head1 METHODS C has a number of methods in addition to the standard L, L and L methods. =cut use strict; use PPI::Statement (); use PPI::Statement::Include::Perl6 (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement'; } =pod =head2 type The C method returns the general type of statement (C<'use'>, C<'no'> or C<'require'>). Returns the type as a string, or C if the type cannot be detected. =cut sub type { my $self = shift; my $keyword = $self->schild(0) or return undef; $keyword->isa('PPI::Token::Word') and $keyword->content; } =pod =head2 module The C method returns the module name specified in any include statement. This C pragma names, because pragma are implemented as modules. (And lets face it, the definition of a pragma can be fuzzy at the best of times in any case) This covers all of these... use strict; use My::Module; no strict; require My::Module; ...but does not cover any of these... use 5.006; require 5.005; require "explicit/file/name.pl"; Returns the module name as a string, or C if the include does not specify a module name. =cut sub module { my $self = shift; my $module = $self->schild(1) or return undef; $module->isa('PPI::Token::Word') and $module->content; } =pod =head2 module_version The C method returns the minimum version of the module required by the statement, if there is one. =cut sub module_version { my $self = shift; my $argument = $self->schild(3); if ( $argument and $argument->isa('PPI::Token::Operator') ) { return undef; } my $version = $self->schild(2) or return undef; return undef unless $version->isa('PPI::Token::Number'); return $version; } =pod =head2 pragma The C method checks for an include statement's use as a pragma, and returns it if so. Or at least, it claims to. In practice it's a lot harder to say exactly what is or isn't a pragma, because the definition is fuzzy. The C of a pragma is to modify the way in which the parser works. This is done though the use of modules that do various types of internals magic. For now, PPI assumes that any "module name" that is only a set of lowercase letters (and perhaps numbers, like C). This behaviour is expected to change, most likely to something that knows the specific names of the various "pragmas". Returns the name of the pragma, or false ('') if the include is not a pragma. =cut sub pragma { my $self = shift; my $module = $self->module or return ''; $module =~ /^[a-z][a-z\d]*$/ ? $module : ''; } =pod =head2 version The C method checks for an include statement that introduces a dependency on the version of C the code is compatible with. This covers two specific statements. use 5.006; require 5.006; Currently the version is returned as a string, although in future the version may be returned as a L object. If you want a numeric representation, use C. Returns false if the statement is not a version dependency. =cut sub version { my $self = shift; my $version = $self->schild(1) or return undef; $version->isa('PPI::Token::Number') ? $version->content : ''; } =pod =head2 version_literal The C method has the same behavior as C, but the version is returned as a numeric literal. Returns false if the statement is not a version dependency. =cut sub version_literal { my $self = shift; my $version = $self->schild(1) or return undef; $version->isa('PPI::Token::Number') ? $version->literal : ''; } =pod =head2 arguments The C method gives you the rest of the statement after the module/pragma and module version, i.e. the stuff that will be used to construct what gets passed to the module's C subroutine. This does include the comma, etc. operators, but doesn't include non-significant direct children or any final semicolon. =cut sub arguments { my $self = shift; my @args = $self->schildren; # Remove the "use", "no" or "require" shift @args; # Remove the statement terminator if ( $args[-1]->isa('PPI::Token::Structure') and $args[-1]->content eq ';' ) { pop @args; } # Remove the module or perl version. shift @args; return unless @args; if ( $args[0]->isa('PPI::Token::Number') ) { my $after = $args[1] or return; $after->isa('PPI::Token::Operator') or shift @args; } return @args; } 1; =pod =head1 TO DO - Write specific unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Scheduled.pm0000755000175100010010000000412312430462144014457 0ustar package PPI::Statement::Scheduled; =pod =head1 NAME PPI::Statement::Scheduled - A scheduled code block =head1 INHERITANCE PPI::Statement::Scheduled isa PPI::Statement::Sub isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION A scheduled code block is one that is intended to be run at a specific time during the loading process. There are five types of scheduled block: BEGIN { # Executes as soon as this block is fully defined ... } CHECK { # Executes after overall compile-phase in reverse order ... } UNITCHECK { # Executes after compile-phase of individual module in reverse order ... } INIT { # Executes just before run-time ... } END { # Executes as late as possible in reverse order ... } Technically these scheduled blocks are actually subroutines, and in fact may have 'sub' in front of them. =head1 METHODS =cut use strict; use PPI::Statement::Sub (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement::Sub'; } sub __LEXER__normal() { '' } sub _complete { my $child = $_[0]->schild(-1); return !! ( defined $child and $child->isa('PPI::Structure::Block') and $child->complete ); } =pod =head2 type The C method returns the type of scheduled block, which should always be one of C<'BEGIN'>, C<'CHECK'>, C<'UNITCHECK'>, C<'INIT'> or C<'END'>. =cut sub type { my $self = shift; my @children = $self->schildren or return undef; $children[0]->content eq 'sub' ? $children[1]->content : $children[0]->content; } # This is actually the same as Sub->name sub name { shift->type(@_); } 1; =pod =head1 TO DO - Write unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement/Include/0000755000175100010010000000000012430470371013602 5ustar PPI-1.220/lib/PPI/Statement/Include/Perl6.pm0000755000175100010010000000321312430462144015131 0ustar package PPI::Statement::Include::Perl6; =pod =head1 NAME PPI::Statement::Include::Perl6 - Inline Perl 6 file section =head1 SYNOPSIS use v6-alpha; grammar My::Grammar { ... } =head1 INHERITANCE PPI::Statement::Include::Perl6 isa PPI::Statement::Include isa PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION A C is a special include statement that indicates the start of a section of Perl 6 code inlined into a regular Perl 5 code file. The primary purpose of the class is to allow L to provide at least basic support for "6 in 5" modules like v6.pm; Currently, PPI only supports starting a Perl 6 block. It does not currently support changing back to Perl 5 again. Additionally all POD and __DATA__ blocks and __END__ blocks will be included in the Perl 6 string and will not be parsed by PPI. =cut use strict; use PPI::Statement::Include (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Statement::Include'; } =pod =head2 perl6 The C method returns the block of Perl 6 code that is attached to the "use v6...;" command. =cut sub perl6 { $_[0]->{perl6}; } 1; =pod =head1 TO DO - Write specific unit tests for this package =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Util.pm0000755000175100010010000000375512430462144011542 0ustar package PPI::Util; # Provides some common utility functions that can be imported use strict; use Exporter (); use Digest::MD5 (); use Params::Util qw{_INSTANCE _SCALAR0 _ARRAY0}; use vars qw{$VERSION @ISA @EXPORT_OK}; BEGIN { $VERSION = '1.220'; @ISA = 'Exporter'; @EXPORT_OK = qw{_Document _slurp}; } # Alarms are used to catch unexpectedly slow and complex documents use constant HAVE_ALARM => ! ( $^O eq 'MSWin32' or $^O eq 'cygwin' ); # 5.8.7 was the first version to resolve the notorious # "unicode length caching" bug. use constant HAVE_UNICODE => !! ( $] >= 5.008007 ); # Common reusable true and false functions # This makes it easy to upgrade many places in PPI::XS sub TRUE () { 1 } sub FALSE () { '' } ##################################################################### # Functions # Allows a sub that takes a L to handle the full range # of different things, including file names, SCALAR source, etc. sub _Document { shift if @_ > 1; return undef unless defined $_[0]; require PPI::Document; return PPI::Document->new(shift) unless ref $_[0]; return PPI::Document->new(shift) if _SCALAR0($_[0]); return PPI::Document->new(shift) if _ARRAY0($_[0]); return shift if _INSTANCE($_[0], 'PPI::Document'); return undef; } # Provide a simple _slurp implementation sub _slurp { my $file = shift; local $/ = undef; local *FILE; open( FILE, '<', $file ) or return "open($file) failed: $!"; my $source = ; close( FILE ) or return "close($file) failed: $!"; return \$source; } # Provides a version of Digest::MD5's md5hex that explicitly # works on the unix-newlined version of the content. sub md5hex { my $string = shift; $string =~ s/(?:\015{1,2}\012|\015|\012)/\015/gs; Digest::MD5::md5_hex($string); } # As above but slurps and calculates the id for a file by name sub md5hex_file { my $file = shift; my $content = _slurp($file); return undef unless ref $content; $$content =~ s/(?:\015{1,2}\012|\015|\012)/\n/gs; md5hex($$content); } 1; PPI-1.220/lib/PPI/Normal/0000755000175100010010000000000012430470371011503 5ustar PPI-1.220/lib/PPI/Normal/Standard.pm0000755000175100010010000000621212430462144013604 0ustar package PPI::Normal::Standard; =pod =head1 NAME PPI::Normal::Standard - Provides standard document normalization functions =head1 DESCRIPTION This module provides the default normalization methods for L. There is no reason for you to need to load this yourself. B. =cut use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } ##################################################################### # Configuration and Registration my @METHODS = ( remove_insignificant_elements => 1, remove_useless_attributes => 1, remove_useless_pragma => 2, remove_statement_separator => 2, remove_useless_return => 2, ); sub import { PPI::Normal->register( map { /\D/ ? "PPI::Normal::Standard::$_" : $_ } @METHODS ) or die "Failed to register PPI::Normal::Standard transforms"; } ##################################################################### # Level 1 Transforms # Remove all insignificant elements sub remove_insignificant_elements { my $Document = shift; $Document->prune( sub { ! $_[1]->significant } ); } # Remove custom attributes that are not relevant to normalization sub remove_useless_attributes { my $Document = shift; delete $Document->{tab_width}; ### FIXME - Add support for more things } ##################################################################### # Level 2 Transforms # Remove version dependencies and pragma my $remove_pragma = map { $_ => 1 } qw{ strict warnings diagnostics less }; sub remove_useless_pragma { my $Document = shift; $Document->prune( sub { return '' unless $_[1]->isa('PPI::Statement::Include'); return 1 if $_[1]->version; return 1 if $remove_pragma->{$_[1]->pragma}; ''; } ); } # Remove all semi-colons at the end of statements sub remove_statement_separator { my $Document = shift; $Document->prune( sub { $_[1]->isa('PPI::Token::Structure') or return ''; $_[1]->content eq ';' or return ''; my $stmt = $_[1]->parent or return ''; $stmt->isa('PPI::Statement') or return ''; $_[1]->next_sibling and return ''; 1; } ); } # In any block, the "return" in the last statement is not # needed if there is only one and only one thing after the # return. sub remove_useless_return { my $Document = shift; $Document->prune( sub { $_[1]->isa('PPI::Token::Word') or return ''; $_[1]->content eq 'return' or return ''; my $stmt = $_[1]->parent or return ''; $stmt->isa('PPI::Statement::Break') or return ''; $stmt->children == 2 or return ''; $stmt->next_sibling and return ''; my $block = $stmt->parent or return ''; $block->isa('PPI::Structure::Block') or return ''; 1; } ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Normal.pm0000755000175100010010000001432112430462144012044 0ustar package PPI::Normal; =pod =head1 NAME PPI::Normal - Normalize Perl Documents =head2 DESCRIPTION Perl Documents, as created by PPI, are typically filled with all sorts of mess such as whitespace and comments and other things that don't effect the actual meaning of the code. In addition, because there is more than one way to do most things, and the syntax of Perl itself is quite flexible, there are many ways in which the "same" code can look quite different. PPI::Normal attempts to resolve this by providing a variety of mechanisms and algorithms to "normalize" Perl Documents, and determine a sort of base form for them (although this base form will be a memory structure, and not something that can be turned back into Perl source code). The process itself is quite complex, and so for convenience and extensibility it has been separated into a number of layers. At a later point, it will be possible to write Plugin classes to insert additional normalization steps into the various different layers. In addition, you can choose to do the normalization only as deep as a particular layer, depending on aggressively you want the normalization process to be. =head1 METHODS =cut use strict; use Carp (); use List::MoreUtils (); use PPI::Util '_Document'; use PPI::Document::Normalized (); use vars qw{$VERSION %LAYER}; BEGIN { $VERSION = '1.220'; # Registered function store %LAYER = ( 1 => [], 2 => [], ); } ##################################################################### # Configuration =pod =head2 register $function => $layer, ... The C method is used by normalization method providers to tell the normalization engines which functions need to be run, and in which layer they apply. Provide a set of key/value pairs, where the key is the full name of the function (in string form), and the value is the layer (see description of the layers above) in which it should be run. Returns true if all functions are registered, or C on error. =cut sub register { my $class = shift; while ( @_ ) { # Check the function my $function = shift; SCOPE: { no strict 'refs'; defined $function and defined &{"$function"} or Carp::croak("Bad function name provided to PPI::Normal"); } # Has it already been added? if ( List::MoreUtils::any { $_ eq $function } ) { return 1; } # Check the layer to add it to my $layer = shift; defined $layer and $layer =~ /^(?:1|2)$/ or Carp::croak("Bad layer provided to PPI::Normal"); # Add to the layer data store push @{ $LAYER{$layer} }, $function; } 1; } # With the registration mechanism in place, load in the main set of # normalization methods to initialize the store. use PPI::Normal::Standard; ##################################################################### # Constructor and Accessors =pod =head2 new my $level_1 = PPI::Normal->new; my $level_2 = PPI::Normal->new(2); Creates a new normalization object, to which Document objects can be passed to be normalized. Of course, what you probably REALLY want is just to call L's C method. Takes an optional single parameter of the normalisation layer to use, which at this time can be either "1" or "2". Returns a new C object, or C on error. =cut sub new { my $class = shift; my $layer = @_ ? (defined $_[0] and ! ref $_[0] and $_[0] =~ /^[12]$/) ? shift : return undef : 1; # Create the object my $object = bless { layer => $layer, }, $class; $object; } =pod =head1 layer The C accessor returns the normalisation layer of the object. =cut sub layer { $_[0]->{layer} } ##################################################################### # Main Methods =pod =head2 process The C method takes anything that can be converted to a L (object, SCALAR ref, filename), loads it and applies the normalisation process to the document. Returns a L object, or C on error. =cut sub process { my $self = ref $_[0] ? shift : shift->new; # PPI::Normal objects are reusable, but not re-entrant return undef if $self->{Document}; # Get or create the document $self->{Document} = _Document(shift) or return undef; # Work out what functions we need to call my @functions = map { @{ $LAYER{$_} } } ( 1 .. $self->layer ); # Execute each function foreach my $function ( @functions ) { no strict 'refs'; &{"$function"}( $self->{Document} ); } # Create the normalized Document object my $Normalized = PPI::Document::Normalized->new( Document => $self->{Document}, version => $VERSION, functions => \@functions, ) or return undef; # Done, clean up delete $self->{Document}; return $Normalized; } 1; =pod =head1 NOTES The following normalisation layers are implemented. When writing plugins, you should register each transformation function with the appropriate layer. =head2 Layer 1 - Insignificant Data Removal The basic step common to all normalization, layer 1 scans through the Document and removes all whitespace, comments, POD, and anything else that returns false for its C method. It also checks each Element and removes known-useless sub-element metadata such as the Element's physical position in the file. =head2 Layer 2 - Significant Element Removal After the removal of the insignificant data, Layer 2 removed larger, more complex, and superficially "significant" elements, that can be removed for the purposes of normalisation. Examples from this layer include pragmas, now-useless statement separators (since the PDOM tree is holding statement elements), and several other minor bits and pieces. =head2 Layer 3 - TO BE COMPLETED This version of the forward-port of the Perl::Compare functionality to the 0.900+ API of PPI only implements Layer 1 and 2 at this time. =head1 TO DO - Write the other 4-5 layers :) =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Find.pm0000755000175100010010000002144112430462144011475 0ustar package PPI::Find; =pod =head1 NAME PPI::Find - Object version of the Element->find method =head1 SYNOPSIS # Create the Find object my $Find = PPI::Find->new( \&wanted ); # Return all matching Elements as a list my @found = $Find->in( $Document ); # Can we find any matching Elements if ( $Find->any_matches($Document) ) { print "Found at least one matching Element"; } # Use the object as an iterator $Find->start($Document) or die "Failed to execute search"; while ( my $token = $Find->match ) { ... } =head1 DESCRIPTION PPI::Find is the primary PDOM searching class in the core PPI package. =head2 History It became quite obvious during the development of PPI that many of the modules that would be built on top of it were going to need large numbers of saved, storable or easily creatable search objects that could be reused a number of times. Although the internal ->find method provides a basic ability to search, it is by no means thorough. PPI::Find attempts to resolve this problem. =head2 Structure and Style PPI::Find provides a similar API to the popular L module for file searching, but without the ability to assemble queries. The implementation of a separate PPI::Find::Rule sub-class that does provide this ability is left as an exercise for the reader. =head2 The &wanted function At the core of each PPI::Find object is a "wanted" function that is passed a number of arguments and returns a value which controls the flow of the search. As the search executes, each Element will be passed to the wanted function in depth-first order. It will be provided with two arguments. The current Element to test as $_[0], and the top-level Element of the search as $_[1]. The &wanted function is expected to return 1 (positive) if the Element matches the condition, 0 (false) if it does not, and undef (undefined) if the condition does not match, and the Find search should not descend to any of the current Element's children. Errors should be reported from the &wanted function via die, which will be caught by the Find object and returned as an error. =head1 METHODS =cut use strict; use Params::Util qw{_INSTANCE}; use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } ##################################################################### # Constructor =pod =head2 new &wanted The C constructor takes a single argument of the &wanted function, as described above and creates a new search. Returns a new PPI::Find object, or C if not passed a CODE reference. =cut sub new { my $class = ref $_[0] ? ref shift : shift; my $wanted = ref $_[0] eq 'CODE' ? shift : return undef; # Create the object my $self = bless { wanted => $wanted, }, $class; $self; } =pod =head2 clone The C method creates another instance of the same Find object. The cloning is done safely, so if your existing Find object is in the middle of an iteration, the cloned Find object will not also be in the iteration and can be safely used independently. Returns a duplicate PPI::Find object. =cut sub clone { my $self = ref $_[0] ? shift : die "->clone can only be called as an object method"; my $class = ref $self; # Create the object my $clone = bless { wanted => $self->{wanted}, }, $class; $clone; } #################################################################### # Search Execution Methods =pod =head2 in $Document [, array_ref => 1 ] The C method starts and completes a full run of the search. It takes as argument a single L object which will serve as the top of the search process. Returns a list of PPI::Element objects that match the condition described by the &wanted function, or the null list on error. You should check the ->errstr method for any errors if you are returned the null list, which may also mean simply that no Elements were found that matched the condition. Because of this need to explicitly check for errors, an alternative return value mechanism is provide. If you pass the C<< array_ref => 1 >> parameter to the method, it will return the list of matched Elements as a reference to an ARRAY. The method will return false if no elements were matched, or C on error. The ->errstr method can still be used to get the error message as normal. =cut sub in { my $self = shift; my $Element = shift; my %params = @_; delete $self->{errstr}; # Are we already acting as an iterator if ( $self->{in} ) { return $self->_error('->in called while another search is in progress', %params); } # Get the root element for the search unless ( _INSTANCE($Element, 'PPI::Element') ) { return $self->_error('->in was not passed a PPI::Element object', %params); } # Prepare the search $self->{in} = $Element; $self->{matches} = []; # Execute the search if ( !eval { $self->_execute; 1 } ) { my $errstr = $@; $errstr =~ s/\s+at\s+line\s+.+$//; return $self->_error("Error while searching: $errstr", %params); } # Clean up and return delete $self->{in}; if ( $params{array_ref} ) { if ( @{$self->{matches}} ) { return delete $self->{matches}; } delete $self->{matches}; return ''; } # Return as a list my $matches = delete $self->{matches}; @$matches; } =pod =head2 start $Element The C method lets the Find object act as an iterator. The method is passed the parent PPI::Element object as for the C method, but does not accept any parameters. To simplify error handling, the entire search is done at once, with the results cached and provided as-requested. Returns true if the search completes, and false on error. =cut sub start { my $self = shift; my $Element = shift; delete $self->{errstr}; # Are we already acting as an iterator if ( $self->{in} ) { return $self->_error('->in called while another search is in progress'); } # Get the root element for the search unless ( _INSTANCE($Element, 'PPI::Element') ) { return $self->_error('->in was not passed a PPI::Element object'); } # Prepare the search $self->{in} = $Element; $self->{matches} = []; # Execute the search if ( !eval { $self->_execute; 1 } ) { my $errstr = $@; $errstr =~ s/\s+at\s+line\s+.+$//; $self->_error("Error while searching: $errstr"); return undef; } 1; } =pod =head2 match The C method returns the next matching Element in the iteration. Returns a PPI::Element object, or C if there are no remaining Elements to be returned. =cut sub match { my $self = shift; return undef unless $self->{matches}; # Fetch and return the next match my $match = shift @{$self->{matches}}; return $match if $match; $self->finish; undef; } =pod =head2 finish The C method provides a mechanism to end iteration if you wish to stop the iteration prematurely. It resets the Find object and allows it to be safely reused. A Find object will be automatically finished when C returns false. This means you should only need to call C when you stop iterating early. You may safely call this method even when not iterating and it will return without failure. Always returns true =cut sub finish { my $self = shift; delete $self->{in}; delete $self->{matches}; delete $self->{errstr}; 1; } ##################################################################### # Support Methods and Error Handling sub _execute { my $self = shift; my $wanted = $self->{wanted}; my @queue = ( $self->{in} ); # Pull entries off the queue and hand them off to the wanted function while ( my $Element = shift @queue ) { my $rv = &$wanted( $Element, $self->{in} ); # Add to the matches if returns true push @{$self->{matches}}, $Element if $rv; # Continue and don't descend if it returned undef # or if it doesn't have children next unless defined $rv; next unless $Element->isa('PPI::Node'); # Add the children to the head of the queue if ( $Element->isa('PPI::Structure') ) { unshift @queue, $Element->finish if $Element->finish; unshift @queue, $Element->children; unshift @queue, $Element->start if $Element->start; } else { unshift @queue, $Element->children; } } 1; } =pod =head2 errstr The C method returns the error messages when a given PPI::Find object fails any action. Returns a string, or C if there is no error. =cut sub errstr { shift->{errstr}; } sub _error { my $self = shift; $self->{errstr} = shift; my %params = @_; $params{array_ref} ? undef : (); } 1; =pod =head1 TO DO - Implement the L class =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Transform.pm0000755000175100010010000001352412430462144012573 0ustar package PPI::Transform; =pod =head1 NAME PPI::Transform - Abstract base class for document transformation classes =head1 DESCRIPTION C provides an API for the creation of classes and objects that modify or transform PPI documents. =head1 METHODS =cut use strict; use Carp (); use List::Util (); use PPI::Document (); use Params::Util qw{_INSTANCE _CLASS _CODE _SCALAR0}; use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } ##################################################################### # Apply Handler Registration my %HANDLER; my @ORDER; # Yes, you can use this yourself. # I'm just leaving it undocumented for now. sub register_apply_handler { my $class = shift; my $handler = _CLASS(shift) or Carp::croak("Invalid PPI::Transform->register_apply_handler param"); my $get = _CODE(shift) or Carp::croak("Invalid PPI::Transform->register_apply_handler param"); my $set = _CODE(shift) or Carp::croak("Invalid PPI::Transform->register_apply_handler param"); if ( $HANDLER{$handler} ) { Carp::croak("PPI::Transform->apply handler '$handler' already exists"); } # Register the handler $HANDLER{$handler} = [ $get, $set ]; unshift @ORDER, $handler; } # Register the default handlers __PACKAGE__->register_apply_handler( 'SCALAR', \&_SCALAR_get, \&_SCALAR_set ); __PACKAGE__->register_apply_handler( 'PPI::Document', sub { $_[0] }, sub() { 1 } ); ##################################################################### # Constructor =pod =head2 new my $transform = PPI::Transform->new( param1 => 'value1', param2 => 'value2', ); The C constructor creates a new object for your C subclass. A default constructor is provided for you which takes no params and creates a basic, empty, object. If you wish to have your transform constructor take params, these B be in the form of a list of key/value pairs. Returns a new C-compatible object, or returns C on error. =cut sub new { my $class = shift; bless { @_ }, $class; } =pod =head2 document The C method should be implemented by each subclass, and takes a single argument of a L object, modifying it B as appropriate for the particular transform class. That's right, this method B and B the document object. If you do not want the original to be modified, you need to clone it yourself before passing it in. Returns the numbers of changes made to the document. If the transform is unable to track the quantity (including the situation where it cannot tell B it made a change) it should return 1. Returns zero if no changes were made to the document, or C if an error occurs. By default this error is likely to only mean that you passed in something that wasn't a L, but may include additional errors depending on the subclass. =cut sub document { my $class = shift; die "$class does not implement the required ->document method"; } =pod =head2 apply The C method is used to apply the transform to something. The argument must be a L, or something which can be turned into a one and then be written back to again. Currently, this list is limited to a C reference, although a handler registration process is available for you to add support for additional types of object should you wish (see the source for this module). Returns true if the transform was applied, false if there is an error in the transform process, or may die if there is a critical error in the apply handler. =cut sub apply { my $self = _SELF(shift); my $it = defined $_[0] ? shift : return undef; # Try to find an apply handler my $class = _SCALAR0($it) ? 'SCALAR' : List::Util::first { _INSTANCE($it, $_) } @ORDER or return undef; my $handler = $HANDLER{$class} or die("->apply handler for $class missing! Panic"); # Get, change, set my $Document = _INSTANCE($handler->[0]->($it), 'PPI::Document') or Carp::croak("->apply handler for $class failed to get a PPI::Document"); $self->document( $Document ) or return undef; $handler->[1]->($it, $Document) or Carp::croak("->apply handler for $class failed to save the changed document"); 1; } =pod =head2 file # Read from one file and write to another $transform->file( 'Input.pm' => 'Output.pm' ); # Change a file in place $transform->file( 'Change.pm' ); The C method modifies a Perl document by filename. If passed a single parameter, it modifies the file in-place. If provided a second parameter, it will attempt to save the modified file to the alternative filename. Returns true on success, or C on error. =cut sub file { my $self = _SELF(shift); # Where do we read from and write to my $input = defined $_[0] ? shift : return undef; my $output = @_ ? defined $_[0] ? "$_[0]" : undef : $input or return undef; # Process the file my $Document = PPI::Document->new( "$input" ) or return undef; $self->document( $Document ) or return undef; $Document->save( $output ); } ##################################################################### # Apply Hander Methods sub _SCALAR_get { PPI::Document->new( $_[0] ); } sub _SCALAR_set { my $it = shift; $$it = $_[0]->serialize; 1; } ##################################################################### # Support Functions sub _SELF { return shift if ref $_[0]; my $self = $_[0]->new or Carp::croak( "Failed to auto-instantiate new $_[0] object" ); $self; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Document.pm0000755000175100010010000005551012430462144012377 0ustar package PPI::Document; =pod =head1 NAME PPI::Document - Object representation of a Perl document =head1 INHERITANCE PPI::Document isa PPI::Node isa PPI::Element =head1 SYNOPSIS use PPI; # Load a document from a file my $Document = PPI::Document->new('My/Module.pm'); # Strip out comments $Document->prune('PPI::Token::Comment'); # Find all the named subroutines my $sub_nodes = $Document->find( sub { $_[1]->isa('PPI::Statement::Sub') and $_[1]->name } ); my @sub_names = map { $_->name } @$sub_nodes; # Save the file $Document->save('My/Module.pm.stripped'); =head1 DESCRIPTION The C class represents a single Perl "document". A C object acts as a root L, with some additional methods for loading and saving, and working with the line/column locations of Elements within a file. The exemption to its L-like behavior this is that a C object can NEVER have a parent node, and is always the root node in a tree. =head2 Storable Support C implements the necessary C and C hooks to provide native support for L, if you have it installed. However if you want to clone clone a Document, you are highly recommended to use the internal C<$Document-Eclone> method rather than Storable's C function (although C should still work). =head1 METHODS Most of the things you are likely to want to do with a Document are probably going to involve the methods from L class, of which this is a subclass. The methods listed here are the remaining few methods that are truly Document-specific. =cut use strict; use Carp (); use List::MoreUtils (); use Params::Util qw{_SCALAR0 _ARRAY0 _INSTANCE}; use Digest::MD5 (); use PPI::Util (); use PPI (); use PPI::Node (); use PPI::Exception::ParserTimeout (); use overload 'bool' => \&PPI::Util::TRUE; use overload '""' => 'content'; use vars qw{$VERSION @ISA $errstr}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Node'; $errstr = ''; } use PPI::Document::Fragment (); # Document cache my $CACHE; # Convenience constants related to constants use constant LOCATION_LINE => 0; use constant LOCATION_CHARACTER => 1; use constant LOCATION_COLUMN => 2; use constant LOCATION_LOGICAL_LINE => 3; use constant LOCATION_LOGICAL_FILE => 4; ##################################################################### # Constructor and Static Methods =pod =head2 new # Simple construction $doc = PPI::Document->new( $filename ); $doc = PPI::Document->new( \$source ); # With the readonly attribute set $doc = PPI::Document->new( $filename, readonly => 1, ); The C constructor takes as argument a variety of different sources of Perl code, and creates a single cohesive Perl C for it. If passed a file name as a normal string, it will attempt to load the document from the file. If passed a reference to a C, this is taken to be source code and parsed directly to create the document. If passed zero arguments, a "blank" document will be created that contains no content at all. In all cases, the document is considered to be "anonymous" and not tied back to where it was created from. Specifically, if you create a PPI::Document from a filename, the document will B remember where it was created from. The constructor also takes attribute flags. At this time, the only available attribute is the C flag. Setting C to true will allow various systems to provide additional optimisations and caching. Note that because C is an optimisation flag, it is off by default and you will need to explicitly enable it. Returns a C object, or C if parsing fails. =cut sub new { local $_; # An extra one, just in case my $class = ref $_[0] ? ref shift : shift; unless ( @_ ) { my $self = $class->SUPER::new; $self->{readonly} = ! 1; $self->{tab_width} = 1; return $self; } # Check constructor attributes my $source = shift; my %attr = @_; my $timeout = delete $attr{timeout}; if ( $timeout and ! PPI::Util::HAVE_ALARM() ) { Carp::croak("This platform does not support PPI parser timeouts"); } # Check the data source if ( ! defined $source ) { $class->_error("An undefined value was passed to PPI::Document::new"); } elsif ( ! ref $source ) { # Catch people using the old API if ( $source =~ /(?:\012|\015)/ ) { Carp::croak("API CHANGE: Source code should only be passed to PPI::Document->new as a SCALAR reference"); } # When loading from a filename, use the caching layer if it exists. if ( $CACHE ) { my $file_contents = PPI::Util::_slurp( $source ); # Errors returned as plain string return $class->_error($file_contents) if !ref $file_contents; # Retrieve the document from the cache my $document = $CACHE->get_document($file_contents); return $class->_setattr( $document, %attr ) if $document; if ( $timeout ) { eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm( $timeout ); $document = PPI::Lexer->lex_source( $$file_contents ); alarm( 0 ); }; } else { $document = PPI::Lexer->lex_source( $$file_contents ); } if ( $document ) { # Save in the cache $CACHE->store_document( $document ); return $class->_setattr( $document, %attr ); } } else { if ( $timeout ) { eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm( $timeout ); my $document = PPI::Lexer->lex_file( $source ); return $class->_setattr( $document, %attr ) if $document; alarm( 0 ); }; } else { my $document = PPI::Lexer->lex_file( $source ); return $class->_setattr( $document, %attr ) if $document; } } } elsif ( _SCALAR0($source) ) { if ( $timeout ) { eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm( $timeout ); my $document = PPI::Lexer->lex_source( $$source ); return $class->_setattr( $document, %attr ) if $document; alarm( 0 ); }; } else { my $document = PPI::Lexer->lex_source( $$source ); return $class->_setattr( $document, %attr ) if $document; } } elsif ( _ARRAY0($source) ) { $source = join '', map { "$_\n" } @$source; if ( $timeout ) { eval { local $SIG{ALRM} = sub { die "alarm\n" }; alarm( $timeout ); my $document = PPI::Lexer->lex_source( $source ); return $class->_setattr( $document, %attr ) if $document; alarm( 0 ); }; } else { my $document = PPI::Lexer->lex_source( $source ); return $class->_setattr( $document, %attr ) if $document; } } else { $class->_error("Unknown object or reference was passed to PPI::Document::new"); } # Pull and store the error from the lexer my $errstr; if ( _INSTANCE($@, 'PPI::Exception::Timeout') ) { $errstr = 'Timed out while parsing document'; } elsif ( _INSTANCE($@, 'PPI::Exception') ) { $errstr = $@->message; } elsif ( $@ ) { $errstr = $@; $errstr =~ s/\sat line\s.+$//; } elsif ( PPI::Lexer->errstr ) { $errstr = PPI::Lexer->errstr; } else { $errstr = "Unknown error parsing Perl document"; } PPI::Lexer->_clear; $class->_error( $errstr ); } sub load { Carp::croak("API CHANGE: File names should now be passed to PPI::Document->new to load a file"); } sub _setattr { my ($class, $document, %attr) = @_; $document->{readonly} = !! $attr{readonly}; return $document; } =pod =head2 set_cache $cache As of L 1.100, C supports parser caching. The default cache class L provides a L-based caching or the parsed document based on the MD5 hash of the document as a string. The static C method is used to set the cache object for C to use when loading documents. It takes as argument a L object (or something that C the same). If passed C, this method will stop using the current cache, if any. For more information on caching, see L. Returns true on success, or C if not passed a valid param. =cut sub set_cache { my $class = ref $_[0] ? ref shift : shift; if ( defined $_[0] ) { # Enable the cache my $object = _INSTANCE(shift, 'PPI::Cache') or return undef; $CACHE = $object; } else { # Disable the cache $CACHE = undef; } 1; } =pod =head2 get_cache If a document cache is currently set, the C method will return it. Returns a L object, or C if there is no cache currently set for C. =cut sub get_cache { $CACHE; } ##################################################################### # PPI::Document Instance Methods =pod =head2 readonly The C attribute indicates if the document is intended to be read-only, and will never be modified. This is an advisory flag, that writers of L-related systems may or may not use to enable optimisations and caches for your document. Returns true if the document is read-only or false if not. =cut sub readonly { $_[0]->{readonly}; } =pod =head2 tab_width [ $width ] In order to handle support for C correctly, C need to understand the concept of tabs and tab width. The C method is used to get and set the size of the tab width. At the present time, PPI only supports "naive" (width 1) tabs, but we do plan on supporting arbitrary, default and auto-sensing tab widths later. Returns the tab width as an integer, or Cs if you attempt to set the tab width. =cut sub tab_width { my $self = shift; return $self->{tab_width} unless @_; $self->{tab_width} = shift; } =pod =head2 save $document->save( $file ) The C method serializes the C object and saves the resulting Perl document to a file. Returns C on failure to open or write to the file. =cut sub save { my $self = shift; local *FILE; open( FILE, '>', $_[0] ) or return undef; print FILE $self->serialize or return undef; close FILE or return undef; return 1; } =pod =head2 serialize Unlike the C method, which shows only the immediate content within an element, Document objects also have to be able to be written out to a file again. When doing this we need to take into account some additional factors. Primarily, we need to handle here-docs correctly, so that are written to the file in the expected place. The C method generates the actual file content for a given Document object. The resulting string can be written straight to a file. Returns the serialized document as a string. =cut sub serialize { my $self = shift; my @tokens = $self->tokens; # The here-doc content buffer my $heredoc = ''; # Start the main loop my $output = ''; foreach my $i ( 0 .. $#tokens ) { my $Token = $tokens[$i]; # Handle normal tokens unless ( $Token->isa('PPI::Token::HereDoc') ) { my $content = $Token->content; # Handle the trivial cases unless ( $heredoc ne '' and $content =~ /\n/ ) { $output .= $content; next; } # We have pending here-doc content that needs to be # inserted just after the first newline in the content. if ( $content eq "\n" ) { # Shortcut the most common case for speed $output .= $content . $heredoc; } else { # Slower and more general version $content =~ s/\n/\n$heredoc/; $output .= $content; } $heredoc = ''; next; } # This token is a HereDoc. # First, add the token content as normal, which in this # case will definitely not contain a newline. $output .= $Token->content; # Now add all of the here-doc content to the heredoc buffer. foreach my $line ( $Token->heredoc ) { $heredoc .= $line; } if ( $Token->{_damaged} ) { # Special Case: # There are a couple of warning/bug situations # that can occur when a HereDoc content was read in # from the end of a file that we silently allow. # # When writing back out to the file we have to # auto-repair these problems if we aren't going back # on to the end of the file. # When calculating $last_line, ignore the final token if # and only if it has a single newline at the end. my $last_index = $#tokens; if ( $tokens[$last_index]->{content} =~ /^[^\n]*\n$/ ) { $last_index--; } # This is a two part test. # First, are we on the last line of the # content part of the file my $last_line = List::MoreUtils::none { $tokens[$_] and $tokens[$_]->{content} =~ /\n/ } (($i + 1) .. $last_index); if ( ! defined $last_line ) { # Handles the null list case $last_line = 1; } # Secondly, are their any more here-docs after us, # (with content or a terminator) my $any_after = List::MoreUtils::any { $tokens[$_]->isa('PPI::Token::HereDoc') and ( scalar(@{$tokens[$_]->{_heredoc}}) or defined $tokens[$_]->{_terminator_line} ) } (($i + 1) .. $#tokens); if ( ! defined $any_after ) { # Handles the null list case $any_after = ''; } # We don't need to repair the last here-doc on the # last line. But we do need to repair anything else. unless ( $last_line and ! $any_after ) { # Add a terminating string if it didn't have one unless ( defined $Token->{_terminator_line} ) { $Token->{_terminator_line} = $Token->{_terminator}; } # Add a trailing newline to the terminating # string if it didn't have one. unless ( $Token->{_terminator_line} =~ /\n$/ ) { $Token->{_terminator_line} .= "\n"; } } } # Now add the termination line to the heredoc buffer if ( defined $Token->{_terminator_line} ) { $heredoc .= $Token->{_terminator_line}; } } # End of tokens if ( $heredoc ne '' ) { # If the file doesn't end in a newline, we need to add one # so that the here-doc content starts on the next line. unless ( $output =~ /\n$/ ) { $output .= "\n"; } # Now we add the remaining here-doc content # to the end of the file. $output .= $heredoc; } $output; } =pod =head2 hex_id The C method generates an unique identifier for the Perl document. This identifier is basically just the serialized document, with Unix-specific newlines, passed through MD5 to produce a hexadecimal string. This identifier is used by a variety of systems (such as L and L) as a unique key against which to store or cache information about a document (or indeed, to cache the document itself). Returns a 32 character hexadecimal string. =cut sub hex_id { PPI::Util::md5hex($_[0]->serialize); } =pod =head2 index_locations Within a document, all L objects can be considered to have a "location", a line/column position within the document when considered as a file. This position is primarily useful for debugging type activities. The method for finding the position of a single Element is a bit laborious, and very slow if you need to do it a lot. So the C method will index and save the locations of every Element within the Document in advance, making future calls to virtually free. Please note that this index should always be cleared using C once you are finished with the locations. If content is added to or removed from the file, these indexed locations will be B. =cut sub index_locations { my $self = shift; my @tokens = $self->tokens; # Whenever we hit a heredoc we will need to increment by # the number of lines in it's content section when we # encounter the next token with a newline in it. my $heredoc = 0; # Find the first Token without a location my ($first, $location) = (); foreach ( 0 .. $#tokens ) { my $Token = $tokens[$_]; next if $Token->{_location}; # Found the first Token without a location # Calculate the new location if needed. if ($_) { $location = $self->_add_location( $location, $tokens[$_ - 1], \$heredoc ); } else { my $logical_file = $self->can('filename') ? $self->filename : undef; $location = [ 1, 1, 1, 1, $logical_file ]; } $first = $_; last; } # Calculate locations for the rest if ( defined $first ) { foreach ( $first .. $#tokens ) { my $Token = $tokens[$_]; $Token->{_location} = $location; $location = $self->_add_location( $location, $Token, \$heredoc ); # Add any here-doc lines to the counter if ( $Token->isa('PPI::Token::HereDoc') ) { $heredoc += $Token->heredoc + 1; } } } 1; } sub _add_location { my ($self, $start, $Token, $heredoc) = @_; my $content = $Token->{content}; # Does the content contain any newlines my $newlines =()= $content =~ /\n/g; my ($logical_line, $logical_file) = $self->_logical_line_and_file($start, $Token, $newlines); unless ( $newlines ) { # Handle the simple case return [ $start->[LOCATION_LINE], $start->[LOCATION_CHARACTER] + length($content), $start->[LOCATION_COLUMN] + $self->_visual_length( $content, $start->[LOCATION_COLUMN] ), $logical_line, $logical_file, ]; } # This is the more complex case where we hit or # span a newline boundary. my $physical_line = $start->[LOCATION_LINE] + $newlines; my $location = [ $physical_line, 1, 1, $logical_line, $logical_file ]; if ( $heredoc and $$heredoc ) { $location->[LOCATION_LINE] += $$heredoc; $location->[LOCATION_LOGICAL_LINE] += $$heredoc; $$heredoc = 0; } # Does the token have additional characters # after their last newline. if ( $content =~ /\n([^\n]+?)\z/ ) { $location->[LOCATION_CHARACTER] += length($1); $location->[LOCATION_COLUMN] += $self->_visual_length( $1, $location->[LOCATION_COLUMN], ); } $location; } sub _logical_line_and_file { my ($self, $start, $Token, $newlines) = @_; # Regex taken from perlsyn, with the correction that there's no space # required between the line number and the file name. if ($start->[LOCATION_CHARACTER] == 1) { if ( $Token->isa('PPI::Token::Comment') ) { if ( $Token->content =~ m< \A \# \s* line \s+ (\d+) \s* (?: (\"?) ([^\"]* [^\s\"]) \2 )? \s* \z >xms ) { return $1, ($3 || $start->[LOCATION_LOGICAL_FILE]); } } elsif ( $Token->isa('PPI::Token::Pod') ) { my $content = $Token->content; my $line; my $file = $start->[LOCATION_LOGICAL_FILE]; my $end_of_directive; while ( $content =~ m< ^ \# \s*? line \s+? (\d+) (?: (?! \n) \s)* (?: (\"?) ([^\"]*? [^\s\"]) \2 )?? \s*? $ >xmsg ) { ($line, $file) = ($1, ( $3 || $file ) ); $end_of_directive = pos $content; } if (defined $line) { pos $content = $end_of_directive; my $post_directive_newlines =()= $content =~ m< \G [^\n]* \n >xmsg; return $line + $post_directive_newlines - 1, $file; } } } return $start->[LOCATION_LOGICAL_LINE] + $newlines, $start->[LOCATION_LOGICAL_FILE]; } sub _visual_length { my ($self, $content, $pos) = @_; my $tab_width = $self->tab_width; my ($length, $vis_inc); return length $content if $content !~ /\t/; # Split the content in tab and non-tab parts and calculate the # "visual increase" of each part. for my $part ( split(/(\t)/, $content) ) { if ($part eq "\t") { $vis_inc = $tab_width - ($pos-1) % $tab_width; } else { $vis_inc = length $part; } $length += $vis_inc; $pos += $vis_inc; } $length; } =pod =head2 flush_locations When no longer needed, the C method clears all location data from the tokens. =cut sub flush_locations { shift->_flush_locations(@_); } =pod =head2 normalized The C method is used to generate a "Layer 1" L object for the current Document. A "normalized" Perl Document is an arbitrary structure that removes any irrelevant parts of the document and refactors out variations in style, to attempt to approach something that is closer to the "true meaning" of the Document. See L for more information on document normalization and the tasks for which it is useful. Returns a L object, or C on error. =cut sub normalized { # The normalization process will utterly destroy and mangle # anything passed to it, so we are going to only give it a # clone of ourself. PPI::Normal->process( $_[0]->clone ); } =pod =head1 complete The C method is used to determine if a document is cleanly structured, all braces are closed, the final statement is fully terminated and all heredocs are fully entered. Returns true if the document is complete or false if not. =cut sub complete { my $self = shift; # Every structure has to be complete $self->find_any( sub { $_[1]->isa('PPI::Structure') and ! $_[1]->complete } ) and return ''; # Strip anything that isn't a statement off the end my @child = $self->children; while ( @child and not $child[-1]->isa('PPI::Statement') ) { pop @child; } # We must have at least one statement return '' unless @child; # Check the completeness of the last statement return $child[-1]->_complete; } ##################################################################### # PPI::Node Methods # We are a scope boundary ### XS -> PPI/XS.xs:_PPI_Document__scope 0.903+ sub scope() { 1 } ##################################################################### # PPI::Element Methods sub insert_before { return undef; # die "Cannot insert_before a PPI::Document"; } sub insert_after { return undef; # die "Cannot insert_after a PPI::Document"; } sub replace { return undef; # die "Cannot replace a PPI::Document"; } ##################################################################### # Error Handling # Set the error message sub _error { $errstr = $_[1]; undef; } # Clear the error message. # Returns the object as a convenience. sub _clear { $errstr = ''; $_[0]; } =pod =head2 errstr For error that occur when loading and saving documents, you can use C, as either a static or object method, to access the error message. If a Document loads or saves without error, C will return false. =cut sub errstr { $errstr; } ##################################################################### # Native Storable Support sub STORABLE_freeze { my $self = shift; my $class = ref $self; my %hash = %$self; return ($class, \%hash); } sub STORABLE_thaw { my ($self, undef, $class, $hash) = @_; bless $self, $class; foreach ( keys %$hash ) { $self->{$_} = delete $hash->{$_}; } $self->__link_children; } 1; =pod =head1 TO DO - May need to overload some methods to forcefully prevent Document objects becoming children of another Node. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Node.pm0000755000175100010010000004704312430462144011510 0ustar package PPI::Node; =pod =head1 NAME PPI::Node - Abstract PPI Node class, an Element that can contain other Elements =head1 INHERITANCE PPI::Node isa PPI::Element =head1 SYNOPSIS # Create a typical node (a Document in this case) my $Node = PPI::Document->new; # Add an element to the node( in this case, a token ) my $Token = PPI::Token::Word->new('my'); $Node->add_element( $Token ); # Get the elements for the Node my @elements = $Node->children; # Find all the barewords within a Node my $barewords = $Node->find( 'PPI::Token::Word' ); # Find by more complex criteria my $my_tokens = $Node->find( sub { $_[1]->content eq 'my' } ); # Remove all the whitespace $Node->prune( 'PPI::Token::Whitespace' ); # Remove by more complex criteria $Node->prune( sub { $_[1]->content eq 'my' } ); =head1 DESCRIPTION The C class provides an abstract base class for the Element classes that are able to contain other elements L, L, and L. As well as those listed below, all of the methods that apply to L objects also apply to C objects. =head1 METHODS =cut use strict; use Carp (); use Scalar::Util qw{refaddr}; use List::MoreUtils (); use Params::Util qw{_INSTANCE _CLASS _CODELIKE}; use PPI::Element (); use vars qw{$VERSION @ISA *_PARENT}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Element'; *_PARENT = *PPI::Element::_PARENT; } ##################################################################### # The basic constructor sub new { my $class = ref $_[0] || $_[0]; bless { children => [] }, $class; } ##################################################################### # PDOM Methods =pod =head2 scope The C method returns true if the node represents a lexical scope boundary, or false if it does not. =cut ### XS -> PPI/XS.xs:_PPI_Node__scope 0.903+ sub scope() { '' } =pod =head2 add_element $Element The C method adds a L object to the end of a C. Because Elements maintain links to their parent, an Element can only be added to a single Node. Returns true if the L was added. Returns C if the Element was already within another Node, or the method is not passed a L object. =cut sub add_element { my $self = shift; # Check the element my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; $_PARENT{refaddr $Element} and return undef; # Add the argument to the elements push @{$self->{children}}, $Element; Scalar::Util::weaken( $_PARENT{refaddr $Element} = $self ); 1; } # In a typical run profile, add_element is the number 1 resource drain. # This is a highly optimised unsafe version, for internal use only. sub __add_element { Scalar::Util::weaken( $_PARENT{refaddr $_[1]} = $_[0] ); push @{$_[0]->{children}}, $_[1]; } =pod =head2 elements The C method accesses all child elements B within the C object. Note that in the base of the L classes, this C include the brace tokens at either end of the structure. Returns a list of zero or more L objects. Alternatively, if called in the scalar context, the C method returns a count of the number of elements. =cut sub elements { if ( wantarray ) { return @{$_[0]->{children}}; } else { return scalar @{$_[0]->{children}}; } } =pod =head2 first_element The C method accesses the first element structurally within the C object. As for the C method, this does include the brace tokens for L objects. Returns a L object, or C if for some reason the C object does not contain any elements. =cut # Normally the first element is also the first child sub first_element { $_[0]->{children}->[0]; } =pod =head2 last_element The C method accesses the last element structurally within the C object. As for the C method, this does include the brace tokens for L objects. Returns a L object, or C if for some reason the C object does not contain any elements. =cut # Normally the last element is also the last child sub last_element { $_[0]->{children}->[-1]; } =pod =head2 children The C method accesses all child elements lexically within the C object. Note that in the case of the L classes, this does B include the brace tokens at either end of the structure. Returns a list of zero of more L objects. Alternatively, if called in the scalar context, the C method returns a count of the number of lexical children. =cut # In the default case, this is the same as for the elements method sub children { wantarray ? @{$_[0]->{children}} : scalar @{$_[0]->{children}}; } =pod =head2 schildren The C method is really just a convenience, the significant-only variation of the normal C method. In list context, returns a list of significant children. In scalar context, returns the number of significant children. =cut sub schildren { return grep { $_->significant } @{$_[0]->{children}} if wantarray; my $count = 0; foreach ( @{$_[0]->{children}} ) { $count++ if $_->significant; } return $count; } =pod =head2 child $index The C method accesses a child L object by its position within the Node. Returns a L object, or C if there is no child element at that node. =cut sub child { $_[0]->{children}->[$_[1]]; } =pod =head2 schild $index The lexical structure of the Perl language ignores 'insignificant' items, such as whitespace and comments, while L treats these items as valid tokens so that it can reassemble the file at any time. Because of this, in many situations there is a need to find an Element within a Node by index, only counting lexically significant Elements. The C method returns a child Element by index, ignoring insignificant Elements. The index of a child Element is specified in the same way as for a normal array, with the first Element at index 0, and negative indexes used to identify a "from the end" position. =cut sub schild { my $self = shift; my $idx = 0 + shift; my $el = $self->{children}; if ( $idx < 0 ) { my $cursor = 0; while ( exists $el->[--$cursor] ) { return $el->[$cursor] if $el->[$cursor]->significant and ++$idx >= 0; } } else { my $cursor = -1; while ( exists $el->[++$cursor] ) { return $el->[$cursor] if $el->[$cursor]->significant and --$idx < 0; } } undef; } =pod =head2 contains $Element The C method is used to determine if another L object is logically "within" a C. For the special case of the brace tokens at either side of a L object, they are generally considered "within" a L object, even if they are not actually in the elements for the L. Returns true if the L is within us, false if not, or C on error. =cut sub contains { my $self = shift; my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; # Iterate up the Element's parent chain until we either run out # of parents, or get to ourself. while ( $Element = $Element->parent ) { return 1 if refaddr($self) == refaddr($Element); } ''; } =pod =head2 find $class | \&wanted The C method is used to search within a code tree for L objects that meet a particular condition. To specify the condition, the method can be provided with either a simple class name (full or shortened), or a C/function reference. # Find all single quotes in a Document (which is a Node) $Document->find('PPI::Quote::Single'); # The same thing with a shortened class name $Document->find('Quote::Single'); # Anything more elaborate, we go with the sub $Document->find( sub { # At the top level of the file... $_[1]->parent == $_[0] and ( # ...find all comments and POD $_[1]->isa('PPI::Token::Pod') or $_[1]->isa('PPI::Token::Comment') ) } ); The function will be passed two arguments, the top-level C you are searching in and the current L that the condition is testing. The anonymous function should return one of three values. Returning true indicates a condition match, defined-false (C<0> or C<''>) indicates no-match, and C indicates no-match and no-descend. In the last case, the tree walker will skip over anything below the C-returning element and move on to the next element at the same level. To halt the entire search and return C immediately, a condition function should throw an exception (i.e. C). Note that this same wanted logic is used for all methods documented to have a C<\&wanted> parameter, as this one does. The C method returns a reference to an array of L objects that match the condition, false (but defined) if no Elements match the condition, or C if you provide a bad condition, or an error occurs during the search process. In the case of a bad condition, a warning will be emitted as well. =cut sub find { my $self = shift; my $wanted = $self->_wanted(shift) or return undef; # Use a queue based search, rather than a recursive one my @found; my @queue = @{$self->{children}}; my $ok = eval { while ( @queue ) { my $Element = shift @queue; my $rv = &$wanted( $self, $Element ); push @found, $Element if $rv; # Support "don't descend on undef return" next unless defined $rv; # Skip if the Element doesn't have any children next unless $Element->isa('PPI::Node'); # Depth-first keeps the queue size down and provides a # better logical order. if ( $Element->isa('PPI::Structure') ) { unshift @queue, $Element->finish if $Element->finish; unshift @queue, @{$Element->{children}}; unshift @queue, $Element->start if $Element->start; } else { unshift @queue, @{$Element->{children}}; } } 1; }; if ( !$ok ) { # Caught exception thrown from the wanted function return undef; } @found ? \@found : ''; } =pod =head2 find_first $class | \&wanted If the normal C method is like a grep, then C is equivalent to the L C function. Given an element class or a wanted function, it will search depth-first through a tree until it finds something that matches the condition, returning the first Element that it encounters. See the C method for details on the format of the search condition. Returns the first L object that matches the condition, false if nothing matches the condition, or C if given an invalid condition, or an error occurs. =cut sub find_first { my $self = shift; my $wanted = $self->_wanted(shift) or return undef; # Use the same queue-based search as for ->find my @queue = @{$self->{children}}; my $rv; my $ok = eval { # The defined() here prevents a ton of calls to PPI::Util::TRUE while ( @queue ) { my $Element = shift @queue; my $element_rv = $wanted->( $self, $Element ); if ( $element_rv ) { $rv = $Element; last; } # Support "don't descend on undef return" next if !defined $element_rv; # Skip if the Element doesn't have any children next if !$Element->isa('PPI::Node'); # Depth-first keeps the queue size down and provides a # better logical order. if ( $Element->isa('PPI::Structure') ) { unshift @queue, $Element->finish if defined($Element->finish); unshift @queue, @{$Element->{children}}; unshift @queue, $Element->start if defined($Element->start); } else { unshift @queue, @{$Element->{children}}; } } 1; }; if ( !$ok ) { # Caught exception thrown from the wanted function return undef; } $rv or ''; } =pod =head2 find_any $class | \&wanted The C method is a short-circuiting true/false method that behaves like the normal C method, but returns true as soon as it finds any Elements that match the search condition. See the C method for details on the format of the search condition. Returns true if any Elements that match the condition can be found, false if not, or C if given an invalid condition, or an error occurs. =cut sub find_any { my $self = shift; my $rv = $self->find_first(@_); $rv ? 1 : $rv; # false or undef } =pod =head2 remove_child $Element If passed a L object that is a direct child of the Node, the C method will remove the C intact, along with any of its children. As such, this method acts essentially as a 'cut' function. If successful, returns the removed element. Otherwise, returns C. =cut sub remove_child { my $self = shift; my $child = _INSTANCE(shift, 'PPI::Element') or return undef; # Find the position of the child my $key = refaddr $child; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; return undef unless defined $p; # Splice it out, and remove the child's parent entry splice( @{$self->{children}}, $p, 1 ); delete $_PARENT{refaddr $child}; $child; } =pod =head2 prune $class | \&wanted The C method is used to strip L objects out of a code tree. The argument is the same as for the C method, either a class name, or an anonymous subroutine which returns true/false. Any Element that matches the class|wanted will be deleted from the code tree, along with any of its children. The C method returns the number of C objects that matched and were removed, B. This might also be zero, so avoid a simple true/false test on the return false of the C method. It returns C on error, which you probably B test for. =cut sub prune { my $self = shift; my $wanted = $self->_wanted(shift) or return undef; # Use a depth-first queue search my $pruned = 0; my @queue = $self->children; my $ok = eval { while ( my $element = shift @queue ) { my $rv = &$wanted( $self, $element ); if ( $rv ) { # Delete the child $element->delete or return undef; $pruned++; next; } # Support the undef == "don't descend" next unless defined $rv; if ( _INSTANCE($element, 'PPI::Node') ) { # Depth-first keeps the queue size down unshift @queue, $element->children; } } 1; }; if ( !$ok ) { # Caught exception thrown from the wanted function return undef; } $pruned; } # This method is likely to be very heavily used, so take # it slowly and carefully. ### NOTE: Renaming this function or changing either to self will probably ### break File::Find::Rule::PPI sub _wanted { my $either = shift; my $it = defined($_[0]) ? shift : do { Carp::carp('Undefined value passed as search condition') if $^W; return undef; }; # Has the caller provided a wanted function directly return $it if _CODELIKE($it); if ( ref $it ) { # No other ref types are supported Carp::carp('Illegal non-CODE reference passed as search condition') if $^W; return undef; } # The first argument should be an Element class, possibly in shorthand $it = "PPI::$it" unless substr($it, 0, 5) eq 'PPI::'; unless ( _CLASS($it) and $it->isa('PPI::Element') ) { # We got something, but it isn't an element Carp::carp("Cannot create search condition for '$it': Not a PPI::Element") if $^W; return undef; } # Create the class part of the wanted function my $wanted_class = "\n\treturn '' unless \$_[1]->isa('$it');"; # Have we been given a second argument to check the content my $wanted_content = ''; if ( defined $_[0] ) { my $content = shift; if ( ref $content eq 'Regexp' ) { $content = "$content"; } elsif ( ref $content ) { # No other ref types are supported Carp::carp("Cannot create search condition for '$it': Not a PPI::Element") if $^W; return undef; } else { $content = quotemeta $content; } # Complete the content part of the wanted function $wanted_content .= "\n\treturn '' unless defined \$_[1]->{content};"; $wanted_content .= "\n\treturn '' unless \$_[1]->{content} =~ /$content/;"; } # Create the complete wanted function my $code = "sub {" . $wanted_class . $wanted_content . "\n\t1;" . "\n}"; # Compile the wanted function $code = eval $code; (ref $code eq 'CODE') ? $code : undef; } #################################################################### # PPI::Element overloaded methods sub tokens { map { $_->tokens } @{$_[0]->{children}}; } ### XS -> PPI/XS.xs:_PPI_Element__content 0.900+ sub content { join '', map { $_->content } @{$_[0]->{children}}; } # Clone as normal, but then go down and relink all the _PARENT entries sub clone { my $self = shift; my $clone = $self->SUPER::clone; $clone->__link_children; $clone; } sub location { my $self = shift; my $first = $self->{children}->[0] or return undef; $first->location; } ##################################################################### # Internal Methods sub DESTROY { local $_; if ( $_[0]->{children} ) { my @queue = $_[0]; while ( defined($_ = shift @queue) ) { unshift @queue, @{delete $_->{children}} if $_->{children}; # Remove all internal/private weird crosslinking so that # the cascading DESTROY calls will get called properly. %$_ = (); } } # Remove us from our parent node as normal delete $_PARENT{refaddr $_[0]}; } # Find the position of a child sub __position { my $key = refaddr $_[1]; List::MoreUtils::firstidx { refaddr $_ == $key } @{$_[0]->{children}}; } # Insert one or more elements before a child sub __insert_before_child { my $self = shift; my $key = refaddr shift; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; foreach ( @_ ) { Scalar::Util::weaken( $_PARENT{refaddr $_} = $self ); } splice( @{$self->{children}}, $p, 0, @_ ); 1; } # Insert one or more elements after a child sub __insert_after_child { my $self = shift; my $key = refaddr shift; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; foreach ( @_ ) { Scalar::Util::weaken( $_PARENT{refaddr $_} = $self ); } splice( @{$self->{children}}, $p + 1, 0, @_ ); 1; } # Replace a child sub __replace_child { my $self = shift; my $key = refaddr shift; my $p = List::MoreUtils::firstidx { refaddr $_ == $key } @{$self->{children}}; foreach ( @_ ) { Scalar::Util::weaken( $_PARENT{refaddr $_} = $self ); } splice( @{$self->{children}}, $p, 1, @_ ); 1; } # Create PARENT links for an entire tree. # Used when cloning or thawing. sub __link_children { my $self = shift; # Relink all our children ( depth first ) my @queue = ( $self ); while ( my $Node = shift @queue ) { # Link our immediate children foreach my $Element ( @{$Node->{children}} ) { Scalar::Util::weaken( $_PARENT{refaddr($Element)} = $Node ); unshift @queue, $Element if $Element->isa('PPI::Node'); } # If it's a structure, relink the open/close braces next unless $Node->isa('PPI::Structure'); Scalar::Util::weaken( $_PARENT{refaddr($Node->start)} = $Node ) if $Node->start; Scalar::Util::weaken( $_PARENT{refaddr($Node->finish)} = $Node ) if $Node->finish; } 1; } 1; =pod =head1 TO DO - Move as much as possible to L =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Dumper.pm0000755000175100010010000001534312430462144012055 0ustar package PPI::Dumper; =pod =head1 NAME PPI::Dumper - Dumping of PDOM trees =head1 SYNOPSIS # Load a document my $Module = PPI::Document->new( 'MyModule.pm' ); # Create the dumper my $Dumper = PPI::Dumper->new( $Module ); # Dump the document $Dumper->print; =head1 DESCRIPTION The PDOM trees in PPI are quite complex, and getting a dump of their structure for development and debugging purposes is important. This module provides that functionality. The process is relatively simple. Create a dumper object with a particular set of options, and then call one of the dump methods to generate the dump content itself. =head1 METHODS =cut use strict; use Params::Util qw{_INSTANCE}; use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } ##################################################################### # Constructor =pod =head2 new $Element, param => value, ... The C constructor creates a dumper, and takes as argument a single L object of any type to serve as the root of the tree to be dumped, and a number of key-Evalue parameters to control the output format of the Dumper. Details of the parameters are listed below. Returns a new C object, or C if the constructor is not passed a correct L root object. =over =item memaddr Should the dumper print the memory addresses of each PDOM element. True/false value, off by default. =item indent Should the structures being dumped be indented. This value is numeric, with the number representing the number of spaces to use when indenting the dumper output. Set to '2' by default. =item class Should the dumper print the full class for each element. True/false value, on by default. =item content Should the dumper show the content of each element. True/false value, on by default. =item whitespace Should the dumper show whitespace tokens. By not showing the copious numbers of whitespace tokens the structure of the code can often be made much clearer. True/false value, on by default. =item comments Should the dumper show comment tokens. In situations where you have a lot of comments, the code can often be made clearer by ignoring comment tokens. True/false value, on by default. =item locations Should the dumper show the location of each token. The values shown are [ line, rowchar, column ]. See L for a description of what these values really are. True/false value, off by default. =back =cut sub new { my $class = shift; my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; # Create the object my $self = bless { root => $Element, display => { memaddr => '', # Show the refaddr of the item indent => 2, # Indent the structures class => 1, # Show the object class content => 1, # Show the object contents whitespace => 1, # Show whitespace tokens comments => 1, # Show comment tokens locations => 0, # Show token locations }, }, $class; # Handle the options my %options = map { lc $_ } @_; foreach ( keys %{$self->{display}} ) { if ( exists $options{$_} ) { if ( $_ eq 'indent' ) { $self->{display}->{indent} = $options{$_}; } else { $self->{display}->{$_} = !! $options{$_}; } } } $self->{indent_string} = join '', (' ' x $self->{display}->{indent}); $self; } ##################################################################### # Main Interface Methods =pod =head2 print The C method generates the dump and prints it to STDOUT. Returns as for the internal print function. =cut sub print { CORE::print(shift->string); } =pod =head2 string The C method generates the dump and provides it as a single string. Returns a string or undef if there is an error while generating the dump. =cut sub string { my $array_ref = shift->_dump or return undef; join '', map { "$_\n" } @$array_ref; } =pod =head2 list The C method generates the dump and provides it as a raw list, without trailing newlines. Returns a list or the null list if there is an error while generation the dump. =cut sub list { my $array_ref = shift->_dump or return (); @$array_ref; } ##################################################################### # Generation Support Methods sub _dump { my $self = ref $_[0] ? shift : shift->new(shift); my $Element = _INSTANCE($_[0], 'PPI::Element') ? shift : $self->{root}; my $indent = shift || ''; my $output = shift || []; # Print the element if needed my $show = 1; if ( $Element->isa('PPI::Token::Whitespace') ) { $show = 0 unless $self->{display}->{whitespace}; } elsif ( $Element->isa('PPI::Token::Comment') ) { $show = 0 unless $self->{display}->{comments}; } push @$output, $self->_element_string( $Element, $indent ) if $show; # Recurse into our children if ( $Element->isa('PPI::Node') ) { my $child_indent = $indent . $self->{indent_string}; foreach my $child ( @{$Element->{children}} ) { $self->_dump( $child, $child_indent, $output ); } } $output; } sub _element_string { my $self = ref $_[0] ? shift : shift->new(shift); my $Element = _INSTANCE($_[0], 'PPI::Element') ? shift : $self->{root}; my $indent = shift || ''; my $string = ''; # Add the memory location if ( $self->{display}->{memaddr} ) { $string .= $Element->refaddr . ' '; } # Add the location if such exists if ( $self->{display}->{locations} ) { my $loc_string; if ( $Element->isa('PPI::Token') ) { my $location = $Element->location; if ($location) { $loc_string = sprintf("[ % 4d, % 3d, % 3d ] ", @$location); } } # Output location or pad with 20 spaces $string .= $loc_string || " " x 20; } # Add the indent if ( $self->{display}->{indent} ) { $string .= $indent; } # Add the class name if ( $self->{display}->{class} ) { $string .= ref $Element; } if ( $Element->isa('PPI::Token') ) { # Add the content if ( $self->{display}->{content} ) { my $content = $Element->content; $content =~ s/\n/\\n/g; $content =~ s/\t/\\t/g; $content =~ s/\f/\\f/g; $string .= " \t'$content'"; } } elsif ( $Element->isa('PPI::Structure') ) { # Add the content if ( $self->{display}->{content} ) { my $start = $Element->start ? $Element->start->content : '???'; my $finish = $Element->finish ? $Element->finish->content : '???'; $string .= " \t$start ... $finish"; } } $string; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Structure.pm0000755000175100010010000002127412430462144012621 0ustar package PPI::Structure; =pod =head1 NAME PPI::Structure - The base class for Perl braced structures =head1 INHERITANCE PPI::Structure isa PPI::Node isa PPI::Element =head1 DESCRIPTION PPI::Structure is the root class for all Perl bracing structures. This covers all forms of C< [ ... ] >, C< { ... } >, and C< ( ... ) > brace types, and includes cases where only one half of the pair exist. The class PPI::Structure itself is full abstract and no objects of that type should actually exist in the tree. =head2 Elements vs Children A B has an unusual existence. Unlike a L or L, which both simply contain other elements, a structure B contains and consists of content. That is, the brace tokens are B considered to be "children" of the structure, but are part of it. In practice, this will mean that while the -Eelements and -Etokens methods (and related) B return a list with the brace tokens at either end, the -Echildren method explicitly will B return the brace. =head1 STRUCTURE CLASSES Excluding the transient L that exists briefly inside the parser, there are eight types of structure. =head2 L This covers all round braces used for function arguments, in C loops, literal lists, and braces used for precedence-ordering purposes. =head2 L Although B used for the C loop list, this B used for the special case of the round-brace three-part semicolon-separated C loop expression (the traditional C style for loop). =head2 L This is for the expression being matched in switch statements. =head2 L This is for the matching expression in "when" statements. =head2 L This round-brace structure covers boolean conditional braces, such as for C and C blocks. =head2 L This curly-brace and common structure is used for all form of code blocks. This includes those for C, C and similar, as well as C, C, C, C and (labelled or anonymous) scoping blocks. =head2 L This class covers brace structures used for the construction of anonymous C and C references. =head2 L This class covers square-braces and curly-braces used after a -E pointer to access the subscript of an C or C. =head1 METHODS C itself has very few methods. Most of the time, you will be working with the more generic L or L methods, or one of the methods that are subclass-specific. =cut use strict; use Scalar::Util (); use Params::Util qw{_INSTANCE}; use PPI::Node (); use PPI::Exception (); use vars qw{$VERSION @ISA *_PARENT}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Node'; *_PARENT = *PPI::Element::_PARENT; } use PPI::Structure::Block (); use PPI::Structure::Condition (); use PPI::Structure::Constructor (); use PPI::Structure::For (); use PPI::Structure::Given (); use PPI::Structure::List (); use PPI::Structure::Subscript (); use PPI::Structure::Unknown (); use PPI::Structure::When (); ##################################################################### # Constructor sub new { my $class = shift; my $Token = PPI::Token::__LEXER__opens($_[0]) ? shift : return undef; # Create the object my $self = bless { children => [], start => $Token, }, $class; # Set the start braces parent link Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $Token} = $self ); $self; } ##################################################################### # PPI::Structure API methods =pod =head2 start For lack of better terminology (like "open" and "close") that has not already in use for some other more important purpose, the two individual braces for the structure are known within PPI as the "start" and "finish" braces (at least for method purposes). The C method returns the start brace for the structure (i.e. the opening brace). Returns the brace as a L or C if the structure does not have a starting brace. Under normal parsing circumstances this should never occur, but may happen due to manipulation of the PDOM tree. =cut sub start { $_[0]->{start} } =pod =head2 finish The C method returns the finish brace for the structure (i.e. the closing brace). Returns the brace as a L or C if the structure does not have a finishing brace. This can be quite common if the document is not complete (for example, from an editor where the user may be halfway through typeing a subroutine). =cut sub finish { $_[0]->{finish} } =pod =head2 braces The C method is a utility method which returns the brace type, regardless of whether has both braces defined, or just the starting brace, or just the ending brace. Returns on of the three strings C<'[]'>, C<'{}'>, or C<'()'>, or C on error (primarily not having a start brace, as mentioned above). =cut sub braces { my $self = $_[0]->{start} ? shift : return undef; return { '[' => '[]', '(' => '()', '{' => '{}', }->{ $self->{start}->{content} }; } =pod =head1 complete The C method is a convenience method that returns true if the both braces are defined for the structure, or false if only one brace is defined. Unlike the top level C method which checks for completeness in depth, the structure complete method ONLY confirms completeness for the braces, and does not recurse downwards. =cut sub complete { !! ($_[0]->{start} and $_[0]->{finish}); } ##################################################################### # PPI::Node overloaded methods # For us, the "elements" concept includes the brace tokens sub elements { my $self = shift; if ( wantarray ) { # Return a list in array context return ( $self->{start} || (), @{$self->{children}}, $self->{finish} || () ); } else { # Return the number of elements in scalar context. # This is memory-cheaper than creating another big array return scalar(@{$self->{children}}) + ($self->{start} ? 1 : 0) + ($self->{finish} ? 1 : 0); } } # For us, the first element is probably the opening brace sub first_element { # Technically, if we have no children and no opening brace, # then the first element is the closing brace. $_[0]->{start} or $_[0]->{children}->[0] or $_[0]->{finish}; } # For us, the last element is probably the closing brace sub last_element { # Technically, if we have no children and no closing brace, # then the last element is the opening brace $_[0]->{finish} or $_[0]->{children}->[-1] or $_[0]->{start}; } # Location is same as the start token, if any sub location { my $self = shift; my $first = $self->first_element or return undef; $first->location; } ##################################################################### # PPI::Element overloaded methods # Get the full set of tokens, including start and finish sub tokens { my $self = shift; my @tokens = ( $self->{start} || (), $self->SUPER::tokens(@_), $self->{finish} || (), ); @tokens; } # Like the token method ->content, get our merged contents. # This will recurse downwards through everything ### Reimplement this using List::Utils stuff sub content { my $self = shift; my $content = $self->{start} ? $self->{start}->content : ''; foreach my $child ( @{$self->{children}} ) { $content .= $child->content; } $content .= $self->{finish}->content if $self->{finish}; $content; } # Is the structure completed sub _complete { !! ( defined $_[0]->{finish} ); } # You can insert either another structure, or a token sub insert_before { my $self = shift; my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; if ( $Element->isa('PPI::Structure') ) { return $self->__insert_before($Element); } elsif ( $Element->isa('PPI::Token') ) { return $self->__insert_before($Element); } ''; } # As above, you can insert either another structure, or a token sub insert_after { my $self = shift; my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; if ( $Element->isa('PPI::Structure') ) { return $self->__insert_after($Element); } elsif ( $Element->isa('PPI::Token') ) { return $self->__insert_after($Element); } ''; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/0000755000175100010010000000000012430470371011333 5ustar PPI-1.220/lib/PPI/Token/Quote/0000755000175100010010000000000012430470371012430 5ustar PPI-1.220/lib/PPI/Token/Quote/Literal.pm0000755000175100010010000000301712430462144014365 0ustar package PPI::Token::Quote::Literal; =pod =head1 NAME PPI::Token::Quote::Literal - The literal quote-like operator =head1 INHERITANCE PPI::Token::Quote::Literal isa PPI::Token::Quote isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents a single literal quote-like operator, such as C. =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::Quote (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::Quote }; } ##################################################################### # PPI::Token::Quote Methods sub string { my $self = shift; my @sections = $self->_sections; my $str = $sections[0]; substr( $self->{content}, $str->{position}, $str->{size} ); } # Use the same implementation as another module *literal = *PPI::Token::Quote::Single::literal; 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Quote/Double.pm0000755000175100010010000000560012430462144014203 0ustar package PPI::Token::Quote::Double; =pod =head1 NAME PPI::Token::Quote::Double - A standard "double quote" token =head1 INHERITANCE PPI::Token::Quote::Double isa PPI::Token::Quote isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents a double-quoted interpolating string. The string is treated as a single entity, L will not try to understand what is in the string during the parsing process. =head1 METHODS There are several methods available for C, beyond those provided by the parent L, L and L classes. =cut use strict; use Params::Util qw{_INSTANCE}; use PPI::Token::Quote (); use PPI::Token::_QuoteEngine::Simple (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Simple PPI::Token::Quote }; } ##################################################################### # PPI::Token::Quote::Double Methods =pod =head2 interpolations The interpolations method checks to see if the double quote actually contains any interpolated variables. Returns true if the string contains interpolations, or false if not. =cut # Upgrade: Return the interpolated substrings. # Upgrade: Returns parsed expressions. sub interpolations { # Are there any unescaped $things in the string !! ($_[0]->content =~ /(? method will, if possible, modify a simple double-quoted string token in place, turning it into the equivalent single-quoted string. If the token is modified, it is reblessed into the L package. The object itself is returned as a convenience. =cut sub simplify { # This only works on EXACTLY this class my $self = _INSTANCE(shift, 'PPI::Token::Quote::Double') or return undef; # Don't bother if there are characters that could complicate things my $content = $self->content; my $value = substr($content, 1, length($content) - 2); return $self if $value =~ /[\\\$@\'\"]/; # Change the token to a single string $self->{content} = "'$value'"; bless $self, 'PPI::Token::Quote::Single'; } ##################################################################### # PPI::Token::Quote Methods sub string { my $str = $_[0]->{content}; substr( $str, 1, length($str) - 2 ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Quote/Interpolate.pm0000755000175100010010000000270712430462144015264 0ustar package PPI::Token::Quote::Interpolate; =pod =head1 NAME PPI::Token::Quote::Interpolate - The interpolation quote-like operator =head1 INHERITANCE PPI::Token::Quote::Interpolate isa PPI::Token::Quote isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents a single interpolation quote-like operator, such as C. =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::Quote (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::Quote }; } ##################################################################### # PPI::Token::Quote Methods sub string { my $self = shift; my @sections = $self->_sections; my $str = $sections[0]; substr( $self->{content}, $str->{position}, $str->{size} ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Quote/Single.pm0000755000175100010010000000307312430462144014214 0ustar package PPI::Token::Quote::Single; =pod =head1 NAME PPI::Token::Quote::Single - A 'single quote' token =head1 INHERITANCE PPI::Token::Quote::Single isa PPI::Token::Quote isa PPI::Token isa PPI::Element =head1 SYNOPSIS 'This is a single quote' q{This is a literal, but NOT a single quote} =head1 DESCRIPTION A C object represents a single quoted string literal. =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::Quote (); use PPI::Token::_QuoteEngine::Simple (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Simple PPI::Token::Quote }; } ##################################################################### # PPI::Token::Quote Methods sub string { my $str = $_[0]->{content}; substr( $str, 1, length($str) - 2 ); } my %UNESCAPE = ( "\\'" => "'", "\\\\" => "\\", ); sub literal { # Unescape \\ and \' ONLY my $str = $_[0]->string; $str =~ s/(\\.)/$UNESCAPE{$1} || $1/ge; return $str; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Regexp.pm0000755000175100010010000000500612430462144013126 0ustar package PPI::Token::Regexp; =pod =head1 NAME PPI::Token::Regexp - Regular expression abstract base class =head1 INHERITANCE PPI::Token::Regexp isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is never instantiated, and simply provides a common abstract base class for the three regular expression classes. These being: =over 2 =item m// - L =item s/// - L =item tr/// - L =back The names are hopefully obvious enough not to have to explain what each class is. See their pages for more details. To save some confusion, it's worth pointing out here that C is B a regular expression (which PPI takes to mean something that will actually examine or modify a string), but rather a quote-like operator that acts as a constructor for compiled L objects. =head1 METHODS The following methods are inherited by this class' offspring: =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # PPI::Token::Regexp Methods =pod =head2 get_match_string The C method returns the portion of the regexp that performs the match. =cut sub get_match_string { return $_[0]->_section_content( 0 ); } =pod =head2 get_substitute_string The C method returns the portion of the regexp that is substituted for the match, if any. If the regexp does not substitute, C is returned. =cut sub get_substitute_string { return $_[0]->_section_content( 1 ); } =pod =head2 get_modifiers The C method returns the modifiers of the regexp. =cut sub get_modifiers { return $_[0]->_modifiers(); } =pod =head2 get_delimiters The C method returns the delimiters of the regexp as an array. The first element is the delimiters of the match string, and the second element (if any) is the delimiters of the substitute string (if any). =cut sub get_delimiters { return $_[0]->_delimiters(); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Regexp/0000755000175100010010000000000012430470371012565 5ustar PPI-1.220/lib/PPI/Token/Regexp/Match.pm0000755000175100010010000000275312430462144014170 0ustar package PPI::Token::Regexp::Match; =pod =head1 NAME PPI::Token::Regexp::Match - A standard pattern match regex =head1 INHERITANCE PPI::Token::Regexp::Match isa PPI::Token::Regexp isa PPI::Token isa PPI::Element =head1 SYNOPSIS $text =~ m/match regexp/; $text =~ /match regexp/; =head1 DESCRIPTION A C object represents a single match regular expression. Just to be doubly clear, here are things that are and B considered a match regexp. # Is a match regexp /This is a match regexp/; m/Old McDonald had a farm/eieio; # These are NOT match regexp qr/This is a regexp quote-like operator/; s/This is a/replace regexp/; =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::Regexp (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::Regexp }; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Regexp/Substitute.pm0000755000175100010010000000234112430462144015300 0ustar package PPI::Token::Regexp::Substitute; =pod =head1 NAME PPI::Token::Regexp::Substitute - A match and replace regular expression token =head1 INHERITANCE PPI::Token::Regexp::Substitute isa PPI::Token::Regexp isa PPI::Token isa PPI::Element =head1 SYNOPSIS $text =~ s/find/$replace/; =head1 DESCRIPTION A C object represents a single substitution regular expression. =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::Regexp (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::Regexp }; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Regexp/Transliterate.pm0000755000175100010010000000267212430462144015755 0ustar package PPI::Token::Regexp::Transliterate; =pod =head1 NAME PPI::Token::Regexp::Transliterate - A transliteration regular expression token =head1 INHERITANCE PPI::Token::Regexp::Transliterate isa PPI::Token::Regexp isa PPI::Token isa PPI::Element =head1 SYNOPSIS $text =~ tr/abc/xyz/; =head1 DESCRIPTION A C object represents a single transliteration regular expression. I'm afraid you'll have to excuse the ridiculously long class name, but when push came to shove I ended up going for pedantically correct names for things (practically cut and paste from the various docs). =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::Regexp (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::Regexp }; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/HereDoc.pm0000755000175100010010000001702112430462144013205 0ustar package PPI::Token::HereDoc; =pod =head1 NAME PPI::Token::HereDoc - Token class for the here-doc =head1 INHERITANCE PPI::Token::HereDoc isa PPI::Token isa PPI::Element =head1 DESCRIPTION Here-docs are incredibly handy when writing Perl, but incredibly tricky when parsing it, primarily because they don't follow the general flow of input. They jump ahead and nab lines directly off the input buffer. Whitespace and newlines may not matter in most Perl code, but they matter in here-docs. They are also tricky to store as an object. They look sort of like an operator and a string, but they don't act like it. And they have a second section that should be something like a separate token, but isn't because a string can span from above the here-doc content to below it. So when parsing, this is what we do. Firstly, the PPI::Token::HereDoc object, does not represent the C<<< << >>> operator, or the "END_FLAG", or the content, or even the terminator. It represents all of them at once. The token itself has only the declaration part as its "content". # This is what the content of a HereDoc token is < method on a HereDoc token, you get '<< "FOO"'. As for the content and the terminator, when treated purely in "content" terms they do not exist. The content is made available with the C method, and the name of the terminator with the C method. To make things work in the way you expect, PPI has to play some games when doing line/column location calculation for tokens, and also during the content parsing and generation processes. Documents cannot simply by recreated by stitching together the token contents, and involve a somewhat more expensive procedure, but the extra expense should be relatively negligible unless you are doing huge quantities of them. Please note that due to the immature nature of PPI in general, we expect C to be a rich (bad) source of corner-case bugs for quite a while, but for the most part they should more or less DWYM. =head2 Comparison to other string types Although technically it can be considered a quote, for the time being C are being treated as a completely separate C subclass, and will not be found in a search for L or L. This may change in the future, with it most likely to end up under QuoteLike. =head1 METHODS Although it has the standard set of C methods, C objects have a relatively large number of unique methods all of their own. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # PPI::Token::HereDoc Methods =pod =head2 heredoc The C method is the authoritative method for accessing the contents of the C object. It returns the contents of the here-doc as a list of newline-terminated strings. If called in scalar context, it returns the number of lines in the here-doc, B the terminator line. =cut sub heredoc { wantarray ? @{shift->{_heredoc}} : scalar @{shift->{_heredoc}}; } =pod =head2 terminator The C method returns the name of the terminating string for the here-doc. Returns the terminating string as an unescaped string (in the rare case the terminator has an escaped quote in it). =cut sub terminator { shift->{_terminator}; } ##################################################################### # Tokenizer Methods # Parse in the entire here-doc in one call sub __TOKENIZER__on_char { my $t = $_[1]; # We are currently located on the first char after the << # Handle the most common form first for simplicity and speed reasons ### FIXME - This regex, and this method in general, do not yet allow ### for the null here-doc, which terminates at the first ### empty line. pos $t->{line} = $t->{line_cursor}; if ( $t->{line} !~ m/\G( \s* (?: "[^"]*" | '[^']*' | `[^`]*` | \\?\w+ ) )/gcx ) { # Degenerate to a left-shift operation $t->{token}->set_class('Operator'); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Add the rest of the token, work out what type it is, # and suck in the content until the end. my $token = $t->{token}; $token->{content} .= $1; $t->{line_cursor} += length $1; # Find the terminator, clean it up and determine # the type of here-doc we are dealing with. my $content = $token->{content}; if ( $content =~ /^\<\<(\w+)$/ ) { # Bareword $token->{_mode} = 'interpolate'; $token->{_terminator} = $1; } elsif ( $content =~ /^\<\<\s*\'(.*)\'$/ ) { # ''-quoted literal $token->{_mode} = 'literal'; $token->{_terminator} = $1; $token->{_terminator} =~ s/\\'/'/g; } elsif ( $content =~ /^\<\<\s*\"(.*)\"$/ ) { # ""-quoted literal $token->{_mode} = 'interpolate'; $token->{_terminator} = $1; $token->{_terminator} =~ s/\\"/"/g; } elsif ( $content =~ /^\<\<\s*\`(.*)\`$/ ) { # ``-quoted command $token->{_mode} = 'command'; $token->{_terminator} = $1; $token->{_terminator} =~ s/\\`/`/g; } elsif ( $content =~ /^\<\<\\(\w+)$/ ) { # Legacy forward-slashed bareword $token->{_mode} = 'literal'; $token->{_terminator} = $1; } else { # WTF? return undef; } # Define $line outside of the loop, so that if we encounter the # end of the file, we have access to the last line still. my $line; # Suck in the HEREDOC $token->{_heredoc} = []; my $terminator = $token->{_terminator} . "\n"; while ( defined($line = $t->_get_line) ) { if ( $line eq $terminator ) { # Keep the actual termination line for consistency # when we are re-assembling the file $token->{_terminator_line} = $line; # The HereDoc is now fully parsed return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Add the line push @{$token->{_heredoc}}, $line; } # End of file. # Error: Didn't reach end of here-doc before end of file. # $line might be undef if we get NO lines. if ( defined $line and $line eq $token->{_terminator} ) { # If the last line matches the terminator # but is missing the newline, we want to allow # it anyway (like perl itself does). In this case # perl would normally throw a warning, but we will # also ignore that as well. pop @{$token->{_heredoc}}; $token->{_terminator_line} = $line; } else { # The HereDoc was not properly terminated. $token->{_terminator_line} = undef; # Trim off the trailing whitespace if ( defined $token->{_heredoc}->[-1] and $t->{source_eof_chop} ) { chop $token->{_heredoc}->[-1]; $t->{source_eof_chop} = ''; } } # Set a hint for PPI::Document->serialize so it can # inexpensively repair it if needed when writing back out. $token->{_damaged} = 1; # The HereDoc is not fully parsed $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 TO DO - Implement PPI::Token::Quote interface compatibility - Check CPAN for any use of the null here-doc or here-doc-in-s///e - Add support for the null here-doc - Add support for here-doc in s///e =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Unknown.pm0000755000175100010010000002163512430462144013341 0ustar package PPI::Token::Unknown; =pod =head1 NAME PPI::Token::Unknown - Token of unknown or as-yet undetermined type =head1 INHERITANCE PPI::Token::Unknown isa PPI::Token isa PPI::Element =head1 DESCRIPTION Object of the type C exist primarily inside the tokenizer, where they are temporarily brought into existing for a very short time to represent a token that could be one of a number of types. Generally, they only exist for a character or two, after which they are resolved and converted into the correct type. For an object of this type to survive the parsing process is considered a major bug. Please report any C you encounter in a L object as a bug. =cut use strict; use PPI::Token (); use PPI::Exception (); use vars qw{$VERSION @ISA $CURLY_SYMBOL}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; $CURLY_SYMBOL = qr{\G\^[[:upper:]_]\w+\}}; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $t = $_[1]; # Tokenizer object my $c = $t->{token}->{content}; # Current token my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Current character # Now, we split on the different values of the current content if ( $c eq '*' ) { if ( $char =~ /(?:(?!\d)\w|\:)/ ) { # Symbol (unless the thing before it is a number my $tokens = $t->_previous_significant_tokens(1); my $p0 = $tokens->[0]; if ( $p0 and ! $p0->isa('PPI::Token::Number') ) { $t->{class} = $t->{token}->set_class( 'Symbol' ); return 1; } } if ( $char eq '{' ) { # Get rest of line pos $t->{line} = $t->{line_cursor} + 1; if ( $t->{line} =~ m/$CURLY_SYMBOL/gc ) { # control-character symbol (e.g. *{^_Foo}) $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } else { # Obvious GLOB cast $t->{class} = $t->{token}->set_class( 'Cast' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } } if ( $char eq '$' ) { # Operator/operand-sensitive, multiple or GLOB cast my $_class; my $tokens = $t->_previous_significant_tokens(1); my $p0 = $tokens->[0]; if ( $p0 ) { # Is it a token or a number if ( $p0->isa('PPI::Token::Symbol') ) { $_class = 'Operator'; } elsif ( $p0->isa('PPI::Token::Number') ) { $_class = 'Operator'; } elsif ( $p0->isa('PPI::Token::Structure') and $p0->content =~ /^(?:\)|\])$/ ) { $_class = 'Operator'; } else { ### This is pretty weak, there's ### room for a dozen more tests ### before going with a default. ### Or even better, a proper ### operator/operand method :( $_class = 'Cast'; } } else { # Nothing before it, must be glob cast $_class = 'Cast'; } # Set class and rerun $t->{class} = $t->{token}->set_class( $_class ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } if ( $char eq '*' || $char eq '=' ) { # Power operator '**' or mult-assign '*=' $t->{class} = $t->{token}->set_class( 'Operator' ); return 1; } $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } elsif ( $c eq '$' ) { if ( $char =~ /[a-z_]/i ) { # Symbol $t->{class} = $t->{token}->set_class( 'Symbol' ); return 1; } if ( $PPI::Token::Magic::magic{ $c . $char } ) { # Magic variable $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } if ( $char eq '{' ) { # Get rest of line pos $t->{line} = $t->{line_cursor} + 1; if ( $t->{line} =~ m/$CURLY_SYMBOL/gc ) { # control-character symbol (e.g. ${^MATCH}) $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } } # Must be a cast $t->{class} = $t->{token}->set_class( 'Cast' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } elsif ( $c eq '@' ) { if ( $char =~ /[\w:]/ ) { # Symbol $t->{class} = $t->{token}->set_class( 'Symbol' ); return 1; } if ( $PPI::Token::Magic::magic{ $c . $char } ) { # Magic variable $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } if ( $char eq '{' ) { # Get rest of line pos $t->{line} = $t->{line_cursor} + 1; if ( $t->{line} =~ m/$CURLY_SYMBOL/gc ) { # control-character symbol (e.g. @{^_Foo}) $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } } # Must be a cast $t->{class} = $t->{token}->set_class( 'Cast' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } elsif ( $c eq '%' ) { # Is it a number? if ( $char =~ /\d/ ) { # This is %2 (modulus number) $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Is it a magic variable? if ( $char eq '^' || $PPI::Token::Magic::magic{ $c . $char } ) { $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } # Is it a symbol? if ( $char =~ /[\w:]/ ) { $t->{class} = $t->{token}->set_class( 'Symbol' ); return 1; } if ( $char eq '{' ) { # Get rest of line pos $t->{line} = $t->{line_cursor} + 1; if ( $t->{line} =~ m/$CURLY_SYMBOL/gc ) { # control-character symbol (e.g. @{^_Foo}) $t->{class} = $t->{token}->set_class( 'Magic' ); return 1; } } if ( $char =~ /[\$@%*{]/ ) { # It's a cast $t->{class} = $t->{token}->set_class( 'Cast' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Probably the mod operator $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->{class}->__TOKENIZER__on_char( $t ); } elsif ( $c eq '&' ) { # Is it a number? if ( $char =~ /\d/ ) { # This is &2 (bitwise-and number) $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Is it a symbol if ( $char =~ /[\w:]/ ) { $t->{class} = $t->{token}->set_class( 'Symbol' ); return 1; } if ( $char =~ /[\$@%{]/ ) { # The ampersand is a cast $t->{class} = $t->{token}->set_class( 'Cast' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Probably the binary and operator $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->{class}->__TOKENIZER__on_char( $t ); } elsif ( $c eq '-' ) { if ( $char =~ /\d/o ) { # Number $t->{class} = $t->{token}->set_class( 'Number' ); return 1; } if ( $char eq '.' ) { # Number::Float $t->{class} = $t->{token}->set_class( 'Number::Float' ); return 1; } if ( $char =~ /[a-zA-Z]/ ) { $t->{class} = $t->{token}->set_class( 'DashedWord' ); return 1; } # The numeric negative operator $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->{class}->__TOKENIZER__on_char( $t ); } elsif ( $c eq ':' ) { if ( $char eq ':' ) { # ::foo style bareword $t->{class} = $t->{token}->set_class( 'Word' ); return 1; } # Now, : acts very very differently in different contexts. # Mainly, we need to find out if this is a subroutine attribute. # We'll leave a hint in the token to indicate that, if it is. if ( $_[0]->__TOKENIZER__is_an_attribute( $t ) ) { # This : is an attribute indicator $t->{class} = $t->{token}->set_class( 'Operator' ); $t->{token}->{_attribute} = 1; return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # It MIGHT be a label, but its probably the ?: trinary operator $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->{class}->__TOKENIZER__on_char( $t ); } # erm... PPI::Exception->throw('Unknown value in PPI::Token::Unknown token'); } # Are we at a location where a ':' would indicate a subroutine attribute sub __TOKENIZER__is_an_attribute { my $t = $_[1]; # Tokenizer object my $tokens = $t->_previous_significant_tokens(3); my $p0 = $tokens->[0]; # If we just had another attribute, we are also an attribute return 1 if $p0->isa('PPI::Token::Attribute'); # If we just had a prototype, then we are an attribute return 1 if $p0->isa('PPI::Token::Prototype'); # Other than that, we would need to have had a bareword return '' unless $p0->isa('PPI::Token::Word'); # We could be an anonymous subroutine if ( $p0->isa('PPI::Token::Word') and $p0->content eq 'sub' ) { return 1; } # Or, we could be a named subroutine my $p1 = $tokens->[1]; my $p2 = $tokens->[2]; if ( $p1->isa('PPI::Token::Word') and $p1->content eq 'sub' and ( $p2->isa('PPI::Token::Structure') or ( $p2->isa('PPI::Token::Whitespace') and $p2->content eq '' ) ) ) { return 1; } # We aren't an attribute ''; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Cast.pm0000755000175100010010000000260212430462144012565 0ustar package PPI::Token::Cast; =pod =head1 NAME PPI::Token::Cast - A prefix which forces a value into a different context =head1 INHERITANCE PPI::Token::Cast isa PPI::Token isa PPI::Element =head1 DESCRIPTION A "cast" in PPI terms is one of more characters used as a prefix which force a value into a different class or context. This includes referencing, dereferencing, and a few other minor cases. For expressions such as C<@$foo> or C<@{ $foo{bar} }> the C<@> in both cases represents a cast. In this case, an array dereference. =head1 METHODS There are no additional methods beyond those provided by the parent L and L classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # Tokenizer Methods # A cast is either % @ $ or $# sub __TOKENIZER__on_char { $_[1]->_finalize_token->__TOKENIZER__on_char( $_[1] ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Separator.pm0000755000175100010010000000250312430462144013633 0ustar package PPI::Token::Separator; =pod =head1 NAME PPI::Token::Separator - The __DATA__ and __END__ tags =head1 INHERITANCE PPI::Token::Separator isa PPI::Token::Word isa PPI::Token isa PPI::Element =head1 DESCRIPTION Although superficially looking like a normal L object, when the C<__DATA__> and C<__END__> compiler tags appear at the beginning of a line (on supposedly) their own line, these tags become file section separators. The indicate that the time for Perl code is over, and the rest of the file is dedicated to something else (data in the case of C<__DATA__>) or to nothing at all (in the case of C<__END__>). =head1 METHODS This class has no methods beyond what is provided by its L, L and L parent classes. =cut use strict; use PPI::Token::Word (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Word'; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Whitespace.pm0000755000175100010010000002715312430462144013777 0ustar package PPI::Token::Whitespace; =pod =head1 NAME PPI::Token::Whitespace - Tokens representing ordinary white space =head1 INHERITANCE PPI::Token::Whitespace isa PPI::Token isa PPI::Element =head1 DESCRIPTION As a full "round-trip" parser, PPI records every last byte in a file and ensure that it is included in the L object. This even includes whitespace. In fact, Perl documents are seen as "floating in a sea of whitespace", and thus any document will contain vast quantities of C objects. For the most part, you shouldn't notice them. Or at least, you shouldn't B to notice them. This means doing things like consistently using the "S for significant" series of L and L methods to do things. If you want the nth child element, you should be using C rather than C, and likewise C, C, and so on and so forth. =head1 METHODS Again, for the most part you should really B need to do anything very significant with whitespace. But there are a couple of convenience methods provided, beyond those provided by the parent L and L classes. =cut use strict; use Clone (); use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } =pod =head2 null Because L sees documents as sitting on a sort of substrate made of whitespace, there are a couple of corner cases that get particularly nasty if they don't find whitespace in certain places. Imagine walking down the beach to go into the ocean, and then quite unexpectedly falling off the side of the planet. Well it's somewhat equivalent to that, including the whole screaming death bit. The C method is a convenience provided to get some internals out of some of these corner cases. Specifically it create a whitespace token that represents nothing, or at least the null string C<''>. It's a handy way to have some "whitespace" right where you need it, without having to have any actual characters. =cut my $null; sub null { $null ||= $_[0]->new(''); Clone::clone($null); } ### XS -> PPI/XS.xs:_PPI_Token_Whitespace__significant 0.900+ sub significant() { '' } =pod =head2 tidy C is a convenience method for removing unneeded whitespace. Specifically, it removes any whitespace from the end of a line. Note that this B include POD, where you may well need to keep certain types of whitespace. The entire POD chunk lives in its own L object. =cut sub tidy { $_[0]->{content} =~ s/^\s+?(?>\n)//; 1; } ##################################################################### # Parsing Methods # Build the class and commit maps use vars qw{ @CLASSMAP @COMMITMAP %MATCHWORD }; BEGIN { @CLASSMAP = (); @COMMITMAP = (); foreach ( 'a' .. 'u', 'w', 'y', 'z', 'A' .. 'Z', '_' ) { $COMMITMAP[ord $_] = 'PPI::Token::Word'; } foreach ( qw!; [ ] { } )! ) { $COMMITMAP[ord $_] = 'PPI::Token::Structure' } foreach ( 0 .. 9 ) { $CLASSMAP[ord $_] = 'Number' } foreach ( qw{= ? | + > . ! ~ ^} ) { $CLASSMAP[ord $_] = 'Operator' } foreach ( qw{* $ @ & : %} ) { $CLASSMAP[ord $_] = 'Unknown' } # Miscellaneous remainder $COMMITMAP[ord '#'] = 'PPI::Token::Comment'; $COMMITMAP[ord 'v'] = 'PPI::Token::Number::Version'; $CLASSMAP[ord ','] = 'PPI::Token::Operator'; $CLASSMAP[ord "'"] = 'Quote::Single'; $CLASSMAP[ord '"'] = 'Quote::Double'; $CLASSMAP[ord '`'] = 'QuoteLike::Backtick'; $CLASSMAP[ord '\\'] = 'Cast'; $CLASSMAP[ord '_'] = 'Word'; $CLASSMAP[9] = 'Whitespace'; # A horizontal tab $CLASSMAP[10] = 'Whitespace'; # A newline $CLASSMAP[12] = 'Whitespace'; # A form feed $CLASSMAP[13] = 'Whitespace'; # A carriage return $CLASSMAP[32] = 'Whitespace'; # A normal space # Words (functions and keywords) after which a following / is # almost certainly going to be a regex %MATCHWORD = map { $_ => 1 } qw{ return split if unless grep map }; } sub __TOKENIZER__on_line_start { my $t = $_[1]; my $line = $t->{line}; # Can we classify the entire line in one go if ( $line =~ /^\s*$/ ) { # A whitespace line $t->_new_token( 'Whitespace', $line ); return 0; } elsif ( $line =~ /^\s*#/ ) { # A comment line $t->_new_token( 'Comment', $line ); $t->_finalize_token; return 0; } elsif ( $line =~ /^=(\w+)/ ) { # A Pod tag... change to pod mode $t->_new_token( 'Pod', $line ); if ( $1 eq 'cut' ) { # This is an error, but one we'll ignore # Don't go into Pod mode, since =cut normally # signals the end of Pod mode } else { $t->{class} = 'PPI::Token::Pod'; } return 0; } elsif ( $line =~ /^use v6\-alpha\;/ ) { # Indicates a Perl 6 block. Make the initial # implementation just suck in the entire rest of the # file. my @perl6; while ( 1 ) { my $line6 = $t->_get_line; last unless defined $line6; push @perl6, $line6; } push @{ $t->{perl6} }, join '', @perl6; # We only sucked in the block, we don't actually do # anything to the "use v6..." line. So return as if # we didn't find anything at all. return 1; } 1; } sub __TOKENIZER__on_char { my $t = $_[1]; my $char = ord substr $t->{line}, $t->{line_cursor}, 1; # Do we definitely know what something is? return $COMMITMAP[$char]->__TOKENIZER__commit($t) if $COMMITMAP[$char]; # Handle the simple option first return $CLASSMAP[$char] if $CLASSMAP[$char]; if ( $char == 40 ) { # $char eq '(' # Finalise any whitespace token... $t->_finalize_token if $t->{token}; # Is this the beginning of a sub prototype? # We are a sub prototype IF # 1. The previous significant token is a bareword. # 2. The one before that is the word 'sub'. # 3. The one before that is a 'structure' # Get the three previous significant tokens my $tokens = $t->_previous_significant_tokens(3); if ( $tokens ) { # A normal subroutine declaration my $p1 = $tokens->[1]; my $p2 = $tokens->[2]; if ( $tokens->[0]->isa('PPI::Token::Word') and $p1->isa('PPI::Token::Word') and $p1->content eq 'sub' and ( $p2->isa('PPI::Token::Structure') or ( $p2->isa('PPI::Token::Whitespace') and $p2->content eq '' ) ) ) { # This is a sub prototype return 'Prototype'; } # An prototyped anonymous subroutine my $p0 = $tokens->[0]; if ( $p0->isa('PPI::Token::Word') and $p0->content eq 'sub' # Maybe it's invoking a method named 'sub' and not ( $p1 and $p1->isa('PPI::Token::Operator') and $p1->content eq '->') ) { return 'Prototype'; } } # This is a normal open bracket return 'Structure'; } elsif ( $char == 60 ) { # $char eq '<' # Finalise any whitespace token... $t->_finalize_token if $t->{token}; # This is either "less than" or "readline quote-like" # Do some context stuff to guess which. my $prev = $t->_last_significant_token; # The most common group of less-thans are used like # $foo < $bar # 1 < $bar # $#foo < $bar return 'Operator' if $prev->isa('PPI::Token::Symbol'); return 'Operator' if $prev->isa('PPI::Token::Magic'); return 'Operator' if $prev->isa('PPI::Token::Number'); return 'Operator' if $prev->isa('PPI::Token::ArrayIndex'); # If it is <<... it's a here-doc instead my $next_char = substr( $t->{line}, $t->{line_cursor} + 1, 1 ); if ( $next_char eq '<' ) { return 'Operator'; } # The most common group of readlines are used like # while ( <...> ) # while <>; my $prec = $prev->content; if ( $prev->isa('PPI::Token::Structure') and $prec eq '(' ) { return 'QuoteLike::Readline'; } if ( $prev->isa('PPI::Token::Word') and $prec eq 'while' ) { return 'QuoteLike::Readline'; } if ( $prev->isa('PPI::Token::Operator') and $prec eq '=' ) { return 'QuoteLike::Readline'; } if ( $prev->isa('PPI::Token::Operator') and $prec eq ',' ) { return 'QuoteLike::Readline'; } if ( $prev->isa('PPI::Token::Structure') and $prec eq '}' ) { # Could go either way... do a regex check # $foo->{bar} < 2; # grep { .. } ; pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/\G<(?!\d)\w+>/gc ) { # Almost definitely readline return 'QuoteLike::Readline'; } } # Otherwise, we guess operator, which has been the default up # until this more comprehensive section was created. return 'Operator'; } elsif ( $char == 47 ) { # $char eq '/' # Finalise any whitespace token... $t->_finalize_token if $t->{token}; # This is either a "divided by" or a "start regex" # Do some context stuff to guess ( ack ) which. # Hopefully the guess will be good enough. my $prev = $t->_last_significant_token; my $prec = $prev->content; # Most times following an operator, we are a regex. # This includes cases such as: # , - As an argument in a list # .. - The second condition in a flip flop # =~ - A bound regex # !~ - Ditto return 'Regexp::Match' if $prev->isa('PPI::Token::Operator'); # After a symbol return 'Operator' if $prev->isa('PPI::Token::Symbol'); if ( $prec eq ']' and $prev->isa('PPI::Token::Structure') ) { return 'Operator'; } # After another number return 'Operator' if $prev->isa('PPI::Token::Number'); # After going into scope/brackets if ( $prev->isa('PPI::Token::Structure') and ( $prec eq '(' or $prec eq '{' or $prec eq ';' ) ) { return 'Regexp::Match'; } # Functions and keywords if ( $MATCHWORD{$prec} and $prev->isa('PPI::Token::Word') ) { return 'Regexp::Match'; } # Or as the very first thing in a file return 'Regexp::Match' if $prec eq ''; # What about the char after the slash? There's some things # that would be highly illogical to see if its an operator. my $next_char = substr $t->{line}, $t->{line_cursor} + 1, 1; if ( defined $next_char and length $next_char ) { if ( $next_char =~ /(?:\^|\[|\\)/ ) { return 'Regexp::Match'; } } # Otherwise... erm... assume operator? # Add more tests here as potential cases come to light return 'Operator'; } elsif ( $char == 120 ) { # $char eq 'x' # x followed immediately by a digit can be the x # operator or a word. Disambiguate by checking # whether the previous token is an operator that cannot be # followed by the x operator, e.g.: +. # # x followed immediately by '=' is the 'x=' operator, not # 'x ='. An important exception is x followed immediately by # '=>', which makes the x into a bareword. pos $t->{line} = $t->{line_cursor} + 1; return 'Operator' if $t->_current_x_is_operator and $t->{line} =~ m/\G(?:\d|(?!(=>|[\w\s])))/gc; # Otherwise, commit like a normal bareword return PPI::Token::Word->__TOKENIZER__commit($t); } elsif ( $char == 45 ) { # $char eq '-' # Look for an obvious operator operand context my $context = $t->_opcontext; if ( $context eq 'operator' ) { return 'Operator'; } else { # More logic needed return 'Unknown'; } } elsif ( $char >= 128 ) { # Outside ASCII return 'PPI::Token::Word'->__TOKENIZER__commit($t) if $t =~ /\w/; return 'Whitespace' if $t =~ /\s/; } # All the whitespaces are covered, so what to do ### For now, die PPI::Exception->throw("Encountered unexpected character '$char'"); } sub __TOKENIZER__on_line_end { $_[1]->_finalize_token if $_[1]->{token}; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/DashedWord.pm0000755000175100010010000000372212430462144013723 0ustar package PPI::Token::DashedWord; =pod =head1 NAME PPI::Token::DashedWord - A dashed bareword token =head1 INHERITANCE PPI::Token::DashedWord isa PPI::Token isa PPI::Element =head1 DESCRIPTION The "dashed bareword" token represents literal values like C<-foo>. NOTE: this class is currently unused. All tokens that should be PPI::Token::DashedWords are just normal PPI::Token::Word instead. That actually makes sense, since there really is nothing special about this class except that dashed words cannot be subroutine names or keywords. As such, this class may be removed from PPI in the future. =head1 METHODS =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } =pod =head2 literal Returns the value of the dashed word as a string. This differs from C because C<-Foo'Bar> expands to C<-Foo::Bar>. =cut *literal = *PPI::Token::Word::literal; ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $t = $_[1]; # Suck to the end of the dashed bareword pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/\G(\w+)/gc ) { $t->{token}->{content} .= $1; $t->{line_cursor} += length $1; } # Are we a file test operator? if ( $t->{token}->{content} =~ /^\-[rwxoRWXOezsfdlpSbctugkTBMAC]$/ ) { # File test operator $t->{class} = $t->{token}->set_class( 'Operator' ); } else { # No, normal dashed bareword $t->{class} = $t->{token}->set_class( 'Word' ); } $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/BOM.pm0000755000175100010010000000475512430462144012323 0ustar package PPI::Token::BOM; =pod =head1 NAME PPI::Token::BOM - Tokens representing Unicode byte order marks =head1 INHERITANCE PPI::Token::BOM isa PPI::Token isa PPI::Element =head1 DESCRIPTION This is a special token in that it can only occur at the beginning of documents. If a BOM byte mark occurs elsewhere in a file, it should be treated as L. We recognize the byte order marks identified at this URL: L UTF-32, big-endian 00 00 FE FF UTF-32, little-endian FF FE 00 00 UTF-16, big-endian FE FF UTF-16, little-endian FF FE UTF-8 EF BB BF Note that as of this writing, PPI only has support for UTF-8 (namely, in POD and strings) and no support for UTF-16 or UTF-32. We support the BOMs of the latter two for completeness only. The BOM is considered non-significant, like white space. =head1 METHODS There are no additional methods beyond those provided by the parent L and L classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } sub significant() { '' } ##################################################################### # Parsing Methods my %bom_types = ( "\x00\x00\xfe\xff" => 'UTF-32', "\xff\xfe\x00\x00" => 'UTF-32', "\xfe\xff" => 'UTF-16', "\xff\xfe" => 'UTF-16', "\xef\xbb\xbf" => 'UTF-8', ); sub __TOKENIZER__on_line_start { my $t = $_[1]; $_ = $t->{line}; if (m/^(\x00\x00\xfe\xff | # UTF-32, big-endian \xff\xfe\x00\x00 | # UTF-32, little-endian \xfe\xff | # UTF-16, big-endian \xff\xfe | # UTF-16, little-endian \xef\xbb\xbf) # UTF-8 /xs) { my $bom = $1; if ($bom_types{$bom} ne 'UTF-8') { return $t->_error("$bom_types{$bom} is not supported"); } $t->_new_token('BOM', $bom) or return undef; $t->{line_cursor} += length $bom; } # Continue just as if there was no BOM $t->{class} = 'PPI::Token::Whitespace'; return $t->{class}->__TOKENIZER__on_line_start($t); } 1; =pod =head1 SUPPORT See the L in the main module =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Label.pm0000755000175100010010000000215212430462144012712 0ustar package PPI::Token::Label; =pod =head1 NAME PPI::Token::Label - Token class for a statement label =head1 INHERITANCE PPI::Token::Label isa PPI::Token isa PPI::Element =head1 DESCRIPTION A label is an identifier attached to a line or statements, to allow for various types of flow control. For example, a loop might have a label attached so that a C or C flow control statement can be used from multiple levels below to reference the loop directly. =head1 METHODS There are no additional methods beyond those provided by the parent L and L classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Prototype.pm0000755000175100010010000000476612430462144013715 0ustar package PPI::Token::Prototype; =pod =head1 NAME PPI::Token::Prototype - A subroutine prototype descriptor =head1 INHERITANCE PPI::Token::End isa PPI::Token isa PPI::Element =head1 SYNOPSIS sub ($@) prototype; =head1 DESCRIPTION Although it sort of looks like a list or condition, a subroutine prototype is a lot more like a string. Its job is to provide hints to the perl compiler on what type of arguments a particular subroutine expects, which the compiler uses to validate parameters at compile-time, and allows programmers to use the functions without explicit parameter parens. Due to the rise of OO Perl coding, which ignores these prototypes, they are most often used to allow for constant-like things, and to "extend" the language and create things that act like keywords and core functions. # Create something that acts like a constant sub MYCONSTANT () { 10 } # Create the "any" core-looking function sub any (&@) { ... } if ( any { $_->cute } @babies ) { ... } =head1 METHODS This class provides one additional method beyond those defined by the L and L parent classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } sub __TOKENIZER__on_char { my $class = shift; my $t = shift; # Suck in until we find the closing paren (or the end of line) pos $t->{line} = $t->{line_cursor}; die "regex should always match" if $t->{line} !~ m/\G(.*?(?:\)|$))/gc; $t->{token}->{content} .= $1; $t->{line_cursor} += length $1; # Shortcut if end of line return 0 unless $1 =~ /\)$/; # Found the closing paren $t->_finalize_token->__TOKENIZER__on_char( $t ); } =pod =head2 prototype The C accessor returns the actual prototype pattern, stripped of flanking parens and of all whitespace. This mirrors the behavior of the Perl C builtin function. Note that stripping parens and whitespace means that the return of C can be an empty string. =cut sub prototype { my $self = shift; my $proto = $self->content; $proto =~ s/(^\(|\)$|\s+)//g; $proto; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Word.pm0000755000175100010010000002735212430462144012617 0ustar package PPI::Token::Word; =pod =head1 NAME PPI::Token::Word - The generic "word" Token =head1 INHERITANCE PPI::Token::Word isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object is a PPI-specific representation of several different types of word-like things, and is one of the most common Token classes found in typical documents. Specifically, it includes not only barewords, but also any other valid Perl identifier including non-operator keywords and core functions, and any include C<::> separators inside it, as long as it fits the format of a class, function, etc. =head1 METHODS There are no methods available for C beyond those provided by its L and L parent classes. We expect to add additional methods to help further resolve a Word as a function, method, etc over time. If you need such a thing right now, look at L. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA %OPERATOR %QUOTELIKE %KEYWORDS}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; # Copy in OPERATOR from PPI::Token::Operator *OPERATOR = *PPI::Token::Operator::OPERATOR; %QUOTELIKE = ( 'q' => 'Quote::Literal', 'qq' => 'Quote::Interpolate', 'qx' => 'QuoteLike::Command', 'qw' => 'QuoteLike::Words', 'qr' => 'QuoteLike::Regexp', 'm' => 'Regexp::Match', 's' => 'Regexp::Substitute', 'tr' => 'Regexp::Transliterate', 'y' => 'Regexp::Transliterate', ); # List of keywords is from regen/keywords.pl in the perl source. %KEYWORDS = map { $_ => 1 } qw{ abs accept alarm and atan2 bind binmode bless break caller chdir chmod chomp chop chown chr chroot close closedir cmp connect continue cos crypt dbmclose dbmopen default defined delete die do dump each else elsif endgrent endhostent endnetent endprotoent endpwent endservent eof eq eval evalbytes exec exists exit exp fc fcntl fileno flock for foreach fork format formline ge getc getgrent getgrgid getgrnam gethostbyaddr gethostbyname gethostent getlogin getnetbyaddr getnetbyname getnetent getpeername getpgrp getppid getpriority getprotobyname getprotobynumber getprotoent getpwent getpwnam getpwuid getservbyname getservbyport getservent getsockname getsockopt given glob gmtime goto grep gt hex if index int ioctl join keys kill last lc lcfirst le length link listen local localtime lock log lstat lt m map mkdir msgctl msgget msgrcv msgsnd my ne next no not oct open opendir or ord our pack package pipe pop pos print printf prototype push q qq qr quotemeta qw qx rand read readdir readline readlink readpipe recv redo ref rename require reset return reverse rewinddir rindex rmdir s say scalar seek seekdir select semctl semget semop send setgrent sethostent setnetent setpgrp setpriority setprotoent setpwent setservent setsockopt shift shmctl shmget shmread shmwrite shutdown sin sleep socket socketpair sort splice split sprintf sqrt srand stat state study sub substr symlink syscall sysopen sysread sysseek system syswrite tell telldir tie tied time times tr truncate uc ucfirst umask undef unless unlink unpack unshift untie until use utime values vec wait waitpid wantarray warn when while write x xor y }; } =pod =head2 literal Returns the value of the Word as a string. This assumes (often incorrectly) that the Word is a bareword and not a function, method, keyword, etc. This differs from C because C expands to C. =cut sub literal { my $self = shift; my $word = $self->content; # Expand Foo'Bar to Foo::Bar $word =~ s/\'/::/g; return $word; } =pod =head2 method_call Answers whether this is the name of a method in a method call. Returns true if yes, false if no, and nothing if unknown. =cut sub method_call { my $self = shift; my $previous = $self->sprevious_sibling; if ( $previous and $previous->isa('PPI::Token::Operator') and $previous->content eq '->' ) { return 1; } my $snext = $self->snext_sibling; return 0 unless $snext; if ( $snext->isa('PPI::Structure::List') or $snext->isa('PPI::Token::Structure') or $snext->isa('PPI::Token::Operator') and ( $snext->content eq ',' or $snext->content eq '=>' ) ) { return 0; } if ( $snext->isa('PPI::Token::Word') and $snext->content =~ m< \w :: \z >xms ) { return 1; } return; } sub __TOKENIZER__on_char { my $class = shift; my $t = shift; # Suck in till the end of the bareword pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/\G(\w+(?:(?:\'|::)\w+)*(?:::)?)/gc ) { my $word = $1; # Special Case: If we accidentally treat eq'foo' like # the word "eq'foo", then just make 'eq' (or whatever # else is in the %KEYWORDS hash. if ( $word =~ /^(\w+)'/ && $KEYWORDS{$1} ) { $word = $1; } $t->{token}->{content} .= $word; $t->{line_cursor} += length $word; } # We might be a subroutine attribute. my $tokens = $t->_previous_significant_tokens(1); if ( $tokens and $tokens->[0]->{_attribute} ) { $t->{class} = $t->{token}->set_class( 'Attribute' ); return $t->{class}->__TOKENIZER__commit( $t ); } # Check for a quote like operator my $word = $t->{token}->{content}; if ( $QUOTELIKE{$word} and ! $class->__TOKENIZER__literal($t, $word, $tokens) ) { $t->{class} = $t->{token}->set_class( $QUOTELIKE{$word} ); return $t->{class}->__TOKENIZER__on_char( $t ); } # Or one of the word operators if ( $OPERATOR{$word} and ! $class->__TOKENIZER__literal($t, $word, $tokens) ) { $t->{class} = $t->{token}->set_class( 'Operator' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Unless this is a simple identifier, at this point # it has to be a normal bareword if ( $word =~ /\:/ ) { return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # If the NEXT character in the line is a colon, this # is a label. my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); if ( $char eq ':' ) { $t->{token}->{content} .= ':'; $t->{line_cursor}++; $t->{class} = $t->{token}->set_class( 'Label' ); # If not a label, '_' on its own is the magic filehandle } elsif ( $word eq '_' ) { $t->{class} = $t->{token}->set_class( 'Magic' ); } # Finalise and process the character again $t->_finalize_token->__TOKENIZER__on_char( $t ); } # We are committed to being a bareword. # Or so we would like to believe. sub __TOKENIZER__commit { my ($class, $t) = @_; # Our current position is the first character of the bareword. # Capture the bareword. pos $t->{line} = $t->{line_cursor}; unless ( $t->{line} =~ m/\G((?!\d)\w+(?:(?:\'|::)\w+)*(?:::)?)/gc ) { # Programmer error die sprintf "Fatal error... regex failed to match in '%s' when expected", substr $t->{line}, $t->{line_cursor}; } # Special Case: If we accidentally treat eq'foo' like the word "eq'foo", # then unwind it and just make it 'eq' (or the other stringy comparitors) my $word = $1; if ( $word =~ /^(\w+)'/ && $KEYWORDS{$1} ) { $word = $1; } # Advance the position one after the end of the bareword $t->{line_cursor} += length $word; # We might be a subroutine attribute. my $tokens = $t->_previous_significant_tokens(1); if ( $tokens and $tokens->[0]->{_attribute} ) { $t->_new_token( 'Attribute', $word ); return ($t->{line_cursor} >= $t->{line_length}) ? 0 : $t->{class}->__TOKENIZER__on_char($t); } # Check for the end of the file if ( $word eq '__END__' ) { # Create the token for the __END__ itself $t->_new_token( 'Separator', $1 ); $t->_finalize_token; # Move into the End zone (heh) $t->{zone} = 'PPI::Token::End'; # Add the rest of the line as a comment, and a whitespace newline # Anything after the __END__ on the line is "ignored". So we must # also ignore it, by turning it into a comment. my $end_rest = substr( $t->{line}, $t->{line_cursor} ); $t->{line_cursor} = length $t->{line}; if ( $end_rest =~ /\n$/ ) { chomp $end_rest; $t->_new_token( 'Comment', $end_rest ) if length $end_rest; $t->_new_token( 'Whitespace', "\n" ); } else { $t->_new_token( 'Comment', $end_rest ) if length $end_rest; } $t->_finalize_token; return 0; } # Check for the data section if ( $word eq '__DATA__' ) { # Create the token for the __DATA__ itself $t->_new_token( 'Separator', "$1" ); $t->_finalize_token; # Move into the Data zone $t->{zone} = 'PPI::Token::Data'; # Add the rest of the line as the Data token my $data_rest = substr( $t->{line}, $t->{line_cursor} ); $t->{line_cursor} = length $t->{line}; if ( $data_rest =~ /\n$/ ) { chomp $data_rest; $t->_new_token( 'Comment', $data_rest ) if length $data_rest; $t->_new_token( 'Whitespace', "\n" ); } else { $t->_new_token( 'Comment', $data_rest ) if length $data_rest; } $t->_finalize_token; return 0; } my $token_class; if ( $word =~ /\:/ ) { # Since its not a simple identifier... $token_class = 'Word'; } elsif ( $class->__TOKENIZER__literal($t, $word, $tokens) ) { $token_class = 'Word'; } elsif ( $QUOTELIKE{$word} ) { # Special Case: A Quote-like operator $t->_new_token( $QUOTELIKE{$word}, $word ); return ($t->{line_cursor} >= $t->{line_length}) ? 0 : $t->{class}->__TOKENIZER__on_char( $t ); } elsif ( $OPERATOR{$word} && ($word ne 'x' || $t->_current_x_is_operator) ) { # Word operator $token_class = 'Operator'; } else { # If the next character is a ':' then its a label... pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/\G(\s*:)(?!:)/gc ) { if ( $tokens and $tokens->[0]->{content} eq 'sub' ) { # ... UNLESS its after 'sub' in which # case it is a sub name and an attribute # operator. # We COULD have checked this at the top # level of checks, but this would impose # an additional performance per-word # penalty, and every other case where the # attribute operator doesn't directly # touch the object name already works. $token_class = 'Word'; } else { $word .= $1; $t->{line_cursor} += length($1); $token_class = 'Label'; } } elsif ( $word eq '_' ) { $token_class = 'Magic'; } else { $token_class = 'Word'; } } # Create the new token and finalise $t->_new_token( $token_class, $word ); if ( $t->{line_cursor} >= $t->{line_length} ) { # End of the line $t->_finalize_token; return 0; } $t->_finalize_token->__TOKENIZER__on_char($t); } # Is the word in a "forced" context, and thus cannot be either an # operator or a quote-like thing. This version is only useful # during tokenization. sub __TOKENIZER__literal { my ($class, $t, $word, $tokens) = @_; # Is this a forced-word context? # i.e. Would normally be seen as an operator. unless ( $QUOTELIKE{$word} or $PPI::Token::Operator::OPERATOR{$word} ) { return ''; } # Check the cases when we have previous tokens pos $t->{line} = $t->{line_cursor}; if ( $tokens ) { my $token = $tokens->[0] or return ''; # We are forced if we are a method name return 1 if $token->{content} eq '->'; # We are forced if we are a sub name return 1 if $token->isa('PPI::Token::Word') && $token->{content} eq 'sub'; # If we are contained in a pair of curly braces, # we are probably a bareword hash key if ( $token->{content} eq '{' and $t->{line} =~ /\G\s*\}/gc ) { return 1; } } # In addition, if the word is followed by => it is probably # also actually a word and not a regex. if ( $t->{line} =~ /\G\s*=>/gc ) { return 1; } # Otherwise we probably aren't forced ''; } 1; =pod =head1 TO DO - Add C, C etc detector methods =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Attribute.pm0000755000175100010010000000742012430462144013641 0ustar package PPI::Token::Attribute; =pod =head1 NAME PPI::Token::Attribute - A token for a subroutine attribute =head1 INHERITANCE PPI::Token::Attribute isa PPI::Token isa PPI::Element =head1 DESCRIPTION In Perl, attributes are a relatively recent addition to the language. Given the code C< sub foo : bar(something) {} >, the C part is the attribute. A C token represents the entire of the attribute, as the braces and its contents are not parsed into the tree, and are treated by Perl (and thus by us) as a single string. =head1 METHODS This class provides some additional methods beyond those provided by its L and L parent classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # PPI::Token::Attribute Methods =pod =head2 identifier The C attribute returns the identifier part of the attribute. That is, for the attribute C, the C method would return C<"foo">. =cut sub identifier { my $self = shift; $self->{content} =~ /^(.+?)\(/ ? $1 : $self->{content}; } =pod =head2 parameters The C method returns the parameter string for the attribute. That is, for the attribute C, the C method would return C<"bar">. Returns the parameters as a string (including the null string C<''> for the case of an attribute such as C.) Returns C if the attribute does not have parameters. =cut sub parameters { my $self = shift; $self->{content} =~ /\((.+)\)$/ ? $1 : undef; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Unless this is a '(', we are finished. unless ( $char eq '(' ) { # Finalise and recheck return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # This is a bar(...) style attribute. # We are currently on the ( so scan in until the end. # We finish on the character AFTER our end my $string = $class->__TOKENIZER__scan_for_end( $t ); if ( ref $string ) { # EOF $t->{token}->{content} .= $$string; $t->_finalize_token; return 0; } # Found the end of the attribute $t->{token}->{content} .= $string; $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Scan for a close braced, and take into account both escaping, # and open close bracket pairs in the string. When complete, the # method leaves the line cursor on the LAST character found. sub __TOKENIZER__scan_for_end { my $t = $_[1]; # Loop as long as we can get new lines my $string = ''; my $depth = 0; while ( exists $t->{line} ) { # Get the search area pos $t->{line} = $t->{line_cursor}; # Look for a match unless ( $t->{line} =~ /\G((?:\\.|[^()])*?[()])/gc ) { # Load in the next line and push to first character $string .= substr( $t->{line}, $t->{line_cursor} ); $t->_fill_line(1) or return \$string; $t->{line_cursor} = 0; next; } # Add to the string $string .= $1; $t->{line_cursor} += length $1; # Alter the depth and continue if we aren't at the end $depth += ($1 =~ /\($/) ? 1 : -1 and next; # Found the end return $string; } # Returning the string as a reference indicates EOF \$string; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Pod.pm0000755000175100010010000000607212430462144012422 0ustar package PPI::Token::Pod; =pod =head1 NAME PPI::Token::Pod - Sections of POD in Perl documents =head1 INHERITANCE PPI::Token::Pod isa PPI::Token isa PPI::Element =head1 DESCRIPTION A single C object represents a complete section of POD documentation within a Perl document. =head1 METHODS This class provides some additional methods beyond those provided by its L and L parent classes. =cut use strict; use Params::Util qw{_INSTANCE}; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # PPI::Token::Pod Methods =pod =head2 merge @podtokens The C constructor takes a number of C objects, and returns a new object that represents one combined POD block with the content of all of them. Returns a new C object, or C on error. =cut sub merge { my $class = (! ref $_[0]) ? shift : return undef; # Check there are no bad arguments if ( grep { ! _INSTANCE($_, 'PPI::Token::Pod') } @_ ) { return undef; } # Get the tokens, and extract the lines my @content = ( map { [ $_->lines ] } @_ ) or return undef; # Remove the leading =pod tags, trailing =cut tags, and any empty lines # between them and the pod contents. foreach my $pod ( @content ) { # Leading =pod tag if ( @$pod and $pod->[0] =~ /^=pod\b/o ) { shift @$pod; } # Trailing =cut tag if ( @$pod and $pod->[-1] =~ /^=cut\b/o ) { pop @$pod; } # Leading and trailing empty lines while ( @$pod and $pod->[0] eq '' ) { shift @$pod } while ( @$pod and $pod->[-1] eq '' ) { pop @$pod } } # Remove any empty pod sections, and add the =pod and =cut tags # for the merged pod back to it. @content = ( [ '=pod' ], grep { @$_ } @content, [ '=cut' ] ); # Create the new object $class->new( join "\n", map { join( "\n", @$_ ) . "\n" } @content ); } =pod =head2 lines The C method takes the string of POD and breaks it into lines, returning them as a list. =cut sub lines { split /(?:\015{1,2}\012|\015|\012)/, $_[0]->{content}; } ##################################################################### # PPI::Element Methods ### XS -> PPI/XS.xs:_PPI_Token_Pod__significant 0.900+ sub significant() { '' } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_line_start { my $t = $_[1]; # Add the line to the token first $t->{token}->{content} .= $t->{line}; # Check the line to see if it is a =cut line if ( $t->{line} =~ /^=(\w+)/ ) { # End of the token $t->_finalize_token if $1 eq 'cut'; } 0; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Comment.pm0000755000175100010010000000661412430462144013304 0ustar package PPI::Token::Comment; =pod =head1 NAME PPI::Token::Comment - A comment in Perl source code =head1 INHERITANCE PPI::Token::Comment isa PPI::Token isa PPI::Element =head1 SYNOPSIS # This is a PPI::Token::Comment print "Hello World!"; # So it this $string =~ s/ foo # This, unfortunately, is not :( bar /w; =head1 DESCRIPTION In PPI, comments are represented by C objects. These come in two flavours, line comment and inline comments. A C is a comment that stands on its own line. These comments hold their own newline and whitespace (both leading and trailing) as part of the one C object. An inline comment is a comment that appears after some code, and continues to the end of the line. This does B include whitespace, and the terminating newlines is considered a separate L token. This is largely a convenience, simplifying a lot of normal code relating to the common things people do with comments. Most commonly, it means when you C or C a comment, a line comment disappears taking the entire line with it, and an inline comment is removed from the inside of the line, allowing the newline to drop back onto the end of the code, as you would expect. It also means you can move comments around in blocks much more easily. For now, this is a suitably handy way to do things. However, I do reserve the right to change my mind on this one if it gets dangerously anachronistic somewhere down the line. =head1 METHODS Only very limited methods are available, beyond those provided by our parent L and L classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ### XS -> PPI/XS.xs:_PPI_Token_Comment__significant 0.900+ sub significant() { '' } # Most stuff goes through __TOKENIZER__commit. # This is such a rare case, do char at a time to keep the code small sub __TOKENIZER__on_char { my $t = $_[1]; # Make sure not to include the trailing newline if ( substr( $t->{line}, $t->{line_cursor}, 1 ) eq "\n" ) { return $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; } sub __TOKENIZER__commit { my $t = $_[1]; # Get the rest of the line my $rest = substr( $t->{line}, $t->{line_cursor} ); if ( chomp $rest ) { # Include the newline separately # Add the current token, and the newline $t->_new_token('Comment', $rest); $t->_new_token('Whitespace', "\n"); } else { # Add this token only $t->_new_token('Comment', $rest); } # Advance the line cursor to the end $t->{line_cursor} = $t->{line_length} - 1; 0; } # Comments end at the end of the line sub __TOKENIZER__on_line_end { $_[1]->_finalize_token if $_[1]->{token}; 1; } =pod =head2 line The C accessor returns true if the C is a line comment, or false if it is an inline comment. =cut sub line { # Entire line comments have a newline at the end $_[0]->{content} =~ /\n$/ ? 1 : 0; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Symbol.pm0000755000175100010010000001233112430462144013140 0ustar package PPI::Token::Symbol; =pod =head1 NAME PPI::Token::Symbol - A token class for variables and other symbols =head1 INHERITANCE PPI::Token::Symbol isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used to cover all tokens that represent variables and other things that start with a sigil. =head1 METHODS This class has several methods beyond what is provided by its L and L parent classes. Most methods are provided to help work out what the object is actually pointing at, rather than what it might appear to be pointing at. =cut use strict; use Params::Util qw{_INSTANCE}; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # PPI::Token::Symbol Methods =pod =head2 canonical The C method returns a normalized, canonical version of the symbol. For example, it converts C<$ ::foo'bar::baz> to C<$main::foo::bar::baz>. This does not fully resolve the symbol, but merely removes syntax variations. =cut sub canonical { my $symbol = shift->content; $symbol =~ s/\s+//; $symbol =~ s/(?<=[\$\@\%\&\*])::/main::/; $symbol =~ s/\'/::/g; $symbol; } =pod =head2 symbol The C method returns the ACTUAL symbol this token refers to. A token of C<$foo> might actually be referring to C<@foo>, if it is found in the form C<$foo[1]>. This method attempts to resolve these issues to determine the actual symbol. Returns the symbol as a string. =cut my %cast_which_trumps_braces = map { $_ => 1 } qw{ $ @ }; sub symbol { my $self = shift; my $symbol = $self->canonical; # Immediately return the cases where it can't be anything else my $type = substr( $symbol, 0, 1 ); return $symbol if $type eq '%'; return $symbol if $type eq '&'; # Unless the next significant Element is a structure, it's correct. my $after = $self->snext_sibling; return $symbol unless _INSTANCE($after, 'PPI::Structure'); # Process the rest for cases where it might actually be something else my $braces = $after->braces; return $symbol unless defined $braces; if ( $type eq '$' ) { # If it is cast to '$' or '@', that trumps any braces my $before = $self->sprevious_sibling; return $symbol if $before && $before->isa( 'PPI::Token::Cast' ) && $cast_which_trumps_braces{ $before->content }; # Otherwise the braces rule substr( $symbol, 0, 1, '@' ) if $braces eq '[]'; substr( $symbol, 0, 1, '%' ) if $braces eq '{}'; } elsif ( $type eq '@' ) { substr( $symbol, 0, 1, '%' ) if $braces eq '{}'; } $symbol; } =pod =head2 raw_type The C method returns the B type of the symbol in the form of its sigil. Returns the sigil as a string. =cut sub raw_type { substr( $_[0]->content, 0, 1 ); } =pod =head2 symbol_type The C method returns the B type of the symbol in the form of its sigil. Returns the sigil as a string. =cut sub symbol_type { substr( $_[0]->symbol, 0, 1 ); } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $t = $_[1]; # Suck in till the end of the symbol pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/\G([\w:\']+)/gc ) { $t->{token}->{content} .= $1; $t->{line_cursor} += length $1; } # Handle magic things my $content = $t->{token}->{content}; if ( $content eq '@_' or $content eq '$_' ) { $t->{class} = $t->{token}->set_class( 'Magic' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Shortcut for most of the X:: symbols if ( $content eq '$::' ) { # May well be an alternate form of a Magic my $nextchar = substr( $t->{line}, $t->{line_cursor}, 1 ); if ( $nextchar eq '|' ) { $t->{token}->{content} .= $nextchar; $t->{line_cursor}++; $t->{class} = $t->{token}->set_class( 'Magic' ); } return $t->_finalize_token->__TOKENIZER__on_char( $t ); } if ( $content =~ /^[\$%*@&]::(?:[^\w]|$)/ ) { my $current = substr( $content, 0, 3, '' ); $t->{token}->{content} = $current; $t->{line_cursor} -= length( $content ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } if ( $content =~ /^(?:\$|\@)\d+/ ) { $t->{class} = $t->{token}->set_class( 'Magic' ); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Trim off anything we oversucked... $content =~ /^( [\$@%&*] (?: : (?!:) | # Allow single-colon non-magic vars (?: \w+ | \' (?!\d) \w+ | \:: \w+ ) (?: # Allow both :: and ' in namespace separators (?: \' (?!\d) \w+ | \:: \w+ ) )* (?: :: )? # Technically a compiler-magic hash, but keep it here ) )/x or return undef; unless ( length $1 eq length $content ) { $t->{line_cursor} += length($1) - length($content); $t->{token}->{content} = $1; } $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Magic.pm0000755000175100010010000001376412430462144012726 0ustar package PPI::Token::Magic; =pod =head1 NAME PPI::Token::Magic - Tokens representing magic variables =head1 INHERITANCE PPI::Token::Magic isa PPI::Token::Symbol isa PPI::Token isa PPI::Element =head1 SYNOPSIS # When we say magic variables, we mean these... $1 $2 $3 $4 $5 $6 $7 $8 $9 $_ $& $` $' $+ @+ %+ $* $. $/ $| $\\ $" $; $% $= $- @- %- $) $# $~ $^ $: $? $! %! $@ $$ $< $> $( $0 $[ $] @_ @* $} $, $#+ $#- $^L $^A $^E $^C $^D $^F $^H $^I $^M $^N $^O $^P $^R $^S $^T $^V $^W $^X =head1 DESCRIPTION C is a sub-class of L which identifies the token as "magic variable", one of the strange and unusual variables that are connected to "things" behind the scenes. Some are extremely common, like C<$_>, and others you will quite probably never encounter in your Perl career. =head1 METHODS The class provides no additional methods, beyond those provided by it's L, L and L. =cut use strict; use PPI::Token::Symbol (); use PPI::Token::Unknown (); use vars qw{$VERSION @ISA %magic}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Symbol'; # Magic variables taken from perlvar. # Several things added separately to avoid warnings. foreach ( qw{ $1 $2 $3 $4 $5 $6 $7 $8 $9 $_ $& $` $' $+ @+ %+ $* $. $/ $| $\\ $" $; $% $= $- @- %- $) $~ $^ $: $? $! %! $@ $$ $< $> $( $0 $[ $] @_ @* $^L $^A $^E $^C $^D $^F $^H $^I $^M $^N $^O $^P $^R $^S $^T $^V $^W $^X %^H $::| }, '$}', '$,', '$#', '$#+', '$#-' ) { $magic{$_} = 1; } } sub __TOKENIZER__on_char { my $t = $_[1]; # $c is the candidate new content my $c = $t->{token}->{content} . substr( $t->{line}, $t->{line_cursor}, 1 ); # Do a quick first test so we don't have to do more than this one. # All of the tests below match this one, so it should provide a # small speed up. This regex should be updated to match the inside # tests if they are changed. if ( $c =~ /^ \$ .* [ \w : \$ \{ ] $/x ) { if ( $c =~ /^(\$(?:\_[\w:]|::))/ or $c =~ /^\$\'[\w]/ ) { # If and only if we have $'\d, it is not a # symbol. (this was apparently a conscious choice) # Note that $::0 on the other hand is legal if ( $c =~ /^\$\'\d$/ ) { # In this case, we have a magic plus a digit. # Save the CURRENT token, and rerun the on_char return $t->_finalize_token->__TOKENIZER__on_char( $t ); } # A symbol in the style $_foo or $::foo or $'foo. # Overwrite the current token $t->{class} = $t->{token}->set_class('Symbol'); return PPI::Token::Symbol->__TOKENIZER__on_char( $t ); } if ( $c =~ /^\$\$\w/ ) { # This is really a scalar dereference. ( $$foo ) # Add the current token as the cast... $t->{token} = PPI::Token::Cast->new( '$' ); $t->_finalize_token; # ... and create a new token for the symbol return $t->_new_token( 'Symbol', '$' ); } if ( $c eq '$${' ) { # This _might_ be a dereference of one of the # control-character symbols. pos $t->{line} = $t->{line_cursor} + 1; if ( $t->{line} =~ m/$PPI::Token::Unknown::CURLY_SYMBOL/gc ) { # This is really a dereference. ( $${^_foo} ) # Add the current token as the cast... $t->{token} = PPI::Token::Cast->new( '$' ); $t->_finalize_token; # ... and create a new token for the symbol return $t->_new_token( 'Magic', '$' ); } } if ( $c eq '$#$' or $c eq '$#{' ) { # This is really an index dereferencing cast, although # it has the same two chars as the magic variable $#. $t->{class} = $t->{token}->set_class('Cast'); return $t->_finalize_token->__TOKENIZER__on_char( $t ); } if ( $c =~ /^(\$\#)\w/ ) { # This is really an array index thingy ( $#array ) $t->{token} = PPI::Token::ArrayIndex->new( "$1" ); return PPI::Token::ArrayIndex->__TOKENIZER__on_char( $t ); } if ( $c =~ /^\$\^\w+$/o ) { # It's an escaped char magic... maybe ( like $^M ) my $next = substr( $t->{line}, $t->{line_cursor}+1, 1 ); # Peek ahead if ($magic{$c} && (!$next || $next !~ /\w/)) { $t->{token}->{content} = $c; $t->{line_cursor}++; } else { # Maybe it's a long magic variable like $^WIDE_SYSTEM_CALLS return 1; } } if ( $c =~ /^\$\#\{/ ) { # The $# is actually a cast, and { is its block # Add the current token as the cast... $t->{token} = PPI::Token::Cast->new( '$#' ); $t->_finalize_token; # ... and create a new token for the block return $t->_new_token( 'Structure', '{' ); } } elsif ($c =~ /^%\^/) { return 1 if $c eq '%^'; # It's an escaped char magic... maybe ( like %^H ) if ($magic{$c}) { $t->{token}->{content} = $c; $t->{line_cursor}++; } else { # Back off, treat '%' as an operator chop $t->{token}->{content}; bless $t->{token}, $t->{class} = 'PPI::Token::Operator'; $t->{line_cursor}--; } } if ( $magic{$c} ) { # $#+ and $#- $t->{line_cursor} += length( $c ) - length( $t->{token}->{content} ); $t->{token}->{content} = $c; } else { pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/($PPI::Token::Unknown::CURLY_SYMBOL)/gc ) { # control character symbol (e.g. ${^MATCH}) $t->{token}->{content} .= $1; $t->{line_cursor} += length $1; } elsif ( $c =~ /^\$\d+$/ and $t->{line} =~ /\G(\d+)/gc ) { # Grab trailing digits of regex capture variables. $t->{token}{content} .= $1; $t->{line_cursor} += length $1; } } # End the current magic token, and recheck $t->_finalize_token->__TOKENIZER__on_char( $t ); } # Our version of canonical is plain simple sub canonical { $_[0]->content } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Structure.pm0000755000175100010010000001150012430462144013670 0ustar package PPI::Token::Structure; =pod =head1 NAME PPI::Token::Structure - Token class for characters that define code structure =head1 INHERITANCE PPI::Token::Structure isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that control the generally tree structure or code. This consists of seven characters. These are the six brace characters from the "round", "curly" and "square" pairs, plus the semi-colon statement separator C<;>. =head1 METHODS This class has no methods beyond what is provided by its L and L parent classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } # Set the matching braces, done as an array # for slightly faster lookups. use vars qw{@MATCH @OPENS @CLOSES}; BEGIN { $MATCH[ord '{'] = '}'; $MATCH[ord '}'] = '{'; $MATCH[ord '['] = ']'; $MATCH[ord ']'] = '['; $MATCH[ord '('] = ')'; $MATCH[ord ')'] = '('; $OPENS[ord '{'] = 1; $OPENS[ord '['] = 1; $OPENS[ord '('] = 1; $CLOSES[ord '}'] = 1; $CLOSES[ord ']'] = 1; $CLOSES[ord ')'] = 1; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { # Structures are one character long, always. # Finalize and process again. $_[1]->_finalize_token->__TOKENIZER__on_char( $_[1] ); } sub __TOKENIZER__commit { my $t = $_[1]; $t->_new_token( 'Structure', substr( $t->{line}, $t->{line_cursor}, 1 ) ); $t->_finalize_token; 0; } ##################################################################### # Lexer Methods # For a given brace, find its opposing pair sub __LEXER__opposite { $MATCH[ord $_[0]->{content} ]; } ##################################################################### # PPI::Element Methods # There is a unusual situation in regards to "siblings". # # As an Element, braces sit outside the normal tree structure, and in # this context they NEVER have siblings. # # However, as tokens they DO have siblings. # # As such, we need special versions of _all_ of the sibling methods to # handle this. # # Statement terminators do not have these problems, and for them sibling # calls work as normal, and so they can just be passed upwards. sub next_sibling { return $_[0]->SUPER::next_sibling if $_[0]->{content} eq ';'; return ''; } sub snext_sibling { return $_[0]->SUPER::snext_sibling if $_[0]->{content} eq ';'; return ''; } sub previous_sibling { return $_[0]->SUPER::previous_sibling if $_[0]->{content} eq ';'; return ''; } sub sprevious_sibling { return $_[0]->SUPER::sprevious_sibling if $_[0]->{content} eq ';'; return ''; } sub next_token { my $self = shift; return $self->SUPER::next_token if $self->{content} eq ';'; my $structure = $self->parent or return ''; # If this is an opening brace, descend down into our parent # structure, if it has children. if ( $OPENS[ ord $self->{content} ] ) { my $child = $structure->child(0); if ( $child ) { # Decend deeper, or return if it is a token return $child->isa('PPI::Token') ? $child : $child->first_token; } elsif ( $structure->finish ) { # Empty structure, so next is closing brace return $structure->finish; } # Anything that slips through to here is a structure # with an opening brace, but no closing brace, so we # just have to go with it, and continue as we would # if we started with a closing brace. } # We can use the default implement, if we call it from the # parent structure of the closing brace. $structure->next_token; } sub previous_token { my $self = shift; return $self->SUPER::previous_token if $self->{content} eq ';'; my $structure = $self->parent or return ''; # If this is a closing brace, descend down into our parent # structure, if it has children. if ( $CLOSES[ ord $self->{content} ] ) { my $child = $structure->child(-1); if ( $child ) { # Decend deeper, or return if it is a token return $child->isa('PPI::Token') ? $child : $child->last_token; } elsif ( $structure->start ) { # Empty structure, so next is closing brace return $structure->start; } # Anything that slips through to here is a structure # with a closing brace, but no opening brace, so we # just have to go with it, and continue as we would # if we started with a opening brace. } # We can use the default implement, if we call it from the # parent structure of the closing brace. $structure->previous_token; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Operator.pm0000755000175100010010000000620212430462144013466 0ustar package PPI::Token::Operator; =pod =head1 NAME PPI::Token::Operator - Token class for operators =head1 INHERITANCE PPI::Token::Operator isa PPI::Token isa PPI::Element =head1 SYNOPSIS # This is the list of valid operators ++ -- ** ! ~ + - =~ !~ * / % x << >> lt gt le ge cmp ~~ == != <=> . .. ... , & | ^ && || // ? : **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= < > <= >= <> => -> and or xor not eq ne =head1 DESCRIPTION All operators in PPI are created as C objects, including the ones that may superficially look like a L object. =head1 METHODS There are no additional methods beyond those provided by the parent L and L classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA %OPERATOR}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; # Build the operator index ### NOTE - This is accessed several times explicitly ### in PPI::Token::Word. Do not rename this ### without also correcting them. %OPERATOR = map { $_ => 1 } ( qw{ -> ++ -- ** ! ~ + - =~ !~ * / % x . << >> < > <= >= lt gt le ge == != <=> eq ne cmp ~~ & | ^ && || // .. ... ? : = **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= => <> and or xor not }, ',' # Avoids "comma in qw{}" warning ); } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $t = $_[1]; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Are we still an operator if we add the next character my $content = $t->{token}->{content}; return 1 if $OPERATOR{ $content . $char }; # Handle the special case of a .1234 decimal number if ( $content eq '.' ) { if ( $char =~ /^[0-9]$/ ) { # This is a decimal number $t->{class} = $t->{token}->set_class('Number::Float'); return $t->{class}->__TOKENIZER__on_char( $t ); } } # Handle the special case if we might be a here-doc if ( $content eq '<<' ) { pos $t->{line} = $t->{line_cursor}; # Either <{line} =~ m/\G(?: (?!\d)\w | \s*['"`] | \\\w ) /gcx ) { # This is a here-doc. # Change the class and move to the HereDoc's own __TOKENIZER__on_char method. $t->{class} = $t->{token}->set_class('HereDoc'); return $t->{class}->__TOKENIZER__on_char( $t ); } } # Handle the special case of the null Readline if ( $content eq '<>' ) { $t->{class} = $t->{token}->set_class('QuoteLike::Readline'); } # Finalize normally $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/End.pm0000755000175100010010000000464412430462144012411 0ustar package PPI::Token::End; =pod =head1 NAME PPI::Token::End - Completely useless content after the __END__ tag =head1 INHERITANCE PPI::Token::End isa PPI::Token isa PPI::Element =head1 DESCRIPTION If you've read L, you should understand by now the concept of documents "floating in a sea of PPI::Token::Whitespace". Well it doesn't after the __END__ tag. Once you __END__, it's all over. Anything after that tag isn't even fit to be called whitespace. It just simply doesn't exist as far as perl (the interpreter) is concerned. That's not to say there isn't useful content. Most often people use the __END__ tag to hide POD content, so that perl never has to see it, and presumably providing some small speed up. That's fine. PPI likes POD. Any POD after the __END__ tag is parsed into valid L tags as normal. B class, on the other hand, is for "what's after __END__ when it isn't POD". Basically, the completely worthless bits of the file :) =head1 METHODS This class has no method beyond what is provided by its L and L parent classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # Tokenizer Methods ### XS -> PPI/XS.xs:_PPI_Token_End__significant 0.900+ sub significant() { '' } sub __TOKENIZER__on_char() { 1 } sub __TOKENIZER__on_line_start { my $t = $_[1]; # Can we classify the entire line in one go if ( $t->{line} =~ /^=(\w+)/ ) { # A Pod tag... change to pod mode $t->_new_token( 'Pod', $t->{line} ); unless ( $1 eq 'cut' ) { # Normal start to pod $t->{class} = 'PPI::Token::Pod'; } # This is an error, but one we'll ignore # Don't go into Pod mode, since =cut normally # signals the end of Pod mode } else { if ( defined $t->{token} ) { # Add to existing token $t->{token}->{content} .= $t->{line}; } else { $t->_new_token( 'End', $t->{line} ); } } 0; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number/0000755000175100010010000000000012430470371012563 5ustar PPI-1.220/lib/PPI/Token/Number/Hex.pm0000755000175100010010000000333712430462144013655 0ustar package PPI::Token::Number::Hex; =pod =head1 NAME PPI::Token::Number::Hex - Token class for a binary number =head1 SYNOPSIS $n = 0x1234; # hexadecimal integer =head1 INHERITANCE PPI::Token::Number::Hex isa PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that represent base-16 numbers. =head1 METHODS =cut use strict; use PPI::Token::Number (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Number'; } =pod =head2 base Returns the base for the number: 16. =cut sub base() { 16 } =pod =head2 literal Return the numeric value of this token. =cut sub literal { my $self = shift; my $str = $self->_literal; my $neg = $str =~ s/^\-//; my $val = hex lc( $str ); # lc for compatibility with perls before 5.14 return $neg ? -$val : $val; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Allow underscores straight through return 1 if $char eq '_'; if ( $char =~ /[\da-f]/i ) { return 1; } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2006 Chris Dolan. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number/Float.pm0000755000175100010010000000502612430462144014173 0ustar package PPI::Token::Number::Float; =pod =head1 NAME PPI::Token::Number::Float - Token class for a floating-point number =head1 SYNOPSIS $n = 1.234; =head1 INHERITANCE PPI::Token::Number::Float isa PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that represent floating point numbers. A float is identified by n decimal point. Exponential notation (the C or C) is handled by the PPI::Token::Number::Exp class. =head1 METHODS =cut use strict; use PPI::Token::Number (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Number'; } =pod =head2 base Returns the base for the number: 10. =cut sub base() { 10 } =pod =head2 literal Return the numeric value of this token. =cut sub literal { my $self = shift; my $str = $self->_literal; my $neg = $str =~ s/^\-//; $str =~ s/^\./0./; my $val = 0+$str; return $neg ? -$val : $val; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Allow underscores straight through return 1 if $char eq '_'; # Allow digits return 1 if $char =~ /\d/o; # Is there a second decimal point? Then version string or '..' operator if ( $char eq '.' ) { if ( $t->{token}->{content} =~ /\.$/ ) { # We have a .., which is an operator. # Take the . off the end of the token.. # and finish it, then make the .. operator. chop $t->{token}->{content}; $t->{class} = $t->{token}->set_class( 'Number' ); $t->_new_token('Operator', '..'); return 0; } elsif ( $t->{token}->{content} !~ /_/ ) { # Underscore means not a Version, fall through to end token $t->{class} = $t->{token}->set_class( 'Number::Version' ); return 1; } } if ($char eq 'e' || $char eq 'E') { $t->{class} = $t->{token}->set_class( 'Number::Exp' ); return 1; } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2006 Chris Dolan. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number/Octal.pm0000755000175100010010000000353312430462144014171 0ustar package PPI::Token::Number::Octal; =pod =head1 NAME PPI::Token::Number::Octal - Token class for a binary number =head1 SYNOPSIS $n = 0777; # octal integer =head1 INHERITANCE PPI::Token::Number::Octal isa PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that represent base-8 numbers. =head1 METHODS =cut use strict; use PPI::Token::Number (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Number'; } =pod =head2 base Returns the base for the number: 8. =cut sub base() { 8 } =pod =head2 literal Return the numeric value of this token. =cut sub literal { my $self = shift; return if $self->{_error}; my $str = $self->_literal; my $neg = $str =~ s/^\-//; my $val = oct $str; return $neg ? -$val : $val; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Allow underscores straight through return 1 if $char eq '_'; if ( $char =~ /\d/ ) { # You cannot have 8s and 9s on octals if ( $char eq '8' or $char eq '9' ) { $t->{token}->{_error} = "Illegal character in octal number '$char'"; } return 1; } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2006 Chris Dolan. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number/Exp.pm0000755000175100010010000000461512430462144013665 0ustar package PPI::Token::Number::Exp; =pod =head1 NAME PPI::Token::Number::Exp - Token class for an exponential notation number =head1 SYNOPSIS $n = 1.0e-2; $n = 1e+2; =head1 INHERITANCE PPI::Token::Number::Exp isa PPI::Token::Number::Float isa PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that represent floating point numbers with exponential notation. =head1 METHODS =cut use strict; use PPI::Token::Number::Float (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Number::Float'; } =pod =head2 literal Return the numeric value of this token. =cut sub literal { my $self = shift; return if $self->{_error}; my ($mantissa, $exponent) = split m/e/i, $self->_literal; my $neg = $mantissa =~ s/^\-//; $mantissa =~ s/^\./0./; $exponent =~ s/^\+//; my $val = $mantissa * 10 ** $exponent; return $neg ? -$val : $val; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # To get here, the token must have already encountered an 'E' # Allow underscores straight through return 1 if $char eq '_'; # Allow digits return 1 if $char =~ /\d/o; # Start of exponent is special if ( $t->{token}->{content} =~ /e$/i ) { # Allow leading +/- in exponent return 1 if $char eq '-' || $char eq '+'; # Invalid character in exponent. Recover if ( $t->{token}->{content} =~ s/\.(e)$//i ) { my $word = $1; $t->{class} = $t->{token}->set_class('Number'); $t->_new_token('Operator', '.'); $t->_new_token('Word', $word); return $t->{class}->__TOKENIZER__on_char( $t ); } else { $t->{token}->{_error} = "Illegal character in exponent '$char'"; } } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2006 Chris Dolan. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number/Binary.pm0000755000175100010010000000370312430462144014352 0ustar package PPI::Token::Number::Binary; =pod =head1 NAME PPI::Token::Number::Binary - Token class for a binary number =head1 SYNOPSIS $n = 0b1110011; # binary integer =head1 INHERITANCE PPI::Token::Number::Binary isa PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that represent base-2 numbers. =head1 METHODS =cut use strict; use PPI::Token::Number (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Number'; } =pod =head2 base Returns the base for the number: 2. =cut sub base() { 2 } =pod =head2 literal Return the numeric value of this token. =cut sub literal { my $self = shift; return if $self->{_error}; my $str = $self->_literal; my $neg = $str =~ s/^\-//; $str =~ s/^0[bB]//; my $val = 0; for my $bit ( $str =~ m/(.)/g ) { $val = $val * 2 + $bit; } return $neg ? -$val : $val; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Allow underscores straight through return 1 if $char eq '_'; if ( $char =~ /[\w\d]/ ) { unless ( $char eq '1' or $char eq '0' ) { # Add a warning if it contains non-binary chars $t->{token}->{_error} = "Illegal character in binary number '$char'"; } return 1; } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2006 Chris Dolan. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number/Version.pm0000755000175100010010000000556612430462144014564 0ustar package PPI::Token::Number::Version; =pod =head1 NAME PPI::Token::Number::Version - Token class for a byte-packed number =head1 SYNOPSIS $n = 1.1.0; $n = 127.0.0.1; $n = 10_000.10_000.10_000; $n = v1.2.3.4 =head1 INHERITANCE PPI::Token::Number::Version isa PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that have multiple decimal points. In truth, these aren't treated like numbers at all by Perl, but they look like numbers to a parser. =head1 METHODS =cut use strict; use PPI::Token::Number (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::Number'; } =pod =head2 base Returns the base for the number: 256. =cut sub base() { 256 } =pod =head2 literal Return the numeric value of this token. =cut sub literal { my $self = shift; my $content = $self->{content}; $content =~ s/^v//; return join '', map { chr $_ } ( split /\./, $content ); } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Allow digits return 1 if $char =~ /\d/o; # Is this a second decimal point in a row? Then the '..' operator if ( $char eq '.' ) { if ( $t->{token}->{content} =~ /\.$/ ) { # We have a .., which is an operator. # Take the . off the end of the token.. # and finish it, then make the .. operator. chop $t->{token}->{content}; $t->{class} = $t->{token}->set_class( 'Number::Float' ); $t->_new_token('Operator', '..'); return 0; } else { return 1; } } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } sub __TOKENIZER__commit { my $t = $_[1]; # Get the rest of the line pos $t->{line} = $t->{line_cursor}; if ( $t->{line} !~ m/\G(v\d+(?:\.\d+)*)/gc ) { # This was not a v-string after all (it's a word) return PPI::Token::Word->__TOKENIZER__commit($t); } # This is a v-string my $vstring = $1; $t->{line_cursor} += length($vstring); $t->_new_token('Number::Version', $vstring); $t->_finalize_token->__TOKENIZER__on_char($t); } 1; =pod =head1 BUGS - Does not handle leading minus sign correctly. Should translate to a DashedWord. See L -95.0.1.0 --> "-_\000\cA\000" -96.0.1.0 --> Argument "`\0^A\0" isn't numeric in negation (-) =head1 SUPPORT See the L in the main module. =head1 AUTHOR Chris Dolan Ecdolan@cpan.orgE =head1 COPYRIGHT Copyright 2006 Chris Dolan. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Data.pm0000755000175100010010000000371312430462144012550 0ustar package PPI::Token::Data; =pod =head1 NAME PPI::Token::Data - The actual data in the __DATA__ section of a file =head1 INHERITANCE PPI::Token::Data isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used to represent the actual data inside a file's C<__DATA__> section. One C object is used to represent the entire of the data, primarily so that it can provide a convenient handle directly to the data. =head1 METHODS C provides one method in addition to those provided by our parent L and L classes. =cut use strict; use IO::String (); use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # Methods =pod =head2 handle The C method returns a L handle that allows you to do all the normal handle-y things to the contents of the __DATA__ section of the file. Unlike in perl itself, this means you can also do things like C new data onto the end of the __DATA__ section, or modify it with any other process that can accept an L as input or output. Returns an L object. =cut sub handle { my $self = shift; IO::String->new( \$self->{content} ); } sub __TOKENIZER__on_line_start { my ( $self, $t ) = @_; # Add the line if ( defined $t->{token} ) { $t->{token}->{content} .= $t->{line}; } else { defined( $t->{token} = $t->{class}->new( $t->{line} ) ) or return undef; } return 0; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/ArrayIndex.pm0000755000175100010010000000255612430462144013751 0ustar package PPI::Token::ArrayIndex; =pod =head1 NAME PPI::Token::ArrayIndex - Token getting the last index for an array =head1 INHERITANCE PPI::Token::ArrayIndex isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C token represents an attempt to get the last index of an array, such as C<$#array>. =head1 METHODS There are no additional methods beyond those provided by the parent L and L classes. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $t = $_[1]; # Suck in till the end of the arrayindex pos $t->{line} = $t->{line_cursor}; if ( $t->{line} =~ m/\G([\w:']+)/gc ) { $t->{token}->{content} .= $1; $t->{line_cursor} += length $1; } # End of token $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Number.pm0000755000175100010010000000635612430462144013135 0ustar package PPI::Token::Number; =pod =head1 NAME PPI::Token::Number - Token class for a number =head1 SYNOPSIS $n = 1234; # decimal integer $n = 0b1110011; # binary integer $n = 01234; # octal integer $n = 0x1234; # hexadecimal integer $n = 12.34e-56; # exponential notation ( currently not working ) =head1 INHERITANCE PPI::Token::Number isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is used for tokens that represent numbers, in the various types that Perl supports. =head1 METHODS =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } =pod =head2 base The C method is provided by all of the ::Number subclasses. This is 10 for decimal, 16 for hexadecimal, 2 for binary, etc. =cut sub base() { 10 } =pod =head2 literal Return the numeric value of this token. =cut sub literal { return 0 + $_[0]->_literal; } sub _literal { # De-sugar the string representation my $self = shift; my $string = $self->content; $string =~ s/^\+//; $string =~ s/_//g; return $string; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_char { my $class = shift; my $t = shift; my $char = substr( $t->{line}, $t->{line_cursor}, 1 ); # Allow underscores straight through return 1 if $char eq '_'; # Handle the conversion from an unknown to known type. # The regex covers "potential" hex/bin/octal number. my $token = $t->{token}; if ( $token->{content} =~ /^-?0_*$/ ) { # This could be special if ( $char eq 'x' || $char eq 'X' ) { $t->{class} = $t->{token}->set_class( 'Number::Hex' ); return 1; } elsif ( $char eq 'b' || $char eq 'B' ) { $t->{class} = $t->{token}->set_class( 'Number::Binary' ); return 1; } elsif ( $char =~ /\d/ ) { # You cannot have 8s and 9s on octals if ( $char eq '8' or $char eq '9' ) { $token->{_error} = "Illegal character in octal number '$char'"; } $t->{class} = $t->{token}->set_class( 'Number::Octal' ); return 1; } } # Handle the easy case, integer or real. return 1 if $char =~ /\d/o; if ( $char eq '.' ) { $t->{class} = $t->{token}->set_class( 'Number::Float' ); return 1; } if ( $char eq 'e' || $char eq 'E' ) { $t->{class} = $t->{token}->set_class( 'Number::Exp' ); return 1; } # Doesn't fit a special case, or is after the end of the token # End of token. $t->_finalize_token->__TOKENIZER__on_char( $t ); } 1; =pod =head1 CAVEATS Compared to Perl, the number tokenizer is too liberal about allowing underscores anywhere. For example, the following is a syntax error in Perl, but is allowed in PPI: 0_b10 =head1 TO DO - Treat v-strings as binary strings or barewords, not as "base-256" numbers - Break out decimal integers into their own subclass? - Implement literal() =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/QuoteLike/0000755000175100010010000000000012430470371013235 5ustar PPI-1.220/lib/PPI/Token/QuoteLike/Regexp.pm0000755000175100010010000000447512430462144015041 0ustar package PPI::Token::QuoteLike::Regexp; =pod =head1 NAME PPI::Token::QuoteLike::Regexp - Regexp constructor quote-like operator =head1 INHERITANCE PPI::Token::QuoteLike::Regexp isa PPI::Token::QuoteLike isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents the quote-like operator used to construct anonymous L objects, as follows. # Create a Regexp object for a module filename my $module = qr/\.pm$/; =head1 METHODS The following methods are provided by this class, beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::QuoteLike (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::QuoteLike }; } ##################################################################### # PPI::Token::QuoteLike::Regexp Methods =pod =head2 get_match_string The C method returns the portion of the string that will be compiled into the match portion of the regexp. =cut sub get_match_string { return $_[0]->_section_content( 0 ); } =pod =head2 get_substitute_string The C method always returns C, since the C construction provides no substitution string. This method is provided for orthogonality with C. =cut sub get_substitute_string { return undef; } =pod =head2 get_modifiers The C method returns the modifiers that will be compiled into the regexp. =cut sub get_modifiers { return $_[0]->_modifiers(); } =pod =head2 get_delimiters The C method returns the delimiters of the string as an array. The first and only element is the delimiters of the string to be compiled into a match string. =cut sub get_delimiters { return $_[0]->_delimiters(); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/QuoteLike/Backtick.pm0000755000175100010010000000225512430462144015314 0ustar package PPI::Token::QuoteLike::Backtick; =pod =head1 NAME PPI::Token::QuoteLike::Backtick - A `backticks` command token =head1 INHERITANCE PPI::Token::QuoteLike::Backtick isa PPI::Token::QuoteLike isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents a command output capturing quote. =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::QuoteLike (); use PPI::Token::_QuoteEngine::Simple (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Simple PPI::Token::QuoteLike }; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/QuoteLike/Words.pm0000755000175100010010000000301712430462144014674 0ustar package PPI::Token::QuoteLike::Words; =pod =head1 NAME PPI::Token::QuoteLike::Words - Word list constructor quote-like operator =head1 INHERITANCE PPI::Token::QuoteLike::Words isa PPI::Token::QuoteLike isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents a quote-like operator that acts as a constructor for a list of words. # Create a list for a significant chunk of the alphabet my @list = qw{a b c d e f g h i j k l}; =head1 METHODS =cut use strict; use PPI::Token::QuoteLike (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::QuoteLike }; } =pod =head2 literal Returns the words contained. Note that this method does not check the context that the token is in; it always returns the list and not merely the last element if the token is in scalar context. =cut sub literal { my $self = shift; my $section = $self->{sections}->[0]; return split ' ', substr( $self->{content}, $section->{position}, $section->{size}, ); } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/QuoteLike/Readline.pm0000755000175100010010000000254212430462144015323 0ustar package PPI::Token::QuoteLike::Readline; =pod =head1 NAME PPI::Token::QuoteLike::Readline - The readline quote-like operator =head1 INHERITANCE PPI::Token::QuoteLike::Readline isa PPI::Token::QuoteLike isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C quote-like operator is used to read either a single line from a file, or all the lines from a file, as follows. # Read in a single line $line = ; # From a scalar handle $line = <$filehandle>; # Read all the lines @lines = ; =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::QuoteLike (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::QuoteLike }; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/QuoteLike/Command.pm0000755000175100010010000000226412430462144015157 0ustar package PPI::Token::QuoteLike::Command; =pod =head1 NAME PPI::Token::QuoteLike::Command - The command quote-like operator =head1 INHERITANCE PPI::Token::QuoteLike::Command isa PPI::Token::QuoteLike isa PPI::Token isa PPI::Element =head1 DESCRIPTION A C object represents a command output capturing quote-like operator. =head1 METHODS There are no methods available for C beyond those provided by the parent L, L and L classes. =cut use strict; use PPI::Token::QuoteLike (); use PPI::Token::_QuoteEngine::Full (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = qw{ PPI::Token::_QuoteEngine::Full PPI::Token::QuoteLike }; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/_QuoteEngine/0000755000175100010010000000000012430470371013715 5ustar PPI-1.220/lib/PPI/Token/_QuoteEngine/Full.pm0000755000175100010010000003026412430462144015164 0ustar package PPI::Token::_QuoteEngine::Full; # Full quote engine use strict; use Clone (); use Carp (); use PPI::Token::_QuoteEngine (); use vars qw{$VERSION @ISA %quotes %sections}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::_QuoteEngine'; # Prototypes for the different braced sections %sections = ( '(' => { type => '()', _close => ')' }, '<' => { type => '<>', _close => '>' }, '[' => { type => '[]', _close => ']' }, '{' => { type => '{}', _close => '}' }, ); # For each quote type, the extra fields that should be set. # This should give us faster initialization. %quotes = ( 'q' => { operator => 'q', braced => undef, separator => undef, _sections => 1 }, 'qq' => { operator => 'qq', braced => undef, separator => undef, _sections => 1 }, 'qx' => { operator => 'qx', braced => undef, separator => undef, _sections => 1 }, 'qw' => { operator => 'qw', braced => undef, separator => undef, _sections => 1 }, 'qr' => { operator => 'qr', braced => undef, separator => undef, _sections => 1, modifiers => 1 }, 'm' => { operator => 'm', braced => undef, separator => undef, _sections => 1, modifiers => 1 }, 's' => { operator => 's', braced => undef, separator => undef, _sections => 2, modifiers => 1 }, 'tr' => { operator => 'tr', braced => undef, separator => undef, _sections => 2, modifiers => 1 }, # Y is the little used variant of tr 'y' => { operator => 'y', braced => undef, separator => undef, _sections => 2, modifiers => 1 }, '/' => { operator => undef, braced => 0, separator => '/', _sections => 1, modifiers => 1 }, # Angle brackets quotes mean "readline(*FILEHANDLE)" '<' => { operator => undef, braced => 1, separator => undef, _sections => 1, }, # The final ( and kind of depreciated ) "first match only" one is not # used yet, since I'm not sure on the context differences between # this and the trinary operator, but its here for completeness. '?' => { operator => undef, braced => 0, separator => '?', _sections => 1, modifiers => 1 }, ); } sub new { my $class = shift; my $init = defined $_[0] ? shift : Carp::croak("::Full->new called without init string"); # Create the token ### This manual SUPER'ing ONLY works because none of ### Token::Quote, Token::QuoteLike and Token::Regexp ### implement a new function of their own. my $self = PPI::Token::new( $class, $init ) or return undef; # Do we have a prototype for the initializer? If so, add the extra fields my $options = $quotes{$init} or return $self->_error( "Unknown quote type '$init'" ); foreach ( keys %$options ) { $self->{$_} = $options->{$_}; } # Set up the modifiers hash if needed $self->{modifiers} = {} if $self->{modifiers}; # Handle the special < base if ( $init eq '<' ) { $self->{sections}->[0] = Clone::clone( $sections{'<'} ); } $self; } sub _fill { my $class = shift; my $t = shift; my $self = $t->{token} or Carp::croak("::Full->_fill called without current token"); # Load in the operator stuff if needed if ( $self->{operator} ) { # In an operator based quote-like, handle the gap between the # operator and the opening separator. if ( substr( $t->{line}, $t->{line_cursor}, 1 ) =~ /\s/ ) { # Go past the gap my $gap = $self->_scan_quote_like_operator_gap( $t ); return undef unless defined $gap; if ( ref $gap ) { # End of file $self->{content} .= $$gap; return 0; } $self->{content} .= $gap; } # The character we are now on is the separator. Capture, # and advance into the first section. my $sep = substr( $t->{line}, $t->{line_cursor}++, 1 ); $self->{content} .= $sep; # Determine if these are normal or braced type sections if ( my $section = $sections{$sep} ) { $self->{braced} = 1; $self->{sections}->[0] = Clone::clone($section); } else { $self->{braced} = 0; $self->{separator} = $sep; } } # Parse different based on whether we are normal or braced my $rv = $self->{braced} ? $self->_fill_braced($t) : $self->_fill_normal($t); return $rv if !$rv; # Return now unless it has modifiers ( i.e. s/foo//eieio ) return 1 unless $self->{modifiers}; # Check for modifiers my $char; my $len = 0; while ( ($char = substr( $t->{line}, $t->{line_cursor} + 1, 1 )) =~ /[^\W\d_]/ ) { $len++; $self->{content} .= $char; $self->{modifiers}->{lc $char} = 1; $t->{line_cursor}++; } } # Handle the content parsing path for normally separated sub _fill_normal { my $self = shift; my $t = shift; # Get the content up to the next separator my $string = $self->_scan_for_unescaped_character( $t, $self->{separator} ); return undef unless defined $string; if ( ref $string ) { # End of file if ( length($$string) > 1 ) { # Complete the properties for the first section my $str = $$string; chop $str; $self->{sections}->[0] = { position => length($self->{content}), size => length($$string) - 1, type => "$self->{separator}$self->{separator}", }; $self->{_sections} = 1; } else { # No sections at all $self->{sections} = [ ]; $self->{_sections} = 0; } $self->{content} .= $$string; return 0; } # Complete the properties of the first section $self->{sections}->[0] = { position => length $self->{content}, size => length($string) - 1, type => "$self->{separator}$self->{separator}", }; $self->{content} .= $string; # We are done if there is only one section return 1 if $self->{_sections} == 1; # There are two sections. # Advance into the next section $t->{line_cursor}++; # Get the content up to the end separator $string = $self->_scan_for_unescaped_character( $t, $self->{separator} ); return undef unless defined $string; if ( ref $string ) { # End of file if ( length($$string) > 1 ) { # Complete the properties for the second section my $str = $$string; chop $str; $self->{sections}->[1] = { position => length($self->{content}), size => length($$string) - 1, type => "$self->{separator}$self->{separator}", }; } else { # No sections at all $self->{_sections} = 1; } $self->{content} .= $$string; return 0; } # Complete the properties of the second section $self->{sections}->[1] = { position => length($self->{content}), size => length($string) - 1 }; $self->{content} .= $string; 1; } # Handle content parsing for matching brace separated sub _fill_braced { my $self = shift; my $t = shift; # Get the content up to the close character my $section = $self->{sections}->[0]; my $brace_str = $self->_scan_for_brace_character( $t, $section->{_close} ); return undef unless defined $brace_str; if ( ref $brace_str ) { # End of file if ( length($$brace_str) > 1 ) { # Complete the properties for the first section my $str = $$brace_str; chop $str; $self->{sections}->[0] = { position => length($self->{content}), size => length($$brace_str) - 1, type => $section->{type}, }; $self->{_sections} = 1; } else { # No sections at all $self->{sections} = [ ]; $self->{_sections} = 0; } $self->{content} .= $$brace_str; return 0; } # Complete the properties of the first section $section->{position} = length $self->{content}; $section->{size} = length($brace_str) - 1; $self->{content} .= $brace_str; delete $section->{_close}; # We are done if there is only one section return 1 if $self->{_sections} == 1; # There are two sections. # Is there a gap between the sections. my $char = substr( $t->{line}, ++$t->{line_cursor}, 1 ); if ( $char =~ /\s/ ) { # Go past the gap my $gap_str = $self->_scan_quote_like_operator_gap( $t ); return undef unless defined $gap_str; if ( ref $gap_str ) { # End of file $self->{content} .= $$gap_str; return 0; } $self->{content} .= $gap_str; $char = substr( $t->{line}, $t->{line_cursor}, 1 ); } $section = $sections{$char}; if ( $section ) { # It's a brace # Initialize the second section $self->{content} .= $char; $section = { %$section }; # Advance into the second section $t->{line_cursor}++; # Get the content up to the close character $brace_str = $self->_scan_for_brace_character( $t, $section->{_close} ); return undef unless defined $brace_str; if ( ref $brace_str ) { # End of file if ( length($$brace_str) > 1 ) { # Complete the properties for the second section my $str = $$brace_str; chop $str; $self->{sections}->[1] = { position => length($self->{content}), size => length($$brace_str) - 1, type => $section->{type}, }; $self->{_sections} = 2; } else { # No sections at all $self->{_sections} = 1; } $self->{content} .= $$brace_str; return 0; } else { # Complete the properties for the second section $self->{sections}->[1] = { position => length($self->{content}), size => length($brace_str) - 1, type => $section->{type}, }; $self->{content} .= $brace_str; } } elsif ( $char =~ m/ \A [^\w\s] \z /smx ) { # It is some other delimiter (weird, but possible) # Add the delimiter to the content. $self->{content} .= $char; # Advance into the next section $t->{line_cursor}++; # Get the content up to the end separator my $string = $self->_scan_for_unescaped_character( $t, $char ); return undef unless defined $string; if ( ref $string ) { # End of file if ( length($$string) > 1 ) { # Complete the properties for the second section my $str = $$string; chop $str; $self->{sections}->[1] = { position => length($self->{content}), size => length($$string) - 1, type => "$char$char", }; } else { # Only the one section $self->{_sections} = 1; } $self->{content} .= $$string; return 0; } # Complete the properties of the second section $self->{sections}->[1] = { position => length($self->{content}), size => length($string) - 1, type => "$char$char", }; $self->{content} .= $string; } else { # Error, it has to be a delimiter of some sort. # Although this will result in a REALLY illegal regexp, # we allow it anyway. # Create a null second section $self->{sections}->[1] = { position => length($self->{content}), size => 0, type => '', }; # Attach an error to the token and move on $self->{_error} = "No second section of regexp, or does not start with a balanced character"; # Roll back the cursor one char and return signalling end of regexp $t->{line_cursor}--; return 0; } 1; } ##################################################################### # Additional methods to find out about the quote # In a scalar context, get the number of sections # In an array context, get the section information sub _sections { wantarray ? @{$_[0]->{sections}} : scalar @{$_[0]->{sections}} } # Get a section's content sub _section_content { my $self = shift; my $i = shift; $self->{sections} or return; my $section = $self->{sections}->[$i] or return; return substr( $self->content, $section->{position}, $section->{size} ); } # Get the modifiers if any. # In list context, return the modifier hash. # In scalar context, clone the hash and return a reference to it. # If there are no modifiers, simply return. sub _modifiers { my $self = shift; $self->{modifiers} or return; wantarray and return %{ $self->{modifiers} }; return +{ %{ $self->{modifiers} } }; } # Get the delimiters, or at least give it a good try to get them. sub _delimiters { my $self = shift; $self->{sections} or return; my @delims; foreach my $sect ( @{ $self->{sections} } ) { if ( exists $sect->{type} ) { push @delims, $sect->{type}; } else { my $content = $self->content; push @delims, substr( $content, $sect->{position} - 1, 1 ) . substr( $content, $sect->{position} + $sect->{size}, 1 ); } } return @delims; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/_QuoteEngine/Simple.pm0000755000175100010010000000257312430462144015515 0ustar package PPI::Token::_QuoteEngine::Simple; # Simple quote engine use strict; use PPI::Token::_QuoteEngine (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token::_QuoteEngine'; } sub new { my $class = shift; my $separator = shift or return undef; # Create a new token containing the separator ### This manual SUPER'ing ONLY works because none of ### Token::Quote, Token::QuoteLike and Token::Regexp ### implement a new function of their own. my $self = PPI::Token::new( $class, $separator ) or return undef; $self->{separator} = $separator; $self; } sub _fill { my $class = shift; my $t = shift; my $self = $t->{token} or return undef; # Scan for the end separator my $string = $self->_scan_for_unescaped_character( $t, $self->{separator} ); return undef unless defined $string; if ( ref $string ) { # End of file $self->{content} .= $$string; return 0; } else { # End of string $self->{content} .= $string; return $self; } } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/_QuoteEngine.pm0000755000175100010010000001360312430462144014260 0ustar package PPI::Token::_QuoteEngine; =pod =head1 NAME PPI::Token::_QuoteEngine - The PPI Quote Engine =head1 DESCRIPTION The C package is designed hold functionality for processing quotes and quote like operators, including regexes. These have special requirements in parsing. The C package itself provides various parsing methods, which the L, L and L can inherit from. In this sense, it serves as a base class. =head2 Using this class I<(Refers only to internal uses. This class does not provide a public interface)> To use these, you should initialize them as normal C<'$Class-Enew'>, and then call the 'fill' method, which will cause the specialised parser to scan forwards and parse the quote to its end point. If -Efill returns true, finalise the token. =cut use strict; use Carp (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } # Hook for the __TOKENIZER__on_char token call sub __TOKENIZER__on_char { my $class = shift; my $t = $_[0]->{token} ? shift : return undef; # Call the fill method to process the quote my $rv = $t->{token}->_fill( $t ); return undef unless defined $rv; ## Doesn't support "end of file" indicator # Finalize the token and return 0 to tell the tokenizer # to go to the next character. $t->_finalize_token; 0; } ##################################################################### # Optimised character processors, used for quotes # and quote like stuff, and accessible to the child classes # An outright scan, raw and fast. # Searches for a particular character, not escaped, loading in new # lines as needed. # When called, we start at the current position. # When leaving, the position should be set to the position # of the character, NOT the one after it. sub _scan_for_unescaped_character { my $class = shift; my $t = shift; my $char = (length $_[0] == 1) ? quotemeta shift : return undef; # Create the search regex. # Same as above but with a negative look-behind assertion. my $search = qr/(.*?(?{line} ) { # Get the search area for the current line pos $t->{line} = $t->{line_cursor}; # Can we find a match on this line if ( $t->{line} =~ m/\G$search/gc ) { # Found the character on this line $t->{line_cursor} += length($1) - 1; return $string . $1; } # Load in the next line $string .= substr $t->{line}, $t->{line_cursor}; my $rv = $t->_fill_line('inscan'); if ( $rv ) { # Push to first character $t->{line_cursor} = 0; } elsif ( defined $rv ) { # We hit the End of File return \$string; } else { # Unexpected error return undef; } } # We shouldn't be able to get here return undef; } # Scan for a close braced, and take into account both escaping, # and open close bracket pairs in the string. When complete, the # method leaves the line cursor on the LAST character found. sub _scan_for_brace_character { my $class = shift; my $t = shift; my $close_brace = $_[0] =~ /^(?:\>|\)|\}|\])$/ ? shift : Carp::confess(''); # return undef; my $open_brace = $close_brace; $open_brace =~ tr/\>\)\}\]/\<\(\{\[/; # Create the search string $close_brace = quotemeta $close_brace; $open_brace = quotemeta $open_brace; my $search = qr/\G(.*?(?{line} ) { # Get the search area pos $t->{line} = $t->{line_cursor}; # Look for a match unless ( $t->{line} =~ /$search/gc ) { # Load in the next line $string .= substr( $t->{line}, $t->{line_cursor} ); my $rv = $t->_fill_line('inscan'); if ( $rv ) { # Push to first character $t->{line_cursor} = 0; next; } if ( defined $rv ) { # We hit the End of File return \$string; } # Unexpected error return undef; } # Add to the string $string .= $1; $t->{line_cursor} += length $1; # Alter the depth and continue if we aren't at the end $depth += ($1 =~ /$open_brace$/) ? 1 : -1 and next; # Rewind the cursor by one character ( cludgy hack ) $t->{line_cursor} -= 1; return $string; } # Returning the string as a reference indicates EOF \$string; } # Find all spaces and comments, up to, but not including # the first non-whitespace character. # # Although it doesn't return it, it leaves the cursor # on the character following the gap sub _scan_quote_like_operator_gap { my $t = $_[1]; my $string = ''; while ( exists $t->{line} ) { # Get the search area for the current line pos $t->{line} = $t->{line_cursor}; # Since this regex can match zero characters, it should always match $t->{line} =~ /\G(\s*(?:\#.*)?)/gc or return undef; # Add the chars found to the string $string .= $1; # Did we match the entire line? unless ( $t->{line_cursor} + length $1 == length $t->{line} ) { # Partial line match, which means we are at # the end of the gap. Fix the cursor and return # the string. $t->{line_cursor} += length $1; return $string; } # Load in the next line. # If we reach the EOF, $t->{line} gets deleted, # which is caught by the while. my $rv = $t->_fill_line('inscan'); if ( $rv ) { # Set the cursor to the first character $t->{line_cursor} = 0; } elsif ( defined $rv ) { # Returning the string as a reference indicates EOF return \$string; } else { return undef; } } # Shouldn't be able to get here return undef; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/QuoteLike.pm0000755000175100010010000000316212430462144013577 0ustar package PPI::Token::QuoteLike; =pod =head1 NAME PPI::Token::QuoteLike - Quote-like operator abstract base class =head1 INHERITANCE PPI::Token::QuoteLike isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is never instantiated, and simply provides a common abstract base class for the five quote-like operator classes. In PPI, a "quote-like" is the set of quote-like things that exclude the string quotes and regular expressions. The subclasses of C are: =over 2 =item qw{} - L =item `` - L =item qx{} - L =item qr// - L =item - L =back The names are hopefully obvious enough not to have to explain what each class is. See their pages for more details. You may note that the backtick and command quote-like are treated separately, even though they do the same thing. This is intentional, as the inherit from and are processed by two different parts of the PPI's quote engine. =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token/Quote.pm0000755000175100010010000000461412430462144012775 0ustar package PPI::Token::Quote; =pod =head1 NAME PPI::Token::Quote - String quote abstract base class =head1 INHERITANCE PPI::Token::Quote isa PPI::Token isa PPI::Element =head1 DESCRIPTION The C class is never instantiated, and simply provides a common abstract base class for the four quote classes. In PPI, a "quote" is limited to only the quote-like things that themselves directly represent a string. (although this includes double quotes with interpolated elements inside them). The subclasses of C are: =over 2 =item C<''> - L =item C - L =item C<""> - L =item C - L =back The names are hopefully obvious enough not to have to explain what each class is here. See their respective pages for more details. Please note that although the here-doc B represent a literal string, it is such a nasty piece of work that in L it is given the honor of its own token class (L). =head1 METHODS =cut use strict; use PPI::Token (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Token'; } ##################################################################### # PPI::Token::Quote Methods =pod =head2 string The C method is provided by all four ::Quote classes. It won't get you the actual literal Perl value, but it will strip off the wrapping of the quotes. # The following all return foo from the ->string method 'foo' "foo" q{foo} qq =cut #sub string { # my $class = ref $_[0] || $_[0]; # die "$class does not implement method ->string"; #} =pod =head2 literal The C method is provided by ::Quote:Literal and ::Quote::Single. This returns the value of the string as Perl sees it: without the quote marks and with C<\\> and C<\'> resolved to C<\> and C<'>. The C method is not implemented by ::Quote::Double or ::Quote::Interpolate yet. =cut 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Lexer.pm0000755000175100010010000011550112430462144011675 0ustar package PPI::Lexer; =pod =head1 NAME PPI::Lexer - The PPI Lexer =head1 SYNOPSIS use PPI; # Create a new Lexer my $Lexer = PPI::Lexer->new; # Build a PPI::Document object from a Token stream my $Tokenizer = PPI::Tokenizer->load('My/Module.pm'); my $Document = $Lexer->lex_tokenizer($Tokenizer); # Build a PPI::Document object for some raw source my $source = "print 'Hello World!'; kill(Humans->all);"; $Document = $Lexer->lex_source($source); # Build a PPI::Document object for a particular file name $Document = $Lexer->lex_file('My/Module.pm'); =head1 DESCRIPTION The is the L Lexer. In the larger scheme of things, its job is to take token streams, in a variety of forms, and "lex" them into nested structures. Pretty much everything in this module happens behind the scenes at this point. In fact, at the moment you don't really need to instantiate the lexer at all, the three main methods will auto-instantiate themselves a C object as needed. All methods do a one-shot "lex this and give me a L object". In fact, if you are reading this, what you B want to do is to just "load a document", in which case you can do this in a much more direct and concise manner with one of the following. use PPI; $Document = PPI::Document->load( $filename ); $Document = PPI::Document->new( $string ); See L for more details. For more unusual tasks, by all means forge onwards. =head1 METHODS =cut use strict; use Scalar::Util (); use Params::Util qw{_STRING _INSTANCE}; use List::MoreUtils (); use PPI (); use PPI::Exception (); use vars qw{$VERSION $errstr *_PARENT %ROUND %RESOLVE}; BEGIN { $VERSION = '1.220'; $errstr = ''; # Faster than having another method call just # to set the structure finish token. *_PARENT = *PPI::Element::_PARENT; # Keyword -> Structure class maps %ROUND = ( # Conditions 'if' => 'PPI::Structure::Condition', 'elsif' => 'PPI::Structure::Condition', 'unless' => 'PPI::Structure::Condition', 'while' => 'PPI::Structure::Condition', 'until' => 'PPI::Structure::Condition', # For(each) 'for' => 'PPI::Structure::For', 'foreach' => 'PPI::Structure::For', ); # Opening brace to refining method %RESOLVE = ( '(' => '_round', '[' => '_square', '{' => '_curly', ); } # Allows for experimental overriding of the tokenizer use vars qw{ $X_TOKENIZER }; BEGIN { $X_TOKENIZER ||= 'PPI::Tokenizer'; } use constant X_TOKENIZER => $X_TOKENIZER; ##################################################################### # Constructor =pod =head2 new The C constructor creates a new C object. The object itself is merely used to hold various buffers and state data during the lexing process, and holds no significant data between -Elex_xxxxx calls. Returns a new C object =cut sub new { my $class = shift->_clear; bless { Tokenizer => undef, # Where we store the tokenizer for a run buffer => [], # The input token buffer delayed => [], # The "delayed insignificant tokens" buffer }, $class; } ##################################################################### # Main Lexing Methods =pod =head2 lex_file $filename The C method takes a filename as argument. It then loads the file, creates a L for the content and lexes the token stream produced by the tokenizer. Basically, a sort of all-in-one method for getting a L object from a file name. Returns a L object, or C on error. =cut sub lex_file { my $self = ref $_[0] ? shift : shift->new; my $file = _STRING(shift); unless ( defined $file ) { return $self->_error("Did not pass a filename to PPI::Lexer::lex_file"); } # Create the Tokenizer my $Tokenizer = eval { X_TOKENIZER->new($file); }; if ( _INSTANCE($@, 'PPI::Exception') ) { return $self->_error( $@->message ); } elsif ( $@ ) { return $self->_error( $errstr ); } $self->lex_tokenizer( $Tokenizer ); } =pod =head2 lex_source $string The C method takes a normal scalar string as argument. It creates a L object for the string, and then lexes the resulting token stream. Returns a L object, or C on error. =cut sub lex_source { my $self = ref $_[0] ? shift : shift->new; my $source = shift; unless ( defined $source and not ref $source ) { return $self->_error("Did not pass a string to PPI::Lexer::lex_source"); } # Create the Tokenizer and hand off to the next method my $Tokenizer = eval { X_TOKENIZER->new(\$source); }; if ( _INSTANCE($@, 'PPI::Exception') ) { return $self->_error( $@->message ); } elsif ( $@ ) { return $self->_error( $errstr ); } $self->lex_tokenizer( $Tokenizer ); } =pod =head2 lex_tokenizer $Tokenizer The C takes as argument a L object. It lexes the token stream from the tokenizer into a L object. Returns a L object, or C on error. =cut sub lex_tokenizer { my $self = ref $_[0] ? shift : shift->new; my $Tokenizer = _INSTANCE(shift, 'PPI::Tokenizer'); return $self->_error( "Did not pass a PPI::Tokenizer object to PPI::Lexer::lex_tokenizer" ) unless $Tokenizer; # Create the empty document my $Document = PPI::Document->new; # Lex the token stream into the document $self->{Tokenizer} = $Tokenizer; if ( !eval { $self->_lex_document($Document); 1 } ) { # If an error occurs DESTROY the partially built document. undef $Document; if ( _INSTANCE($@, 'PPI::Exception') ) { return $self->_error( $@->message ); } else { return $self->_error( $errstr ); } } return $Document; } ##################################################################### # Lex Methods - Document Object sub _lex_document { my ($self, $Document) = @_; # my $self = shift; # my $Document = _INSTANCE(shift, 'PPI::Document') or return undef; # Start the processing loop my $Token; while ( ref($Token = $self->_get_token) ) { # Add insignificant tokens directly beneath us unless ( $Token->significant ) { $self->_add_element( $Document, $Token ); next; } if ( $Token->content eq ';' ) { # It's a semi-colon on it's own. # We call this a null statement. $self->_add_element( $Document, PPI::Statement::Null->new($Token), ); next; } # Handle anything other than a structural element unless ( ref $Token eq 'PPI::Token::Structure' ) { # Determine the class for the Statement, and create it my $Statement = $self->_statement($Document, $Token)->new($Token); # Move the lexing down into the statement $self->_add_delayed( $Document ); $self->_add_element( $Document, $Statement ); $self->_lex_statement( $Statement ); next; } # Is this the opening of a structure? if ( $Token->__LEXER__opens ) { # This should actually have a Statement instead $self->_rollback( $Token ); my $Statement = PPI::Statement->new; $self->_add_element( $Document, $Statement ); $self->_lex_statement( $Statement ); next; } # Is this the close of a structure. if ( $Token->__LEXER__closes ) { # Because we are at the top of the tree, this is an error. # This means either a mis-parsing, or an mistake in the code. # To handle this, we create a "Naked Close" statement $self->_add_element( $Document, PPI::Statement::UnmatchedBrace->new($Token) ); next; } # Shouldn't be able to get here PPI::Exception->throw('Lexer reached an illegal state'); } # Did we leave the main loop because of a Tokenizer error? unless ( defined $Token ) { my $errstr = $self->{Tokenizer} ? $self->{Tokenizer}->errstr : ''; $errstr ||= 'Unknown Tokenizer Error'; PPI::Exception->throw($errstr); } # No error, it's just the end of file. # Add any insignificant trailing tokens. $self->_add_delayed( $Document ); # If the Tokenizer has any v6 blocks to attach, do so now. # Checking once at the end is faster than adding a special # case check for every statement parsed. my $perl6 = $self->{Tokenizer}->{'perl6'}; if ( @$perl6 ) { my $includes = $Document->find( 'PPI::Statement::Include::Perl6' ); foreach my $include ( @$includes ) { unless ( @$perl6 ) { PPI::Exception->throw('Failed to find a perl6 section'); } $include->{perl6} = shift @$perl6; } } return 1; } ##################################################################### # Lex Methods - Statement Object use vars qw{%STATEMENT_CLASSES}; BEGIN { # Keyword -> Statement Subclass %STATEMENT_CLASSES = ( # Things that affect the timing of execution 'BEGIN' => 'PPI::Statement::Scheduled', 'CHECK' => 'PPI::Statement::Scheduled', 'UNITCHECK' => 'PPI::Statement::Scheduled', 'INIT' => 'PPI::Statement::Scheduled', 'END' => 'PPI::Statement::Scheduled', # Special subroutines for which 'sub' is optional 'AUTOLOAD' => 'PPI::Statement::Sub', 'DESTROY' => 'PPI::Statement::Sub', # Loading and context statement 'package' => 'PPI::Statement::Package', # 'use' => 'PPI::Statement::Include', 'no' => 'PPI::Statement::Include', 'require' => 'PPI::Statement::Include', # Various declarations 'my' => 'PPI::Statement::Variable', 'local' => 'PPI::Statement::Variable', 'our' => 'PPI::Statement::Variable', 'state' => 'PPI::Statement::Variable', # Statements starting with 'sub' could be any one of... # 'sub' => 'PPI::Statement::Sub', # 'sub' => 'PPI::Statement::Scheduled', # 'sub' => 'PPI::Statement', # Compound statement 'if' => 'PPI::Statement::Compound', 'unless' => 'PPI::Statement::Compound', 'for' => 'PPI::Statement::Compound', 'foreach' => 'PPI::Statement::Compound', 'while' => 'PPI::Statement::Compound', 'until' => 'PPI::Statement::Compound', # Switch statement 'given' => 'PPI::Statement::Given', 'when' => 'PPI::Statement::When', 'default' => 'PPI::Statement::When', # Various ways of breaking out of scope 'redo' => 'PPI::Statement::Break', 'next' => 'PPI::Statement::Break', 'last' => 'PPI::Statement::Break', 'return' => 'PPI::Statement::Break', 'goto' => 'PPI::Statement::Break', # Special sections of the file '__DATA__' => 'PPI::Statement::Data', '__END__' => 'PPI::Statement::End', ); } sub _statement { my ($self, $Parent, $Token) = @_; # my $self = shift; # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1"; # my $Token = _INSTANCE(shift, 'PPI::Token') or die "Bad param 2"; # Check for things like ( parent => ... ) if ( $Parent->isa('PPI::Structure::List') or $Parent->isa('PPI::Structure::Constructor') ) { if ( $Token->isa('PPI::Token::Word') ) { # Is the next significant token a => # Read ahead to the next significant token my $Next; while ( $Next = $self->_get_token ) { unless ( $Next->significant ) { push @{$self->{delayed}}, $Next; # $self->_delay_element( $Next ); next; } # Got the next token if ( $Next->isa('PPI::Token::Operator') and $Next->content eq '=>' ) { # Is an ordinary expression $self->_rollback( $Next ); return 'PPI::Statement::Expression'; } else { last; } } # Rollback and continue $self->_rollback( $Next ); } } # Is it a token in our known classes list my $class = $STATEMENT_CLASSES{$Token->content}; # Handle potential barewords for subscripts if ( $Parent->isa('PPI::Structure::Subscript') ) { # Fast obvious case, just an expression unless ( $class and $class->isa('PPI::Statement::Expression') ) { return 'PPI::Statement::Expression'; } # This is something like "my" or "our" etc... more subtle. # Check if the next token is a closing curly brace. # This means we are something like $h{my} my $Next; while ( $Next = $self->_get_token ) { unless ( $Next->significant ) { push @{$self->{delayed}}, $Next; # $self->_delay_element( $Next ); next; } # Found the next significant token. # Is it a closing curly brace? if ( $Next->content eq '}' ) { $self->_rollback( $Next ); return 'PPI::Statement::Expression'; } else { $self->_rollback( $Next ); return $class; } } # End of file... this means it is something like $h{our # which is probably going to be $h{our} ... I think $self->_rollback( $Next ); return 'PPI::Statement::Expression'; } # If it's a token in our list, use that class return $class if $class; # Handle the more in-depth sub detection if ( $Token->content eq 'sub' ) { # Read ahead to the next significant token my $Next; while ( $Next = $self->_get_token ) { unless ( $Next->significant ) { push @{$self->{delayed}}, $Next; # $self->_delay_element( $Next ); next; } # Got the next significant token my $sclass = $STATEMENT_CLASSES{$Next->content}; if ( $sclass and $sclass eq 'PPI::Statement::Scheduled' ) { $self->_rollback( $Next ); return 'PPI::Statement::Scheduled'; } if ( $Next->isa('PPI::Token::Word') ) { $self->_rollback( $Next ); return 'PPI::Statement::Sub'; } ### Comment out these two, as they would return PPI::Statement anyway # if ( $content eq '{' ) { # Anonymous sub at start of statement # return 'PPI::Statement'; # } # # if ( $Next->isa('PPI::Token::Prototype') ) { # Anonymous sub at start of statement # return 'PPI::Statement'; # } # PPI::Statement is the safest fall-through $self->_rollback( $Next ); return 'PPI::Statement'; } # End of file... PPI::Statement::Sub is the most likely $self->_rollback( $Next ); return 'PPI::Statement::Sub'; } if ( $Token->content eq 'use' ) { # Add a special case for "use v6" lines. my $Next; while ( $Next = $self->_get_token ) { unless ( $Next->significant ) { push @{$self->{delayed}}, $Next; # $self->_delay_element( $Next ); next; } # Found the next significant token. # Is it a v6 use? if ( $Next->content eq 'v6' ) { $self->_rollback( $Next ); return 'PPI::Statement::Include::Perl6'; } else { $self->_rollback( $Next ); return 'PPI::Statement::Include'; } } # End of file... this means it is an incomplete use # line, just treat it as a normal include. $self->_rollback( $Next ); return 'PPI::Statement::Include'; } # If our parent is a Condition, we are an Expression if ( $Parent->isa('PPI::Structure::Condition') ) { return 'PPI::Statement::Expression'; } # If our parent is a List, we are also an expression if ( $Parent->isa('PPI::Structure::List') ) { return 'PPI::Statement::Expression'; } # Switch statements use expressions, as well. if ( $Parent->isa('PPI::Structure::Given') or $Parent->isa('PPI::Structure::When') ) { return 'PPI::Statement::Expression'; } if ( _INSTANCE($Token, 'PPI::Token::Label') ) { return 'PPI::Statement::Compound'; } # Beyond that, I have no idea for the moment. # Just keep adding more conditions above this. return 'PPI::Statement'; } sub _lex_statement { my ($self, $Statement) = @_; # my $self = shift; # my $Statement = _INSTANCE(shift, 'PPI::Statement') or die "Bad param 1"; # Handle some special statements if ( $Statement->isa('PPI::Statement::End') ) { return $self->_lex_end( $Statement ); } # Begin processing tokens my $Token; while ( ref( $Token = $self->_get_token ) ) { # Delay whitespace and comment tokens unless ( $Token->significant ) { push @{$self->{delayed}}, $Token; # $self->_delay_element( $Token ); next; } # Structual closes, and __DATA__ and __END__ tags implicitly # end every type of statement if ( $Token->__LEXER__closes or $Token->isa('PPI::Token::Separator') ) { # Rollback and end the statement return $self->_rollback( $Token ); } # Normal statements never implicitly end unless ( $Statement->__LEXER__normal ) { # Have we hit an implicit end to the statement unless ( $self->_continues( $Statement, $Token ) ) { # Rollback and finish the statement return $self->_rollback( $Token ); } } # Any normal character just gets added unless ( $Token->isa('PPI::Token::Structure') ) { $self->_add_element( $Statement, $Token ); next; } # Handle normal statement terminators if ( $Token->content eq ';' ) { $self->_add_element( $Statement, $Token ); return 1; } # Which leaves us with a new structure # Determine the class for the structure and create it my $method = $RESOLVE{$Token->content}; my $Structure = $self->$method($Statement)->new($Token); # Move the lexing down into the Structure $self->_add_delayed( $Statement ); $self->_add_element( $Statement, $Structure ); $self->_lex_structure( $Structure ); } # Was it an error in the tokenizer? unless ( defined $Token ) { PPI::Exception->throw; } # No, it's just the end of the file... # Roll back any insignificant tokens, they'll get added at the Document level $self->_rollback; } sub _lex_end { my ($self, $Statement) = @_; # my $self = shift; # my $Statement = _INSTANCE(shift, 'PPI::Statement::End') or die "Bad param 1"; # End of the file, EVERYTHING is ours my $Token; while ( $Token = $self->_get_token ) { # Inlined $Statement->__add_element($Token); Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $Token} = $Statement ); push @{$Statement->{children}}, $Token; } # Was it an error in the tokenizer? unless ( defined $Token ) { PPI::Exception->throw; } # No, it's just the end of the file... # Roll back any insignificant tokens, they get added at the Document level $self->_rollback; } # For many statements, it can be difficult to determine the end-point. # This method takes a statement and the next significant token, and attempts # to determine if the there is a statement boundary between the two, or if # the statement can continue with the token. sub _continues { my ($self, $Statement, $Token) = @_; # my $self = shift; # my $Statement = _INSTANCE(shift, 'PPI::Statement') or die "Bad param 1"; # my $Token = _INSTANCE(shift, 'PPI::Token') or die "Bad param 2"; # Handle the simple block case # { print 1; } if ( $Statement->schildren == 1 and $Statement->schild(0)->isa('PPI::Structure::Block') ) { return ''; } # Alrighty then, there are only five implied end statement types, # ::Scheduled blocks, ::Sub declarations, ::Compound, ::Given, and ::When # statements. unless ( ref($Statement) =~ /\b(?:Scheduled|Sub|Compound|Given|When)$/ ) { return 1; } # Of these five, ::Scheduled, ::Sub, ::Given, and ::When follow the same # simple rule and can be handled first. my @part = $Statement->schildren; my $LastChild = $part[-1]; unless ( $Statement->isa('PPI::Statement::Compound') ) { # If the last significant element of the statement is a block, # then a scheduled statement is done, no questions asked. return ! $LastChild->isa('PPI::Structure::Block'); } # Now we get to compound statements, which kind of suck (to lex). # However, of them all, the 'if' type, which includes unless, are # relatively easy to handle compared to the others. my $type = $Statement->type; if ( $type eq 'if' ) { # This should be one of the following # if (EXPR) BLOCK # if (EXPR) BLOCK else BLOCK # if (EXPR) BLOCK elsif (EXPR) BLOCK ... else BLOCK # We only implicitly end on a block unless ( $LastChild->isa('PPI::Structure::Block') ) { # if (EXPR) ... # if (EXPR) BLOCK else ... # if (EXPR) BLOCK elsif (EXPR) BLOCK ... return 1; } # If the token before the block is an 'else', # it's over, no matter what. my $NextLast = $Statement->schild(-2); if ( $NextLast and $NextLast->isa('PPI::Token') and $NextLast->isa('PPI::Token::Word') and $NextLast->content eq 'else' ) { return ''; } # Otherwise, we continue for 'elsif' or 'else' only. if ( $Token->isa('PPI::Token::Word') and ( $Token->content eq 'else' or $Token->content eq 'elsif' ) ) { return 1; } return ''; } if ( $type eq 'label' ) { # We only have the label so far, could be any of # LABEL while (EXPR) BLOCK # LABEL while (EXPR) BLOCK continue BLOCK # LABEL for (EXPR; EXPR; EXPR) BLOCK # LABEL foreach VAR (LIST) BLOCK # LABEL foreach VAR (LIST) BLOCK continue BLOCK # LABEL BLOCK continue BLOCK # Handle cases with a word after the label if ( $Token->isa('PPI::Token::Word') and $Token->content =~ /^(?:while|until|for|foreach)$/ ) { return 1; } # Handle labelled blocks if ( $Token->isa('PPI::Token::Structure') && $Token->content eq '{' ) { return 1; } return ''; } # Handle the common "after round braces" case if ( $LastChild->isa('PPI::Structure') and $LastChild->braces eq '()' ) { # LABEL while (EXPR) ... # LABEL while (EXPR) ... # LABEL for (EXPR; EXPR; EXPR) ... # LABEL for VAR (LIST) ... # LABEL foreach VAR (LIST) ... # Only a block will do return $Token->isa('PPI::Token::Structure') && $Token->content eq '{'; } if ( $type eq 'for' ) { # LABEL for (EXPR; EXPR; EXPR) BLOCK if ( $LastChild->isa('PPI::Token::Word') and $LastChild->content =~ /^for(?:each)?\z/ ) { # LABEL for ... if ( ( $Token->isa('PPI::Token::Structure') and $Token->content eq '(' ) or $Token->isa('PPI::Token::QuoteLike::Words') ) { return 1; } if ( $LastChild->isa('PPI::Token::QuoteLike::Words') ) { # LABEL for VAR QW{} ... # LABEL foreach VAR QW{} ... # Only a block will do return $Token->isa('PPI::Token::Structure') && $Token->content eq '{'; } # In this case, we can also behave like a foreach $type = 'foreach'; } elsif ( $LastChild->isa('PPI::Structure::Block') ) { # LABEL for (EXPR; EXPR; EXPR) BLOCK # That's it, nothing can continue return ''; } elsif ( $LastChild->isa('PPI::Token::QuoteLike::Words') ) { # LABEL for VAR QW{} ... # LABEL foreach VAR QW{} ... # Only a block will do return $Token->isa('PPI::Token::Structure') && $Token->content eq '{'; } } # Handle the common continue case if ( $LastChild->isa('PPI::Token::Word') and $LastChild->content eq 'continue' ) { # LABEL while (EXPR) BLOCK continue ... # LABEL foreach VAR (LIST) BLOCK continue ... # LABEL BLOCK continue ... # Only a block will do return $Token->isa('PPI::Token::Structure') && $Token->content eq '{'; } # Handle the common continuable block case if ( $LastChild->isa('PPI::Structure::Block') ) { # LABEL while (EXPR) BLOCK # LABEL while (EXPR) BLOCK ... # LABEL for (EXPR; EXPR; EXPR) BLOCK # LABEL foreach VAR (LIST) BLOCK # LABEL foreach VAR (LIST) BLOCK ... # LABEL BLOCK ... # Is this the block for a continue? if ( _INSTANCE($part[-2], 'PPI::Token::Word') and $part[-2]->content eq 'continue' ) { # LABEL while (EXPR) BLOCK continue BLOCK # LABEL foreach VAR (LIST) BLOCK continue BLOCK # LABEL BLOCK continue BLOCK # That's it, nothing can continue this return ''; } # Only a continue will do return $Token->isa('PPI::Token::Word') && $Token->content eq 'continue'; } if ( $type eq 'block' ) { # LABEL BLOCK continue BLOCK # Every possible case is covered in the common cases above } if ( $type eq 'while' ) { # LABEL while (EXPR) BLOCK # LABEL while (EXPR) BLOCK continue BLOCK # LABEL until (EXPR) BLOCK # LABEL until (EXPR) BLOCK continue BLOCK # The only case not covered is the while ... if ( $LastChild->isa('PPI::Token::Word') and ( $LastChild->content eq 'while' or $LastChild->content eq 'until' ) ) { # LABEL while ... # LABEL until ... # Only a condition structure will do return $Token->isa('PPI::Token::Structure') && $Token->content eq '('; } } if ( $type eq 'foreach' ) { # LABEL foreach VAR (LIST) BLOCK # LABEL foreach VAR (LIST) BLOCK continue BLOCK # The only two cases that have not been covered already are # 'foreach ...' and 'foreach VAR ...' if ( $LastChild->isa('PPI::Token::Symbol') ) { # LABEL foreach my $scalar ... # Open round brace, or a quotewords return 1 if $Token->isa('PPI::Token::Structure') && $Token->content eq '('; return 1 if $Token->isa('PPI::Token::QuoteLike::Words'); return ''; } if ( $LastChild->content eq 'foreach' or $LastChild->content eq 'for' ) { # There are three possibilities here if ( $Token->isa('PPI::Token::Word') and ( ($STATEMENT_CLASSES{ $Token->content } || '') eq 'PPI::Statement::Variable' ) ) { # VAR == 'my ...' return 1; } elsif ( $Token->content =~ /^\$/ ) { # VAR == '$scalar' return 1; } elsif ( $Token->isa('PPI::Token::Structure') and $Token->content eq '(' ) { return 1; } elsif ( $Token->isa('PPI::Token::QuoteLike::Words') ) { return 1; } else { return ''; } } if ( ($STATEMENT_CLASSES{ $LastChild->content } || '') eq 'PPI::Statement::Variable' ) { # LABEL foreach my ... # Only a scalar will do return $Token->content =~ /^\$/; } # Handle the rare for my $foo qw{bar} ... case if ( $LastChild->isa('PPI::Token::QuoteLike::Words') ) { # LABEL for VAR QW ... # LABEL foreach VAR QW ... # Only a block will do return $Token->isa('PPI::Token::Structure') && $Token->content eq '{'; } } # Something we don't know about... what could it be PPI::Exception->throw("Illegal state in '$type' compound statement"); } ##################################################################### # Lex Methods - Structure Object # Given a parent element, and a ( token to open a structure, determine # the class that the structure should be. sub _round { my ($self, $Parent) = @_; # my $self = shift; # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1"; # Get the last significant element in the parent my $Element = $Parent->schild(-1); if ( _INSTANCE($Element, 'PPI::Token::Word') ) { # Can it be determined because it is a keyword? my $rclass = $ROUND{$Element->content}; return $rclass if $rclass; } # If we are part of a for or foreach statement, we are a ForLoop if ( $Parent->isa('PPI::Statement::Compound') ) { if ( $Parent->type =~ /^for(?:each)?$/ ) { return 'PPI::Structure::For'; } } elsif ( $Parent->isa('PPI::Statement::Given') ) { return 'PPI::Structure::Given'; } elsif ( $Parent->isa('PPI::Statement::When') ) { return 'PPI::Structure::When'; } # Otherwise, it must be a list # If the previous element is -> then we mark it as a dereference if ( _INSTANCE($Element, 'PPI::Token::Operator') and $Element->content eq '->' ) { $Element->{_dereference} = 1; } 'PPI::Structure::List' } # Given a parent element, and a [ token to open a structure, determine # the class that the structure should be. sub _square { my ($self, $Parent) = @_; # my $self = shift; # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1"; # Get the last significant element in the parent my $Element = $Parent->schild(-1); # Is this a subscript, like $foo[1] or $foo{expr} if ( $Element ) { if ( $Element->isa('PPI::Token::Operator') and $Element->content eq '->' ) { # $foo->[] $Element->{_dereference} = 1; return 'PPI::Structure::Subscript'; } if ( $Element->isa('PPI::Structure::Subscript') ) { # $foo{}[] return 'PPI::Structure::Subscript'; } if ( $Element->isa('PPI::Token::Symbol') and $Element->content =~ /^(?:\$|\@)/ ) { # $foo[], @foo[] return 'PPI::Structure::Subscript'; } # FIXME - More cases to catch } # Otherwise, we assume that it's an anonymous arrayref constructor 'PPI::Structure::Constructor'; } use vars qw{%CURLY_CLASSES @CURLY_LOOKAHEAD_CLASSES}; BEGIN { # Keyword -> Structure class maps %CURLY_CLASSES = ( # Blocks 'sub' => 'PPI::Structure::Block', 'grep' => 'PPI::Structure::Block', 'map' => 'PPI::Structure::Block', 'sort' => 'PPI::Structure::Block', 'do' => 'PPI::Structure::Block', # rely on 'continue' + block being handled elsewhere # rely on 'eval' + block being handled elsewhere # Hash constructors 'scalar' => 'PPI::Structure::Constructor', '=' => 'PPI::Structure::Constructor', '||=' => 'PPI::Structure::Constructor', '&&=' => 'PPI::Structure::Constructor', '//=' => 'PPI::Structure::Constructor', '||' => 'PPI::Structure::Constructor', '&&' => 'PPI::Structure::Constructor', '//' => 'PPI::Structure::Constructor', '?' => 'PPI::Structure::Constructor', ':' => 'PPI::Structure::Constructor', ',' => 'PPI::Structure::Constructor', '=>' => 'PPI::Structure::Constructor', '+' => 'PPI::Structure::Constructor', # per perlref 'return' => 'PPI::Structure::Constructor', # per perlref 'bless' => 'PPI::Structure::Constructor', # pragmatic -- # perlfunc says first arg is a reference, and # bless {; ... } fails to compile. ); @CURLY_LOOKAHEAD_CLASSES = ( {}, # not used { ';' => 'PPI::Structure::Block', # per perlref '}' => 'PPI::Structure::Constructor', }, { '=>' => 'PPI::Structure::Constructor', }, ); } # Given a parent element, and a { token to open a structure, determine # the class that the structure should be. sub _curly { my ($self, $Parent) = @_; # my $self = shift; # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1"; # Get the last significant element in the parent my $Element = $Parent->schild(-1); my $content = $Element ? $Element->content : ''; # Is this a subscript, like $foo[1] or $foo{expr} if ( $Element ) { if ( $content eq '->' and $Element->isa('PPI::Token::Operator') ) { # $foo->{} $Element->{_dereference} = 1; return 'PPI::Structure::Subscript'; } if ( $Element->isa('PPI::Structure::Subscript') ) { # $foo[]{} return 'PPI::Structure::Subscript'; } if ( $content =~ /^(?:\$|\@)/ and $Element->isa('PPI::Token::Symbol') ) { # $foo{}, @foo{} return 'PPI::Structure::Subscript'; } if ( $Element->isa('PPI::Structure::Block') ) { # deference - ${$hash_ref}{foo} # or even ${burfle}{foo} # hash slice - @{$hash_ref}{'foo', 'bar'} if ( my $prior = $Parent->schild(-2) ) { my $prior_content = $prior->content(); $prior->isa( 'PPI::Token::Cast' ) and ( $prior_content eq '@' || $prior_content eq '$' ) and return 'PPI::Structure::Subscript'; } } if ( $CURLY_CLASSES{$content} ) { # Known type return $CURLY_CLASSES{$content}; } } # Are we in a compound statement if ( $Parent->isa('PPI::Statement::Compound') ) { # We will only encounter blocks in compound statements return 'PPI::Structure::Block'; } # Are we the second or third argument of use if ( $Parent->isa('PPI::Statement::Include') ) { if ( $Parent->schildren == 2 || $Parent->schildren == 3 && $Parent->schild(2)->isa('PPI::Token::Number') ) { # This is something like use constant { ... }; return 'PPI::Structure::Constructor'; } } # Unless we are at the start of the statement, everything else should be a block ### FIXME This is possibly a bad choice, but will have to do for now. return 'PPI::Structure::Block' if $Element; # Special case: Are we the param of a core function # i.e. map({ $_ => 1 } @foo) if ( $Parent->isa('PPI::Statement') and _INSTANCE($Parent->parent, 'PPI::Structure::List') ) { my $function = $Parent->parent->parent->schild(-2); if ( $function and $function->content =~ /^(?:map|grep|sort)$/ ) { return 'PPI::Structure::Block'; } } # We need to scan ahead. my $Next; my $position = 0; my @delayed; while ( $Next = $self->_get_token ) { unless ( $Next->significant ) { push @delayed, $Next; next; } # If we are off the end of the lookahead array, if ( ++$position >= @CURLY_LOOKAHEAD_CLASSES ) { # default to block. $self->_buffer( splice(@delayed), $Next ); last; # If the content at this position is known } elsif ( my $class = $CURLY_LOOKAHEAD_CLASSES[$position] {$Next->content} ) { # return the associated class. $self->_buffer( splice(@delayed), $Next ); return $class; } # Delay and continue push @delayed, $Next; } # Hit the end of the document, or bailed out, go with block $self->_buffer( splice(@delayed) ); if ( ref $Parent eq 'PPI::Statement' ) { bless $Parent, 'PPI::Statement::Compound'; } return 'PPI::Structure::Block'; } sub _lex_structure { my ($self, $Structure) = @_; # my $self = shift; # my $Structure = _INSTANCE(shift, 'PPI::Structure') or die "Bad param 1"; # Start the processing loop my $Token; while ( ref($Token = $self->_get_token) ) { # Is this a direct type token unless ( $Token->significant ) { push @{$self->{delayed}}, $Token; # $self->_delay_element( $Token ); next; } # Anything other than a Structure starts a Statement unless ( $Token->isa('PPI::Token::Structure') ) { # Because _statement may well delay and rollback itself, # we need to add the delayed tokens early $self->_add_delayed( $Structure ); # Determine the class for the Statement and create it my $Statement = $self->_statement($Structure, $Token)->new($Token); # Move the lexing down into the Statement $self->_add_element( $Structure, $Statement ); $self->_lex_statement( $Statement ); next; } # Is this the opening of another structure directly inside us? if ( $Token->__LEXER__opens ) { # Rollback the Token, and recurse into the statement $self->_rollback( $Token ); my $Statement = PPI::Statement->new; $self->_add_element( $Structure, $Statement ); $self->_lex_statement( $Statement ); next; } # Is this the close of a structure ( which would be an error ) if ( $Token->__LEXER__closes ) { # Is this OUR closing structure if ( $Token->content eq $Structure->start->__LEXER__opposite ) { # Add any delayed tokens, and the finishing token (the ugly way) $self->_add_delayed( $Structure ); $Structure->{finish} = $Token; Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $Token} = $Structure ); # Confirm that ForLoop structures are actually so, and # aren't really a list. if ( $Structure->isa('PPI::Structure::For') ) { if ( 2 > scalar grep { $_->isa('PPI::Statement') } $Structure->children ) { bless($Structure, 'PPI::Structure::List'); } } return 1; } # Unmatched closing brace. # Either they typed the wrong thing, or haven't put # one at all. Either way it's an error we need to # somehow handle gracefully. For now, we'll treat it # as implicitly ending the structure. This causes the # least damage across the various reasons why this # might have happened. return $self->_rollback( $Token ); } # It's a semi-colon on it's own, just inside the block. # This is a null statement. $self->_add_element( $Structure, PPI::Statement::Null->new($Token), ); } # Is this an error unless ( defined $Token ) { PPI::Exception->throw; } # No, it's just the end of file. # Add any insignificant trailing tokens. $self->_add_delayed( $Structure ); } ##################################################################### # Support Methods # Get the next token for processing, handling buffering sub _get_token { shift(@{$_[0]->{buffer}}) or $_[0]->{Tokenizer}->get_token; } # Old long version of the above # my $self = shift; # # First from the buffer # if ( @{$self->{buffer}} ) { # return shift @{$self->{buffer}}; # } # # # Then from the Tokenizer # $self->{Tokenizer}->get_token; # } # Delay the addition of a insignificant elements. # This ended up being inlined. # sub _delay_element { # my $self = shift; # my $Element = _INSTANCE(shift, 'PPI::Element') or die "Bad param 1"; # push @{ $_[0]->{delayed} }, $_[1]; # } # Add an Element to a Node, including any delayed Elements sub _add_element { my ($self, $Parent, $Element) = @_; # my $self = shift; # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1"; # my $Element = _INSTANCE(shift, 'PPI::Element') or die "Bad param 2"; # Handle a special case, where a statement is not fully resolved if ( ref $Parent eq 'PPI::Statement' and my $first = $Parent->schild(0) ) { if ( $first->isa('PPI::Token::Label') and !(my $second = $Parent->schild(1)) ) { my $new_class = $STATEMENT_CLASSES{$second->content}; # It's a labelled statement bless $Parent, $new_class if $new_class; } } # Add first the delayed, from the front, then the passed element foreach my $el ( @{$self->{delayed}} ) { Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $el} = $Parent ); # Inlined $Parent->__add_element($el); } Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $Element} = $Parent ); push @{$Parent->{children}}, @{$self->{delayed}}, $Element; # Clear the delayed elements $self->{delayed} = []; } # Specifically just add any delayed tokens, if any. sub _add_delayed { my ($self, $Parent) = @_; # my $self = shift; # my $Parent = _INSTANCE(shift, 'PPI::Node') or die "Bad param 1"; # Add any delayed foreach my $el ( @{$self->{delayed}} ) { Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $el} = $Parent ); # Inlined $Parent->__add_element($el); } push @{$Parent->{children}}, @{$self->{delayed}}; # Clear the delayed elements $self->{delayed} = []; } # Rollback the delayed tokens, plus any passed. Once all the tokens # have been moved back on to the buffer, the order should be. # <--- @{$self->{delayed}}, @_, @{$self->{buffer}} <---- sub _rollback { my $self = shift; # First, put any passed objects back if ( @_ ) { unshift @{$self->{buffer}}, splice @_; } # Then, put back anything delayed if ( @{$self->{delayed}} ) { unshift @{$self->{buffer}}, splice @{$self->{delayed}}; } 1; } # Partial rollback, just return a single list to the buffer sub _buffer { my $self = shift; # Put any passed objects back if ( @_ ) { unshift @{$self->{buffer}}, splice @_; } 1; } ##################################################################### # Error Handling # Set the error message sub _error { $errstr = $_[1]; undef; } # Clear the error message. # Returns the object as a convenience. sub _clear { $errstr = ''; $_[0]; } =pod =head2 errstr For any error that occurs, you can use the C, as either a static or object method, to access the error message. If no error occurs for any particular action, C will return false. =cut sub errstr { $errstr; } ##################################################################### # PDOM Extensions # # This is something of a future expansion... ignore it for now :) # # use PPI::Statement::Sub (); # # sub PPI::Statement::Sub::__LEXER__normal { '' } 1; =pod =head1 TO DO - Add optional support for some of the more common source filters - Some additional checks for blessing things into various Statement and Structure subclasses. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Token.pm0000755000175100010010000001326212430462144011677 0ustar package PPI::Token; =pod =head1 NAME PPI::Token - A single token of Perl source code =head1 INHERITANCE PPI::Token isa PPI::Element =head1 DESCRIPTION C is the abstract base class for all Tokens. In PPI terms, a "Token" is a L that directly represents bytes of source code. =head1 METHODS =cut use strict; use Params::Util qw{_INSTANCE}; use PPI::Element (); use PPI::Exception (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Element'; } # We don't load the abstracts, they are loaded # as part of the inheritance process. # Load the token classes use PPI::Token::BOM (); use PPI::Token::Whitespace (); use PPI::Token::Comment (); use PPI::Token::Pod (); use PPI::Token::Number (); use PPI::Token::Number::Binary (); use PPI::Token::Number::Octal (); use PPI::Token::Number::Hex (); use PPI::Token::Number::Float (); use PPI::Token::Number::Exp (); use PPI::Token::Number::Version (); use PPI::Token::Word (); use PPI::Token::DashedWord (); use PPI::Token::Symbol (); use PPI::Token::ArrayIndex (); use PPI::Token::Magic (); use PPI::Token::Quote::Single (); use PPI::Token::Quote::Double (); use PPI::Token::Quote::Literal (); use PPI::Token::Quote::Interpolate (); use PPI::Token::QuoteLike::Backtick (); use PPI::Token::QuoteLike::Command (); use PPI::Token::QuoteLike::Regexp (); use PPI::Token::QuoteLike::Words (); use PPI::Token::QuoteLike::Readline (); use PPI::Token::Regexp::Match (); use PPI::Token::Regexp::Substitute (); use PPI::Token::Regexp::Transliterate (); use PPI::Token::Operator (); use PPI::Token::Cast (); use PPI::Token::Structure (); use PPI::Token::Label (); use PPI::Token::HereDoc (); use PPI::Token::Separator (); use PPI::Token::Data (); use PPI::Token::End (); use PPI::Token::Prototype (); use PPI::Token::Attribute (); use PPI::Token::Unknown (); ##################################################################### # Constructor and Related sub new { bless { content => (defined $_[1] ? "$_[1]" : '') }, $_[0]; } sub set_class { my $self = shift; # @_ or throw Exception("No arguments to set_class"); my $class = substr( $_[0], 0, 12 ) eq 'PPI::Token::' ? shift : 'PPI::Token::' . shift; # Find out if the current and new classes are complex my $old_quote = (ref($self) =~ /\b(?:Quote|Regex)\b/o) ? 1 : 0; my $new_quote = ($class =~ /\b(?:Quote|Regex)\b/o) ? 1 : 0; # No matter what happens, we will have to rebless bless $self, $class; # If we are changing to or from a Quote style token, we # can't just rebless and need to do some extra thing # Otherwise, we have done enough return $class if ($old_quote - $new_quote) == 0; # Make a new token from the old content, and overwrite the current # token's attributes with the new token's attributes. my $token = $class->new( $self->{content} ); %$self = %$token; # Return the class as a convenience return $class; } ##################################################################### # PPI::Token Methods =pod =head2 set_content $string The C method allows you to set/change the string that the C object represents. Returns the string you set the Token to =cut sub set_content { $_[0]->{content} = $_[1]; } =pod =head2 add_content $string The C method allows you to add additional bytes of code to the end of the Token. Returns the new full string after the bytes have been added. =cut sub add_content { $_[0]->{content} .= $_[1] } =pod =head2 length The C method returns the length of the string in a Token. =cut sub length { CORE::length($_[0]->{content}) } ##################################################################### # Overloaded PPI::Element methods sub content { $_[0]->{content}; } # You can insert either a statement, or a non-significant token. sub insert_before { my $self = shift; my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; if ( $Element->isa('PPI::Structure') ) { return $self->__insert_before($Element); } elsif ( $Element->isa('PPI::Token') ) { return $self->__insert_before($Element); } ''; } # As above, you can insert a statement, or a non-significant token sub insert_after { my $self = shift; my $Element = _INSTANCE(shift, 'PPI::Element') or return undef; if ( $Element->isa('PPI::Structure') ) { return $self->__insert_after($Element); } elsif ( $Element->isa('PPI::Token') ) { return $self->__insert_after($Element); } ''; } ##################################################################### # Tokenizer Methods sub __TOKENIZER__on_line_start() { 1 } sub __TOKENIZER__on_line_end() { 1 } sub __TOKENIZER__on_char() { 'Unknown' } ##################################################################### # Lexer Methods sub __LEXER__opens { ref($_[0]) eq 'PPI::Token::Structure' and $_[0]->{content} =~ /(?:\(|\[|\{)/ } sub __LEXER__closes { ref($_[0]) eq 'PPI::Token::Structure' and $_[0]->{content} =~ /(?:\)|\]|\})/ } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Element.pm0000755000175100010010000005437312430462144012220 0ustar package PPI::Element; =pod =head1 NAME PPI::Element - The abstract Element class, a base for all source objects =head1 INHERITANCE PPI::Element is the root of the PDOM tree =head1 DESCRIPTION The abstract C serves as a base class for all source-related objects, from a single whitespace token to an entire document. It provides a basic set of methods to provide a common interface and basic implementations. =head1 METHODS =cut use strict; use Clone (); use Scalar::Util qw{refaddr}; use Params::Util qw{_INSTANCE _ARRAY}; use List::MoreUtils (); use PPI::Util (); use PPI::Node (); use vars qw{$VERSION $errstr %_PARENT}; BEGIN { $VERSION = '1.220'; $errstr = ''; # Master Child -> Parent index %_PARENT = (); } use overload 'bool' => \&PPI::Util::TRUE; use overload '""' => 'content'; use overload '==' => '__equals'; use overload '!=' => '__nequals'; use overload 'eq' => '__eq'; use overload 'ne' => '__ne'; ##################################################################### # General Properties =pod =head2 significant Because we treat whitespace and other non-code items as Tokens (in order to be able to "round trip" the L back to a file) the C method allows us to distinguish between tokens that form a part of the code, and tokens that aren't significant, such as whitespace, POD, or the portion of a file after (and including) the C<__END__> token. Returns true if the Element is significant, or false it not. =cut ### XS -> PPI/XS.xs:_PPI_Element__significant 0.845+ sub significant() { 1 } =pod =head2 class The C method is provided as a convenience, and really does nothing more than returning C. However, some people have found that they appreciate the laziness of C<$Foo-Eclass eq 'whatever'>, so I have caved to popular demand and included it. Returns the class of the Element as a string =cut sub class { ref($_[0]) } =pod =head2 tokens The C method returns a list of L objects for the Element, essentially getting back that part of the document as if it had not been lexed. This also means there are no Statements and no Structures in the list, just the Token classes. =cut sub tokens { $_[0] } =pod =head2 content For B C, the C method will reconstitute the base code for it as a single string. This method is also the method used for overloading stringification. When an Element is used in a double-quoted string for example, this is the method that is called. B You should be aware that because of the way that here-docs are handled, any here-doc content is not included in C, and as such you should B eval or execute the result if it contains any L. The L method C should be used to stringify a PDOM document into something that can be executed as expected. Returns the basic code as a string (excluding here-doc content). =cut ### XS -> PPI/XS.xs:_PPI_Element__content 0.900+ sub content() { '' } ##################################################################### # Naigation Methods =pod =head2 parent Elements themselves are not intended to contain other Elements, that is left to the L abstract class, a subclass of C. However, all Elements can be contained B a parent Node. If an Element is within a parent Node, the C method returns the Node. =cut sub parent { $_PARENT{refaddr $_[0]} } =pod =head2 descendant_of $element Answers whether a C is contained within another one. Cs are considered to be descendants of themselves. =cut sub descendant_of { my $cursor = shift; my $parent = shift or return undef; while ( refaddr $cursor != refaddr $parent ) { $cursor = $_PARENT{refaddr $cursor} or return ''; } return 1; } =pod =head2 ancestor_of $element Answers whether a C is contains another one. Cs are considered to be ancestors of themselves. =cut sub ancestor_of { my $self = shift; my $cursor = shift or return undef; while ( refaddr $cursor != refaddr $self ) { $cursor = $_PARENT{refaddr $cursor} or return ''; } return 1; } =pod =head2 statement For a C that is contained (at some depth) within a L, the C method will return the first parent Statement object lexically 'above' the Element. Returns a L object, which may be the same Element if the Element is itself a L object. Returns false if the Element is not within a Statement and is not itself a Statement. =cut sub statement { my $cursor = shift; while ( ! _INSTANCE($cursor, 'PPI::Statement') ) { $cursor = $_PARENT{refaddr $cursor} or return ''; } $cursor; } =pod =head2 top For a C that is contained within a PDOM tree, the C method will return the top-level Node in the tree. Most of the time this should be a L object, however this will not always be so. For example, if a subroutine has been removed from its Document, to be moved to another Document. Returns the top-most PDOM object, which may be the same Element, if it is not within any parent PDOM object. =cut sub top { my $cursor = shift; while ( my $parent = $_PARENT{refaddr $cursor} ) { $cursor = $parent; } $cursor; } =pod =head2 document For an Element that is contained within a L object, the C method will return the top-level Document for the Element. Returns the L for this Element, or false if the Element is not contained within a Document. =cut sub document { my $top = shift->top; _INSTANCE($top, 'PPI::Document') and $top; } =pod =head2 next_sibling All L objects (specifically, our parent Node) contain a number of C objects. The C method returns the C immediately after the current one, or false if there is no next sibling. =cut sub next_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; $elements->[$position + 1] || ''; } =pod =head2 snext_sibling As per the other 's' methods, the C method returns the next B sibling of the C object. Returns a C object, or false if there is no 'next' significant sibling. =cut sub snext_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; while ( defined(my $it = $elements->[++$position]) ) { return $it if $it->significant; } ''; } =pod =head2 previous_sibling All L objects (specifically, our parent Node) contain a number of C objects. The C method returns the Element immediately before the current one, or false if there is no 'previous' C object. =cut sub previous_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; $position and $elements->[$position - 1] or ''; } =pod =head2 sprevious_sibling As per the other 's' methods, the C method returns the previous B sibling of the C object. Returns a C object, or false if there is no 'previous' significant sibling. =cut sub sprevious_sibling { my $self = shift; my $parent = $_PARENT{refaddr $self} or return ''; my $key = refaddr $self; my $elements = $parent->{children}; my $position = List::MoreUtils::firstidx { refaddr $_ == $key } @$elements; while ( $position-- and defined(my $it = $elements->[$position]) ) { return $it if $it->significant; } ''; } =pod =head2 first_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the first PPI::Token object within or equal to this one. That is, if called on a L subclass, it will descend until it finds a L. If called on a L object, it will return the same object. Returns a L object, or dies on error (which should be extremely rare and only occur if an illegal empty L exists below the current Element somewhere.) =cut sub first_token { my $cursor = shift; while ( $cursor->isa('PPI::Node') ) { $cursor = $cursor->first_element or die "Found empty PPI::Node while getting first token"; } $cursor; } =pod =head2 last_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the last PPI::Token object within or equal to this one. That is, if called on a L subclass, it will descend until it finds a L. If called on a L object, it will return the itself. Returns a L object, or dies on error (which should be extremely rare and only occur if an illegal empty L exists below the current Element somewhere.) =cut sub last_token { my $cursor = shift; while ( $cursor->isa('PPI::Node') ) { $cursor = $cursor->last_element or die "Found empty PPI::Node while getting first token"; } $cursor; } =pod =head2 next_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the L object that is immediately after the current Element, even if it is not within the same parent L as the one for which the method is being called. Note that this is B defined as a L-specific method, because it can be useful to find the next token that is after, say, a L, although obviously it would be useless to want the next token after a L. Returns a L object, or false if there are no more tokens after the Element. =cut sub next_token { my $cursor = shift; # Find the next element, going upwards as needed while ( 1 ) { my $element = $cursor->next_sibling; if ( $element ) { return $element if $element->isa('PPI::Token'); return $element->first_token; } $cursor = $cursor->parent or return ''; if ( $cursor->isa('PPI::Structure') and $cursor->finish ) { return $cursor->finish; } } } =pod =head2 previous_token As a support method for higher-order algorithms that deal specifically with tokens and actual Perl content, the C method finds the L object that is immediately before the current Element, even if it is not within the same parent L as this one. Note that this is not defined as a L-only method, because it can be useful to find the token is before, say, a L, although obviously it would be useless to want the next token before a L. Returns a L object, or false if there are no more tokens before the C. =cut sub previous_token { my $cursor = shift; # Find the previous element, going upwards as needed while ( 1 ) { my $element = $cursor->previous_sibling; if ( $element ) { return $element if $element->isa('PPI::Token'); return $element->last_token; } $cursor = $cursor->parent or return ''; if ( $cursor->isa('PPI::Structure') and $cursor->start ) { return $cursor->start; } } } ##################################################################### # Manipulation =pod =head2 clone As per the L module, the C method makes a perfect copy of an Element object. In the generic case, the implementation is done using the L module's mechanism itself. In higher-order cases, such as for Nodes, there is more work involved to keep the parent-child links intact. =cut sub clone { Clone::clone(shift); } =pod =head2 insert_before @Elements The C method allows you to insert lexical perl content, in the form of C objects, before the calling C. You need to be very careful when modifying perl code, as it's easy to break things. In its initial incarnation, this method allows you to insert a single Element, and will perform some basic checking to prevent you inserting something that would be structurally wrong (in PDOM terms). In future, this method may be enhanced to allow the insertion of multiple Elements, inline-parsed code strings or L objects. Returns true if the Element was inserted, false if it can not be inserted, or C if you do not provide a C object as a parameter. =cut sub __insert_before { my $self = shift; $self->parent->__insert_before_child( $self, @_ ); } =pod =head2 insert_after @Elements The C method allows you to insert lexical perl content, in the form of C objects, after the calling C. You need to be very careful when modifying perl code, as it's easy to break things. In its initial incarnation, this method allows you to insert a single Element, and will perform some basic checking to prevent you inserting something that would be structurally wrong (in PDOM terms). In future, this method may be enhanced to allow the insertion of multiple Elements, inline-parsed code strings or L objects. Returns true if the Element was inserted, false if it can not be inserted, or C if you do not provide a C object as a parameter. =cut sub __insert_after { my $self = shift; $self->parent->__insert_after_child( $self, @_ ); } =pod =head2 remove For a given C, the C method will remove it from its parent B, along with all of its children. Returns the C itself as a convenience, or C if an error occurs while trying to remove the C. =cut sub remove { my $self = shift; my $parent = $self->parent or return $self; $parent->remove_child( $self ); } =pod =head2 delete For a given C, the C method will remove it from its parent, immediately deleting the C and all of its children (if it has any). Returns true if the C was successfully deleted, or C if an error occurs while trying to remove the C. =cut sub delete { $_[0]->remove or return undef; $_[0]->DESTROY; 1; } =pod =head2 replace $Element Although some higher level class support more exotic forms of replace, at the basic level the C method takes a single C as an argument and replaces the current C with it. To prevent accidental damage to code, in this initial implementation the replacement element B be of the same class (or a subclass) as the one being replaced. =cut sub replace { my $self = ref $_[0] ? shift : return undef; _INSTANCE(shift, ref $self) or return undef; die "The ->replace method has not yet been implemented"; } =pod =head2 location If the Element exists within a L that has indexed the Element locations using C, the C method will return the location of the first character of the Element within the Document. Returns the location as a reference to a five-element array in the form C<[ $line, $rowchar, $col, $logical_line, $logical_file_name ]>. The values are in a human format, with the first character of the file located at C<[ 1, 1, 1, ?, 'something' ]>. The second and third numbers are similar, except that the second is the literal horizontal character, and the third is the visual column, taking into account tabbing (see L). The fourth number is the line number, taking into account any C<#line> directives. The fifth element is the name of the file that the element was found in, if available, taking into account any C<#line> directives. Returns C on error, or if the L object has not been indexed. =cut sub location { my $self = shift; $self->_ensure_location_present or return undef; # Return a copy, not the original return [ @{$self->{_location}} ]; } =pod =head2 line_number If the Element exists within a L that has indexed the Element locations using C, the C method will return the line number of the first character of the Element within the Document. Returns C on error, or if the L object has not been indexed. =cut sub line_number { my $self = shift; my $location = $self->location() or return undef; return $location->[0]; } =pod =head2 column_number If the Element exists within a L that has indexed the Element locations using C, the C method will return the column number of the first character of the Element within the Document. Returns C on error, or if the L object has not been indexed. =cut sub column_number { my $self = shift; my $location = $self->location() or return undef; return $location->[1]; } =pod =head2 visual_column_number If the Element exists within a L that has indexed the Element locations using C, the C method will return the visual column number of the first character of the Element within the Document, according to the value of L. Returns C on error, or if the L object has not been indexed. =cut sub visual_column_number { my $self = shift; my $location = $self->location() or return undef; return $location->[2]; } =pod =head2 logical_line_number If the Element exists within a L that has indexed the Element locations using C, the C method will return the line number of the first character of the Element within the Document, taking into account any C<#line> directives. Returns C on error, or if the L object has not been indexed. =cut sub logical_line_number { my $self = shift; return $self->location()->[3]; } =pod =head2 logical_filename If the Element exists within a L that has indexed the Element locations using C, the C method will return the logical file name containing the first character of the Element within the Document, taking into account any C<#line> directives. Returns C on error, or if the L object has not been indexed. =cut sub logical_filename { my $self = shift; my $location = $self->location() or return undef; return $location->[4]; } sub _ensure_location_present { my $self = shift; unless ( exists $self->{_location} ) { # Are we inside a normal document? my $Document = $self->document or return undef; if ( $Document->isa('PPI::Document::Fragment') ) { # Because they can't be serialized, document fragments # do not support the concept of location. return undef; } # Generate the locations. If they need one location, then # the chances are they'll want more, and it's better that # everything is already pre-generated. $Document->index_locations or return undef; unless ( exists $self->{_location} ) { # erm... something went very wrong here return undef; } } return 1; } # Although flush_locations is only publically a Document-level method, # we are able to implement it at an Element level, allowing us to # selectively flush only the part of the document that occurs after the # element for which the flush is called. sub _flush_locations { my $self = shift; unless ( $self == $self->top ) { return $self->top->_flush_locations( $self ); } # Get the full list of all Tokens my @Tokens = $self->tokens; # Optionally allow starting from an arbitrary element (or rather, # the first Token equal-to-or-within an arbitrary element) if ( _INSTANCE($_[0], 'PPI::Element') ) { my $start = shift->first_token; while ( my $Token = shift @Tokens ) { return 1 unless $Token->{_location}; next unless refaddr($Token) == refaddr($start); # Found the start. Flush it's location delete $$Token->{_location}; last; } } # Iterate over any remaining Tokens and flush their location foreach my $Token ( @Tokens ) { delete $Token->{_location}; } 1; } ##################################################################### # XML Compatibility Methods sub _xml_name { my $class = ref $_[0] || $_[0]; my $name = lc join( '_', split /::/, $class ); substr($name, 4); } sub _xml_attr { return {}; } sub _xml_content { defined $_[0]->{content} ? $_[0]->{content} : ''; } ##################################################################### # Internals # Set the error string sub _error { $errstr = $_[1]; undef; } # Clear the error string sub _clear { $errstr = ''; $_[0]; } # Being DESTROYed in this manner, rather than by an explicit # ->delete means our reference count has probably fallen to zero. # Therefore we don't need to remove ourselves from our parent, # just the index ( just in case ). ### XS -> PPI/XS.xs:_PPI_Element__DESTROY 0.900+ sub DESTROY { delete $_PARENT{refaddr $_[0]} } # Operator overloads sub __equals { ref $_[1] and refaddr($_[0]) == refaddr($_[1]) } sub __nequals { !__equals(@_) } sub __eq { my $self = _INSTANCE($_[0], 'PPI::Element') ? $_[0]->content : $_[0]; my $other = _INSTANCE($_[1], 'PPI::Element') ? $_[1]->content : $_[1]; $self eq $other; } sub __ne { !__eq(@_) } 1; =pod =head1 TO DO It would be nice if C could be used in an ad-hoc manner. That is, if called on an Element within a Document that has not been indexed, it will do a one-off calculation to find the location. It might be very painful if someone started using it a lot, without remembering to index the document, but it would be handy for things that are only likely to use it once, such as error handlers. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Transform/0000755000175100010010000000000012430470371012226 5ustar PPI-1.220/lib/PPI/Transform/UpdateCopyright.pm0000755000175100010010000000715712430462144015713 0ustar package PPI::Transform::UpdateCopyright; =pod =head1 NAME PPI::Transform::UpdateCopyright - Demonstration PPI::Transform class =head1 SYNOPSIS my $transform = PPI::Transform::UpdateCopyright->new( name => 'Adam Kennedy' ); $transform->file('Module.pm'); =head1 DESCRIPTION B provides a demonstration of a typical L class. This class implements a document transform that will take the name of an author and update the copyright statement to refer to the current year, if it does not already do so. =head1 METHODS =cut use strict; use Params::Util qw{_STRING}; use PPI::Transform (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } ##################################################################### # Constructor and Accessors =pod =head2 new my $transform = PPI::Transform::UpdateCopyright->new( name => 'Adam Kennedy' ); The C constructor creates a new transform object for a specific author. It takes a single C parameter that should be the name (or longer string) for the author. Specifying the name is required to allow the changing of a subset of copyright statements that refer to you from a larger set in a file. =cut sub new { my $self = shift->SUPER::new(@_); # Must provide a name unless ( defined _STRING($self->name) ) { PPI::Exception->throw("Did not provide a valid name param"); } return $self; } =pod =head2 name The C accessor returns the author name that the transform will be searching for copyright statements of. =cut sub name { $_[0]->{name}; } ##################################################################### # Transform sub document { my $self = shift; my $document = _INSTANCE(shift, 'PPI::Document') or return undef; # Find things to transform my $name = quotemeta $self->name; my $regexp = qr/\bcopyright\b.*$name/m; my $elements = $document->find( sub { $_[1]->isa('PPI::Token::Pod') or return ''; $_[1]->content =~ $regexp or return ''; return 1; } ); return undef unless defined $elements; return 0 unless $elements; # Try to transform any elements my $changes = 0; my $change = sub { my $copyright = shift; my $thisyear = (localtime time)[5] + 1900; my @year = $copyright =~ m/(\d{4})/g; if ( @year == 1 ) { # Handle the single year format if ( $year[0] == $thisyear ) { # No change return $copyright; } else { # Convert from single year to multiple year $changes++; $copyright =~ s/(\d{4})/$1 - $thisyear/; return $copyright; } } if ( @year == 2 ) { # Handle the range format if ( $year[1] == $thisyear ) { # No change return $copyright; } else { # Change the second year to the current one $changes++; $copyright =~ s/$year[1]/$thisyear/; return $copyright; } } # huh? die "Invalid or unknown copyright line '$copyright'"; }; # Attempt to transform each element my $pattern = qr/\b(copyright.*\d)({4}(?:\s*-\s*\d{4})?)(.*$name)/mi; foreach my $element ( @$elements ) { $element =~ s/$pattern/$1 . $change->($2) . $2/eg; } return $changes; } 1; =pod =head1 TO DO - May need to overload some methods to forcefully prevent Document objects becoming children of another Node. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2009 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Document/0000755000175100010010000000000012430470371012031 5ustar PPI-1.220/lib/PPI/Document/Normalized.pm0000755000175100010010000001716312430462144014505 0ustar package PPI::Document::Normalized; =pod =head1 NAME PPI::Document::Normalized - A normalized Perl Document =head1 DESCRIPTION A C object is the result of the normalization process contained in the L class. See the documentation for L for more information. The object contains a version stamp and function list for the version of L used to create it, and a processed and delinked L object. Typically, the Document object will have been mangled by the normalization process in a way that would make it fatal to try to actually DO anything with it. Put simply, B use the Document object after normalization. B The object is designed the way it is to provide a bias towards false negatives. A comparison between two ::Normalized object will only return true if they were produced by the same version of PPI::Normal, with the same set of normalization functions (in the same order). You may get false negatives if you are caching objects across an upgrade. Please note that this is done for security purposes, as there are many cases in which low layer normalization is likely to be done as part of a code security process, and false positives could be highly dangerous. =head1 METHODS =cut # For convenience (and since this isn't really a public class), import # the methods we will need from Scalar::Util. use strict; use Scalar::Util qw{refaddr reftype blessed}; use Params::Util qw{_INSTANCE _ARRAY}; use PPI::Util (); use vars qw{$VERSION}; BEGIN { $VERSION = '1.220'; } use overload 'bool' => \&PPI::Util::TRUE; use overload '==' => 'equal'; ##################################################################### # Constructor and Accessors =pod =head2 new The C method is intended for use only by the L class, and to get ::Normalized objects, you are highly recommended to use either that module, or the C method of the L object itself. =cut sub new { my $class = shift; my %args = @_; # Check the required params my $Document = _INSTANCE($args{Document}, 'PPI::Document') or return undef; my $version = $args{version} or return undef; my $functions = _ARRAY($args{functions}) or return undef; # Create the object my $self = bless { Document => $Document, version => $version, functions => $functions, }, $class; $self; } sub _Document { $_[0]->{Document} } =pod =head2 version The C accessor returns the L version used to create the object. =cut sub version { $_[0]->{version} } =pod =head2 functions The C accessor returns a reference to an array of the normalization functions (in order) that were called when creating the object. =cut sub functions { $_[0]->{functions} } ##################################################################### # Comparison Methods =pod =head2 equal $Normalized The C method is the primary comparison method, taking another PPI::Document::Normalized object, and checking for equivalence to it. The C<==> operator is also overload to this method, so that you can do something like the following: my $first = PPI::Document->load('first.pl'); my $second = PPI::Document->load('second.pl'); if ( $first->normalized == $second->normalized ) { print "The two documents are equivalent"; } Returns true if the normalized documents are equivalent, false if not, or C if there is an error. =cut sub equal { my $self = shift; my $other = _INSTANCE(shift, 'PPI::Document::Normalized') or return undef; # Prevent multiple concurrent runs return undef if $self->{processing}; # Check the version and function list first return '' unless $self->version eq $other->version; $self->_equal_ARRAY( $self->functions, $other->functions ) or return ''; # Do the main comparison run $self->{seen} = {}; my $rv = $self->_equal_blessed( $self->_Document, $other->_Document ); delete $self->{seen}; $rv; } # Check that two objects are matched sub _equal_blessed { my ($self, $this, $that) = @_; my ($bthis, $bthat) = (blessed $this, blessed $that); $bthis and $bthat and $bthis eq $bthat or return ''; # Check the object as a reference $self->_equal_reference( $this, $that ); } # Check that two references match their types sub _equal_reference { my ($self, $this, $that) = @_; my ($rthis, $rthat) = (refaddr $this, refaddr $that); $rthis and $rthat or return undef; # If we have seen this before, are the pointing # is it the same one we saw in both sides my $seen = $self->{seen}->{$rthis}; if ( $seen and $seen ne $rthat ) { return ''; } # Check the reference types my ($tthis, $tthat) = (reftype $this, reftype $that); $tthis and $tthat and $tthis eq $tthat or return undef; # Check the children of the reference type $self->{seen}->{$rthis} = $rthat; my $method = "_equal_$tthat"; my $rv = $self->$method( $this, $that ); delete $self->{seen}->{$rthis}; $rv; } # Compare the children of two SCALAR references sub _equal_SCALAR { my ($self, $this, $that) = @_; my ($cthis, $cthat) = ($$this, $$that); return $self->_equal_blessed( $cthis, $cthat ) if blessed $cthis; return $self->_equal_reference( $cthis, $cthat ) if ref $cthis; return (defined $cthat and $cthis eq $cthat) if defined $cthis; ! defined $cthat; } # For completeness sake, lets just treat REF as a specialist SCALAR case sub _equal_REF { shift->_equal_SCALAR(@_) } # Compare the children of two ARRAY references sub _equal_ARRAY { my ($self, $this, $that) = @_; # Compare the number of elements scalar(@$this) == scalar(@$that) or return ''; # Check each element in the array. # Descend depth-first. foreach my $i ( 0 .. scalar(@$this) ) { my ($cthis, $cthat) = ($this->[$i], $that->[$i]); if ( blessed $cthis ) { return '' unless $self->_equal_blessed( $cthis, $cthat ); } elsif ( ref $cthis ) { return '' unless $self->_equal_reference( $cthis, $cthat ); } elsif ( defined $cthis ) { return '' unless (defined $cthat and $cthis eq $cthat); } else { return '' if defined $cthat; } } 1; } # Compare the children of a HASH reference sub _equal_HASH { my ($self, $this, $that) = @_; # Compare the number of keys return '' unless scalar(keys %$this) == scalar(keys %$that); # Compare each key, descending depth-first. foreach my $k ( keys %$this ) { return '' unless exists $that->{$k}; my ($cthis, $cthat) = ($this->{$k}, $that->{$k}); if ( blessed $cthis ) { return '' unless $self->_equal_blessed( $cthis, $cthat ); } elsif ( ref $cthis ) { return '' unless $self->_equal_reference( $cthis, $cthat ); } elsif ( defined $cthis ) { return '' unless (defined $cthat and $cthis eq $cthat); } else { return '' if defined $cthat; } } 1; } # We do not support GLOB comparisons sub _equal_GLOB { my ($self, $this, $that) = @_; warn('GLOB comparisons are not supported'); ''; } # We do not support CODE comparisons sub _equal_CODE { my ($self, $this, $that) = @_; refaddr $this == refaddr $that; } # We don't support IO comparisons sub _equal_IO { my ($self, $this, $that) = @_; warn('IO comparisons are not supported'); ''; } sub DESTROY { # Take the screw up Document with us if ( $_[0]->{Document} ) { $_[0]->{Document}->DESTROY; delete $_[0]->{Document}; } } 1; =pod =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2005 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Document/Fragment.pm0000755000175100010010000000362412430462144014141 0ustar package PPI::Document::Fragment; =pod =head1 NAME PPI::Document::Fragment - A fragment of a Perl Document =head1 DESCRIPTION In some situations you might want to work with a fragment of a larger document. C is a class intended for this purpose. It is functionally almost identical to a normal L, except that it is not possible to get line/column positions for the elements within it, and it does not represent a scope. =head1 METHODS =cut use strict; use PPI::Document (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Document'; } ##################################################################### # PPI::Document Methods =pod =head2 index_locations Unlike when called on a PPI::Document object, you should not be attempting to find locations of things within a PPI::Document::Fragment, and thus any call to the C will print a warning and return C instead of attempting to index the locations of the Elements. =cut # There's no point indexing a fragment sub index_locations { warn "Useless attempt to index the locations of a document fragment"; undef; } ##################################################################### # PPI::Element Methods # We are not a scope boundary ### XS -> PPI/XS.xs:_PPI_Document_Fragment__scope 0.903+ sub scope() { '' } 1; =pod =head1 TO DO Integrate this into the rest of PPI so it has actual practical uses. The most obvious would be to implement arbitrary cut/copy/paste more easily. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Document/File.pm0000755000175100010010000000623112430462144013252 0ustar package PPI::Document::File; =pod =head1 NAME PPI::Document::File - A Perl Document located in a specific file =head1 DESCRIPTION B B provides a L subclass that represents a Perl document stored in a specific named file. =head1 METHODS =cut use strict; use Carp (); use Params::Util qw{_STRING _INSTANCE}; use PPI::Document (); use vars qw{$VERSION @ISA}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Document'; } ##################################################################### # Constructor and Accessors =pod =head2 new my $file = PPI::Document::File->new( 'Module.pm' ); The C constructor works the same as for the regular one, except that the only params allowed is a file name. You cannot create an "anonymous" PPI::Document::File object, not can you create an empty one. Returns a new PPI::Document::File object, or C on error. =cut sub new { my $class = shift; my $filename = _STRING(shift); unless ( defined $filename ) { # Perl::Critic got a complaint about not handling a file # named "0". return $class->_error("Did not provide a file name to load"); } # Load the Document my $self = $class->SUPER::new( $filename, @_ ) or return undef; # Unlike a normal inheritance situation, due to our need to stay # compatible with caching magic, this actually returns a regular # anonymous document. We need to rebless if if ( _INSTANCE($self, 'PPI::Document') ) { bless $self, 'PPI::Document::File'; } else { die "PPI::Document::File SUPER call returned an object of the wrong type"; } # Save the filename $self->{filename} = $filename; $self; } =head2 filename The C accessor returns the name of the file in which the document is stored. =cut sub filename { $_[0]->{filename}; } =pod =head2 save # Save to the file we were loaded from $file->save; # Save a copy to somewhere else $file->save( 'Module2.pm' ); The C method works similarly to the one in the parent L class, saving a copy of the document to a file. The difference with this subclass is that if C is not passed any filename, it will save it back to the file it was loaded from. Note: When saving to a different file, it is considered to be saving a B and so the value returned by the C accessor will stay the same, and not change to the new filename. =cut sub save { my $self = shift; # Save to where? my $filename = shift; unless ( defined $filename ) { $filename = $self->filename; } # Hand off to main save method $self->SUPER::save( $filename, @_ ); } 1; =pod =head1 TO DO - May need to overload some methods to forcefully prevent Document objects becoming children of another Node. =head1 SUPPORT See the L in the main module. =head1 AUTHOR Adam Kennedy Eadamk@cpan.orgE =head1 COPYRIGHT Copyright 2001 - 2011 Adam Kennedy. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The full text of the license can be found in the LICENSE file included with this module. =cut PPI-1.220/lib/PPI/Statement.pm0000755000175100010010000002157012430462144012564 0ustar package PPI::Statement; =pod =head1 NAME PPI::Statement - The base class for Perl statements =head1 INHERITANCE PPI::Statement isa PPI::Node isa PPI::Element =head1 DESCRIPTION PPI::Statement is the root class for all Perl statements. This includes (from L) "Declarations", "Simple Statements" and "Compound Statements". The class PPI::Statement itself represents a "Simple Statement" as defined in the L manpage. =head1 STATEMENT CLASSES Please note that unless documented themselves, these classes are yet to be frozen/finalised. Names may change slightly or be added or removed. =head2 L This covers all "scheduled" blocks, chunks of code that are executed separately from the main body of the code, at a particular time. This includes all C, C, C, C and C blocks. =head2 L A package declaration, as defined in L. =head2 L A statement that loads or unloads another module. This includes 'use', 'no', and 'require' statements. =head2 L A named subroutine declaration, or forward declaration =head2 L A variable declaration statement. This could be either a straight declaration or also be an expression. This includes all 'my', 'state', 'local' and 'our' statements. =head2 L This covers the whole family of 'compound' statements, as described in L. This includes all statements starting with 'if', 'unless', 'for', 'foreach' and 'while'. Note that this does NOT include 'do', as it is treated differently. All compound statements have implicit ends. That is, they do not end with a ';' statement terminator. =head2 L A statement that breaks out of a structure. This includes all of 'redo', 'goto', 'next', 'last' and 'return' statements. =head2 L The kind of statement introduced in Perl 5.10 that starts with 'given'. This has an implicit end. =head2 L The kind of statement introduced in Perl 5.10 that starts with 'when' or 'default'. This also has an implicit end. =head2 L A special statement which encompasses an entire C<__DATA__> block, including the initial C<'__DATA__'> token itself and the entire contents. =head2 L A special statement which encompasses an entire __END__ block, including the initial '__END__' token itself and the entire contents, including any parsed PPI::Token::POD that may occur in it. =head2 L L is a little more speculative, and is intended to help represent the special rules relating to "expressions" such as in: # Several examples of expression statements # Boolean conditions if ( expression ) { ... } # Lists, such as for arguments Foo->bar( expression ) =head2 L A null statement is a special case for where we encounter two consecutive statement terminators. ( ;; ) The second terminator is given an entire statement of its own, but one that serves no purpose. Hence a 'null' statement. Theoretically, assuming a correct parsing of a perl file, all null statements are superfluous and should be able to be removed without damage to the file. But don't do that, in case PPI has parsed something wrong. =head2 L Because L is intended for use when parsing incorrect or incomplete code, the problem arises of what to do with a stray closing brace. Rather than die, it is allocated its own "unmatched brace" statement, which really means "unmatched closing brace". An unmatched open brace at the end of a file would become a structure with no contents and no closing brace. If the document loaded is intended to be correct and valid, finding a L in the PDOM is generally indicative of a misparse. =head2 L This is used temporarily mid-parsing to hold statements for which the lexer cannot yet determine what class it should be, usually because there are insufficient clues, or it might be more than one thing. You should never encounter these in a fully parsed PDOM tree. =head1 METHODS C itself has very few methods. Most of the time, you will be working with the more generic L or L methods, or one of the methods that are subclass-specific. =cut use strict; use Scalar::Util (); use Params::Util qw{_INSTANCE}; use PPI::Node (); use PPI::Exception (); use vars qw{$VERSION @ISA *_PARENT}; BEGIN { $VERSION = '1.220'; @ISA = 'PPI::Node'; *_PARENT = *PPI::Element::_PARENT; } use PPI::Statement::Break (); use PPI::Statement::Compound (); use PPI::Statement::Data (); use PPI::Statement::End (); use PPI::Statement::Expression (); use PPI::Statement::Include (); use PPI::Statement::Null (); use PPI::Statement::Package (); use PPI::Statement::Scheduled (); use PPI::Statement::Sub (); use PPI::Statement::Given (); use PPI::Statement::UnmatchedBrace (); use PPI::Statement::Unknown (); use PPI::Statement::Variable (); use PPI::Statement::When (); # "Normal" statements end at a statement terminator ; # Some are not, and need the more rigorous _continues to see # if we are at an implicit statement boundary. sub __LEXER__normal() { 1 } ##################################################################### # Constructor sub new { my $class = shift; if ( ref $class ) { PPI::Exception->throw; } # Create the object my $self = bless { children => [], }, $class; # If we have been passed what should be an initial token, add it my $token = shift; if ( _INSTANCE($token, 'PPI::Token') ) { # Inlined $self->__add_element(shift); Scalar::Util::weaken( $_PARENT{Scalar::Util::refaddr $token} = $self ); push @{$self->{children}}, $token; } $self; } =pod =head2 label One factor common to most statements is their ability to be labeled. The C