=pod

=head1 ctkDlgGetCode

	Set up a TextEdit widget and some buttons to enter perl code for
	callbacks, methods, POD section and general code.

	Global flag $main::editingCodeProperties keeps track of open instances
	It can be inspected to find out if an editing process is on work.

	Arguments

		-debug          debug mode (0 | 1),
		-code           code to be modified,
		-title          title of the Toplevel,
		-subTitle       title of the TextEdit widget,
		-editCode       identicfication code for the instance,
		-extract        ref to sub to extract subroutine or methods names,
		-assistentState flag that activates the assistent, may be one of (0,1).

=head2 Maintenance

		History 
			01.12.2007 first draft
			29.01.2008 version 1.03
			06.03.2008 version 1.04

=cut

package ctkDlgGetCode;

require Tk::Derived;
require Tk::Toplevel;

our  $VERSION = '1.05';

@ISA = (qw/Tk::Derived Tk::Toplevel/);

my $debug = 0;

my $assistent;

Construct Tk::Widget 'ctkDlgGetCode';

sub ClassInit {
	my ($class,$mw) = @_;
	my $rv;
	$rv = $class->SUPER::ClassInit($mw);
	return $rv;
}

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

	my $numberOfChangesAtInit = 0;
	my $dirtyFlag = 0;
	$debug = delete $args->{-debug} if (exists $args->{-debug});
	my $code = delete $args->{-code} if (exists $args->{-code});
	my $subTitle = delete $args->{-subtitle} if (exists $args->{-subtitle});
	my $editCode = delete $args->{-editcode} if (exists $args->{-editcode});
	my $extract = delete $args->{-extract} if (exists $args->{-extract});
	my $assistentState = delete $args->{-assistentState} if (exists $args->{-assistentState});
	$assistentState = 1 unless (defined $assistentState);
	$code = [] unless defined($code);

	$cw->SUPER::Populate($args);

## ctk: gcode

## ctk: gcode
## ctk: code generated by ctk_w version '2.018'
## ctk: lexically scoped variables for widgets

my $rW001 ;
my $rW004 ;
my $rW005 ;
my $rW002 ;
my $rW006 ;
my $rW009 ;
my $rW003 ;
my $rW010 ;
my $rW007 ;
my $rW008 ;

my $lChanged;
my $lMode ;
my $lLineCol;
my $lSize;
my $msg;

## ctk: instantiate and display widgets

$rW001 = $cw -> Frame ( -relief=>'solid' ) -> pack(-anchor=>'nw', -fill=>'both', -side=>'top', -expand=>1);
$rW004 = $rW001 -> Label ( -background=>'#e2e2e2', -justify=>'left', -relief=>'flat', -text=>$subTitle ) -> pack(-anchor=>'nw', -fill=>'x', -side=>'top', -expand=>1);
$rW005 = $rW001 -> Scrolled ( 'TextEdit',-background=>'#ffffff', -state=>'normal', -takefocus=>1, -relief=>'sunken', -scrollbars=>'osoe', -wrap=>'none',-font => 'C_normal' ) -> pack(-anchor=>'nw', -fill=>'both', -side=>'top', -expand=>1);
$rW002 = $cw -> Frame ( -borderwidth=>2, -relief=>'flat' ) -> pack(-anchor=>'nw', -fill=>'x', -side=>'top', -expand=>1);
$rW008 = $rW002 -> Button ( -background=>'#ffffff',
							-command=>sub {
										if (defined $assistent) {
											return undef if (Tk::Exists($assistent->_toplevel()))
										} else {}
										my @sel = $rW005->tagRanges('sel');
										my $insert = $rW005->index('insert');
										$assistent = ctkAssistent->new(-parent, $cw , -target , $rW005, -selection , \@sel, -insert , $insert);
										$assistent->Show();
										return 1
										},
							-state=> $assistentState ? 'normal':'disabled',
							-text=>'Assistent' ) -> pack(-anchor=>'nw', -fill=>'x', -side=>'left', -expand=>1);
