"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20200110/lib/Perl/Tidy/Debugger.pm" (7 Jan 2020, 3572 Bytes) of package /linux/misc/Perl-Tidy-20200110.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Debugger.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 20191203_vs_20200110.

    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 = '20200110';
   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