From 543bd45d31261e2d71635959ccfbf55fa417c035 Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Tue, 10 Nov 2015 23:51:08 +0100 Subject: [PATCH 01/13] Initial commit --- lib/Data/Printer.pm | 79 ++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 75 insertions(+), 4 deletions(-) diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index 1562f49..d34f276 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -10,6 +10,7 @@ use if $] >= 5.010, 'Hash::Util::FieldHash' => qw(fieldhash); use if $] < 5.010, 'Hash::Util::FieldHash::Compat' => qw(fieldhash); use File::Spec; use File::HomeDir (); +use FindBin; use Fcntl; use version 0.77 (); @@ -913,13 +914,68 @@ sub _get_info_message { my $message = $p->{caller_message}; + my ( $filename, $line ) = @caller[1..2]; + $message =~ s/\b__PACKAGE__\b/$caller[0]/g; - $message =~ s/\b__FILENAME__\b/$caller[1]/g; - $message =~ s/\b__LINE__\b/$caller[2]/g; + $message =~ s/\b__FILENAME__\b/$filename/g; + $message =~ s/\b__LINE__\b/$line/g; + # try to guess the variable name that is printed by reading + # $line in $filename + $message =~ s/\b__VAR__\b/get_caller_print_var($p, $filename, $line)/ge; return colored($message, $p->{color}{caller_info}) . $BREAK; } +# This function reads line number $lineno from file $filename +# if this function is called more than once for a given $filename, +# it still rereads the file each time. So a possible improvement could +# be to store each line of a file in private array the first time the +# file is read. Then subsequent calls for the same $filename could +# simply lookup the line in the array. +# +# TODO : +# +# +sub get_caller_print_var { + my ( $p, $filename, $lineno ) = @_; + # Note: $filename can be relative to initial directory of the Perl script, + # If the user has changed working directory at this point, + # $filename may not be valid as a relative path. + # Therefore, use FindBin to recover the intial directory of the script: + # + # See also: http://perldoc.perl.org/perlfaq8.html#How-do-I-add-the-directory-my-program-lives-in-to-the-module%2flibrary-search-path%3f + if ( !File::Spec->file_name_is_absolute( $filename ) ) { + $filename = File::Spec->rel2abs( $filename, $FindBin::Bin ); + } + open ( my $fh, '<', $filename ) or die "Could not open file '$filename': $!"; + my $line; + do { $line = <$fh> } until $. == $lineno || eof; + close $fh; + return '"??"' if not defined $line; + chomp $line; + # Assume the $line is on either of two forms: + # - p $var; + # - p( $var ); + # + # TODO: Some of the many cases that are not yet handled: + # - my $string = np @some_array; + # - warn np($some_string); + # - p(%some_hash, colored => 1); + # - comments at end of line.. + # - multiple prints at the same line: p $aa; p $bb; + # - and so on.. + if ( $line =~ /^\s*p\s+([^(][^;]*);\s*$/) { + $line = $1; + } + elsif ( $line =~ /^\s*p\s*\(\s*([^,]*.*?)\s*\)\s*;?\s*$/ ) { + $line = $1; + } + else { + # Simply use $line as it is. It is should still be better + # than not printing anything! + } + return '"' . $line . '"'; +} sub _merge { my $p = shift; @@ -1650,8 +1706,7 @@ be interpolated into their according value so you can customize them at will: }; As shown above, you may also set a color for "caller_info" in your color -hash. Default is cyan. - +hash. Default is cyan. =head1 EXPERIMENTAL FEATURES @@ -1672,6 +1727,22 @@ As of Data::Printer 0.11, you can create complex filters as a separate module. Those can even be uploaded to CPAN and used by other people! See L for further information. +=head2 Printing name of original variable + +Including the special string C<__VAR__> in C, will cause +the original variable name that was used when calling C to be interpolated. +For example: + + use Data::Printer + caller_message => 'Printing __VAR__ at line __LINE__ of __FILENAME__:'; + my $var = 22; + p $var; + +will give output like: + + Printing "$var" at line 4 of ./test.pl: + 22 + =head1 CAVEATS You can't pass more than one variable at a time. From d994a820f4d25b15712f02a957581a8d797ad906 Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Sun, 22 Nov 2015 21:33:20 +0100 Subject: [PATCH 02/13] Use PPI to parse source line. Added tests. --- Makefile.PL | 4 + lib/Data/Printer.pm | 196 ++++++++++++++++++++++++++---------------- t/23.2-caller_info2.t | 35 ++++++++ 3 files changed, 163 insertions(+), 72 deletions(-) create mode 100644 t/23.2-caller_info2.t diff --git a/Makefile.PL b/Makefile.PL index 247a8d2..3e5d33d 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,6 +11,7 @@ my %options = ( PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0.88, + 'Test::Output' => 0, 'Term::ANSIColor' => 3.0, # introduces 'bright_*' colors 'Scalar::Util' => 0, 'version' => 0.77, # handling VSTRINGS @@ -22,6 +23,9 @@ my %options = ( 'File::Spec' => 0, 'File::Temp' => 0, 'Fcntl' => 0, + 'FindBin' => 0, # determine path to source file + 'File::Basename' => 0, + 'PPI' => 0, # parse source line to extract variable name ($] >= 5.010 ? () : ( diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index d34f276..8c805da 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -11,6 +11,7 @@ use if $] < 5.010, 'Hash::Util::FieldHash::Compat' => qw(fieldhash); use File::Spec; use File::HomeDir (); use FindBin; +use File::Basename (); use Fcntl; use version 0.77 (); @@ -55,25 +56,26 @@ my $properties = { 'caller_message' => 'Printing in line __LINE__ of __FILENAME__:', 'class_method' => '_data_printer', # use a specific dump method, if available 'color' => { - 'array' => 'bright_white', - 'number' => 'bright_blue', - 'string' => 'bright_yellow', - 'class' => 'bright_green', - 'method' => 'bright_green', - 'undef' => 'bright_red', - 'hash' => 'magenta', - 'regex' => 'yellow', - 'code' => 'green', - 'glob' => 'bright_cyan', - 'vstring' => 'bright_blue', - 'lvalue' => 'bright_white', - 'format' => 'bright_cyan', - 'repeated' => 'white on_red', - 'caller_info' => 'bright_cyan', - 'weak' => 'cyan', - 'tainted' => 'red', - 'escaped' => 'bright_red', - 'unknown' => 'bright_yellow on_blue', + 'array' => 'bright_white', + 'number' => 'bright_blue', + 'string' => 'bright_yellow', + 'class' => 'bright_green', + 'method' => 'bright_green', + 'undef' => 'bright_red', + 'hash' => 'magenta', + 'regex' => 'yellow', + 'code' => 'green', + 'glob' => 'bright_cyan', + 'vstring' => 'bright_blue', + 'lvalue' => 'bright_white', + 'format' => 'bright_cyan', + 'repeated' => 'white on_red', + 'caller_info' => 'bright_cyan', + 'caller_info_var' => 'green', + 'weak' => 'cyan', + 'tainted' => 'red', + 'escaped' => 'bright_red', + 'unknown' => 'bright_yellow on_blue', }, 'class' => { inherited => 'none', # also 'all', 'public' or 'private' @@ -919,11 +921,30 @@ sub _get_info_message { $message =~ s/\b__PACKAGE__\b/$caller[0]/g; $message =~ s/\b__FILENAME__\b/$filename/g; $message =~ s/\b__LINE__\b/$line/g; - # try to guess the variable name that is printed by reading - # $line in $filename - $message =~ s/\b__VAR__\b/get_caller_print_var($p, $filename, $line)/ge; - - return colored($message, $p->{color}{caller_info}) . $BREAK; + { + my $regex = qr/\b(__VAR__)\b/; + if ( $message =~ $regex ) { + # try to guess the variable name that is printed by reading + # $line in $filename + my $replace = _get_caller_print_var($p, $filename, $line); + # use grep to remove empty items + my @parts = grep $_, split $regex, $message; + for ( @parts ) { + if (/^$regex$/) { + s/$regex/$replace/; + $_ = colored($_, $p->{color}{caller_info_var}); + } + else { + $_ = colored($_, $p->{color}{caller_info}); + } + } + $message = join "", @parts; + } + else { + $message = colored($message, $p->{color}{caller_info}); + } + } + return $message . $BREAK; } # This function reads line number $lineno from file $filename @@ -933,48 +954,78 @@ sub _get_info_message { # file is read. Then subsequent calls for the same $filename could # simply lookup the line in the array. # -# TODO : -# -# -sub get_caller_print_var { +sub _get_caller_print_var { my ( $p, $filename, $lineno ) = @_; - # Note: $filename can be relative to initial directory of the Perl script, - # If the user has changed working directory at this point, - # $filename may not be valid as a relative path. - # Therefore, use FindBin to recover the intial directory of the script: + my $line = _get_caller_source_line( $filename, $lineno ); + return '"??"' if not defined $line; + require PPI; + #require PPI::Dumper; + my $doc = PPI::Document->new(\$line); + #my $dumper = PPI::Dumper->new( $doc ); + #$dumper->print; + my $statement; + my $num_statements = 0; + for my $child ( @{ $doc->{children} } ) { + if ($child->isa('PPI::Statement') ) { + $statement = $child; + $num_statements++; + } + } + + # Default behavior is to use $new_line = $line. This default should still be better + # than not printing anything! + my $new_line = $line; + # Next: try to do better than the default behavior + # Example: if $line is + # + # "p(%some_hash, colored => 1); # print some_hash" + # + # we are able to reduce this $line to "%some_hash" using the following: + # + if ( $num_statements == 1 ) { + # If the line contains a single top level statement, and + # that statement contains a single PPI::Token::Symbol, + # it is likely that that symbol is the name of the sought variable. + my $elements = $statement->find('PPI::Token::Symbol'); + if ( @$elements == 1 ) { + $new_line = $elements->[0]->content; + } + elsif ( @$elements == 2 ) { + # otherwise, if there is two PPI::Token::Symbol's in the + # statement, and the statement is a PPI::Statement::Variable + # is is likely that the second symbol is the sought variable.. + if ( (ref $statement) eq "PPI::Statement::Variable" ) { + $new_line = $elements->[1]->content; + } + } + } + return '"' . $new_line . '"'; +} + +sub _get_caller_source_line { + my ( $filename, $lineno ) = @_; + + # Note: $filename can be absolute or relative (to initial directory of the + # Perl script), For example, for a test file run from another Perl script + # using "system t/test.t", $filename (i.e. __FILE__) for the invoked script + # "test.t" will be "t/test.t". If the user has changed working directory at + # this point, $filename may also not be valid as a relative path. + # Therefore, FindBin is used to recover the intial directory of the script: # # See also: http://perldoc.perl.org/perlfaq8.html#How-do-I-add-the-directory-my-program-lives-in-to-the-module%2flibrary-search-path%3f if ( !File::Spec->file_name_is_absolute( $filename ) ) { - $filename = File::Spec->rel2abs( $filename, $FindBin::Bin ); + $filename = File::Spec->rel2abs( + File::Basename::basename($filename), $FindBin::Bin + ); } open ( my $fh, '<', $filename ) or die "Could not open file '$filename': $!"; my $line; do { $line = <$fh> } until $. == $lineno || eof; close $fh; - return '"??"' if not defined $line; chomp $line; - # Assume the $line is on either of two forms: - # - p $var; - # - p( $var ); - # - # TODO: Some of the many cases that are not yet handled: - # - my $string = np @some_array; - # - warn np($some_string); - # - p(%some_hash, colored => 1); - # - comments at end of line.. - # - multiple prints at the same line: p $aa; p $bb; - # - and so on.. - if ( $line =~ /^\s*p\s+([^(][^;]*);\s*$/) { - $line = $1; - } - elsif ( $line =~ /^\s*p\s*\(\s*([^,]*.*?)\s*\)\s*;?\s*$/ ) { - $line = $1; - } - else { - # Simply use $line as it is. It is should still be better - # than not printing anything! - } - return '"' . $line . '"'; + $line =~ s/^\s+//; + $line =~ s/\s+$//; + return $line; } sub _merge { @@ -1369,22 +1420,23 @@ Note that both spellings ('color' and 'colour') will work. use Data::Printer { color => { - array => 'bright_white', # array index numbers - number => 'bright_blue', # numbers - string => 'bright_yellow', # strings - class => 'bright_green', # class names - method => 'bright_green', # method names - undef => 'bright_red', # the 'undef' value - hash => 'magenta', # hash keys - regex => 'yellow', # regular expressions - code => 'green', # code references - glob => 'bright_cyan', # globs (usually file handles) - vstring => 'bright_blue', # version strings (v5.16.0, etc) - repeated => 'white on_red', # references to seen values - caller_info => 'bright_cyan', # details on what's being printed - weak => 'cyan', # weak references - tainted => 'red', # tainted content - escaped => 'bright_red', # escaped characters (\t, \n, etc) + array => 'bright_white', # array index numbers + number => 'bright_blue', # numbers + string => 'bright_yellow', # strings + class => 'bright_green', # class names + method => 'bright_green', # method names + undef => 'bright_red', # the 'undef' value + hash => 'magenta', # hash keys + regex => 'yellow', # regular expressions + code => 'green', # code references + glob => 'bright_cyan', # globs (usually file handles) + vstring => 'bright_blue', # version strings (v5.16.0, etc) + repeated => 'white on_red', # references to seen values + caller_info => 'bright_cyan', # details on what's being printed + caller_info_var => 'green', # the name of the variable being printed + weak => 'cyan', # weak references + tainted => 'red', # tainted content + escaped => 'bright_red', # escaped characters (\t, \n, etc) # potential new Perl datatypes, unknown to Data::Printer unknown => 'bright_yellow on_blue', diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t new file mode 100644 index 0000000..cfac74c --- /dev/null +++ b/t/23.2-caller_info2.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +BEGIN { + delete $ENV{DATAPRINTERRC}; + use File::HomeDir::Test; # avoid user's .dataprinter + use Term::ANSIColor; +}; + +use Test::More; +use Test::Output; +use Data::Printer + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:'; + + +my $filepath = _get_path(); + +my $var = 3; +my @some_array = ( 1.. 3 ); +my $str1 = "Printing "; +my $str2 = " in line "; +my $str3 = " of $filepath:\n"; +my $expect1 = $str1 . '"$var"' . $str2; +my $expect2 = "${str3}${var}"; +my $expect3 = $str1 . '"my $aa = 1; p $var;"' . $str2; +my $expect4 = $str1 . '"@some_array"' . $str2; +stderr_like sub {p $var}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "no parens capture"; + +done_testing; + +sub _get_path { my (undef, $filename) =caller; return $filename } + From 13babbdaf6ce9c4f232e3ba9726501abc8be350c Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Sun, 22 Nov 2015 21:43:13 +0100 Subject: [PATCH 03/13] Added more tests.. --- t/23.2-caller_info2.t | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index cfac74c..2b2775b 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -28,8 +28,25 @@ my $expect2 = "${str3}${var}"; my $expect3 = $str1 . '"my $aa = 1; p $var;"' . $str2; my $expect4 = $str1 . '"@some_array"' . $str2; stderr_like sub {p $var}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "no parens capture"; +stderr_like sub {p( $var )}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "parens capture"; +stderr_like \&_writer1, qr/^\Q$expect3\E\d+\Q$expect2\E/, "two statements"; +stderr_is sub {my $str = np @some_array}, "", "no print"; +stderr_like \&_writer2, qr/^\Q$expect4\E\d+\Q$str3\E/, "assignment"; +stderr_like sub {p($var, colored => 0)}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "multiple args"; +stderr_like \&_writer3, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "end of line comment"; done_testing; sub _get_path { my (undef, $filename) =caller; return $filename } +sub _writer1 { + my $aa = 1; p $var; +} + +sub _writer2 { + my $str = p @some_array; +} + +sub _writer3 { + p $var; # p $b +} From f4fd167aafa10ad05cc16dd19b5114bf328e61da Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Mon, 30 Nov 2015 23:27:15 +0100 Subject: [PATCH 04/13] fixed bug due to assuming $elements was always an array --- lib/Data/Printer.pm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index 8c805da..a17861a 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -987,10 +987,11 @@ sub _get_caller_print_var { # that statement contains a single PPI::Token::Symbol, # it is likely that that symbol is the name of the sought variable. my $elements = $statement->find('PPI::Token::Symbol'); - if ( @$elements == 1 ) { + my $num_elem = ( $elements ) ? scalar @$elements : 0; + if ( $num_elem == 1 ) { $new_line = $elements->[0]->content; } - elsif ( @$elements == 2 ) { + elsif ( $num_elem == 2 ) { # otherwise, if there is two PPI::Token::Symbol's in the # statement, and the statement is a PPI::Statement::Variable # is is likely that the second symbol is the sought variable.. From 93549a620fe85a636319795cf4d4a1ab692acc44 Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Tue, 1 Dec 2015 23:42:14 +0100 Subject: [PATCH 05/13] Added support for eval, and added a test case --- lib/Data/Printer.pm | 131 +++++++++++++++++++++++++++++++----------- t/23.2-caller_info2.t | 86 +++++++++++++++++++-------- 2 files changed, 161 insertions(+), 56 deletions(-) diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index a17861a..c1213a8 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -909,7 +909,6 @@ sub _deparse { $sub =~ s/\n/$pad/gse; return $sub; } - sub _get_info_message { my $p = shift; my @caller = caller 2; @@ -918,6 +917,42 @@ sub _get_info_message { my ( $filename, $line ) = @caller[1..2]; + # Note: $filename will not be valid if we were called from "eval $str".. + # In that case $filename will be on the form "(eval xx)".. + # For example, for "eval 'p $var'", $filename will be "(eval xx)", + # in "caller 2", for "xx" equal to an integer representing the + # number of the eval statement in the source (as encountered on runtime). + # + # For example, if this were the third "eval" encountered at runtime, xx + # would be 3. In this case, element 7 of "caller 3" will contain the + # eval-text, i.e. "p $var", and $filename and $line can also be recovered + # from "caller 3". But not all cases allows the source line to be + # recovered. For example, for "eval 'sub my_func { p $var }'", and then a + # call to "my_func()", will set $filename to "(eval xx)", but now element + # 7 of "caller 3" will no longer be defined. So in order to determine the + # source statement in "caller 2", one would need to parse the whole source + # using PPI and search for the xx-th eval statement, and the try to parse + # that statement to arrive at 'p $var'.. However, since the xx number + # refers to runtime code, it may not be the same number as in the source + # code... (Alternatively one could try use "B::Deparse" on "my_func") + # + my $line_str = undef; + my $eval_regex = qr/^\Q(eval\E/; + if ( $filename =~ $eval_regex ) { + # Still try to determine $filename, by going one stack frame up: + my @temp = caller 3; + if ( $temp[1] =~ $eval_regex ) { + # TODO: we do not currently handle recursive evals + # currently: simply bail out on determining the $filename + $filename = undef; + $line = 0; + } + else { + $filename = $temp[1]; + $line = $temp[2]; + } + $line_str = $temp[6]; # this is the $str in "eval $str" (or may be undef) + } $message =~ s/\b__PACKAGE__\b/$caller[0]/g; $message =~ s/\b__FILENAME__\b/$filename/g; $message =~ s/\b__LINE__\b/$line/g; @@ -926,7 +961,7 @@ sub _get_info_message { if ( $message =~ $regex ) { # try to guess the variable name that is printed by reading # $line in $filename - my $replace = _get_caller_print_var($p, $filename, $line); + my $replace = _get_caller_print_var($p, $filename, $line, $line_str); # use grep to remove empty items my @parts = grep $_, split $regex, $message; for ( @parts ) { @@ -947,34 +982,35 @@ sub _get_info_message { return $message . $BREAK; } -# This function reads line number $lineno from file $filename -# if this function is called more than once for a given $filename, -# it still rereads the file each time. So a possible improvement could -# be to store each line of a file in private array the first time the -# file is read. Then subsequent calls for the same $filename could -# simply lookup the line in the array. +# This function reads line number $lineno from file $filename (if $line is undef). +# If this function is called more than once for a given $filename, it still +# rereads the file each time. So a possible improvement could be to store each +# line of a file in private array the first time the file is read. Then +# subsequent calls for the same $filename could simply lookup the line in the +# array. # sub _get_caller_print_var { - my ( $p, $filename, $lineno ) = @_; - my $line = _get_caller_source_line( $filename, $lineno ); + my ( $p, $filename, $lineno, $line ) = @_; + if ( !defined $line ) { + $line = _get_caller_source_line( $filename, $lineno ); + } return '"??"' if not defined $line; require PPI; - #require PPI::Dumper; my $doc = PPI::Document->new(\$line); + #require PPI::Dumper; #my $dumper = PPI::Dumper->new( $doc ); #$dumper->print; - my $statement; - my $num_statements = 0; - for my $child ( @{ $doc->{children} } ) { - if ($child->isa('PPI::Statement') ) { - $statement = $child; - $num_statements++; - } - } + my ($statements, $num_statements) = + _ppi_get_top_level_items( $doc, 'PPI::Statement' ); # Default behavior is to use $new_line = $line. This default should still be better # than not printing anything! my $new_line = $line; + + # It is not necessary to display a trailing semicolon. + # (It will only act as "noise" in the output..) + $new_line =~ s/;$//; + # Next: try to do better than the default behavior # Example: if $line is # @@ -983,26 +1019,55 @@ sub _get_caller_print_var { # we are able to reduce this $line to "%some_hash" using the following: # if ( $num_statements == 1 ) { - # If the line contains a single top level statement, and - # that statement contains a single PPI::Token::Symbol, - # it is likely that that symbol is the name of the sought variable. - my $elements = $statement->find('PPI::Token::Symbol'); - my $num_elem = ( $elements ) ? scalar @$elements : 0; - if ( $num_elem == 1 ) { - $new_line = $elements->[0]->content; - } - elsif ( $num_elem == 2 ) { - # otherwise, if there is two PPI::Token::Symbol's in the - # statement, and the statement is a PPI::Statement::Variable - # is is likely that the second symbol is the sought variable.. - if ( (ref $statement) eq "PPI::Statement::Variable" ) { - $new_line = $elements->[1]->content; + my $statement = $statements->[0]; + my $is_assignment_statement = + (ref $statement) eq "PPI::Statement::Variable"; + my $symbols = $statement->find('PPI::Token::Symbol'); + my $num_symbols = ( $symbols ) ? scalar @$symbols : 0; + my ($words, $num_words) = + _ppi_get_top_level_items( $statement, 'PPI::Token::Word' ); + # Requiring $num_words == 1, avoids considering cases like + # p my_sub( $var ); + # In that case 'p' would be a word, and 'my_sub' would be a word, + # and we should *not* extract '$var' in this case. + # (This is because it is not the variable + # that is printed, rather 'my_sub( $var )' is printed..) + if ( $num_words == 1 or $is_assignment_statement ) { + # If the line contains a single top level statement, and + # that statement contains a single PPI::Token::Symbol, + # it is likely that that symbol is the name of the sought variable. + if ( $num_symbols == 1 ) { + $new_line = $symbols->[0]->content; + } + elsif ( $num_symbols == 2 ) { + # otherwise, if there are two PPI::Token::Symbol's in the + # statement, and the statement is a PPI::Statement::Variable + # it is likely that the second symbol is the sought variable.. + # I.e., consider: + # my $res = p $var; + # there are two symbols : '$res' and '$var', but we are interested + # in the last one. + if ( (ref $statement) eq "PPI::Statement::Variable" ) { + $new_line = $symbols->[1]->content; + } } } } return '"' . $new_line . '"'; } +sub _ppi_get_top_level_items { + my ( $ref, $class_name ) = @_; + + my @items; + for my $child ( @{ $ref->{children} } ) { + if ($child->isa( $class_name ) ) { + push @items, $child; + } + } + return (\@items, scalar @items); +} + sub _get_caller_source_line { my ( $filename, $lineno ) = @_; diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index 2b2775b..c67ec5a 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -16,37 +16,77 @@ use Data::Printer caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:'; -my $filepath = _get_path(); - my $var = 3; my @some_array = ( 1.. 3 ); -my $str1 = "Printing "; -my $str2 = " in line "; -my $str3 = " of $filepath:\n"; -my $expect1 = $str1 . '"$var"' . $str2; -my $expect2 = "${str3}${var}"; -my $expect3 = $str1 . '"my $aa = 1; p $var;"' . $str2; -my $expect4 = $str1 . '"@some_array"' . $str2; -stderr_like sub {p $var}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "no parens capture"; -stderr_like sub {p( $var )}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "parens capture"; -stderr_like \&_writer1, qr/^\Q$expect3\E\d+\Q$expect2\E/, "two statements"; -stderr_is sub {my $str = np @some_array}, "", "no print"; -stderr_like \&_writer2, qr/^\Q$expect4\E\d+\Q$str3\E/, "assignment"; -stderr_like sub {p($var, colored => 0)}, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "multiple args"; -stderr_like \&_writer3, qr/^\Q$expect1\E\d+\Q$expect2\E$/, "end of line comment"; + +# Try capture simple variable +stderr_like + sub {eval 'p $var'}, + _get_expect_regex('$var'), + "no parens capture"; + +# Try capture variable in parenthesis +stderr_like + sub{ eval 'p( $var )'}, + _get_expect_regex('$var'), + "parens capture"; + +# Two statements: "my $aa = 1; p $var;" +# -> it would be possible to capture '$var' here, but it is not implemented yet, so +# we capture the whole line. +stderr_like + sub {eval 'my $aa = 1; p $var'}, + _get_expect_regex('my $aa = 1; p $var'), + "two statements"; + +# Do not print anything for np command +stderr_is + sub {eval 'my $str = np @some_array'}, + "", + "no print"; + +# Assignment statement: "my $str = p @some_array;" +# -> captures '@some_array' +stderr_like + sub {eval 'my $str = p @some_array'}, + _get_expect_regex('@some_array'), + "assignment"; + +# Multiple arguments to 'p' command: Capture correct argument '$var' +stderr_like + sub {eval 'p($var, colored => 0)'}, + _get_expect_regex('$var'), + "multiple args"; + +# Statement with a comment at the end of the line: "p $var; # p $b" +# -> ignores comment, and capture '$var' +stderr_like + sub {eval 'p $var; # p $b'}, + _get_expect_regex('$var'), + "end of line comment"; + +# Printing return values from function calls +# -> should *not* capture arguments to the function call, but rather the whole +# statement +stderr_like + sub {eval 'p _my_sub( $var )'}, + _get_expect_regex('p _my_sub( $var )'), + "print return value from function call"; done_testing; sub _get_path { my (undef, $filename) =caller; return $filename } -sub _writer1 { - my $aa = 1; p $var; -} +sub _get_expect_regex { + my ( $str) = @_; -sub _writer2 { - my $str = p @some_array; + my $expect1 = 'Printing "' . $str . '" in line '; + my $expect2 = ' of ' . _get_path() . ":\n"; + return qr/^\Q$expect1\E\d+\Q$expect2\E/; } -sub _writer3 { - p $var; # p $b +sub _my_sub { + my ( $var ) = @_; + + return ++$var; } From 54166a420fc6530e26f0c2e9033ba67ac915bfc1 Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Tue, 8 Dec 2015 00:20:59 +0100 Subject: [PATCH 06/13] fixed failing tests caused by trailing newline and semicolon added for earlier perl versions --- lib/Data/Printer.pm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index c1213a8..095cb16 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -931,7 +931,7 @@ sub _get_info_message { # call to "my_func()", will set $filename to "(eval xx)", but now element # 7 of "caller 3" will no longer be defined. So in order to determine the # source statement in "caller 2", one would need to parse the whole source - # using PPI and search for the xx-th eval statement, and the try to parse + # using PPI and search for the xx-th eval statement, and then try to parse # that statement to arrive at 'p $var'.. However, since the xx number # refers to runtime code, it may not be the same number as in the source # code... (Alternatively one could try use "B::Deparse" on "my_func") @@ -952,6 +952,10 @@ sub _get_info_message { $line = $temp[2]; } $line_str = $temp[6]; # this is the $str in "eval $str" (or may be undef) + # seems like earlier versions of perl (< 5.20) adds a new line and a + # semicolon to this string. + $line_str =~ s/;$//; + $line_str =~ s/\s+$//; } $message =~ s/\b__PACKAGE__\b/$caller[0]/g; $message =~ s/\b__FILENAME__\b/$filename/g; From d0e1b7423f090ab0170f4a7f51cd57c4f5d5937c Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Thu, 10 Dec 2015 22:26:25 +0100 Subject: [PATCH 07/13] added some more tests --- lib/Data/Printer.pm | 107 +++++++++++++++---------- t/23.2-caller_info2.t | 177 +++++++++++++++++++++++++++++++----------- 2 files changed, 196 insertions(+), 88 deletions(-) diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index 095cb16..6031e41 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -909,6 +909,7 @@ sub _deparse { $sub =~ s/\n/$pad/gse; return $sub; } + sub _get_info_message { my $p = shift; my @caller = caller 2; @@ -917,7 +918,44 @@ sub _get_info_message { my ( $filename, $line ) = @caller[1..2]; - # Note: $filename will not be valid if we were called from "eval $str".. + ( $line, $filename, my $line_str, my $filename_str ) + = _handle_filename( $line, $filename ); + $message =~ s/\b__PACKAGE__\b/$caller[0]/g; + $message =~ s/\b__FILENAME__\b/$filename_str/g; + $message =~ s/\b__LINE__\b/$line/g; + { + my $regex = qr/\b(__VAR__)\b/; + if ( $message =~ $regex ) { + # try to guess the variable name that is printed by reading + # $line in $filename + my $replace = _get_caller_print_var($p, $filename, $line, $line_str); + # use grep to remove empty items + my @parts = grep $_, split $regex, $message; + for ( @parts ) { + if (/^$regex$/) { + s/$regex/$replace/; + $_ = colored($_, $p->{color}{caller_info_var}); + } + else { + $_ = colored($_, $p->{color}{caller_info}); + } + } + $message = join "", @parts; + } + else { + $message = colored($message, $p->{color}{caller_info}); + } + } + return $message . $BREAK; +} + +sub _handle_filename { + my ( $line, $filename ) = @_; + + my $line_str = undef; + my $eval_regex = qr/^\Q(eval\E/; + my $filename_str = $filename; + # Note : $filename will not be valid if we were called from "eval $str".. # In that case $filename will be on the form "(eval xx)".. # For example, for "eval 'p $var'", $filename will be "(eval xx)", # in "caller 2", for "xx" equal to an integer representing the @@ -936,54 +974,30 @@ sub _get_info_message { # refers to runtime code, it may not be the same number as in the source # code... (Alternatively one could try use "B::Deparse" on "my_func") # - my $line_str = undef; - my $eval_regex = qr/^\Q(eval\E/; if ( $filename =~ $eval_regex ) { # Still try to determine $filename, by going one stack frame up: - my @temp = caller 3; - if ( $temp[1] =~ $eval_regex ) { + my @caller = caller 4; + if ( $caller[1] =~ $eval_regex ) { # TODO: we do not currently handle recursive evals # currently: simply bail out on determining the $filename $filename = undef; + $filename_str = '??'; $line = 0; } else { - $filename = $temp[1]; - $line = $temp[2]; + $filename = $caller[1]; + $filename_str = $caller[1]; + $line = $caller[2]; } - $line_str = $temp[6]; # this is the $str in "eval $str" (or may be undef) - # seems like earlier versions of perl (< 5.20) adds a new line and a - # semicolon to this string. - $line_str =~ s/;$//; - $line_str =~ s/\s+$//; - } - $message =~ s/\b__PACKAGE__\b/$caller[0]/g; - $message =~ s/\b__FILENAME__\b/$filename/g; - $message =~ s/\b__LINE__\b/$line/g; - { - my $regex = qr/\b(__VAR__)\b/; - if ( $message =~ $regex ) { - # try to guess the variable name that is printed by reading - # $line in $filename - my $replace = _get_caller_print_var($p, $filename, $line, $line_str); - # use grep to remove empty items - my @parts = grep $_, split $regex, $message; - for ( @parts ) { - if (/^$regex$/) { - s/$regex/$replace/; - $_ = colored($_, $p->{color}{caller_info_var}); - } - else { - $_ = colored($_, $p->{color}{caller_info}); - } - } - $message = join "", @parts; - } - else { - $message = colored($message, $p->{color}{caller_info}); + $line_str = $caller[6]; # this is the $str in "eval $str" (or may be undef) + if ( defined $line_str ) { + # seems like earlier versions of perl (< 5.20) adds a new line and a + # semicolon to this string. + $line_str =~ s/;$//; + $line_str =~ s/\s+$//; } } - return $message . $BREAK; + return ( $line, $filename, $line_str, $filename_str) ; } # This function reads line number $lineno from file $filename (if $line is undef). @@ -995,10 +1009,13 @@ sub _get_info_message { # sub _get_caller_print_var { my ( $p, $filename, $lineno, $line ) = @_; - if ( !defined $line ) { + if ( not defined $line ) { + if ( not defined $filename ) { + return _quote('??'); + } $line = _get_caller_source_line( $filename, $lineno ); } - return '"??"' if not defined $line; + return _quote('??') if not defined $line; require PPI; my $doc = PPI::Document->new(\$line); #require PPI::Dumper; @@ -1051,13 +1068,19 @@ sub _get_caller_print_var { # my $res = p $var; # there are two symbols : '$res' and '$var', but we are interested # in the last one. - if ( (ref $statement) eq "PPI::Statement::Variable" ) { + if ( $is_assignment_statement ) { $new_line = $symbols->[1]->content; } } } } - return '"' . $new_line . '"'; + return _quote( $new_line ); +} + +sub _quote { + my ( $str ) = @_; + + return '"' . $str . '"'; } sub _ppi_get_top_level_items { diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index c67ec5a..2469492 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -1,92 +1,177 @@ use strict; use warnings; +use Data::Printer; + BEGIN { delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter use Term::ANSIColor; }; +use Carp; +use File::Temp (); use Test::More; use Test::Output; -use Data::Printer - return_value => 'pass', - colored => 0, - caller_info => 1, - caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:'; - - -my $var = 3; -my @some_array = ( 1.. 3 ); # Try capture simple variable -stderr_like - sub {eval 'p $var'}, - _get_expect_regex('$var'), - "no parens capture"; +_test( 'p $var', 'no parens capture', expect => '$var' ); # Try capture variable in parenthesis -stderr_like - sub{ eval 'p( $var )'}, - _get_expect_regex('$var'), - "parens capture"; +_test( 'p( $var )', 'parens capture', expect => '$var' ); # Two statements: "my $aa = 1; p $var;" # -> it would be possible to capture '$var' here, but it is not implemented yet, so # we capture the whole line. -stderr_like - sub {eval 'my $aa = 1; p $var'}, - _get_expect_regex('my $aa = 1; p $var'), - "two statements"; +_test( 'my $aa = 1; p $var', 'two statements'); # Do not print anything for np command -stderr_is - sub {eval 'my $str = np @some_array'}, - "", - "no print"; +_test( 'my $str = np @some_array', 'no print', expect => '', exact_match => 1 ); # Assignment statement: "my $str = p @some_array;" # -> captures '@some_array' -stderr_like - sub {eval 'my $str = p @some_array'}, - _get_expect_regex('@some_array'), - "assignment"; +_test( 'my $str = p @some_array', 'assignment', expect => '@some_array' ); # Multiple arguments to 'p' command: Capture correct argument '$var' -stderr_like - sub {eval 'p($var, colored => 0)'}, - _get_expect_regex('$var'), - "multiple args"; +_test( 'p($var, colored => 0)', 'multiple args', expect => '$var' ); # Statement with a comment at the end of the line: "p $var; # p $b" # -> ignores comment, and capture '$var' -stderr_like - sub {eval 'p $var; # p $b'}, - _get_expect_regex('$var'), - "end of line comment"; +_test( 'p $var; # p $b', 'end of line comment', expect => '$var' ); # Printing return values from function calls # -> should *not* capture arguments to the function call, but rather the whole # statement -stderr_like - sub {eval 'p _my_sub( $var )'}, - _get_expect_regex('p _my_sub( $var )'), - "print return value from function call"; +_test( 'p _my_sub( $var )', 'print return value from function call' ); done_testing; -sub _get_path { my (undef, $filename) =caller; return $filename } +# Note that Test::Output functions like 'stderr_like' takes a subroutine +# reference as the first argument. Given a Data::Printer command in string form +# like 'p $var', we would like to generate such a subroutine automatically. +# That is, we would like avoid having a long list of hardcoded subroutines +# 'writer1()', 'writer2()', ..., and so on. There seems to be two ways to +# achieve this: +# +# 1) Use eval. Example: +# +# sub get_func { +# my ($str) = @_; +# return sub {eval "$str"}; +# } +# +# This has the side-effect of evaluating the Data::Printer command in 'eval'- +# context.. which means that the filename of the original source cannot be +# determined from the perl 'caller()' function.. +# +# 2) Generate a test module at runtime (in a tempdir) containing a test +# subroutine with the code. Then require that module. Then call the test +# subroutine of the module. This procdure avoid using eval.. and the caller +# environment of the Data::Printer command would be more similar to the one +# in common use cases. +# +# Here, both methods are used. + +{ + my $temp_dir; # state variable for _test() subroutine below + + # We will require a different module name for each test. + # (Alternatively, we could use the same module name for each test + # and use Class::Unload to delete the previous module) + # We use the state variable $counter to keep track of the different modules + my $counter; + + sub _test { + my ( $statement, $test_name, %opt ) = @_; + if ( not defined $temp_dir ) { # initialize state variable $temp_dir + $temp_dir = _get_temp_dir(); + } + if ( not defined $counter ) { # intitalize state variable $counter + $counter = 1; + } + $opt{expect} //= $statement; + $opt{exact_match} //= 0; + my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); + for my $i (1..2) { + my $module_name = 'DataPrinterTestHelperModule' . $counter++; + my $fn = _create_test_helper_module( + $temp_dir, $statement, $module_name, eval => $i - 1, + ); + my $test_info = ( $i == 1 ? 'eval' : 'module' ); + $func->( + \&{"$module_name" . "::func"}, + $opt{exact_match} + ? $opt{expect} + : _get_expect_regex( $opt{expect}, $fn ), + $test_name . " ($test_info) ", + ); + } + } +} + +sub _get_temp_dir { + my $tempdir; + eval { + $tempdir = File::Temp::tempdir( CLEANUP => 1 ); + }; + if ($@) { + croak "Could not create temp dir: $@"; + } + return $tempdir; +} sub _get_expect_regex { - my ( $str) = @_; + my ( $str, $fn ) = @_; my $expect1 = 'Printing "' . $str . '" in line '; - my $expect2 = ' of ' . _get_path() . ":\n"; + my $expect2 = ' of ' . $fn . ":\n"; return qr/^\Q$expect1\E\d+\Q$expect2\E/; } + +sub _create_test_helper_module { + my ( $temp_dir, $statement, $module_name, %opt ) = @_; + + $opt{eval} //= 0; + if ( $opt{eval} ) { + $statement = "eval '$statement'"; + } + + my $script = <<"END_SCRIPT"; +package $module_name; + +use strict; +use warnings; + +use Data::Printer +{ + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' +}; + +sub func { + my \$var = 3; + my \@some_array = ( 1.. 3 ); + + $statement +} + sub _my_sub { - my ( $var ) = @_; + my ( \$var ) = \@_; - return ++$var; + return ++\$var; } + +1; +END_SCRIPT + + my $fn = File::Spec->catfile( $temp_dir, $module_name . '.pm' ); + open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + print $fh $script; + close $fh; + require $fn; + return $fn; +} + From 4975cacffa4e8a2847d64a4fa1c9461849fa584b Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Thu, 18 Feb 2016 19:30:32 +0100 Subject: [PATCH 08/13] Minor change to test file --- t/23.2-caller_info2.t | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index 2469492..ee25590 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -1,8 +1,6 @@ use strict; use warnings; -use Data::Printer; - BEGIN { delete $ENV{DATAPRINTERRC}; use File::HomeDir::Test; # avoid user's .dataprinter @@ -66,7 +64,7 @@ done_testing; # # 2) Generate a test module at runtime (in a tempdir) containing a test # subroutine with the code. Then require that module. Then call the test -# subroutine of the module. This procdure avoid using eval.. and the caller +# subroutine of the module. This procedure avoids using eval.. and the caller # environment of the Data::Printer command would be more similar to the one # in common use cases. # From 4701f09f14ad6a86b4b3e2aa6b95235bd4b7b23f Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Wed, 24 Feb 2016 15:01:09 +0100 Subject: [PATCH 09/13] Fixed bug. Added tests --- Makefile.PL | 1 + lib/Data/Printer.pm | 70 ++++++++++++-- t/23.2-caller_info2.t | 210 ++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 266 insertions(+), 15 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index 3e5d33d..b2fdf9e 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -18,6 +18,7 @@ my %options = ( 'Sort::Naturally' => 0, 'Package::Stash' => 0.30, 'Carp' => 0, + 'Cwd' => 0, # we use getcwd() 'Clone::PP' => 0, 'File::HomeDir' => 0.91, # introduces File::HomeDir::Test 'File::Spec' => 0, diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index cfe9758..e58114b 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -1004,7 +1004,7 @@ sub _handle_filename { $line_str = $caller[6]; # this is the $str in "eval $str" (or may be undef) if ( defined $line_str ) { # seems like earlier versions of perl (< 5.20) adds a new line and a - # semicolon to this string. + # semicolon to this string.. remove those $line_str =~ s/;$//; $line_str =~ s/\s+$//; } @@ -1028,11 +1028,7 @@ sub _get_caller_print_var { $line = _get_caller_source_line( $filename, $lineno ); } return _quote('??') if not defined $line; - require PPI; - my $doc = PPI::Document->new(\$line); - #require PPI::Dumper; - #my $dumper = PPI::Dumper->new( $doc ); - #$dumper->print; + my $doc = _get_ppi_document( \$line ); my ($statements, $num_statements) = _ppi_get_top_level_items( $doc, 'PPI::Statement' ); @@ -1089,6 +1085,33 @@ sub _get_caller_print_var { return _quote( $new_line ); } +# We use PPI to parse the source line. +# Alternatives to using PPI are +# +# - Using a source filter (Filter::Util::Call) as in Data::Dumper::Simple +# and let the filter parse the line using a regex and then substitute it with +# another call to the data dumper function that includes the variable names in +# the argument list +# +# - Using PadWalker as in Devel::Caller and Data::Dumper::Names +# +# +# See also: +# - perlmonks: "Displaying a variable's name and value in a sub" +# http://www.perlmonks.org/?node_id=888088 +# +sub _get_ppi_document { + my ( $line ) = @_; + + require PPI; + my $doc = PPI::Document->new( $line ); + #require PPI::Dumper; + #my $dumper = PPI::Dumper->new( $doc ); + #$dumper->print; + + return $doc; +} + sub _quote { my ( $str ) = @_; @@ -1119,9 +1142,38 @@ sub _get_caller_source_line { # # See also: http://perldoc.perl.org/perlfaq8.html#How-do-I-add-the-directory-my-program-lives-in-to-the-module%2flibrary-search-path%3f if ( !File::Spec->file_name_is_absolute( $filename ) ) { - $filename = File::Spec->rel2abs( - File::Basename::basename($filename), $FindBin::Bin - ); + if ( $filename eq $0 ) { + # If $filename is the initial script name ( $0 ) and is also relative, + # it will *not* be relative to $FindBin::RealBin (unless $filename + # is a simple name, that is: $filename does not contain any slashes ). + # So if we run a script (say "p.pl") located in + # sub folder "test" by typing "./test/p.pl" at the terminal prompt, + # then $filename will be "./test/p.pl" (which is not a simple name) + # and this is relative to "." and not "./test", so it is not relative + # to $FindBin::RealBin (which is equal to the absolute version of "./test"). + # + # However, if $filename is the name of a module + # ( loaded with a "use" or "require" statement, that is: $filename is + # different from $0, then it turns out that $filename is indeed + # relative to $FindBin::RealBin ( if $filename is relative; which can + # be the case since relative paths are allowed in @INC) . For example + # use lib '.'; use My::Module; + # then $filename (as inspected from My::Module) will be relative and + # equal to "My/Module.pm" (which is relative to $FindBin::RealBin) + # + # Note: One should in general not use relative paths with the lib pragma + # since it can be misleading. The relative path used with the lib pragma + # is always relative to the current directory, which may not be equal to + # $FindBin::RealBin. For example, if a script is run as "./test/p.pl" + # then "use lib '.'" will not insert the directory of the script + # that is: "./test" into @INC, but rather it inserts "." + # + # The correct way to include the directory of the script in @INC seems to be: + # use FindBin; use lib "$FindBin::RealBin"; + # + $filename = File::Basename::basename($filename); + } + $filename = File::Spec->rel2abs( $filename, $FindBin::RealBin ); } open ( my $fh, '<', $filename ) or die "Could not open file '$filename': $!"; my $line; diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index ee25590..a1f315a 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -8,10 +8,15 @@ BEGIN { }; use Carp; +use Cwd (); +use File::Basename (); +use File::Spec; use File::Temp (); use Test::More; use Test::Output; +_update_inc(); + # Try capture simple variable _test( 'p $var', 'no parens capture', expect => '$var' ); @@ -44,6 +49,13 @@ _test( 'p _my_sub( $var )', 'print return value from function call' ); done_testing; + +# Update %INC with the path to the Data::Printer module.. +# we need this for some of the tests.. +sub _update_inc { + require Data::Printer; +} + # Note that Test::Output functions like 'stderr_like' takes a subroutine # reference as the first argument. Given a Data::Printer command in string form # like 'p $var', we would like to generate such a subroutine automatically. @@ -69,21 +81,28 @@ done_testing; # in common use cases. # # Here, both methods are used. - { my $temp_dir; # state variable for _test() subroutine below + sub _test { + if ( not defined $temp_dir ) { # initialize state variable $temp_dir + $temp_dir = _get_temp_dir(); + } + _test1( $temp_dir, @_ ); + _test2( $temp_dir, @_ ); + _test3( $temp_dir, @_ ); + } +} + +{ # We will require a different module name for each test. # (Alternatively, we could use the same module name for each test # and use Class::Unload to delete the previous module) # We use the state variable $counter to keep track of the different modules my $counter; - sub _test { - my ( $statement, $test_name, %opt ) = @_; - if ( not defined $temp_dir ) { # initialize state variable $temp_dir - $temp_dir = _get_temp_dir(); - } + sub _test1 { + my ( $temp_dir, $statement, $test_name, %opt ) = @_; if ( not defined $counter ) { # intitalize state variable $counter $counter = 1; } @@ -107,6 +126,61 @@ done_testing; } } +sub _test2 { + my ( $temp_dir, $statement, $test_name, %opt ) = @_; + $opt{expect} //= $statement; + $opt{exact_match} //= 0; + my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); + + my $cmd1 = _create_script1( $temp_dir, $statement ); + my $dir1 = Cwd::getcwd(); + my ( $cmd2, $dir2 ) = _get_script_start_dir( $cmd1 ); + my @cmds = ( $cmd1, $cmd2 ); + my @dirs = ( $dir1, $dir2 ); + for (0..1) { + my $cmd = $cmds[$_]; + chdir $dirs[$_]; + $func->( + sub { system 'perl', $cmd }, + $opt{exact_match} + ? $opt{expect} + : _get_expect_regex( $opt{expect}, $cmd ), + $test_name . " (separate script $_) ", + ); + } + chdir $dir1; +} + +sub _test3 { + my ( $temp_dir, $statement, $test_name, %opt ) = @_; + $opt{expect} //= $statement; + $opt{exact_match} //= 0; + my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); + + my $curdir = Cwd::getcwd(); + chdir $temp_dir; + my ( $cmd, $module_name ) = _create_script2( $statement ); + $func->( + sub { system 'perl', $cmd }, + $opt{exact_match} + ? $opt{expect} + : _get_expect_regex( $opt{expect}, $module_name ), + $test_name . " (separate script 3) ", + ); + chdir $curdir; +} + + +sub _get_script_start_dir { + my ( $cmd ) = @_; + + my $cmd1 = File::Basename::basename( $cmd ); + my $dir1 = File::Basename::dirname( $cmd ); + my $dir2 = File::Basename::dirname( $dir1 ); + my $cmd2 = File::Spec->catfile( $dir1, $cmd1 ); + return ( $cmd2, $dir2 ); +} + sub _get_temp_dir { my $tempdir; eval { @@ -127,6 +201,130 @@ sub _get_expect_regex { } +sub _create_script1 { + my ( $temp_dir, $statement ) = @_; + + my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); + $mod_path = File::Basename::dirname( $mod_path ); + + my $script = <<"END_SCRIPT"; +use strict; +use warnings; + +use lib '$mod_path'; + +BEGIN { + delete \$ENV{DATAPRINTERRC}; + use File::HomeDir::Test; # avoid user's .dataprinter + use Term::ANSIColor; +}; + +use Data::Printer +{ + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' +}; + +my \$var = 3; +my \@some_array = ( 1.. 3 ); + +$statement; + +sub _my_sub { + my ( \$var ) = \@_; + + return ++\$var; +} +END_SCRIPT + + my $fn = File::Spec->catfile( $temp_dir, 'test_script1.pl' ); + #if ( -e $fn ) { + # unlink $fn; + #} + open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + print $fh $script; + close $fh; + return $fn; +} + +sub _create_script2 { + my ( $statement ) = @_; + + my $module_name = _write_test_module( $statement ); + + my $script = <<"END_SCRIPT"; +use strict; +use warnings; + +# Note: the current directory '.' is usually included in \@INC, but it could be +# at the end of \@INC.. The following command ensures that the current +# directory is at the beginning of \@INC +use lib '.'; +use My::Module; + +My::Module::func(); + +END_SCRIPT + + my $fn = 'test_script2.pl'; + #if ( -e $fn ) { + # unlink $fn; + #} + open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + print $fh $script; + close $fh; + return ( $fn, $module_name ); +} + +sub _write_test_module { + my ( $statement ) = @_; + + my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); + $mod_path = File::Basename::dirname( $mod_path ); + + my $script = <<"END_SCRIPT"; +package My::Module; + +use strict; +use warnings; +use lib '$mod_path'; + +use Data::Printer +{ + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' +}; + +sub func { + my \$var = 3; + my \@some_array = ( 1.. 3 ); + + $statement +} + +sub _my_sub { + my ( \$var ) = \@_; + + return ++\$var; +} + +1; +END_SCRIPT + + my $fn = 'My/Module.pm'; + if ( ! -e 'My' ) { + mkdir 'My' or croak "Could not create directory: $!"; + } + open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + print $fh $script; + close $fh; + return $fn; +} + sub _create_test_helper_module { my ( $temp_dir, $statement, $module_name, %opt ) = @_; From 1796a4ca8f58229cb5ebe0a65b376e13f739bc53 Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Wed, 9 Mar 2016 18:04:59 +0100 Subject: [PATCH 10/13] Fixed bug in filename. Added new test. --- Makefile.PL | 1 - lib/Data/Printer.pm | 247 +++-------------------------- lib/Data/Printer/ShowVar.pm | 303 ++++++++++++++++++++++++++++++++++++ t/23.2-caller_info2.t | 184 +++++++++++++++++----- 4 files changed, 469 insertions(+), 266 deletions(-) create mode 100644 lib/Data/Printer/ShowVar.pm diff --git a/Makefile.PL b/Makefile.PL index b2fdf9e..14c567f 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -24,7 +24,6 @@ my %options = ( 'File::Spec' => 0, 'File::Temp' => 0, 'Fcntl' => 0, - 'FindBin' => 0, # determine path to source file 'File::Basename' => 0, 'PPI' => 0, # parse source line to extract variable name ($] >= 5.010 diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index e58114b..70ae837 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -6,14 +6,15 @@ use Scalar::Util; use Sort::Naturally; use Carp qw(croak); use Clone::PP qw(clone); +use Cwd (); use Package::Stash; use if $] >= 5.010, 'Hash::Util::FieldHash' => qw(fieldhash); use if $] < 5.010, 'Hash::Util::FieldHash::Compat' => qw(fieldhash); use File::Spec; use File::HomeDir (); -use FindBin; use File::Basename (); use Fcntl; +use Data::Printer::ShowVar; # This causes strangeness wrt UNIVERSAL on Perl 5.8 with some versions of version.pm. # Instead, we now require version in the VSTRING() method. # use version 0.77 (); @@ -27,6 +28,20 @@ BEGIN { } } +# +# For background regarding the below $initial_cwd variable, see +# http://www.perlmonks.org/?node_id=1156424 +# https://rt.perl.org/Public/Bug/Display.html?id=127646 +# +my $initial_cwd; +BEGIN { + # This code is copied from FindBin::cwd2(); + $initial_cwd = Cwd::getcwd(); + # getcwd might fail if it hasn't access to the current directory. + # try harder. + defined $initial_cwd or $initial_cwd = Cwd::cwd(); +} + # defaults my $properties = { 'name' => 'var', @@ -931,7 +946,7 @@ sub _get_info_message { my ( $filename, $line ) = @caller[1..2]; ( $line, $filename, my $line_str, my $filename_str ) - = _handle_filename( $line, $filename ); + = Data::Printer::ShowVar::handle_filename( $line, $filename ); $message =~ s/\b__PACKAGE__\b/$caller[0]/g; $message =~ s/\b__FILENAME__\b/$filename_str/g; $message =~ s/\b__LINE__\b/$line/g; @@ -940,7 +955,9 @@ sub _get_info_message { if ( $message =~ $regex ) { # try to guess the variable name that is printed by reading # $line in $filename - my $replace = _get_caller_print_var($p, $filename, $line, $line_str); + my $replace = Data::Printer::ShowVar::get_caller_print_var( + $p, $filename, $line, $line_str + ); # use grep to remove empty items my @parts = grep $_, split $regex, $message; for ( @parts ) { @@ -961,230 +978,6 @@ sub _get_info_message { return $message . $p->{_linebreak}; } -sub _handle_filename { - my ( $line, $filename ) = @_; - - my $line_str = undef; - my $eval_regex = qr/^\Q(eval\E/; - my $filename_str = $filename; - # Note : $filename will not be valid if we were called from "eval $str".. - # In that case $filename will be on the form "(eval xx)".. - # For example, for "eval 'p $var'", $filename will be "(eval xx)", - # in "caller 2", for "xx" equal to an integer representing the - # number of the eval statement in the source (as encountered on runtime). - # - # For example, if this were the third "eval" encountered at runtime, xx - # would be 3. In this case, element 7 of "caller 3" will contain the - # eval-text, i.e. "p $var", and $filename and $line can also be recovered - # from "caller 3". But not all cases allows the source line to be - # recovered. For example, for "eval 'sub my_func { p $var }'", and then a - # call to "my_func()", will set $filename to "(eval xx)", but now element - # 7 of "caller 3" will no longer be defined. So in order to determine the - # source statement in "caller 2", one would need to parse the whole source - # using PPI and search for the xx-th eval statement, and then try to parse - # that statement to arrive at 'p $var'.. However, since the xx number - # refers to runtime code, it may not be the same number as in the source - # code... (Alternatively one could try use "B::Deparse" on "my_func") - # - if ( $filename =~ $eval_regex ) { - # Still try to determine $filename, by going one stack frame up: - my @caller = caller 4; - if ( $caller[1] =~ $eval_regex ) { - # TODO: we do not currently handle recursive evals - # currently: simply bail out on determining the $filename - $filename = undef; - $filename_str = '??'; - $line = 0; - } - else { - $filename = $caller[1]; - $filename_str = $caller[1]; - $line = $caller[2]; - } - $line_str = $caller[6]; # this is the $str in "eval $str" (or may be undef) - if ( defined $line_str ) { - # seems like earlier versions of perl (< 5.20) adds a new line and a - # semicolon to this string.. remove those - $line_str =~ s/;$//; - $line_str =~ s/\s+$//; - } - } - return ( $line, $filename, $line_str, $filename_str) ; -} - -# This function reads line number $lineno from file $filename (if $line is undef). -# If this function is called more than once for a given $filename, it still -# rereads the file each time. So a possible improvement could be to store each -# line of a file in private array the first time the file is read. Then -# subsequent calls for the same $filename could simply lookup the line in the -# array. -# -sub _get_caller_print_var { - my ( $p, $filename, $lineno, $line ) = @_; - if ( not defined $line ) { - if ( not defined $filename ) { - return _quote('??'); - } - $line = _get_caller_source_line( $filename, $lineno ); - } - return _quote('??') if not defined $line; - my $doc = _get_ppi_document( \$line ); - my ($statements, $num_statements) = - _ppi_get_top_level_items( $doc, 'PPI::Statement' ); - - # Default behavior is to use $new_line = $line. This default should still be better - # than not printing anything! - my $new_line = $line; - - # It is not necessary to display a trailing semicolon. - # (It will only act as "noise" in the output..) - $new_line =~ s/;$//; - - # Next: try to do better than the default behavior - # Example: if $line is - # - # "p(%some_hash, colored => 1); # print some_hash" - # - # we are able to reduce this $line to "%some_hash" using the following: - # - if ( $num_statements == 1 ) { - my $statement = $statements->[0]; - my $is_assignment_statement = - (ref $statement) eq "PPI::Statement::Variable"; - my $symbols = $statement->find('PPI::Token::Symbol'); - my $num_symbols = ( $symbols ) ? scalar @$symbols : 0; - my ($words, $num_words) = - _ppi_get_top_level_items( $statement, 'PPI::Token::Word' ); - # Requiring $num_words == 1, avoids considering cases like - # p my_sub( $var ); - # In that case 'p' would be a word, and 'my_sub' would be a word, - # and we should *not* extract '$var' in this case. - # (This is because it is not the variable - # that is printed, rather 'my_sub( $var )' is printed..) - if ( $num_words == 1 or $is_assignment_statement ) { - # If the line contains a single top level statement, and - # that statement contains a single PPI::Token::Symbol, - # it is likely that that symbol is the name of the sought variable. - if ( $num_symbols == 1 ) { - $new_line = $symbols->[0]->content; - } - elsif ( $num_symbols == 2 ) { - # otherwise, if there are two PPI::Token::Symbol's in the - # statement, and the statement is a PPI::Statement::Variable - # it is likely that the second symbol is the sought variable.. - # I.e., consider: - # my $res = p $var; - # there are two symbols : '$res' and '$var', but we are interested - # in the last one. - if ( $is_assignment_statement ) { - $new_line = $symbols->[1]->content; - } - } - } - } - return _quote( $new_line ); -} - -# We use PPI to parse the source line. -# Alternatives to using PPI are -# -# - Using a source filter (Filter::Util::Call) as in Data::Dumper::Simple -# and let the filter parse the line using a regex and then substitute it with -# another call to the data dumper function that includes the variable names in -# the argument list -# -# - Using PadWalker as in Devel::Caller and Data::Dumper::Names -# -# -# See also: -# - perlmonks: "Displaying a variable's name and value in a sub" -# http://www.perlmonks.org/?node_id=888088 -# -sub _get_ppi_document { - my ( $line ) = @_; - - require PPI; - my $doc = PPI::Document->new( $line ); - #require PPI::Dumper; - #my $dumper = PPI::Dumper->new( $doc ); - #$dumper->print; - - return $doc; -} - -sub _quote { - my ( $str ) = @_; - - return '"' . $str . '"'; -} - -sub _ppi_get_top_level_items { - my ( $ref, $class_name ) = @_; - - my @items; - for my $child ( @{ $ref->{children} } ) { - if ($child->isa( $class_name ) ) { - push @items, $child; - } - } - return (\@items, scalar @items); -} - -sub _get_caller_source_line { - my ( $filename, $lineno ) = @_; - - # Note: $filename can be absolute or relative (to initial directory of the - # Perl script), For example, for a test file run from another Perl script - # using "system t/test.t", $filename (i.e. __FILE__) for the invoked script - # "test.t" will be "t/test.t". If the user has changed working directory at - # this point, $filename may also not be valid as a relative path. - # Therefore, FindBin is used to recover the intial directory of the script: - # - # See also: http://perldoc.perl.org/perlfaq8.html#How-do-I-add-the-directory-my-program-lives-in-to-the-module%2flibrary-search-path%3f - if ( !File::Spec->file_name_is_absolute( $filename ) ) { - if ( $filename eq $0 ) { - # If $filename is the initial script name ( $0 ) and is also relative, - # it will *not* be relative to $FindBin::RealBin (unless $filename - # is a simple name, that is: $filename does not contain any slashes ). - # So if we run a script (say "p.pl") located in - # sub folder "test" by typing "./test/p.pl" at the terminal prompt, - # then $filename will be "./test/p.pl" (which is not a simple name) - # and this is relative to "." and not "./test", so it is not relative - # to $FindBin::RealBin (which is equal to the absolute version of "./test"). - # - # However, if $filename is the name of a module - # ( loaded with a "use" or "require" statement, that is: $filename is - # different from $0, then it turns out that $filename is indeed - # relative to $FindBin::RealBin ( if $filename is relative; which can - # be the case since relative paths are allowed in @INC) . For example - # use lib '.'; use My::Module; - # then $filename (as inspected from My::Module) will be relative and - # equal to "My/Module.pm" (which is relative to $FindBin::RealBin) - # - # Note: One should in general not use relative paths with the lib pragma - # since it can be misleading. The relative path used with the lib pragma - # is always relative to the current directory, which may not be equal to - # $FindBin::RealBin. For example, if a script is run as "./test/p.pl" - # then "use lib '.'" will not insert the directory of the script - # that is: "./test" into @INC, but rather it inserts "." - # - # The correct way to include the directory of the script in @INC seems to be: - # use FindBin; use lib "$FindBin::RealBin"; - # - $filename = File::Basename::basename($filename); - } - $filename = File::Spec->rel2abs( $filename, $FindBin::RealBin ); - } - open ( my $fh, '<', $filename ) or die "Could not open file '$filename': $!"; - my $line; - do { $line = <$fh> } until $. == $lineno || eof; - close $fh; - chomp $line; - $line =~ s/^\s+//; - $line =~ s/\s+$//; - return $line; -} - sub _merge { my $p = shift; my $clone = clone $properties; diff --git a/lib/Data/Printer/ShowVar.pm b/lib/Data/Printer/ShowVar.pm new file mode 100644 index 0000000..2facc97 --- /dev/null +++ b/lib/Data/Printer/ShowVar.pm @@ -0,0 +1,303 @@ +package Data::Printer::ShowVar; +use strict; +use warnings; + +use Term::ANSIColor qw(color colored); +use Test::More; +use Carp qw(croak); +use Cwd (); +use File::Basename (); +use File::Spec; + +# +# For background regarding the below $initial_cwd variable, see +# http://www.perlmonks.org/?node_id=1156424 +# https://rt.perl.org/Public/Bug/Display.html?id=127646 +# +my $initial_cwd; +BEGIN { + # This code is copied from FindBin::cwd2(); + $initial_cwd = Cwd::getcwd(); + # getcwd might fail if it hasn't access to the current directory. + # try harder. + defined $initial_cwd or $initial_cwd = Cwd::cwd(); +} + +sub handle_filename { + my ( $line, $filename ) = @_; + + my $line_str = undef; + my $eval_regex = qr/^\Q(eval\E/; + my $filename_str = $filename; + # Note : $filename will not be valid if we were called from "eval $str".. + # In that case $filename will be on the form "(eval xx)".. + # For example, for "eval 'p $var'", $filename will be "(eval xx)", + # in "caller 2", for "xx" equal to an integer representing the + # number of the eval statement in the source (as encountered on runtime). + # + # For example, if this were the third "eval" encountered at runtime, xx + # would be 3. In this case, element 7 of "caller 3" will contain the + # eval-text, i.e. "p $var", and $filename and $line can also be recovered + # from "caller 3". But not all cases allows the source line to be + # recovered. For example, for "eval 'sub my_func { p $var }'", and then a + # call to "my_func()", will set $filename to "(eval xx)", but now element + # 7 of "caller 3" will no longer be defined. So in order to determine the + # source statement in "caller 2", one would need to parse the whole source + # using PPI and search for the xx-th eval statement, and then try to parse + # that statement to arrive at 'p $var'.. However, since the xx number + # refers to runtime code, it may not be the same number as in the source + # code... (Alternatively one could try use "B::Deparse" on "my_func") + # + if ( $filename =~ $eval_regex ) { + # Still try to determine $filename, by going one stack frame up: + my @caller = caller 4; + if ( $caller[1] =~ $eval_regex ) { + # TODO: we do not currently handle recursive evals + # currently: simply bail out on determining the $filename + $filename = undef; + $filename_str = '??'; + $line = 0; + } + else { + $filename = $caller[1]; + $filename_str = $caller[1]; + $line = $caller[2]; + } + $line_str = $caller[6]; # this is the $str in "eval $str" (or may be undef) + if ( defined $line_str ) { + # seems like earlier versions of perl (< 5.20) adds a new line and a + # semicolon to this string.. remove those + $line_str =~ s/;$//; + $line_str =~ s/\s+$//; + } + } + return ( $line, $filename, $line_str, $filename_str) ; +} + +# This function reads line number $lineno from file $filename (if $line is undef). +# If this function is called more than once for a given $filename, it still +# rereads the file each time. So a possible improvement could be to store each +# line of a file in private array the first time the file is read. Then +# subsequent calls for the same $filename could simply lookup the line in the +# array. +# +sub get_caller_print_var { + my ( $p, $filename, $lineno, $line ) = @_; + if ( !defined $line ) { + if ( !defined $filename ) { + return _quote('??'); + } + $line = _get_caller_source_line( $filename, $lineno ); + } + if ( !defined $line ) { + return _quote(""); + } + my $doc = _get_ppi_document( \$line ); + my ($statements, $num_statements) = + _ppi_get_top_level_items( $doc, 'PPI::Statement' ); + + # Default behavior is to use $new_line = $line. This default should still be better + # than not printing anything! + my $new_line = $line; + + # It is not necessary to display a trailing semicolon. + # (It will only act as "noise" in the output..) + $new_line =~ s/;$//; + + # Next: try to do better than the default behavior + # Example: if $line is + # + # "p(%some_hash, colored => 1); # print some_hash" + # + # we are able to reduce this $line to "%some_hash" using the following: + # + if ( $num_statements == 1 ) { + my $statement = $statements->[0]; + my $is_assignment_statement = + (ref $statement) eq "PPI::Statement::Variable"; + my $symbols = $statement->find('PPI::Token::Symbol'); + my $num_symbols = ( $symbols ) ? scalar @$symbols : 0; + my ($words, $num_words) = + _ppi_get_top_level_items( $statement, 'PPI::Token::Word' ); + # Requiring $num_words == 1, avoids considering cases like + # p my_sub( $var ); + # In that case 'p' would be a word, and 'my_sub' would be a word, + # and we should *not* extract '$var' in this case. + # (This is because it is not the variable + # that is printed, rather 'my_sub( $var )' is printed..) + if ( $num_words == 1 or $is_assignment_statement ) { + # If the line contains a single top level statement, and + # that statement contains a single PPI::Token::Symbol, + # it is likely that that symbol is the name of the sought variable. + if ( $num_symbols == 1 ) { + $new_line = $symbols->[0]->content; + } + elsif ( $num_symbols == 2 ) { + # otherwise, if there are two PPI::Token::Symbol's in the + # statement, and the statement is a PPI::Statement::Variable + # it is likely that the second symbol is the sought variable.. + # I.e., consider: + # my $res = p $var; + # there are two symbols : '$res' and '$var', but we are interested + # in the last one. + if ( $is_assignment_statement ) { + $new_line = $symbols->[1]->content; + } + } + } + } + return _quote( $new_line ); +} + +# We use PPI to parse the source line. +# Alternatives to using PPI are +# +# - Using a source filter (Filter::Util::Call) as in Data::Dumper::Simple and +# Debug::ShowStuff::ShowVar and let the filter parse the line using a regex +# and then substitute it with another call to the data dumper function that +# includes the variable names in the argument list +# +# - Using PadWalker as in Devel::Caller and Data::Dumper::Names +# +# - Using B::Deparse as in Data::Dumper::Lazy +# +# - Using B::CallChecker and B::Deparse as in Debug::Show +# +# See also: +# - perlmonks: "Displaying a variable's name and value in a sub" +# http://www.perlmonks.org/?node_id=888088 +# +sub _get_ppi_document { + my ( $line ) = @_; + + require PPI; + my $doc = PPI::Document->new( $line ); + #require PPI::Dumper; + #my $dumper = PPI::Dumper->new( $doc ); + #$dumper->print; + + return $doc; +} + +sub _quote { + my ( $str ) = @_; + + return '"' . $str . '"'; +} + +sub _ppi_get_top_level_items { + my ( $ref, $class_name ) = @_; + + my @items; + for my $child ( @{ $ref->{children} } ) { + if ($child->isa( $class_name ) ) { + push @items, $child; + } + } + return (\@items, scalar @items); +} + +sub _get_caller_source_line { + my ( $filename, $lineno ) = @_; + + $filename = _get_abs_filename( $filename ); + my $open_success = open ( my $fh, '<', $filename ); + if ( !$open_success ) { + ## croak "Could not open file '$filename': $!"; + # We do not want to terminate the program simply + # because the file cannot be read. Instead return 'undef' + # to signal that we failed to read the file. + return undef; + } + my $line; + do { $line = <$fh> } until $. == $lineno || eof; + close $fh; + chomp $line; + $line =~ s/^\s+//; + $line =~ s/\s+$//; + return $line; +} + +sub _get_abs_filename { + my ( $filename ) = @_; + + # Note: $filename can be absolute or relative. + # A difficulty of determining the absolute path of $filename arises + # if $filename is relative: + # + # - If $filename is equal to $0, then $filename is relative + # to the initial current directory at the time the main Perl script was run. + # This directory may not be equal to the current directory at this point. + # The absolute path of $0 can be recovered using $FindBin::Bin, + # but we choose to not use $FindBin::Bin, since $FindBin::Bin does not expose + # the initial current directory (it rather exposes the directory of the main + # script $0, for example if we run from command line: "perl ./test/prog.pl", then + # the initial current directory is what '.' would expand to at the time the script + # prog.pl was run, whereas the directory of the main script ($0, here: 'prog.pl') + # would be '/test/'), which we will need if $filename is different + # from $0 (that is: a module or a another Perl file loded with "do $filename;"). + # + # - If $filename is not equal to $0, which would be the case for + # * a "require $filename" (implicitly called for any "use ModuleName" + # statement) or a "do $filename", and + # * ( for a required file) the corresponding entry in @INC + # is a relative pathname, + # then $filename is relative to the current directory at the time the module + # was loaded (which again, might not be equal to the current directory at + # this point. Also, for a required file at run time ( not at compile time ) + # the current directory at the time the module was loaded need not be equal + # to the initial current directory ( as used to recover $0, see above ) + # + if ( !File::Spec->file_name_is_absolute( $filename ) ) { + # NOTE: variable $initial_cwd below is a lexical variable defined + # outside the scope of this subroutine + # + # The following recovery of the absolute $filename should work for most + # cases. It may still not work however, in the following cases: + # + # 1. This module (i.e. Data::Printer) is loaded at compile time, but later, + # at run time, a module M is loaded that also uses Data::Printer. If M is + # loaded based on a relative path in @INC, and if the current + # directory has changed since Data::Printer was loaded at compile time, + # it could be unclear what the absolute path of M would be. If the path + # cannot be recoverd with $initial_cwd, we also try the current + # directory (see below). However, if the current directory has changed + # since module M was loaded, at the time when a Data::Printer::p() + # command is executed, that will also fail. + # + # 2. This module is loaded at compile time with a "use Data::Printer" + # statement, and either + # - the initial current directory is changed *earlier* at compile + # time. That is, in a BEGIN {} block which is executed before + # $initial_cwd in Data::Printer has been defined. Then $initial_cwd + # may be wrong for some of the modules loaded before Data::Printer, or + # - the initial current directory is changed *after* at compile + # time (or run time). That is, the current directory is changed after + # $initial_cwd in Data::Printer has been defined. Then $initial_cwd + # may be wrong for some of the modules loaded after Data::Printer (and + # that also "use"s Data::Printer). + # + # Note: the above point assumes (at least) that the current directory + # is changed nonlocally (chdir() is called, and and not reset immediately + # after) at compile time. This is considered very unlikely to happen. + # + # + # NOTE: Maybe all these problems could have been avoided if __FILE__ + # and caller() had avoided using relative path names. A ticket has been + # submitted, see: https://rt.perl.org/Public/Bug/Display.html?id=127646 + # + my $fn_abs = File::Spec->rel2abs( $filename, $initial_cwd ); + if ( ! -e $fn_abs ) { + # Assume $filename is relative to current directory if it is not relative + # to $initial_cwd. Note: Cwd::abs_path( $filename ) would fail if a + # directory component of $filename does not exist. See: + # http://stackoverflow.com/q/35876488/2173773 + # we therefore use: File::Spec->rel2abs() + $fn_abs = File::Spec->rel2abs( $filename, '.' ); + } + $filename = $fn_abs; + } + return $filename; +} + +1; diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index a1f315a..14a1408 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -85,12 +85,42 @@ sub _update_inc { my $temp_dir; # state variable for _test() subroutine below sub _test { + my ( $statement, $test_name, %opt ) = @_; if ( not defined $temp_dir ) { # initialize state variable $temp_dir $temp_dir = _get_temp_dir(); } - _test1( $temp_dir, @_ ); - _test2( $temp_dir, @_ ); - _test3( $temp_dir, @_ ); + $opt{expect} //= $statement; + $opt{exact_match} //= 0; + my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); + my @args = ( $temp_dir, $statement, $test_name, + $opt{expect}, $opt{exact_match}, $func ); + _test1( @args ); + _test2( @args ); + _test3( @args ); + #_debug_inc(); + _test4( @args ); + } +} + +sub _debug_inc { + for (sort keys %INC) { + diag '$INC{' . $_ . '} = "' . $INC{$_} . '"'; + } + for (0..$#INC) { + diag '$INC[' . $_ . '] = "' . $INC[$_] . "'"; + } + _find_inc(); + BAIL_OUT('stop'); +} + + +sub _find_inc { + my $mod_name = 'My/Module.pm'; + for ( @INC ) { + my $fn = File::Spec->catfile( $_, $mod_name ); + if ( -e $fn ) { + diag "Found: '" . $fn . "'\n"; + } } } @@ -101,14 +131,14 @@ sub _update_inc { # We use the state variable $counter to keep track of the different modules my $counter; + # This test create a module DataPrinterTestHelperModuleX (where X is + # an integer) in the temp directory. Then it "require" that module + # and call its "func" sub routine. sub _test1 { - my ( $temp_dir, $statement, $test_name, %opt ) = @_; + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; if ( not defined $counter ) { # intitalize state variable $counter $counter = 1; } - $opt{expect} //= $statement; - $opt{exact_match} //= 0; - my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); for my $i (1..2) { my $module_name = 'DataPrinterTestHelperModule' . $counter++; my $fn = _create_test_helper_module( @@ -117,20 +147,20 @@ sub _update_inc { my $test_info = ( $i == 1 ? 'eval' : 'module' ); $func->( \&{"$module_name" . "::func"}, - $opt{exact_match} - ? $opt{expect} - : _get_expect_regex( $opt{expect}, $fn ), + $exact_match + ? $expect + : _get_expect_regex( $expect, $fn ), $test_name . " ($test_info) ", ); } } } +# Run script in temp dir in two ways: +# a) Absolute path : system 'perl', '/tmp/script.pl' +# b) Relative path : system 'perl', 'tmp/script.pl' sub _test2 { - my ( $temp_dir, $statement, $test_name, %opt ) = @_; - $opt{expect} //= $statement; - $opt{exact_match} //= 0; - my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; my $cmd1 = _create_script1( $temp_dir, $statement ); my $dir1 = Cwd::getcwd(); @@ -142,35 +172,48 @@ sub _test2 { chdir $dirs[$_]; $func->( sub { system 'perl', $cmd }, - $opt{exact_match} - ? $opt{expect} - : _get_expect_regex( $opt{expect}, $cmd ), + $exact_match ? $expect : _get_expect_regex( $expect, $cmd ), $test_name . " (separate script $_) ", ); } chdir $dir1; } +# Run script in temp dir that includes a module "My::Module" relative to the +# temp dir. Only the module loads Data::Printer. sub _test3 { - my ( $temp_dir, $statement, $test_name, %opt ) = @_; - $opt{expect} //= $statement; - $opt{exact_match} //= 0; - my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; my $curdir = Cwd::getcwd(); chdir $temp_dir; my ( $cmd, $module_name ) = _create_script2( $statement ); + #$func->( + # sub { system 'perl', $cmd }, + # $exact_match ? $expect : _get_expect_regex( $expect, $module_name ), + # $test_name . " (separate script 2) ", + #); + chdir $curdir; +} + +# Run script in temp dir that uses Data::Printer, then chdir() to new dir and +# later "require" a module "My::Module" (relative to temp dir) that also uses +# Data::Printer. The last +sub _test4 { + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; + + my $curdir = Cwd::getcwd(); + chdir $temp_dir; + my ( $cmd, $module_name ) = _create_script3( $statement ); + my $expect_regex = qr/\Q\E/; $func->( sub { system 'perl', $cmd }, - $opt{exact_match} - ? $opt{expect} - : _get_expect_regex( $opt{expect}, $module_name ), + $exact_match ? $expect : $expect_regex, $test_name . " (separate script 3) ", ); chdir $curdir; } - +# Convert path name like /tmp/test/p.pl to test/p.pl sub _get_script_start_dir { my ( $cmd ) = @_; @@ -243,7 +286,7 @@ END_SCRIPT #if ( -e $fn ) { # unlink $fn; #} - open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; print $fh $script; close $fh; return $fn; @@ -252,7 +295,10 @@ END_SCRIPT sub _create_script2 { my ( $statement ) = @_; - my $module_name = _write_test_module( $statement ); + my $module_dir = 'My'; + my $module_base_name = 'Module'; + my ( $module_name, $module_name_perl ) + = _write_test_module( $statement, $module_base_name, $module_dir ); my $script = <<"END_SCRIPT"; use strict; @@ -262,9 +308,9 @@ use warnings; # at the end of \@INC.. The following command ensures that the current # directory is at the beginning of \@INC use lib '.'; -use My::Module; +use $module_name_perl; -My::Module::func(); +${module_name_perl}::func(); END_SCRIPT @@ -272,20 +318,79 @@ END_SCRIPT #if ( -e $fn ) { # unlink $fn; #} - open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; print $fh $script; close $fh; return ( $fn, $module_name ); } -sub _write_test_module { +sub _create_script3 { my ( $statement ) = @_; + my $dummy_dir = 'dummy_folder'; + if ( ! -e $dummy_dir ) { + mkdir $dummy_dir or croak "Could not create directory: $!"; + } + my $test_dir = 'test'; + if ( ! -e $test_dir ) { + mkdir $test_dir or croak "Could not create directory: $!"; + } + chdir $test_dir; + my $module_dir = 'My'; + my $module_base_name = 'Module2'; + my ( $module_name, $module_name_perl ) + = _write_test_module( $statement, $module_base_name, $module_dir ); + chdir '..'; + my $script = <<"END_SCRIPT"; +use strict; +use warnings; + +# Note: the current directory '.' is usually included in \@INC, but it could be +# at the end of \@INC.. The following command ensures that the current +# directory is at the beginning of \@INC +use lib '.'; + +BEGIN { + delete \$ENV{DATAPRINTERRC}; + use File::HomeDir::Test; # avoid user's .dataprinter + use Term::ANSIColor; +}; + +use Data::Printer +{ + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' +}; + +chdir '$test_dir'; + +eval 'use $module_name_perl'; + +chdir '..'; +chdir '$dummy_dir'; + +${module_name_perl}::func(); + +END_SCRIPT + + my $fn = 'test_script3.pl'; + open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + print $fh $script; + close $fh; + return ( $fn, $module_name ); +} + +sub _write_test_module { + my ( $statement, $base_name, $dir ) = @_; + + my $name = $dir . '::' . $base_name; my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); $mod_path = File::Basename::dirname( $mod_path ); my $script = <<"END_SCRIPT"; -package My::Module; +package $name; use strict; use warnings; @@ -315,16 +420,19 @@ sub _my_sub { 1; END_SCRIPT - my $fn = 'My/Module.pm'; - if ( ! -e 'My' ) { - mkdir 'My' or croak "Could not create directory: $!"; + my $fn = $name; + $fn =~ s/::/\//g; + $fn .= '.pm'; + if ( ! -e $dir ) { + mkdir $dir or croak "Could not create directory: $!"; } - open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; print $fh $script; close $fh; - return $fn; + return ( $fn, $name ); } + sub _create_test_helper_module { my ( $temp_dir, $statement, $module_name, %opt ) = @_; @@ -364,7 +472,7 @@ sub _my_sub { END_SCRIPT my $fn = File::Spec->catfile( $temp_dir, $module_name . '.pm' ); - open( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; + open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; print $fh $script; close $fh; require $fn; From c6f521fc6ebc758c1eea8bebc850017d76d38f92 Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Mon, 4 Apr 2016 23:06:21 +0200 Subject: [PATCH 11/13] Added some more test. Support for p_without_prototypes --- Makefile.PL | 1 + lib/Data/Printer.pm | 3 +- lib/Data/Printer/PPI/Extensions.pm | 33 +++ lib/Data/Printer/ShowVar.pm | 338 ++++++++++++++++++++++------- t/23.2-caller_info2.t | 272 +++++++++++++++-------- 5 files changed, 478 insertions(+), 169 deletions(-) create mode 100644 lib/Data/Printer/PPI/Extensions.pm diff --git a/Makefile.PL b/Makefile.PL index 14c567f..b460792 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -26,6 +26,7 @@ my %options = ( 'Fcntl' => 0, 'File::Basename' => 0, 'PPI' => 0, # parse source line to extract variable name + 'List::Util' => 0, ($] >= 5.010 ? () : ( diff --git a/lib/Data/Printer.pm b/lib/Data/Printer.pm index 19fba54..42371df 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -15,6 +15,7 @@ use File::HomeDir (); use File::Basename (); use Fcntl; use Data::Printer::ShowVar; + # This causes strangeness wrt UNIVERSAL on Perl 5.8 with some versions of version.pm. # Instead, we now require version in the VSTRING() method. # use version 0.77 (); @@ -956,7 +957,7 @@ sub _get_info_message { # try to guess the variable name that is printed by reading # $line in $filename my $replace = Data::Printer::ShowVar::get_caller_print_var( - $p, $filename, $line, $line_str + $p, $filename, $line, $line_str, \@caller ); # use grep to remove empty items my @parts = grep $_, split $regex, $message; diff --git a/lib/Data/Printer/PPI/Extensions.pm b/lib/Data/Printer/PPI/Extensions.pm new file mode 100644 index 0000000..f5b22f0 --- /dev/null +++ b/lib/Data/Printer/PPI/Extensions.pm @@ -0,0 +1,33 @@ +package Data::Printer::PPI::Extensions; +use feature qw(say); +use strict; +use warnings; + +use List::Util qw(any); + +sub name { + my $self = shift; + + my $name = $self->class; + $name =~ s/^PPI:://; + return $name; +} + +sub is_comma_or_semi_colon { + my $item = shift; + + my $name = $item->name; + if ( $name eq 'Token::Operator') { + if ( any { $item->content eq $_ } (',', '=>') ) { + return 1; + } + } + elsif ( $name eq 'Token::Structure' ) { + if ( $item->content eq ';' ) { + return 1; + } + } + return 0; +} + +1; diff --git a/lib/Data/Printer/ShowVar.pm b/lib/Data/Printer/ShowVar.pm index 2facc97..a2a3a6d 100644 --- a/lib/Data/Printer/ShowVar.pm +++ b/lib/Data/Printer/ShowVar.pm @@ -3,11 +3,11 @@ use strict; use warnings; use Term::ANSIColor qw(color colored); -use Test::More; use Carp qw(croak); use Cwd (); use File::Basename (); use File::Spec; +use List::Util qw(any first); # # For background regarding the below $initial_cwd variable, see @@ -32,7 +32,7 @@ sub handle_filename { # Note : $filename will not be valid if we were called from "eval $str".. # In that case $filename will be on the form "(eval xx)".. # For example, for "eval 'p $var'", $filename will be "(eval xx)", - # in "caller 2", for "xx" equal to an integer representing the + # in "caller 3", for "xx" equal to an integer representing the # number of the eval statement in the source (as encountered on runtime). # # For example, if this were the third "eval" encountered at runtime, xx @@ -82,75 +82,208 @@ sub handle_filename { # array. # sub get_caller_print_var { - my ( $p, $filename, $lineno, $line ) = @_; + my ( $p, $filename, $lineno, $line, $caller ) = @_; + + # Determine if we were called as "Data::Printer::p", or as + # "Data::Printer::p_without_prototypes" + my $called_as = $caller->[3]; + if ( !defined $line ) { if ( !defined $filename ) { return _quote('??'); } $line = _get_caller_source_line( $filename, $lineno ); + if ( !defined $line ) { + return _quote(""); + } } - if ( !defined $line ) { - return _quote(""); + my ( $valid_callers, $proto ) = _get_valid_callers( $p, $called_as ); + if (defined $valid_callers ) { + my $doc = _get_ppi_document( \$line ); + if ( defined $doc ) { + $line = _parse_line( $doc, $line, $called_as, $valid_callers, $proto ); + } } - my $doc = _get_ppi_document( \$line ); - my ($statements, $num_statements) = - _ppi_get_top_level_items( $doc, 'PPI::Statement' ); + return _quote( $line ); +} + +sub _get_valid_callers { + my ( $p, $called_as ) = @_; + + my @pp; my @pnp; + if ( defined (my $alias = $p->{alias} ) ) { + push @pp, $alias; + } + push @pp, 'Data::Printer::p', 'p'; + push @pnp, 'Data::Printer::p_without_prototypes', 'p_without_prototypes'; + + my $proto; + my $valid_callers; + if ( any { $_ eq $called_as } @pp ) { + $valid_callers = \@pp; + $proto = 1; + } + elsif ( any { $_ eq $called_as } @pnp ) { + $valid_callers = \@pnp; + $proto = 0; + } + return ($valid_callers, $proto ); +} - # Default behavior is to use $new_line = $line. This default should still be better - # than not printing anything! - my $new_line = $line; +# Parse line, and extract variable name to be printed. +# Default behavior if we cannot determine a variable name is to use $line. +# This default should still be better than not printing anything! +# +# Example: if $line is +# +# "p(%some_hash, colored => 1); # print some_hash" +# +# we should be able to reduce this to "%some_hash": +# +# Note: currently the input variable "$proto" is not used. +sub _parse_line { + my ( $doc, $orig_line, $called_as, $valid_callers, $proto ) = @_; + + # If line contains multiple statements, determine which one to use: + ( my $line, my $statement, my $node, $called_as ) + = _extract_statement_from_line( $doc, $orig_line, $called_as, $valid_callers ); + + my $children = $node->schildren; + my $elem = $node->find_first( + sub { ($_[1]->name eq 'Token::Word') and ($_[1]->content eq $called_as) } + ); + if ( $elem ) { + $elem = $elem->snext_sibling; + if ( $elem ) { + $line = _parse_var( $elem, $line ); + } + } # It is not necessary to display a trailing semicolon. # (It will only act as "noise" in the output..) - $new_line =~ s/;$//; + $line =~ s/\s*;?\s*$//; + + return $line; +} + +# Determine the the first argument (usually a variable, but could also be an +# expression) of the original caller, i.e. p() or p_without_prototypes(). +# Currently we are able to parse the sought variable name the same way regardless +# of whether the caller was p() or p_without_prototypes(). This is due to the way +# PPI parses the line. +sub _parse_var { + my ( $elem, $orig_line ) = @_; + + if ( $elem->name eq 'Structure::List' ) { + $elem = _enter_list_structure( $elem ); + return $orig_line if !$elem; + } + my $line = ""; + while ( $elem ) { + ($elem, $line) = _skip_to_next_token( $elem, $line ); + } + return $line; +} + +sub _enter_list_structure { + my ( $elem ) = @_; + $elem = ( $elem->schildren )[0]; + return undef if !$elem; + if ( any { $elem->name eq $_ } qw(Statement Statement::Expression) ) { + $elem = ( $elem->schildren )[0]; + } + return $elem; +} + +sub _skip_to_next_token { + my ( $elem, $line ) = @_; + while (1) { + $line .= $elem->content; + $elem = $elem->next_sibling; + last if !$elem; + if ( $elem->is_comma_or_semi_colon ) { + $elem = undef; + last; + } + last if $elem->significant; + } + return ($elem, $line); +} + + +# +sub _extract_statement_from_line { + my ( $doc, $orig_line, $called_as, $valid_callers ) = @_; + + my ($statements, $num_statements) = _get_top_level_statements( $doc ); + + my $statement; + my $node; + my $line = $orig_line; - # Next: try to do better than the default behavior - # Example: if $line is - # - # "p(%some_hash, colored => 1); # print some_hash" - # - # we are able to reduce this $line to "%some_hash" using the following: - # - if ( $num_statements == 1 ) { - my $statement = $statements->[0]; - my $is_assignment_statement = - (ref $statement) eq "PPI::Statement::Variable"; - my $symbols = $statement->find('PPI::Token::Symbol'); - my $num_symbols = ( $symbols ) ? scalar @$symbols : 0; - my ($words, $num_words) = - _ppi_get_top_level_items( $statement, 'PPI::Token::Word' ); - # Requiring $num_words == 1, avoids considering cases like - # p my_sub( $var ); - # In that case 'p' would be a word, and 'my_sub' would be a word, - # and we should *not* extract '$var' in this case. - # (This is because it is not the variable - # that is printed, rather 'my_sub( $var )' is printed..) - if ( $num_words == 1 or $is_assignment_statement ) { - # If the line contains a single top level statement, and - # that statement contains a single PPI::Token::Symbol, - # it is likely that that symbol is the name of the sought variable. - if ( $num_symbols == 1 ) { - $new_line = $symbols->[0]->content; - } - elsif ( $num_symbols == 2 ) { - # otherwise, if there are two PPI::Token::Symbol's in the - # statement, and the statement is a PPI::Statement::Variable - # it is likely that the second symbol is the sought variable.. - # I.e., consider: - # my $res = p $var; - # there are two symbols : '$res' and '$var', but we are interested - # in the last one. - if ( $is_assignment_statement ) { - $new_line = $symbols->[1]->content; - } - } + if ( $num_statements >= 1 ) { + ($statement, $node, $called_as) + = _select_statement( $statements, $called_as, $valid_callers ); + if ( defined $statement ) { + $line = $statement->content; + } + } + return ( $line, $statement, $node, $called_as ); +} + +sub _select_statement { + my ( $statements, $called_as, $valid_callers ) = @_; + + my $found_statement; + my $node; + for my $statement (@$statements) { + my $words = $statement->find('PPI::Token::Word'); + my $found_word = first { + my $word = $_->content; any { $_ eq $word } @$valid_callers + } @$words; + if ( defined $found_word ) { + $node = $found_word->parent; + $found_statement = $statement; + $called_as = $found_word->content; + last; + } + } + return ($found_statement, $node, $called_as); +} + +# We choose to only focus on simple statements with p() and p_without_prototypes() +# Two classes of PPI statements are supported: +# +# PPI::Statement : +# +# - p $var, p @var, p %h, ... +# - p ( $var ), p ( $var, colored => 0 ), ... +# - p_without_prototypes "Hello", p_without_prototypes [ 1, 3, 5 ], .. +# +# PPI::Statement::Variable : these are relevant when option "return_value" is 'dump' or +# 'pass' . Examples: +# +# my $var = p $var, ... +# +# +sub _get_top_level_statements { + my ( $ref ) = @_; + + my @items; + for my $child ( @{ $ref->{children} } ) { + if ( ((ref $child) eq 'PPI::Statement') + or ((ref $child) eq 'PPI::Statement::Variable') ) { + push @items, $child; } } - return _quote( $new_line ); + return (\@items, scalar @items); } -# We use PPI to parse the source line. -# Alternatives to using PPI are +# Use PPI to parse the source line. +# +# This approach (using PPI) is admittedly somewhat heavy, but no good +# alternative has yet to be found, though many interesting approaches was found on CPAN, +# but as far as I can see, none of those seems perfect either: # # - Using a source filter (Filter::Util::Call) as in Data::Dumper::Simple and # Debug::ShowStuff::ShowVar and let the filter parse the line using a regex @@ -167,34 +300,89 @@ sub get_caller_print_var { # - perlmonks: "Displaying a variable's name and value in a sub" # http://www.perlmonks.org/?node_id=888088 # -sub _get_ppi_document { - my ( $line ) = @_; +{ + my $is_initialized; + sub _get_ppi_document { + my ( $line ) = @_; - require PPI; - my $doc = PPI::Document->new( $line ); - #require PPI::Dumper; - #my $dumper = PPI::Dumper->new( $doc ); - #$dumper->print; - - return $doc; + if ( !$is_initialized ) { + require PPI; + _setup_ppi_extensions(); + $is_initialized = 1; + } + my $temp_line = $$line; + _add_trailing_semicolon( \$temp_line ); + my $doc = PPI::Document->new( \$temp_line ); + return _check_doc_complete( $doc ); + } } -sub _quote { - my ( $str ) = @_; +sub _add_trailing_semicolon { + my ( $line ) = @_; - return '"' . $str . '"'; + if ( $$line !~ /;\s*$/ ) { + $$line .= ';'; + } } -sub _ppi_get_top_level_items { - my ( $ref, $class_name ) = @_; +sub _setup_ppi_extensions { + require Data::Printer::PPI::Extensions; + no strict "refs"; + for (qw( is_comma_or_semi_colon name)) { + *{"PPI::Element::$_"} = \&{"Data::Printer::PPI::Extensions::$_"}; + } +} - my @items; - for my $child ( @{ $ref->{children} } ) { - if ($child->isa( $class_name ) ) { - push @items, $child; - } +# Checks if the line we read from the source file is complete. That is, if +# it consists of one or more valid Perl statements. Examples of invalid lines: +# +# p $a; my %h = ( +# +# This line is not valid since the second statement (my %h = ... ) is not complete. +# (It is completed on the following lines (not shown)); another example: +# +# }; p $var; +# +# In this case, the preceding source lines (not shown) defines a hash or a sub, +# which is completed on this line ( '};' ). +# +# p { a=> 1, +# +# In this example (assuming use_protypes = 0 ), the hash is not completed on the +# given source line.. +# +# These cases can be handled by reading additional lines before or after the +# given source line until the complete() function of PPI::Document returns true. +# +# However, currently only source lines with one (or more) complete statement are +# handled. ( Support for statements extending +# over multiple lines should be straightforward to implement though, if needed. ) +# +# If the line contains a single Perl statement, it is known that that statement +# is the correct one ( the one that caused the call to Data::Printer::p() ) +# +# If the line contains multiple Perl statements, we must determine which of +# the statements is the correct one. In this case, a currently crude method is +# is used to determine the correct statement: The statements in the +# PPI::Document are traversed one by one and the first one that +# matches (caller())[3] is selected. +# +# +sub _check_doc_complete { + my ( $doc ) = @_; + + if ( $doc->complete ) { + return $doc; } - return (\@items, scalar @items); + else { + return undef; + } +} + +sub _quote { + my ( $str ) = @_; + + return '"' . $str . '"'; } sub _get_caller_source_line { diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index 14a1408..21f9816 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -26,14 +26,14 @@ _test( 'p( $var )', 'parens capture', expect => '$var' ); # Two statements: "my $aa = 1; p $var;" # -> it would be possible to capture '$var' here, but it is not implemented yet, so # we capture the whole line. -_test( 'my $aa = 1; p $var', 'two statements'); +_test( 'my $aa = 1; p $var', 'two statements', expect => '$var'); # Do not print anything for np command -_test( 'my $str = np @some_array', 'no print', expect => '', exact_match => 1 ); +_test( 'my $str = np @a', 'no print', expect => '', exact_match => 1 ); -# Assignment statement: "my $str = p @some_array;" -# -> captures '@some_array' -_test( 'my $str = p @some_array', 'assignment', expect => '@some_array' ); +# Assignment statement: "my $str = p @a;" +# -> captures '@a' +_test( 'my $str = p @a', 'assignment', expect => '@a' ); # Multiple arguments to 'p' command: Capture correct argument '$var' _test( 'p($var, colored => 0)', 'multiple args', expect => '$var' ); @@ -45,10 +45,77 @@ _test( 'p $var; # p $b', 'end of line comment', expect => '$var' ); # Printing return values from function calls # -> should *not* capture arguments to the function call, but rather the whole # statement -_test( 'p _my_sub( $var )', 'print return value from function call' ); +_test( 'p _my_sub( $var )', 'print return value from function call', + expect => '_my_sub( $var )' +); + +# Incomplete statement. This is the case where a statement straddles multiple +# lines. This is not implemented yet, and we should get back only the part of +# the statement ( the part that is on the line that contains the function call). +# Note: for "eval", PPI will have access to both lines, so it +# will work correctly.. +_test( 'my $a = 3; pwp [1,2,' . "\n" . '3]', 'Incomplete statement', + expect => 'my $a = 3; pwp [1,2,', + expect_eval => '[1,2,' . "\n" . '3]', +); + +# No proto type: string +_test( 'pwp "Hello"', 'No proto: string', expect => '"Hello"' ); + +# No proto type: array +_test( 'pwp [1,2, 6]', 'No proto type: array', expect => '[1,2, 6]' ); + +# Nested printer call 1 +_test( 'my @aa = (2, (p $var), 3)', 'Nested call 1', expect => '$var' ); + +# Nested printer call 2 +_test( 'my @aa = (2, p ($var), 3)', 'Nested call 2', expect => '$var' ); + +# Reference to hash +_test( 'pwp \%h', 'reference to hash', expect => '\%h' ); + +# Reference to scalar +_test( 'pwp \my $var2', 'reference to scalar', expect => '\my $var2' ); + +# Array subscript 1 +_test( 'p $a[2]', 'Array subscript 1', expect => '$a[2]' ); + +# Array subscript 2 +_test( 'p $ar->[2]', 'Array subscript 2', expect => '$ar->[2]' ); + +# Hash subscript 1 +_test( 'p $h{b}{c}', 'Hash subscript 1', expect => '$h{b}{c}' ); + +# Hash and array subscript +_test( 'p $hr->{b}[$var - 2]', 'Hash and array subscript', + expect => '$hr->{b}[$var - 2]' +); + +# Func call through reference +_test( 'p $f->( $var, 4 )', 'Func call through reference', + expect => '$f->( $var, 4 )' +); + +# Package variable +_test( 'p $Data::Printer::VERSION', 'Package variable', + expect => '$Data::Printer::VERSION' +); + +# Array reference +_test( 'p @$ar', 'Array reference', expect => '@$ar' ); + +# two statements in one +_test( 'print STDERR "var=$var\n" && p @a', 'Two-in-one', expect => '@a' ); + +# Nested parenthesis +_test( 'pwp (($var + (2 - 5)))', 'Nested parenthesis', + expect => '($var + (2 - 5))' +); + done_testing; +exit; # Update %INC with the path to the Data::Printer module.. # we need this for some of the tests.. @@ -83,47 +150,38 @@ sub _update_inc { # Here, both methods are used. { my $temp_dir; # state variable for _test() subroutine below - + my $pwp_alias; + BEGIN { $pwp_alias = 'Data::Printer::p_without_prototypes' }; sub _test { my ( $statement, $test_name, %opt ) = @_; + $statement =~ s/pwp/$pwp_alias/; + $statement .= ';'; + if ( exists $opt{expect} ) { + $opt{expect} =~ s/pwp/$pwp_alias/; + } + else { + $opt{expect} = $statement; + } + $opt{exact_match} //= 0; if ( not defined $temp_dir ) { # initialize state variable $temp_dir $temp_dir = _get_temp_dir(); } - $opt{expect} //= $statement; - $opt{exact_match} //= 0; my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); my @args = ( $temp_dir, $statement, $test_name, $opt{expect}, $opt{exact_match}, $func ); - _test1( @args ); + if ( exists $opt{expect_eval} ) { + $opt{expect_eval} =~ s/pwp/$pwp_alias/; + } + else { + $opt{expect_eval} = $opt{expect}; + } + _test1( @args, $opt{expect_eval} ); _test2( @args ); _test3( @args ); - #_debug_inc(); _test4( @args ); } } -sub _debug_inc { - for (sort keys %INC) { - diag '$INC{' . $_ . '} = "' . $INC{$_} . '"'; - } - for (0..$#INC) { - diag '$INC[' . $_ . '] = "' . $INC[$_] . "'"; - } - _find_inc(); - BAIL_OUT('stop'); -} - - -sub _find_inc { - my $mod_name = 'My/Module.pm'; - for ( @INC ) { - my $fn = File::Spec->catfile( $_, $mod_name ); - if ( -e $fn ) { - diag "Found: '" . $fn . "'\n"; - } - } -} - { # We will require a different module name for each test. # (Alternatively, we could use the same module name for each test @@ -131,11 +189,12 @@ sub _find_inc { # We use the state variable $counter to keep track of the different modules my $counter; - # This test create a module DataPrinterTestHelperModuleX (where X is + # This test creates a module DataPrinterTestHelperModuleX (where X is # an integer) in the temp directory. Then it "require" that module # and call its "func" sub routine. sub _test1 { - my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; + my ( $temp_dir, $statement, $test_name, $expect_noeval, + $exact_match, $func, $expect_eval ) = @_; if ( not defined $counter ) { # intitalize state variable $counter $counter = 1; } @@ -144,7 +203,8 @@ sub _find_inc { my $fn = _create_test_helper_module( $temp_dir, $statement, $module_name, eval => $i - 1, ); - my $test_info = ( $i == 1 ? 'eval' : 'module' ); + my $test_info = ( $i == 1 ? 'module' : 'eval' ); + my $expect = ( $i == 1 ? $expect_noeval : $expect_eval ); $func->( \&{"$module_name" . "::func"}, $exact_match @@ -187,11 +247,11 @@ sub _test3 { my $curdir = Cwd::getcwd(); chdir $temp_dir; my ( $cmd, $module_name ) = _create_script2( $statement ); - #$func->( - # sub { system 'perl', $cmd }, - # $exact_match ? $expect : _get_expect_regex( $expect, $module_name ), - # $test_name . " (separate script 2) ", - #); + $func->( + sub { system 'perl', $cmd }, + $exact_match ? $expect : _get_expect_regex( $expect, $module_name ), + $test_name . " (separate script 2) ", + ); chdir $curdir; } @@ -244,12 +304,70 @@ sub _get_expect_regex { } +{ + my $decl_str; + BEGIN { + $decl_str = <<"END_STR"; +my \$var = 3; +my \@a = ( 1.. 3 ); +my \%h = ( a=>1, b=>{c=>1} ); +my \$ar = [1,2,3]; +my \$hr = { a=>1, b=>[4,5] }; +my \$f = \\&_my_sub +END_STR + }; + + sub _get_script_var_decl { + return $decl_str; + } +} + +{ + my $sub_def; + BEGIN { + $sub_def = <<"END_STR"; +sub _my_sub { + my ( \$var ) = \@_; + + return ++\$var; +} + +END_STR + }; + + sub _get_script_sub_def { + return $sub_def; + } +} + +{ + my $use_str; + BEGIN { + $use_str = <<"END_STR"; +use Data::Printer +{ + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' +} + +END_STR + }; + + sub _get_script_use_str { + return $use_str; + } +} + sub _create_script1 { my ( $temp_dir, $statement ) = @_; my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); $mod_path = File::Basename::dirname( $mod_path ); - + my $var_decl = _get_script_var_decl(); + my $sub_def = _get_script_sub_def(); + my $use_dataprinter = _get_script_use_str(); my $script = <<"END_SCRIPT"; use strict; use warnings; @@ -262,24 +380,14 @@ BEGIN { use Term::ANSIColor; }; -use Data::Printer -{ - return_value => 'pass', - colored => 0, - caller_info => 1, - caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' -}; +$use_dataprinter; + +$var_decl; -my \$var = 3; -my \@some_array = ( 1.. 3 ); - $statement; -sub _my_sub { - my ( \$var ) = \@_; +$sub_def - return ++\$var; -} END_SCRIPT my $fn = File::Spec->catfile( $temp_dir, 'test_script1.pl' ); @@ -292,6 +400,7 @@ END_SCRIPT return $fn; } + sub _create_script2 { my ( $statement ) = @_; @@ -341,6 +450,7 @@ sub _create_script3 { my ( $module_name, $module_name_perl ) = _write_test_module( $statement, $module_base_name, $module_dir ); chdir '..'; + my $use_dataprinter = _get_script_use_str(); my $script = <<"END_SCRIPT"; use strict; use warnings; @@ -356,13 +466,7 @@ BEGIN { use Term::ANSIColor; }; -use Data::Printer -{ - return_value => 'pass', - colored => 0, - caller_info => 1, - caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' -}; +$use_dataprinter; chdir '$test_dir'; @@ -388,6 +492,9 @@ sub _write_test_module { my $name = $dir . '::' . $base_name; my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); $mod_path = File::Basename::dirname( $mod_path ); + my $var_decl = _get_script_var_decl(); + my $sub_def = _get_script_sub_def(); + my $use_dataprinter = _get_script_use_str(); my $script = <<"END_SCRIPT"; package $name; @@ -396,26 +503,15 @@ use strict; use warnings; use lib '$mod_path'; -use Data::Printer -{ - return_value => 'pass', - colored => 0, - caller_info => 1, - caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' -}; +$use_dataprinter; sub func { - my \$var = 3; - my \@some_array = ( 1.. 3 ); + $var_decl; $statement } -sub _my_sub { - my ( \$var ) = \@_; - - return ++\$var; -} +$sub_def 1; END_SCRIPT @@ -440,6 +536,9 @@ sub _create_test_helper_module { if ( $opt{eval} ) { $statement = "eval '$statement'"; } + my $var_decl = _get_script_var_decl(); + my $sub_def = _get_script_sub_def(); + my $use_dataprinter = _get_script_use_str(); my $script = <<"END_SCRIPT"; package $module_name; @@ -447,30 +546,17 @@ package $module_name; use strict; use warnings; -use Data::Printer -{ - return_value => 'pass', - colored => 0, - caller_info => 1, - caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' -}; +$use_dataprinter; sub func { - my \$var = 3; - my \@some_array = ( 1.. 3 ); - + $var_decl; $statement } -sub _my_sub { - my ( \$var ) = \@_; - - return ++\$var; -} +$sub_def 1; END_SCRIPT - my $fn = File::Spec->catfile( $temp_dir, $module_name . '.pm' ); open ( my $fh, '>', $fn ) or die "Could not open file '$fn': $!"; print $fh $script; From b46f8c930faf58231eada85dae755bb1f69beace Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Tue, 5 Apr 2016 00:14:56 +0200 Subject: [PATCH 12/13] minor changes --- lib/Data/Printer/ShowVar.pm | 17 +---------------- t/23.2-caller_info2.t | 2 +- 2 files changed, 2 insertions(+), 17 deletions(-) diff --git a/lib/Data/Printer/ShowVar.pm b/lib/Data/Printer/ShowVar.pm index a2a3a6d..61bbbf9 100644 --- a/lib/Data/Printer/ShowVar.pm +++ b/lib/Data/Printer/ShowVar.pm @@ -166,7 +166,7 @@ sub _parse_line { return $line; } -# Determine the the first argument (usually a variable, but could also be an +# Determine the first argument (usually a variable, but could also be an # expression) of the original caller, i.e. p() or p_without_prototypes(). # Currently we are able to parse the sought variable name the same way regardless # of whether the caller was p() or p_without_prototypes(). This is due to the way @@ -251,21 +251,6 @@ sub _select_statement { return ($found_statement, $node, $called_as); } -# We choose to only focus on simple statements with p() and p_without_prototypes() -# Two classes of PPI statements are supported: -# -# PPI::Statement : -# -# - p $var, p @var, p %h, ... -# - p ( $var ), p ( $var, colored => 0 ), ... -# - p_without_prototypes "Hello", p_without_prototypes [ 1, 3, 5 ], .. -# -# PPI::Statement::Variable : these are relevant when option "return_value" is 'dump' or -# 'pass' . Examples: -# -# my $var = p $var, ... -# -# sub _get_top_level_statements { my ( $ref ) = @_; diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index 21f9816..39b2a99 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -257,7 +257,7 @@ sub _test3 { # Run script in temp dir that uses Data::Printer, then chdir() to new dir and # later "require" a module "My::Module" (relative to temp dir) that also uses -# Data::Printer. The last +# Data::Printer. sub _test4 { my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; From 11d9171c26df04ed0e5387f46f0a12b581116aca Mon Sep 17 00:00:00 2001 From: Haakon Haegland Date: Sun, 10 Apr 2016 13:36:25 +0200 Subject: [PATCH 13/13] Fixed some bugs. Rewrote test file. --- lib/Data/Printer/ShowVar.pm | 22 ++++- t/23.2-caller_info2.t | 176 +++++++++++++++++++++--------------- 2 files changed, 122 insertions(+), 76 deletions(-) diff --git a/lib/Data/Printer/ShowVar.pm b/lib/Data/Printer/ShowVar.pm index 61bbbf9..239354f 100644 --- a/lib/Data/Printer/ShowVar.pm +++ b/lib/Data/Printer/ShowVar.pm @@ -111,11 +111,20 @@ sub _get_valid_callers { my ( $p, $called_as ) = @_; my @pp; my @pnp; + my @temp = qw(Data::Printer::p); if ( defined (my $alias = $p->{alias} ) ) { - push @pp, $alias; + push @temp, $alias; } - push @pp, 'Data::Printer::p', 'p'; - push @pnp, 'Data::Printer::p_without_prototypes', 'p_without_prototypes'; + else { + push @temp, 'p'; + } + if ( $p->{use_prototypes} ) { + push @pp, @temp; + } + else { + push @pnp, @temp; + } + push @pnp, 'Data::Printer::p_without_prototypes'; my $proto; my $valid_callers; @@ -131,7 +140,7 @@ sub _get_valid_callers { } # Parse line, and extract variable name to be printed. -# Default behavior if we cannot determine a variable name is to use $line. +# Default behavior if we cannot determine a variable name is to return $line. # This default should still be better than not printing anything! # # Example: if $line is @@ -162,7 +171,10 @@ sub _parse_line { # It is not necessary to display a trailing semicolon. # (It will only act as "noise" in the output..) $line =~ s/\s*;?\s*$//; - + # $line will be quoted later. Avoid double pairs of quotes: + $line =~ s/^["'](.*)["']$/$1/; + # When use_prototypes = 0, references, like "\%h", should be printed as "%h": + $line =~ s/^\\//; return $line; } diff --git a/t/23.2-caller_info2.t b/t/23.2-caller_info2.t index 39b2a99..c7dc9d7 100644 --- a/t/23.2-caller_info2.t +++ b/t/23.2-caller_info2.t @@ -15,8 +15,11 @@ use File::Temp (); use Test::More; use Test::Output; +use Data::Dumper; + _update_inc(); + # Try capture simple variable _test( 'p $var', 'no parens capture', expect => '$var' ); @@ -33,10 +36,10 @@ _test( 'my $str = np @a', 'no print', expect => '', exact_match => 1 ); # Assignment statement: "my $str = p @a;" # -> captures '@a' -_test( 'my $str = p @a', 'assignment', expect => '@a' ); +_test( 'my $str = p @a', 'assignment', expect => '@a', proto => 1 ); # Multiple arguments to 'p' command: Capture correct argument '$var' -_test( 'p($var, colored => 0)', 'multiple args', expect => '$var' ); +_test( 'p($var, colored => 0)', 'multiple args', expect => '$var', proto => 1 ); # Statement with a comment at the end of the line: "p $var; # p $b" # -> ignores comment, and capture '$var' @@ -54,16 +57,18 @@ _test( 'p _my_sub( $var )', 'print return value from function call', # the statement ( the part that is on the line that contains the function call). # Note: for "eval", PPI will have access to both lines, so it # will work correctly.. -_test( 'my $a = 3; pwp [1,2,' . "\n" . '3]', 'Incomplete statement', - expect => 'my $a = 3; pwp [1,2,', +_test( 'my $a = 3; p [1,2,' . "\n" . '3]', 'Incomplete statement', + expect => 'my $a = 3; p [1,2,', expect_eval => '[1,2,' . "\n" . '3]', + proto => 0, ); + # No proto type: string -_test( 'pwp "Hello"', 'No proto: string', expect => '"Hello"' ); +_test( 'p "Hello"', 'No proto: string', expect => 'Hello', proto => 0 ); # No proto type: array -_test( 'pwp [1,2, 6]', 'No proto type: array', expect => '[1,2, 6]' ); +_test( 'p [1,2, 6]', 'No proto type: array', expect => '[1,2, 6]', proto => 0 ); # Nested printer call 1 _test( 'my @aa = (2, (p $var), 3)', 'Nested call 1', expect => '$var' ); @@ -72,10 +77,10 @@ _test( 'my @aa = (2, (p $var), 3)', 'Nested call 1', expect => '$var' ); _test( 'my @aa = (2, p ($var), 3)', 'Nested call 2', expect => '$var' ); # Reference to hash -_test( 'pwp \%h', 'reference to hash', expect => '\%h' ); +_test( 'p \%h', 'reference to hash', expect => '%h', proto => 0 ); # Reference to scalar -_test( 'pwp \my $var2', 'reference to scalar', expect => '\my $var2' ); +_test( 'p \my $var2', 'reference to scalar', expect => 'my $var2', proto => 0 ); # Array subscript 1 _test( 'p $a[2]', 'Array subscript 1', expect => '$a[2]' ); @@ -102,14 +107,18 @@ _test( 'p $Data::Printer::VERSION', 'Package variable', ); # Array reference -_test( 'p @$ar', 'Array reference', expect => '@$ar' ); +_test( 'p @$ar', 'Array reference', expect => '@$ar', proto => 1 ); # two statements in one -_test( 'print STDERR "var=$var\n" && p @a', 'Two-in-one', expect => '@a' ); +_test( 'print STDERR "var=$var\n" && p @a', 'Two-in-one', + expect => '@a', + proto => 1, + ); # Nested parenthesis -_test( 'pwp (($var + (2 - 5)))', 'Nested parenthesis', - expect => '($var + (2 - 5))' +_test( 'p (($var + (2 - 5)))', 'Nested parenthesis', + expect => '($var + (2 - 5))', + proto => 0, ); @@ -150,31 +159,19 @@ sub _update_inc { # Here, both methods are used. { my $temp_dir; # state variable for _test() subroutine below - my $pwp_alias; - BEGIN { $pwp_alias = 'Data::Printer::p_without_prototypes' }; sub _test { my ( $statement, $test_name, %opt ) = @_; - $statement =~ s/pwp/$pwp_alias/; $statement .= ';'; - if ( exists $opt{expect} ) { - $opt{expect} =~ s/pwp/$pwp_alias/; - } - else { - $opt{expect} = $statement; - } + $opt{expect} //= $statement; $opt{exact_match} //= 0; + $opt{proto} //= undef; if ( not defined $temp_dir ) { # initialize state variable $temp_dir $temp_dir = _get_temp_dir(); } my $func = ($opt{exact_match} ? \&stderr_is : \&stderr_like ); my @args = ( $temp_dir, $statement, $test_name, - $opt{expect}, $opt{exact_match}, $func ); - if ( exists $opt{expect_eval} ) { - $opt{expect_eval} =~ s/pwp/$pwp_alias/; - } - else { - $opt{expect_eval} = $opt{expect}; - } + $opt{expect}, $opt{exact_match}, $func, $opt{proto} ); + $opt{expect_eval} //= $opt{expect}; _test1( @args, $opt{expect_eval} ); _test2( @args ); _test3( @args ); @@ -194,35 +191,63 @@ sub _update_inc { # and call its "func" sub routine. sub _test1 { my ( $temp_dir, $statement, $test_name, $expect_noeval, - $exact_match, $func, $expect_eval ) = @_; + $exact_match, $func, $proto_info, $expect_eval ) = @_; if ( not defined $counter ) { # intitalize state variable $counter $counter = 1; } - for my $i (1..2) { - my $module_name = 'DataPrinterTestHelperModule' . $counter++; - my $fn = _create_test_helper_module( - $temp_dir, $statement, $module_name, eval => $i - 1, - ); - my $test_info = ( $i == 1 ? 'module' : 'eval' ); - my $expect = ( $i == 1 ? $expect_noeval : $expect_eval ); - $func->( - \&{"$module_name" . "::func"}, - $exact_match + my $proto_types = _get_prototypes( $proto_info ); + for my $proto (@$proto_types) { + for my $i (1..2) { + my $module_name = 'DataPrinterTestHelperModule' . $counter++; + my $fn = _create_test_helper_module( + $temp_dir, $statement, $module_name, $proto, eval => $i - 1, + ); + my $test_info = ( $i == 1 ? 'module' : 'eval' ); + my $expect = ( $i == 1 ? $expect_noeval : $expect_eval ); + $func->( + \&{"$module_name" . "::func"}, + $exact_match ? $expect : _get_expect_regex( $expect, $fn ), - $test_name . " ($test_info) ", - ); + $test_name . " ($test_info) ", + ); + } } } } +sub _get_prototypes { + my ( $proto_info ) = @_; + + my @p; + + if ( !defined $proto_info ) { + @p = (0, 1); + } + else { + @p = ( $proto_info ); + } + return \@p; +} + +sub _get_prototype { + my ( $proto ) = @_; + + if ( !defined $proto ) { + $proto = 1; + } + return $proto; +} + # Run script in temp dir in two ways: # a) Absolute path : system 'perl', '/tmp/script.pl' # b) Relative path : system 'perl', 'tmp/script.pl' sub _test2 { - my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, + $func, $proto ) = @_; - my $cmd1 = _create_script1( $temp_dir, $statement ); + $proto = _get_prototype( $proto ); + my $cmd1 = _create_script1( $temp_dir, $statement, $proto ); my $dir1 = Cwd::getcwd(); my ( $cmd2, $dir2 ) = _get_script_start_dir( $cmd1 ); my @cmds = ( $cmd1, $cmd2 ); @@ -242,11 +267,13 @@ sub _test2 { # Run script in temp dir that includes a module "My::Module" relative to the # temp dir. Only the module loads Data::Printer. sub _test3 { - my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, + $func, $proto ) = @_; + $proto = _get_prototype( $proto ); my $curdir = Cwd::getcwd(); chdir $temp_dir; - my ( $cmd, $module_name ) = _create_script2( $statement ); + my ( $cmd, $module_name ) = _create_script2( $statement, $proto ); $func->( sub { system 'perl', $cmd }, $exact_match ? $expect : _get_expect_regex( $expect, $module_name ), @@ -259,11 +286,13 @@ sub _test3 { # later "require" a module "My::Module" (relative to temp dir) that also uses # Data::Printer. sub _test4 { - my ( $temp_dir, $statement, $test_name, $expect, $exact_match, $func ) = @_; + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, + $func, $proto ) = @_; my $curdir = Cwd::getcwd(); chdir $temp_dir; - my ( $cmd, $module_name ) = _create_script3( $statement ); + $proto = _get_prototype( $proto ); + my ( $cmd, $module_name ) = _create_script3( $statement, $proto ); my $expect_regex = qr/\Q\E/; $func->( sub { system 'perl', $cmd }, @@ -318,7 +347,7 @@ END_STR }; sub _get_script_var_decl { - return $decl_str; + return \$decl_str; } } @@ -336,7 +365,7 @@ END_STR }; sub _get_script_sub_def { - return $sub_def; + return \$sub_def; } } @@ -346,6 +375,7 @@ END_STR $use_str = <<"END_STR"; use Data::Printer { + use_prototypes => xxx, return_value => 'pass', colored => 0, caller_info => 1, @@ -356,18 +386,22 @@ END_STR }; sub _get_script_use_str { - return $use_str; + my ( %opt ) = @_; + $opt{proto} //= 1; + my $temp = $use_str; + $temp =~ s/xxx/$opt{proto}/; + return \$temp; } } sub _create_script1 { - my ( $temp_dir, $statement ) = @_; + my ( $temp_dir, $statement, $proto ) = @_; my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); $mod_path = File::Basename::dirname( $mod_path ); my $var_decl = _get_script_var_decl(); my $sub_def = _get_script_sub_def(); - my $use_dataprinter = _get_script_use_str(); + my $use_dataprinter = _get_script_use_str(proto => $proto); my $script = <<"END_SCRIPT"; use strict; use warnings; @@ -380,13 +414,13 @@ BEGIN { use Term::ANSIColor; }; -$use_dataprinter; +$$use_dataprinter; -$var_decl; +$$var_decl; $statement; -$sub_def +$$sub_def END_SCRIPT @@ -402,12 +436,12 @@ END_SCRIPT sub _create_script2 { - my ( $statement ) = @_; + my ( $statement, $proto ) = @_; my $module_dir = 'My'; my $module_base_name = 'Module'; my ( $module_name, $module_name_perl ) - = _write_test_module( $statement, $module_base_name, $module_dir ); + = _write_test_module( $statement, $module_base_name, $module_dir, $proto ); my $script = <<"END_SCRIPT"; use strict; @@ -434,7 +468,7 @@ END_SCRIPT } sub _create_script3 { - my ( $statement ) = @_; + my ( $statement, $proto ) = @_; my $dummy_dir = 'dummy_folder'; if ( ! -e $dummy_dir ) { @@ -448,9 +482,9 @@ sub _create_script3 { my $module_dir = 'My'; my $module_base_name = 'Module2'; my ( $module_name, $module_name_perl ) - = _write_test_module( $statement, $module_base_name, $module_dir ); + = _write_test_module( $statement, $module_base_name, $module_dir, $proto ); chdir '..'; - my $use_dataprinter = _get_script_use_str(); + my $use_dataprinter = _get_script_use_str(proto => $proto); my $script = <<"END_SCRIPT"; use strict; use warnings; @@ -466,7 +500,7 @@ BEGIN { use Term::ANSIColor; }; -$use_dataprinter; +$$use_dataprinter; chdir '$test_dir'; @@ -487,14 +521,14 @@ END_SCRIPT } sub _write_test_module { - my ( $statement, $base_name, $dir ) = @_; + my ( $statement, $base_name, $dir, $proto ) = @_; my $name = $dir . '::' . $base_name; my $mod_path = File::Basename::dirname( $INC{'Data/Printer.pm'} ); $mod_path = File::Basename::dirname( $mod_path ); my $var_decl = _get_script_var_decl(); my $sub_def = _get_script_sub_def(); - my $use_dataprinter = _get_script_use_str(); + my $use_dataprinter = _get_script_use_str(proto => $proto); my $script = <<"END_SCRIPT"; package $name; @@ -503,15 +537,15 @@ use strict; use warnings; use lib '$mod_path'; -$use_dataprinter; +$$use_dataprinter; sub func { - $var_decl; + $$var_decl; $statement } -$sub_def +$$sub_def 1; END_SCRIPT @@ -530,7 +564,7 @@ END_SCRIPT sub _create_test_helper_module { - my ( $temp_dir, $statement, $module_name, %opt ) = @_; + my ( $temp_dir, $statement, $module_name, $proto, %opt ) = @_; $opt{eval} //= 0; if ( $opt{eval} ) { @@ -538,7 +572,7 @@ sub _create_test_helper_module { } my $var_decl = _get_script_var_decl(); my $sub_def = _get_script_sub_def(); - my $use_dataprinter = _get_script_use_str(); + my $use_dataprinter = _get_script_use_str( proto => $proto ); my $script = <<"END_SCRIPT"; package $module_name; @@ -546,14 +580,14 @@ package $module_name; use strict; use warnings; -$use_dataprinter; +$$use_dataprinter; sub func { - $var_decl; + $$var_decl; $statement } -$sub_def +$$sub_def 1; END_SCRIPT