$rW006 = $rW002 -> Button ( -background=>'#ffffff',
							-command=>sub {
										@$code = split("\n",$rW005->get('1.0','end'));
										&main::changes(1) if ($dirtyFlag); # can't store undo info so far!
										&$extract($code) if defined($extract);
										$numberOfChangesAtInit = $rW005->numberChanges();
										$main::editingCodeProperties -= $editCode if($main::editingCodeProperties & $editCode);
										},
							-state=> 'normal',
							-text=>'Save' ) -> pack(-anchor=>'nw', -fill=>'x', -side=>'left', -expand=>1);
$rW009 = $rW002 -> Button ( -background=>'#ffffff',
							-command=>sub {
								if ($dirtyFlag) {
									if (&std::askYN("Text has been changed, cancel anyway?")) {
										$cw->destroy();
										$main::editingCodeProperties -= $editCode if($main::editingCodeProperties & $editCode);
									}  ## else {}
								} else {
									$main::editingCodeProperties -= $editCode if($main::editingCodeProperties & $editCode);
									$cw->destroy();
								}
							},
							-state=>'normal',
							-text=>'Cancel', -relief=>'raised' ) -> pack(-anchor=>'nw', -fill=>'x', -side=>'left', -expand=>1);
$rW007 = $rW002 -> Button ( -background=>'#ffffff',
							-command=>sub{
										@$code = split("\n",$rW005->get('1.0','end'));
										$numberOfChangesAtInit = $rW005->numberChanges();
										&main::changes(1) if ($dirtyFlag); # can't store undo info so far!
										&$extract($code) if defined($extract);
										$main::editingCodeProperties -= $editCode if($main::editingCodeProperties & $editCode);
										$cw->destroy()
										},
							-state=>'normal',
							-relief=>'raised',
							-text=>'Ok' ) -> pack(-anchor=>'nw', -fill=>'x', -side=>'left', -expand=>1);
$rW003 = $cw -> Frame ( -borderwidth=>1, -relief=>'sunken' ) -> pack(-anchor=>'sw', -fill=>'x', -side=>'bottom', -expand=>1);
## ctk: end of gened Tk-code
map {
		$rW005->insert('end',"$_\n")
} @$code;

$numberOfChangesAtInit = $rW005->numberChanges();

$lChanged = $rW003->Label(-text => '  ',-relief => 'ridge' )->pack(-side => 'right',-anchor => 'se',-expand => 0,-fill => 'x');
$lMode = $rW003->Label(-text => '  ',-relief => 'ridge' )->pack(-side => 'right',-anchor => 'se',-expand => 0,-fill => 'x');
$lLineCol = $rW003->Label(-text => '  ',-relief => 'ridge' )->pack(-side => 'right',-anchor => 'se',-expand => 0,-fill => 'x');
$lSize = $rW003->Label(-text => '  ',-relief => 'ridge' )->pack(-side => 'right',-anchor => 'se',-expand => 0,-fill => 'x');
$msg = $rW003->Label(-text => 'Ready',-relief => 'ridge' )->pack(-side => 'right',-anchor => 'se',-expand => 1,-fill => 'x');

$rW005->menu()->entryconfigure(0,-state => 'disabled');

$rW005->SetGUICallbacks (
		[
		sub {
			$dirtyFlag = &main::edit_indicators($rW005,$lLineCol,$lSize,$lMode,$lChanged,$numberOfChangesAtInit,$editCode);
			$rW005->idletasks();
			$rW003->update()
			},
		sub{$rW005->HighlightAllPairsBracketingCursor}
		]
		);

return $cw
}

## -------------------

sub Trace { shift->trace(@_);}
sub trace {
	shift->log(@_) if ($debug);
}

sub Log { shift->log(@_)}
sub log {
	my $self = shift;
	map {print STDERR "\n$_"} @_;
}

1;
__END__
