lib/Perl/Tidy/Debugger.pm

   1 #####################################################################
   2 #
   3 # The Perl::Tidy::Debugger class shows line tokenization
   4 #
   5 #####################################################################
   6
   7 package Perl::Tidy::Debugger;
   8 use strict;
   9 use warnings;
  10 our $VERSION = '20181120';
  11
  12 sub new {
  13
  14     my ( $class, $filename ) = @_;
  15
  16     return bless {
  17         _debug_file        => $filename,
  18         _debug_file_opened => 0,
  19         _fh                => undef,
  20     }, $class;
  21 }
  22
  23 sub really_open_debug_file {
  24
  25     my $self       = shift;
  26     my $debug_file = $self->{_debug_file};
  27     my $fh;
  28     unless ( $fh = IO::File->new("> $debug_file") ) {
  29         Perl::Tidy::Warn("can't open $debug_file: $!\n");
  30     }
  31     $self->{_debug_file_opened} = 1;
  32     $self->{_fh}                = $fh;
  33     print $fh
  34       "Use -dump-token-types (-dtt) to get a list of token type codes\n";
  35     return;
  36 }
  37
  38 sub close_debug_file {
  39
  40     my $self = shift;
  41     my $fh   = $self->{_fh};
  42     if ( $self->{_debug_file_opened} ) {
  43         if ( !eval { $self->{_fh}->close(); 1 } ) {
  44
  45             # ok, maybe no close function
  46         }
  47     }
  48     return;
  49 }
  50
  51 sub write_debug_entry {
  52
  53     # This is a debug dump routine which may be modified as necessary
  54     # to dump tokens on a line-by-line basis.  The output will be written
  55     # to the .DEBUG file when the -D flag is entered.
  56     my ( $self, $line_of_tokens ) = @_;
  57
  58     my $input_line = $line_of_tokens->{_line_text};
  59
  60     my $rtoken_type = $line_of_tokens->{_rtoken_type};
  61     my $rtokens     = $line_of_tokens->{_rtokens};
  62     my $rlevels     = $line_of_tokens->{_rlevels};
  63     my $rslevels    = $line_of_tokens->{_rslevels};
  64     my $rblock_type = $line_of_tokens->{_rblock_type};
  65
  66     my $input_line_number = $line_of_tokens->{_line_number};
  67     my $line_type         = $line_of_tokens->{_line_type};
  68     ##my $rtoken_array      = $line_of_tokens->{_token_array};
  69
  70     my ( $j, $num );
  71
  72     my $token_str              = "$input_line_number: ";
  73     my $reconstructed_original = "$input_line_number: ";
  74     my $block_str              = "$input_line_number: ";
  75
  76     #$token_str .= "$line_type: ";
  77     #$reconstructed_original .= "$line_type: ";
  78
  79     my $pattern   = "";
  80     my @next_char = ( '"', '"' );
  81     my $i_next    = 0;
  82     unless ( $self->{_debug_file_opened} ) { $self->really_open_debug_file() }
  83     my $fh = $self->{_fh};
  84
  85     # FIXME: could convert to use of token_array instead
  86     foreach my $j ( 0 .. @{$rtoken_type} - 1 ) {
  87
  88         # testing patterns
  89         if ( $rtoken_type->[$j] eq 'k' ) {
  90             $pattern .= $rtokens->[$j];
  91         }
  92         else {
  93             $pattern .= $rtoken_type->[$j];
  94         }
  95         $reconstructed_original .= $rtokens->[$j];
  96         $block_str              .= "($rblock_type->[$j])";
  97         $num = length( $rtokens->[$j] );
  98         my $type_str = $rtoken_type->[$j];
  99
 100         # be sure there are no blank tokens (shouldn't happen)
 101         # This can only happen if a programming error has been made
 102         # because all valid tokens are non-blank
 103         if ( $type_str eq ' ' ) {
 104             print $fh "BLANK TOKEN on the next line\n";
 105             $type_str = $next_char[$i_next];
 106             $i_next   = 1 - $i_next;
 107         }
 108
 109         if ( length($type_str) == 1 ) {
 110             $type_str = $type_str x $num;
 111         }
 112         $token_str .= $type_str;
 113     }
 114
 115     # Write what you want here ...
 116     # print $fh "$input_line\n";
 117     # print $fh "$pattern\n";
 118     print $fh "$reconstructed_original\n";
 119     print $fh "$token_str\n";
 120
 121     #print $fh "$block_str\n";
 122     return;
 123 }
 124 1;
 125