File Coverage

blib/lib/Tk/RulesEditor.pm
Criterion Covered Total %
statement 3 3 100.0
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 4 4 100.0


line stmt bran cond sub pod time code
1             {
2             package Tk::TBrowseEntry;
3 1     1   20711 use base qw(Tk::Derived Tk::BrowseEntry);
  1         3  
  1         925  
4             Construct Tk::Widget 'TBrowseEntry';
5             sub LabEntryWidget { "Entry" }
6             sub Populate {
7             my ($cw, $args) = @_;
8             my $sub = $args->{'-browsecmd'};
9             unless(defined($sub)) { $sub = {}};
10             $cw->SUPER::Populate($args);
11             $cw->Subwidget('entry')->bind('', $sub);
12             $cw->Subwidget('entry')->bind('', $sub);
13             $cw->ConfigSpecs(
14             -background => ['SELF', 'DESCENDANTS'],
15             DEFAULT => [$cw->Subwidget('entry')],
16             );
17             }
18             }
19              
20             {
21             package Tk::OptionLine;
22              
23             use base qw(Tk::Derived Tk::Frame);
24            
25             use strict;
26              
27             Construct Tk::Widget 'OptionLine';
28              
29             sub Populate {
30             my ($cw,$args) = @_;
31              
32             $cw->SUPER::Populate($args);
33            
34             my @padding = (
35             -padx => 2,
36             -pady => 2,
37             );
38              
39             my $b = $cw->Checkbutton(
40             -anchor => 'w',
41             -width => 10,
42             -onvalue => 1,
43             -offvalue => 0,
44             -command => sub { $cw->togglestate },
45             )->pack(@padding,
46             -side => 'left',
47             );
48             $cw->Advertise('status' => $b);
49             my $f = $cw->Frame(
50             )->pack(@padding,
51             -side => 'left',
52             -fill => 'both',
53             -expand => 1,
54             -padx => 2,
55             -pady => 2,
56             );
57             $cw->Advertise('fields' => $f);
58              
59             $cw->ConfigSpecs(
60             -background => ['SELF', 'DESCENDANTS'],
61             -borderwidth => [$cw, $f],
62             -command => ['PASSIVE', undef, undef, sub {}],
63             -relief => [$cw, $f],
64             -text => [$b],
65             -variable => [$b],
66             DEFAULT => [$cw],
67             );
68             $cw->togglestate;
69             }
70            
71             sub togglestate {
72             my $cw = shift;
73             my $v = $cw->Subwidget('status')->cget('-variable');
74             my $dv = $$v;
75             if ($dv) {
76             $cw->setstate('normal');
77             } else {
78             $cw->setstate('disabled');
79             }
80             }
81            
82             sub setstate {
83             my ($cw, $state) = @_;
84             my @w = $cw->Subwidget('fields')->children;
85             foreach my $c (@w) {
86             $c->configure(-state => $state);
87             }
88             }
89              
90             }#end of package OptionLine
91              
92             {
93             package Tk::OptionColor;
94              
95             use base qw(Tk::Derived Tk::OptionLine);
96            
97             use strict;
98              
99             Construct Tk::Widget 'OptionColor';
100              
101             sub Populate {
102             my ($cw,$args) = @_;
103              
104             $cw->SUPER::Populate($args);
105            
106             my @padding = (
107             -padx => 2,
108             -pady => 2,
109             );
110             my $f = $cw->Subwidget('fields');
111             my $value = '';
112             my $v = $f->Entry(
113             -textvariable => \$value,
114             -width => 20,
115             )->pack(@padding,
116             -side => 'left',
117             -expand => 1,
118             -fill => 'x',
119             );
120             my $cmd = sub {
121             my $c = $cw->cget('-command');
122             &$c;
123             };
124             $v->bind('', $cmd);
125             $v->bind('', $cmd);
126             $f->Button(
127             -bitmap => '@' . Tk->findINC('cbxarrow.xbm'),
128             -command => sub {
129             if (my $c = $cw->chooseColor(-initialcolor => $value)) {
130             $cw->content($c);
131             }
132             }
133             )->pack(@padding,
134             -side => 'left'
135             )->pack(@padding,
136             -side => 'left',
137             );
138              
139             $cw->ConfigSpecs(
140             -textvariable => ['PASSIVE', undef, undef, \$value],
141             -background => ['SELF', 'DESCENDANTS'],
142             DEFAULT => [$cw],
143             );
144             }
145            
146             sub content {
147             my $cw = shift;
148             my $v = $cw->cget('-textvariable');
149             if (@_) {
150             $$v = shift;
151             my $cmd = $cw->cget('-command');
152             if (defined($cmd)) {
153             &$cmd($$v);
154             }
155             }
156             return $$v;
157             }
158              
159             }#end of package OptionColor
160              
161             {
162             package Tk::OptionFont;
163              
164             use base qw(Tk::Derived Tk::OptionLine);
165            
166             use strict;
167              
168             Construct Tk::Widget 'OptionFont';
169              
170             sub Populate {
171             my ($cw,$args) = @_;
172              
173             $cw->SUPER::Populate($args);
174            
175             my @padding = (
176             -padx => 2,
177             -pady => 2,
178             );
179             my $f = $cw->Subwidget('fields');
180             my $family = '';
181             my $size = '10';
182             my $weight = 'normal';
183             my $slant = 'roman';
184             my @fonts = sort $cw->fontFamilies;
185             my $cmd = sub {
186             my $c = $cw->cget('-command');
187             &$c;
188             };
189             my $v = $f->TBrowseEntry(
190             -browsecmd => $cmd,
191             -variable => \$family,
192             -width => 20,
193             -choices => [ @fonts ],
194             )->pack(
195             -side => 'left',
196             -expand => 1,
197             -fill => 'x',
198             );
199             my @sizes = qw(0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
200             23 24 25 26 27 28 29 30 33 34 36 40 44 48 50 56 64 72);
201             $f->TBrowseEntry(
202             -browsecmd => $cmd,
203             -variable => \$size,
204             -listwidth => 20,
205             -width => 3,
206             -choices => \@sizes,
207             )->pack(#@padding,
208             -side => 'left',
209             );
210             $f->Checkbutton(
211             -command => $cmd,
212             -variable => \$weight,
213             -text => 'Bold',
214             -onvalue => 'bold',
215             -offvalue => 'normal',
216             )->pack(#@padding,
217             -side => 'left',
218             );
219             $f->Checkbutton(
220             -variable => \$slant,
221             -command => $cmd,
222             -text => 'Italic',
223             -onvalue => 'italic',
224             -offvalue => 'roman',
225             )->pack(#@padding,
226             -side => 'left',
227             );
228              
229             $cw->ConfigSpecs(
230             -background => ['SELF', 'DESCENDANTS'],
231             -familyvar => ['PASSIVE', undef, undef, \$family],
232             -sizevar => ['PASSIVE', undef, undef, \$size],
233             -slantvar => ['PASSIVE', undef, undef, \$slant],
234             -weightvar => ['PASSIVE', undef, undef, \$weight],
235             DEFAULT => [$cw],
236             );
237             }
238            
239             sub content {
240             my $cw = shift;
241             my %t = (
242             '-family' => '-familyvar',
243             '-size' => '-sizevar',
244             '-slant' => '-slantvar',
245             '-weight' => '-weightvar',
246             );
247             if (@_) {
248             my $o = shift;
249             my %args = (@$o);
250             foreach my $k (keys %args) {
251             my $op = $t{$k};
252             my $v = $cw->cget($op);
253             $$v = $args{$k}
254             }
255             my $cmd = $cw->cget('-command');
256             if (defined($cmd)) {
257             &$cmd($o);
258             }
259             }
260             my @res = ();
261             foreach my $k (keys %t) {
262             my $v = $cw->cget($t{$k});
263             push @res, $k, $$v;
264             };
265             return \@res;
266             }
267            
268              
269             }#end of package OptionFont
270              
271             package Tk::RulesEditor;
272              
273             use strict;
274             use base qw(Tk::Derived Tk::Toplevel);
275              
276             Construct Tk::Widget 'RulesEditor';
277              
278             use File::Basename;
279              
280             require Tk::HList;
281             require Tk::Adjuster;
282              
283             sub Populate {
284             my ($cw,$args) = @_;
285            
286             my $widget = delete $args->{'-widget'};
287             unless (defined($widget)) {
288             $widget = $cw->parent;
289             }
290             $args->{'-title'} = $widget->cget('-syntax') . ' - Rules editor';
291             $cw->SUPER::Populate($args);
292             my @padding = (
293             -padx => 2,
294             -pady => 2,
295             );
296             my $synfr = $cw->Frame(
297             -relief => 'groove',
298             -borderwidth => 2,
299             )->pack(@padding,
300             -side => 'bottom',
301             -fill => 'x',
302             );
303             $synfr->Button(
304             -text => 'Close',
305             -command => sub { $cw->destroy },
306             )->pack(@padding,
307             -side => 'right',
308             );
309             $synfr->Button(
310             -text => 'Apply',
311             -command => sub { $cw->apply }
312             )->pack(@padding,
313             -side => 'right',
314             );
315            
316             my $tagfr = $cw->LabFrame(
317             -label => 'Tag names',
318             -labelside => 'acrosstop',
319             )->pack(
320             -side => 'left',
321             -fill => 'both',
322             );
323             my $taglist = $tagfr->Scrolled('HList',
324             -browsecmd => sub { $cw->entryOpen(shift) },
325             -columns => 1,
326             -scrollbars => 'osoe',
327             )->pack(@padding,
328             -expand => 1,
329             -fill => 'both',
330             );
331             my $rules = $widget->cget('-rules');
332             unless (defined($rules)) {
333             $rules = $widget->highlightPlug->rules;
334             }
335             foreach my $rl (@$rules) {
336             my @r = @$rl;
337             my $tag = shift @r;
338             $taglist->add($tag,
339             -text => $tag,
340             -data => \@r,
341             );
342             }
343             my $oppn = $cw->LabFrame(
344             -label => 'Options',
345             -labelside => 'acrosstop',
346             )->pack(
347             -side => 'left',
348             -expand => 1,
349             -fill => 'both',
350             );
351             my $df = $oppn->Frame(
352             -borderwidth => 2,
353             -relief => 'groove',
354             )->pack(@padding,
355             -side => 'bottom',
356             -expand => 1,
357             -fill => 'both',
358             );
359             my $d = $df->Entry(
360             )->pack(@padding,
361             -expand => 1,
362             -fill => 'both'
363             );
364             $cw->Advertise('display' => $d);
365             my @fields = ('-foreground', '-background');
366              
367             my %flags = ();
368             foreach my $fld (@fields) {
369             my $flag = 0;
370             $flags{$fld} = \$flag,
371             my $b = $oppn->OptionColor(
372             -variable => \$flag,
373             -class => 'Frame',
374             -borderwidth => 2,
375             -relief => 'groove',
376             -command => sub {
377             $cw->entryOpen($cw->cget('-current'));
378             },
379             -text => $fld,
380             )->pack(@padding, -fill => 'x');
381             $b->togglestate;
382             $cw->Advertise($fld => $b);
383             }
384             my $fl = 0;
385             $flags{'-font'} = \$fl;
386             my $font = $oppn->OptionFont(
387             -variable => \$fl,
388             -class => 'Frame',
389             -borderwidth => 2,
390             -relief => 'groove',
391             -text => '-font',
392             -command => sub {
393             $cw->entryOpen($cw->cget('-current'));
394             },
395             )->pack(@padding, -fill => 'x');
396             $font->togglestate;
397             $cw->Advertise('-font' => $font);
398             $cw->ConfigSpecs(
399             -background => ['SELF', 'DESCENDANTS'],
400             -current => ['PASSIVE', undef, undef, ''],
401             -flags => ['PASSIVE', undef, undef, \%flags],
402             -widget => ['PASSIVE', undef, undef, $widget],
403             -sampletext => [{-text => $d}, 'sampletext', 'Sampletext', 'ABCDEFGHIJabcdefghij0123456789'],
404             DEFAULT => ['SELF'],
405             );
406             $cw->Delegates(
407             'DEFAULT' => $taglist,
408             );
409             }
410              
411             sub apply {
412             my $cw = shift;
413             my @tree = $cw->infoChildren;
414             my @res = ();
415             foreach my $c (@tree) {
416             my $d = $cw->entrycget($c, '-data');
417             push @res, [$c, @$d];
418             }
419             my $widget = $cw->cget('-widget');
420             $widget->configure(-rules => \@res);
421             $widget->rulesSave;
422             $widget->highlightPlug;
423             }
424              
425             sub entryClose {
426             my $cw = shift;
427             my $s = $cw->cget('-current');
428             if ($s) {
429             $cw->entrySync;
430             $cw->configure('-current' => '');
431             my @l = ('-foreground', '-background', '-font');
432             foreach my $o (@l) {
433             my $w = $cw->Subwidget($o);
434             my $flags = $cw->cget('-flags');
435             my $flag = $flags->{$o};
436             $$flag = 0;
437             my $widget = $cw->cget('-widget');
438             my $display = $cw->Subwidget('display');
439             if ($o eq '-font') {
440             my $font = $widget->cget('-font');
441             my $f = [
442             -family => $widget->fontActual($font, '-family'),
443             -size => abs($widget->fontActual($font, '-size')),
444             -weight => $widget->fontActual($font, '-weight'),
445             -slant => $widget->fontActual($font, '-slant'),
446             ];
447             $w->content($f);
448             $display->configure('-font' => $f);
449             } else {
450             my $c = $widget->cget($o);
451             $w->content($c);
452             $display->configure($o => $c);
453             }
454             $w->togglestate;
455             }
456             }
457             }
458              
459             sub entryOpen {
460             my ($cw, $entry) = @_;
461             $cw->entryClose;
462             if ($entry) {
463             my $data = $cw->entrycget($entry, '-data');
464             my %opt = (@$data);
465             foreach my $o (keys %opt) {
466             my $w = $cw->Subwidget($o);
467             my $flags = $cw->cget('-flags');
468             my $flag = $flags->{$o};
469             $$flag = 1;
470             $w->content($opt{$o});
471             $w->togglestate;
472             }
473             $cw->Subwidget('display')->configure(%opt);
474             $cw->configure('-current' => $entry);
475             }
476             }
477              
478             sub entrySync {
479             my $cw = shift;
480             my $c = $cw->cget('-current');
481             if ($c) {
482             my @l = ('-foreground', '-background', '-font');
483             my @data = ();
484             foreach my $i (@l) {
485             my $w = $cw->Subwidget($i);
486             my $flag = $w->cget('-variable');
487             my $f = $$flag;
488             if ($f) {
489             push @data, $i;
490             push @data, $w->content;
491             }
492             };
493             $cw->entryconfigure($c, -data => \@data);
494             }
495             }
496              
497             1;