File Coverage

blib/lib/Tk/TextHighlight/PerlCool.pm
Criterion Covered Total %
statement 6 6 100.0
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 8 8 100.0


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