view release on metacpan or  search on metacpan

lib/Tk/TextHighlight/RulesEditor.pm  view on Meta::CPAN

{
	package Tk::TextHighlight::TBrowseEntry;
	use base qw(Tk::Derived Tk::BrowseEntry);
	Construct Tk::Widget 'TBrowseEntry';
	sub LabEntryWidget { "Entry" }
	sub Populate {
		my ($cw, $args) = @_;
		my $sub = $args->{'-browsecmd'};
		unless(defined($sub)) { $sub = {}};
		$cw->SUPER::Populate($args);
		$cw->Subwidget('entry')->bind('<Return>', $sub);
		$cw->Subwidget('entry')->bind('<FocusOut>', $sub);
		$cw->ConfigSpecs(
			-background => ['SELF', 'DESCENDANTS'],
			DEFAULT => [$cw->Subwidget('entry')],
		);
	}
}

{
	package Tk::TextHighlight::OptionLine;

	use base qw(Tk::Derived Tk::Frame);
	
	use strict;

	Construct Tk::Widget 'OptionLine';

	sub Populate {
   	my ($cw,$args) = @_;

	   $cw->SUPER::Populate($args);
	   
	   my @padding = (
	   	-padx => 2,
	   	-pady => 2,
	   );

		my $b = $cw->Checkbutton(
			-anchor => 'w',
			-width => 10,
			-onvalue => 1,
			-offvalue => 0,
			-command => sub { $cw->togglestate },
		)->pack(@padding,
			-side => 'left',
		);
		$cw->Advertise('status' => $b);
		my $f = $cw->Frame(
		)->pack(@padding,
			-side => 'left',
			-fill => 'both',
			-expand => 1,
			-padx => 2,
			-pady => 2,
		);
		$cw->Advertise('fields' => $f);

		$cw->ConfigSpecs(
			-background => ['SELF', 'DESCENDANTS'],
			-borderwidth => [$cw, $f],
			-command => ['PASSIVE', undef, undef, sub {}],
			-relief => [$cw, $f],
			-text => [$b],
			-variable => [$b],
			DEFAULT => [$cw],
		);
		$cw->togglestate;
	}
	
	sub togglestate {
		my $cw = shift;
		my $v = $cw->Subwidget('status')->cget('-variable');
		my $dv = $$v;
		if ($dv) { 
			$cw->setstate('normal'); 
		} else {
			$cw->setstate('disabled');
		}
	}
	
	sub setstate {
		my ($cw, $state) = @_;
		my @w = $cw->Subwidget('fields')->children;
		foreach my $c (@w) {
			$c->configure(-state => $state);
		}
	}

}#end of package OptionLine

{
	package Tk::TextHighlight::OptionColor;

	use base qw(Tk::Derived Tk::TextHighlight::OptionLine);
	
	use strict;

	Construct Tk::Widget 'OptionColor';

	sub Populate {
   	my ($cw,$args) = @_;

	   $cw->SUPER::Populate($args);
	   
	   my @padding = (
	   	-padx => 2,
	   	-pady => 2,
	   );
		my $f = $cw->Subwidget('fields');
		my $value = '';
		my $v = $f->Entry(
			-textvariable => \$value,
			-width => 20,
		)->pack(@padding,
			-side => 'left',
			-expand => 1,
			-fill => 'x',
		);
		my $cmd = sub {
			my $c = $cw->cget('-command');
			&$c;
		};
		$v->bind('<Return>', $cmd);
		$v->bind('<FocusOut>', $cmd);
		$f->Button(
			-bitmap => '@' . Tk->findINC('cbxarrow.xbm'),
			-command => sub {
				if (my $c = $cw->chooseColor(-initialcolor => $value)) {
					$cw->content($c);
				}
			}
		)->pack(@padding,
			-side => 'left'
		)->pack(@padding,
			-side => 'left',
		);

		$cw->ConfigSpecs(
			-textvariable => ['PASSIVE', undef, undef, \$value],
			-background => ['SELF', 'DESCENDANTS'],
			DEFAULT => [$cw],
		);
	}
	
	sub content {
		my $cw = shift;
		my $v = $cw->cget('-textvariable');
		if (@_) { 
			$$v = shift;
			my $cmd = $cw->cget('-command');
			if (defined($cmd)) {
				&$cmd($$v);
			}
		}
		return $$v;
	}

}#end of package OptionColor

