File Coverage

blib/lib/Tk/TextHighlight/Perl.pm
Criterion Covered Total %
statement 15 69 21.7
branch 1 8 12.5
condition 0 3 0.0
subroutine 5 12 41.6
pod 6 7 85.7
total 27 99 27.2


line stmt bran cond sub pod time code
1             package Tk::TextHighlight::Perl;
2              
3 1     1   20894 use vars qw($VERSION);
  1         2  
  1         82  
4             $VERSION = '0.4';
5             #use Syntax::Highlight::Perl;
6             #use base 'Syntax::Highlight::Perl::Improved';
7             BEGIN
8             {
9 1     1   3 my $havePerlImproved = 0;
10 1     1   62 eval 'use base "Syntax::Highlight::Perl::Improved"; $havePerlImproved = 1; 1';
  1         5  
  1         3  
  1         1454  
11 1 50       44 unless ($havePerlImproved) {
12 0         0 eval 'use base "Syntax::Highlight::Perl"; 1';
13             }
14             }
15              
16 1     1   8 use strict;
  1         2  
  1         23  
17 1     1   4 use Data::Dumper;
  1         2  
  1         664  
18              
19             sub new {
20 0     0 1   my ($proto, $rules) = @_;
21 0   0       my $class = ref($proto) || $proto;
22 0           my $self = $class->SUPER::new;
23 0 0         if (not defined($rules)) {
24 0           $rules = [
25             ['DEFAULT', -foreground => 'black'],
26             ['Comment_Normal', -foreground => 'lightblue'],
27             ['Comment_Pod', -foreground => 'lightblue'],
28             ['Directive', -foreground => 'brown'],
29             ['Label', -foreground => 'black'],
30             ['Quote', -foreground => 'red'],
31             ['String', -foreground => 'red'],
32             ['Variable_Scalar', -foreground => 'blue'],
33             ['Variable_Array', -foreground => 'blue'],
34             ['Variable_Hash', -foreground => 'blue'],
35             ['Subroutine', -foreground => 'orange'],
36             ['Character', -foreground => 'magenta'],
37             ['Keyword', -foreground => 'brown'],
38             ['Builtin_Operator', -foreground => 'darkgreen'],
39             ['Operator', -foreground => 'brown'],
40             ['Number', -foreground => 'darkblue'],
41             ];
42             };
43 0           $self->{'rules'} = [];
44 0           bless ($self, $class);
45 0           $self->rules($rules);
46 0           $self->unstable(1);
47 0           return $self;
48             }
49              
50             sub highlight {
51 0     0 1   my $hlt = shift;
52 0           my $txt = $hlt->format_string(shift);
53 0           my @target = ();
54 0           my @lst = split /\e\e\e/o, $txt; #start to retrieve the color info tags.
55 0           while (@lst) { #set up the insert command options.
56 0           push(@target, length(shift @lst), shift @lst);
57             };
58 0           return @target;
59             }
60              
61             sub rules {
62 0     0 1   my $hlt = shift;
63 0 0         if (@_) {
64 0           my $r = shift;
65 0           my %format = ();
66 0           foreach my $k (@$r) {
67 0           $format{$k->[0]} = ["", "\e\e\e" . $k->[0] . "\e\e\e"];
68             }
69 0           $hlt->set_format(%format);
70 0           $hlt->reset;
71 0           $hlt->{'rules'} = $r;
72             }
73 0           return $hlt->{'rules'};
74             }
75              
76             sub stateCompare {
77 0     0 1   my ($hlt, $state) = @_;
78 0           my $h = [ $hlt->stateGet ];
79 0           my $equal = 1;
80 0 0         if (Dumper($h) ne Dumper($state)) { $equal = 0 };
  0            
81 0           return $equal;
82             }
83              
84             sub stateGet {
85 0     0 1   my $hlt = shift;
86             return (
87             $hlt->in_heredoc,
88             $hlt->in_string,
89             $hlt->in_pod,
90             $hlt->was_pod,
91             $hlt->in_data,
92             $hlt->{'quote_instigator'},
93             $hlt->{'quote_terminator'},
94             $hlt->{'quote_type'},
95             $hlt->{'found_multi'},
96             $hlt->{'awaiting_multi'},
97             $hlt->{'awaiting_variable'},
98             $hlt->{'awaiting_class'},
99             $hlt->{'last_token'},
100             $hlt->{'last_token_type'},
101 0           $hlt->{'reentrant'},
102             );
103             }
104              
105             sub stateSet {
106 0     0 1   my $hlt = shift;
107 0           $hlt->{'in_heredoc'} = shift;
108 0           $hlt->{'in_string'} = shift;
109 0           $hlt->{'in_pod'} = shift;
110 0           $hlt->{'was_pod'} = shift;
111 0           $hlt->{'in_data'} = shift;
112 0           $hlt->{'quote_instigator'} = shift;
113 0           $hlt->{'quote_terminator'} = shift;
114 0           $hlt->{'quote_type'} = shift;
115 0           $hlt->{'found_multi'} = shift;
116 0           $hlt->{'awaiting_multi'} = shift;
117 0           $hlt->{'awaiting_variable'} = shift;
118 0           $hlt->{'awaiting_class'} = shift;
119 0           $hlt->{'last_token'} = shift;
120 0           $hlt->{'last_token_type'} = shift;
121 0           $hlt->{'reentrant'} = shift;
122             }
123              
124             sub syntax {
125 0     0 0   my $hlt = shift;
126 0           return 'Perl',
127             }
128              
129             1;
130              
131             __END__