File Coverage

blib/lib/Tk/TextHighlight/Template.pm
Criterion Covered Total %
statement 9 118 7.6
branch 0 26 0.0
condition 0 3 0.0
subroutine 3 24 12.5
pod 18 21 85.7
total 30 192 15.6


line stmt bran cond sub pod time code
1             package Tk::TextHighlight::Template;
2              
3 5     5   21359 use vars qw($VERSION);
  5         10  
  5         245  
4             $VERSION = '0.3';
5              
6 5     5   25 use strict;
  5         7  
  5         107  
7 5     5   319010 use Data::Dumper;
  5         53930  
  5         6467  
8              
9             sub new {
10 0     0 0   my ($proto, $rules) = @_;
11 0   0       my $class = ref($proto) || $proto;
12 0 0         if (not defined($rules)) {
13 0           $rules = [];
14             };
15 0           my $self = {};
16 0           $self->{'lists'} = {};
17 0           $self->{'out'} = [];
18             $self->{'rules'} = $rules,
19 0           $self->{'stack'} = [];
20 0           $self->{'snippet'} = '';
21 0           $self->{'callbacks'} = {};
22 0           $self->{'oneliners'} = [],
23             bless ($self, $class);
24 0           return $self;
25             }
26              
27             sub callbacks {
28 0     0 1   my $hlt = shift;
29 0 0         if (@_) { $hlt->{'callbacks'} = shift; };
  0            
30 0           return $hlt->{'callbacks'};
31             }
32              
33             sub highlight {
34 0     0 1   my ($hlt, $text) = @_;
35 0           $hlt->snippetParse;
36 0           my $out = $hlt->out;
37 0           @$out = ();
38 0           while ($text) {
39             # print "highlighting '$text'\n";
40             # print "mode is", $hlt->stackTop, "\n";
41 0           my $sub = $hlt->callbacks->{$hlt->stackTop};
42 0           $text = &$sub($hlt, $text);
43             }
44 0           $hlt->snippetParse;
45 0           return @$out;
46             }
47              
48             sub lists {
49 0     0 1   my $hlt = shift;
50 0 0         if (@_) { $hlt->{'lists'} = shift; };
  0            
51 0           return $hlt->{'lists'};
52             }
53              
54             sub listAdd {
55 0     0 1   my $hlt = shift;
56 0           my $listname = shift;
57             # print "listname $listname\n";
58 0           my $lst = $hlt->lists;
59 0 0         if (@_) {
60 0           $lst->{$listname} = [@_];
61             } else {
62 0           $lst->{$listname} = [];
63             }
64 0           my $r = $hlt->lists->{$listname};
65             # print "added tokens\n"; foreach my $f (@$r) { print " $f\n"; };
66             }
67              
68             sub rules {
69 0     0 1   my $hlt = shift;
70 0 0         if (@_) { $hlt->{'rules'} = shift; }
  0            
71 0           return $hlt->{'rules'};
72             }
73              
74             sub out {
75 0     0 1   my $hlt = shift;
76 0 0         if (@_) { $hlt->{'out'} = shift; }
  0            
77 0           return $hlt->{'out'};
78             }
79              
80             sub parserError {
81 0     0 1   my ($hlt, $text) = @_;
82 0           my $s = $hlt->stack;
83 0 0         if (@$s eq 1) { #we cannot dump this mode because it's the lowest.
84 0           warn "Parser error\n\tmode: '" . $hlt->stackTop . "'\n" .
85             "text: '$text'\nparsing as plain text";
86 0           $hlt->snippetParse($text);
87 0           $text =''; #Let's call it a day;
88             } else {
89 0           warn "Parser error\n\tmode: '" . $hlt->stackTop . "'\n" .
90             "text: '$text'\nexiting mode";
91 0           $hlt->stackPull;
92             };
93 0           return $text;
94             }
95              
96             sub snippet {
97 0     0 0   my $hlt = shift;
98 0 0         if (@_) { $hlt->{'snippet'} = shift; }
  0            
99 0           return $hlt->{'snippet'};
100             }
101              
102             sub snippetAppend {
103 0     0 1   my ($hlt, $ch) = @_;
104 0           $hlt->{'snippet'} = $hlt->{'snippet'} . $ch;
105             }
106              
107             sub snippetParse {
108 0     0 1   my $hlt = shift;
109 0           my $snip = shift;
110 0           my $attr = shift;
111 0 0         unless (defined($snip)) { $snip = $hlt->snippet }
  0            
112 0 0         unless (defined($attr)) { $attr = $hlt->stackTop }
  0            
113 0           my $out = $hlt->{'out'};
114             # print "parsing '$snip' with attribute '$attr'\n";
115 0 0         if ($snip) {
116 0           push(@$out, length($snip), $attr);
117 0           $hlt->snippet('');
118             }
119             }
120              
121             sub stack {
122 0     0 1   my $hlt = shift;
123 0           return $hlt->{'stack'};
124             }
125              
126             sub stackPush {
127 0     0 1   my ($hlt, $val) = @_;
128             # print "pushing $val\n";
129 0           my $stack = $hlt->stack;
130 0           unshift(@$stack, $val);
131             }
132              
133             sub stackPull {
134 0     0 1   my ($hlt, $val) = @_;
135 0           my $stack = $hlt->stack;
136 0           return shift(@$stack);
137             }
138              
139             sub stackTop {
140 0     0 1   my $hlt = shift;
141 0           return $hlt->stack->[0];
142             }
143              
144             sub stateCompare {
145 0     0 1   my ($hlt, $state) = @_;
146 0           my $h = [ $hlt->stateGet ];
147 0           my $equal = 1;
148 0 0         if (Dumper($h) ne Dumper($state)) { $equal = 0 };
  0            
149 0           return $equal;
150             }
151              
152             sub stateGet {
153 0     0 1   my $hlt = shift;
154 0           my $s = $hlt->stack;
155 0           return @$s;
156             }
157              
158             sub stateSet {
159 0     0 1   my $hlt = shift;
160 0           my $s = $hlt->stack;
161 0           @$s = (@_);
162             }
163              
164             sub syntax {
165 0     0 0   my $hlt = shift;
166 0           my $class = ref $hlt;
167 0           $class =~ /Tk::TextHighlight::(.*)/;
168 0           return $1;
169             }
170              
171             sub tokenParse {
172 0     0 1   my $hlt = shift;
173 0           my $tkn = shift;
174 0           $hlt->stackPush($tkn);
175 0           $hlt->snippetParse(@_);
176 0           $hlt->stackPull;
177             }
178              
179             sub tokenTest {
180 0     0 1   my ($hlt, $test, $list) = @_;
181             # print "tokenTest $test\n";
182 0           my $l = $hlt->lists->{$list};
183 0           my @list = reverse sort @$l;
184             # return grep { ($test =~ /^$_/) } @$l;
185 0           my @rl = grep { (substr($test, 0, length($_)) eq $_) } @list;
  0            
186             # foreach my $r (@rl) { print "$r\n" }
187 0 0         if (@rl) {
188 0           return $rl[0]
189             } else {
190 0           return undef;
191             }
192             }
193             1;
194              
195             __END__