{
	package Tk::TextHighlight::OptionFont;

	use base qw(Tk::Derived Tk::TextHighlight::OptionLine);
	
	use strict;

	Construct Tk::Widget 'OptionFont';

	sub Populate {
   	my ($cw,$args) = @_;

	   $cw->SUPER::Populate($args);
	   
	   my @padding = (
	   	-padx => 2,
	   	-pady => 2,
	   );
		my $f = $cw->Subwidget('fields');
		my $family = '';
		my $size = '10';
		my $weight = 'normal';
		my $slant = 'roman';
		my @fonts = sort $cw->fontFamilies;
		my $cmd = sub {
			my $c = $cw->cget('-command');
			&$c;
		};
		my $v = $f->TBrowseEntry(
			-browsecmd => $cmd,
			-variable => \$family,
			-width => 20,
			-choices => [ @fonts ],
		)->pack(
			-side => 'left',
			-expand => 1,
			-fill => 'x',
		);
		my @sizes = qw(0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
			23 24 25 26 27 28 29 30 33 34 36 40 44 48 50 56 64 72);
		$f->TBrowseEntry(
			-browsecmd => $cmd,
			-variable => \$size,
			-listwidth => 20,
			-width => 3,
			-choices => \@sizes,
		)->pack(#@padding,
			-side => 'left',
		);
		$f->Checkbutton(
			-command => $cmd,
			-variable => \$weight,
			-text => 'Bold',
			-onvalue => 'bold',
			-offvalue => 'normal',
		)->pack(#@padding,
			-side => 'left',
		);
		$f->Checkbutton(
			-variable => \$slant,
			-command => $cmd,
			-text => 'Italic',
			-onvalue => 'italic',
			-offvalue => 'roman',
		)->pack(#@padding,
			-side => 'left',
		);

		$cw->ConfigSpecs(
			-background => ['SELF', 'DESCENDANTS'],
			-familyvar => ['PASSIVE', undef, undef, \$family],
			-sizevar => ['PASSIVE', undef, undef, \$size],
			-slantvar => ['PASSIVE', undef, undef, \$slant],
			-weightvar => ['PASSIVE', undef, undef, \$weight],
			DEFAULT => [$cw],
		);
	}
	
	sub content {
		my $cw = shift;
		my %t = (
			'-family' => '-familyvar',
			'-size' => '-sizevar',
			'-slant' => '-slantvar',
			'-weight' => '-weightvar',
		);
		if (@_) {
			my $o = shift;
			my %args = (@$o);
			foreach my $k (keys %args) {
				my $op = $t{$k};
				my $v = $cw->cget($op);
				$$v  = $args{$k}
			}
			my $cmd = $cw->cget('-command');
			if (defined($cmd)) {
				&$cmd($o);
			}
		}
		my @res = ();
		foreach my $k (keys %t) {
			my $v = $cw->cget($t{$k});
			push @res, $k, $$v;
		};
		return \@res;
	}
	

}#end of package OptionFont

package Tk::TextHighlight::RulesEditor;

use strict;
use base qw(Tk::Derived Tk::Toplevel);

Construct Tk::Widget 'RulesEditor';

use File::Basename;

require Tk::HList;
require Tk::Adjuster;

sub Populate {
	my ($cw,$args) = @_;
	
	my $widget = delete $args->{'-widget'};
	unless (defined($widget)) {
		$widget = $cw->parent;
	}
	$args->{'-title'} = $widget->cget('-syntax') . ' - Rules editor';
   $cw->SUPER::Populate($args);
	my @padding = (
		-padx => 2,
		-pady => 2,
	);
	my $synfr = $cw->Frame(
		-relief => 'groove',
		-borderwidth => 2,
	)->pack(@padding,
		-side => 'bottom',
		-fill => 'x',
	);
	$synfr->Button(
		-text => 'Close',
		-command => sub { $cw->destroy },
	)->pack(@padding,
		-side => 'right',
	);
	$synfr->Button(
		-text => 'Apply',
		-command => sub { $cw->apply }
	)->pack(@padding,
		-side => 'right',
	);
		
	my $tagfr = $cw->LabFrame(
		-label => 'Tag names',
		-labelside => 'acrosstop',
	)->pack(
		-side => 'left', 
		-fill => 'both',
	);
	my $taglist = $tagfr->Scrolled('HList',
		-browsecmd => sub { $cw->entryOpen(shift) },
		-columns => 1,
		-scrollbars => 'osoe',
	)->pack(@padding,
		-expand => 1,
		-fill => 'both',
	);
	my $rules = $widget->cget('-rules');
	unless (defined($rules)) {
		$rules = $widget->highlightPlug->rules;
	}