diff --git a/Makefile.PL b/Makefile.PL index 247a8d2..b460792 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -11,17 +11,22 @@ 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 '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, 'File::Temp' => 0, '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 715ae61..42371df 100644 --- a/lib/Data/Printer.pm +++ b/lib/Data/Printer.pm @@ -6,12 +6,16 @@ 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 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 (); @@ -25,6 +29,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', @@ -71,6 +89,7 @@ my $properties = { 'format' => 'bright_cyan', 'repeated' => 'white on_red', 'caller_info' => 'bright_cyan', + 'caller_info_var' => 'green', 'weak' => 'cyan', 'tainted' => 'red', 'unicode' => 'bright_yellow', @@ -925,14 +944,41 @@ sub _get_info_message { my $message = $p->{caller_message}; - $message =~ s/\b__PACKAGE__\b/$caller[0]/g; - $message =~ s/\b__FILENAME__\b/$caller[1]/g; - $message =~ s/\b__LINE__\b/$caller[2]/g; + my ( $filename, $line ) = @caller[1..2]; - return colored($message, $p->{color}{caller_info}) . $p->{_linebreak}; + ( $line, $filename, my $line_str, my $filename_str ) + = 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; + { + 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 = Data::Printer::ShowVar::get_caller_print_var( + $p, $filename, $line, $line_str, \@caller + ); + # 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 . $p->{_linebreak}; } - sub _merge { my $p = shift; my $clone = clone $properties; @@ -1325,22 +1371,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', @@ -1663,8 +1710,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 @@ -1685,6 +1731,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. 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 new file mode 100644 index 0000000..239354f --- /dev/null +++ b/lib/Data/Printer/ShowVar.pm @@ -0,0 +1,488 @@ +package Data::Printer::ShowVar; +use strict; +use warnings; + +use Term::ANSIColor qw(color colored); +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 +# 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 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 + # 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, $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(""); + } + } + 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 ); + } + } + return _quote( $line ); +} + +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 @temp, $alias; + } + 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; + 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 ); +} + +# Parse line, and extract variable name to be printed. +# 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 +# +# "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..) + $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; +} + +# 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 +# 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; + + 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); +} + +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 (\@items, scalar @items); +} + +# 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 +# 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 +# +{ + my $is_initialized; + sub _get_ppi_document { + my ( $line ) = @_; + + 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 _add_trailing_semicolon { + my ( $line ) = @_; + + if ( $$line !~ /;\s*$/ ) { + $$line .= ';'; + } +} + +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::$_"}; + } +} + +# 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; + } + else { + return undef; + } +} + +sub _quote { + my ( $str ) = @_; + + return '"' . $str . '"'; +} + +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 new file mode 100644 index 0000000..c7dc9d7 --- /dev/null +++ b/t/23.2-caller_info2.t @@ -0,0 +1,601 @@ +use strict; +use warnings; + +BEGIN { + delete $ENV{DATAPRINTERRC}; + use File::HomeDir::Test; # avoid user's .dataprinter + use Term::ANSIColor; +}; + +use Carp; +use Cwd (); +use File::Basename (); +use File::Spec; +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' ); + +# Try capture variable in parenthesis +_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', expect => '$var'); + +# Do not print anything for np command +_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', proto => 1 ); + +# Multiple arguments to 'p' command: Capture correct argument '$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' +_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', + 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; 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( 'p "Hello"', 'No proto: string', expect => 'Hello', proto => 0 ); + +# No proto type: array +_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' ); + +# Nested printer call 2 +_test( 'my @aa = (2, p ($var), 3)', 'Nested call 2', expect => '$var' ); + +# Reference to hash +_test( 'p \%h', 'reference to hash', expect => '%h', proto => 0 ); + +# Reference to scalar +_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]' ); + +# 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', proto => 1 ); + +# two statements in one +_test( 'print STDERR "var=$var\n" && p @a', 'Two-in-one', + expect => '@a', + proto => 1, + ); + +# Nested parenthesis +_test( 'p (($var + (2 - 5)))', 'Nested parenthesis', + expect => '($var + (2 - 5))', + proto => 0, +); + + +done_testing; + +exit; + +# 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. +# 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 procedure avoids 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 + sub _test { + my ( $statement, $test_name, %opt ) = @_; + $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, $opt{proto} ); + $opt{expect_eval} //= $opt{expect}; + _test1( @args, $opt{expect_eval} ); + _test2( @args ); + _test3( @args ); + _test4( @args ); + } +} + +{ + # 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; + + # 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_noeval, + $exact_match, $func, $proto_info, $expect_eval ) = @_; + if ( not defined $counter ) { # intitalize state variable $counter + $counter = 1; + } + 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) ", + ); + } + } + } +} + +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, $proto ) = @_; + + $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 ); + my @dirs = ( $dir1, $dir2 ); + for (0..1) { + my $cmd = $cmds[$_]; + chdir $dirs[$_]; + $func->( + sub { system 'perl', $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, $expect, $exact_match, + $func, $proto ) = @_; + + $proto = _get_prototype( $proto ); + my $curdir = Cwd::getcwd(); + chdir $temp_dir; + my ( $cmd, $module_name ) = _create_script2( $statement, $proto ); + $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. +sub _test4 { + my ( $temp_dir, $statement, $test_name, $expect, $exact_match, + $func, $proto ) = @_; + + my $curdir = Cwd::getcwd(); + chdir $temp_dir; + $proto = _get_prototype( $proto ); + my ( $cmd, $module_name ) = _create_script3( $statement, $proto ); + my $expect_regex = qr/\Q\E/; + $func->( + sub { system 'perl', $cmd }, + $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 ) = @_; + + 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 { + $tempdir = File::Temp::tempdir( CLEANUP => 1 ); + }; + if ($@) { + croak "Could not create temp dir: $@"; + } + return $tempdir; +} + +sub _get_expect_regex { + my ( $str, $fn ) = @_; + + my $expect1 = 'Printing "' . $str . '" in line '; + my $expect2 = ' of ' . $fn . ":\n"; + return qr/^\Q$expect1\E\d+\Q$expect2\E/; +} + + +{ + 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 +{ + use_prototypes => xxx, + return_value => 'pass', + colored => 0, + caller_info => 1, + caller_message => 'Printing __VAR__ in line __LINE__ of __FILENAME__:' +} + +END_STR + }; + + sub _get_script_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, $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(proto => $proto); + 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_dataprinter; + +$$var_decl; + +$statement; + +$$sub_def + +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, $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, $proto ); + + 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 $module_name_perl; + +${module_name_perl}::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 _create_script3 { + my ( $statement, $proto ) = @_; + + 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, $proto ); + chdir '..'; + my $use_dataprinter = _get_script_use_str(proto => $proto); + 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_dataprinter; + +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, $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(proto => $proto); + + my $script = <<"END_SCRIPT"; +package $name; + +use strict; +use warnings; +use lib '$mod_path'; + +$$use_dataprinter; + +sub func { + $$var_decl; + + $statement +} + +$$sub_def + +1; +END_SCRIPT + + 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': $!"; + print $fh $script; + close $fh; + return ( $fn, $name ); +} + + +sub _create_test_helper_module { + my ( $temp_dir, $statement, $module_name, $proto, %opt ) = @_; + + $opt{eval} //= 0; + 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( proto => $proto ); + + my $script = <<"END_SCRIPT"; +package $module_name; + +use strict; +use warnings; + +$$use_dataprinter; + +sub func { + $$var_decl; + $statement +} + +$$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; + close $fh; + require $fn; + return $fn; +} +