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