"Fossies" - the Fresh Open Source Software Archive

Member "Perl-Tidy-20210717/lib/Perl/Tidy/Debugger.pm" (14 Jul 2021, 3528 Bytes) of package /linux/misc/Perl-Tidy-20210717.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: 20210402_vs_20210717.

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