#!/usr/local/bin/perl5
#
#  Prototype Mask for Win32::GUI
#

require "usage.pl";

use Win32::GUI;

MAIN: {
#print "ARGV: ",join("~",@ARGV),"\n"; exit;
	&setup;
#	print "d=$debug\n"; exit;
	&process;
	&wrapup;
}


#-----
# Setup
#
# Process command line options and set globals
#



sub setup {
	$|=1;

	&get_options;
}


sub get_options {
  @usage_tab = (
	#opt	arg		action			descrip
	#---	---		------			-------
	'H',	'',		'&usage(1)',	'Help with usage (print this summary)',
	'D',	'',		'$debug++',		'Debug mode',
	'V',	'',		'$verbose++',	'Verbose debug information',
	'Q',	'',		'$quiet++',		'Do not display progress indicators',
  );

	$usage_notes = <<EOM;

Prototype Mask for Win32::GUI
EOM

	&parseargs;
}


#-----
# Wrapup
#

sub wrapup {
}


#-----
# Process
#



sub process {
	my $file = shift(@ARGV);

	$oForm = MaskForm->new($file);
	$oForm->print_mask  if $debug;

	# line height and character dimensions
	my ($LH, $OCW, $OCH) = &char_dims;
	$oForm->set_char_width($OCW);
	$oForm->set_char_height($OCH);
	$oForm->set_line_height($LH);

	$oForm->build_form;
	$oForm->print_form  if $debug;

	$oForm->show;
}


sub char_dims {
	my $dummyWin = new Win32::GUI::Window(
		-left => 100,
		-top => 100,
		-width => 400,
		-height => 400,
		-title => "dummy",
		-name => "Window",
	);

	my ($cw, $ch) = $dummyWin->GetTextExtentPoint32("_");
	# $ch = $ch*1.2;
	my $lh = $ch*1.5;
	print "Onechar = ($cw x $ch), LineHeight=$lh\n"  if $debug;

	return ($lh, $cw, $ch);
}


#=====
# Perl5 Module
#
# MaskForm: Prototype Mask form for Win32::GUI
#

package MaskForm;


# Name of package for debugging messages
BEGIN { $ME = 'MaskForm'; }


# Methods

sub new {
	my $package = shift;
#	print STDERR "trace <$ME>::new($package, @_)\n";

	my $this = bless {}, $package;

	$this->init(@_)  if $#_ >= 0;

	return $this;
}


sub init {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::init($this, @_)\n";

	# clear object
	%$this = ();

	# usage:
	#	init(filename)
	#	init(\$filename)
	#	init(@mask_lines)
	#	init(\@mask_lines)
	#	init(\%mask_definition)
	if ( $#_ == 0 ) {
		# single parameter
		# can be file name or ref to file name or list or hash
		my $arg = shift;
		my $reftype = ref($arg);
		if ( $reftype == 0 ) {
			# not a reference, must be a file name
			$this->def_file($arg);
		} elsif ( $reftype eq "SCALAR" ) {
			# reference to a scalar, use as file name
			$this->def_file($$arg);
		} elsif ( $reftype eq "ARRAY" ) {
			$this->def_list(@$arg);
		} elsif ( $reftype eq "HASH" ) {
			%$this = %$arg;
		}
	} elsif ( $#_ > 0 ) {
		$this->def_list(@_);
	}
}


sub set_form_ready {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_form_ready($this, @_)\n";

	$this->{form_ready} = shift;
}

sub get_form_ready {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_form_ready($this, @_)\n";

	return $this->{form_ready};
}


sub set_char_width {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_char_width($this, @_)\n";

	$this->{char_width} = shift;
}

sub get_char_width {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_char_width($this, @_)\n";

	return $this->{char_width};
}


sub set_char_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_char_height($this, @_)\n";

	$this->{char_height} = shift;
}

sub get_char_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_char_height($this, @_)\n";

	return $this->{char_height};
}


sub set_line_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_line_height($this, @_)\n";

	$this->{line_height} = shift;
}

sub get_line_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_line_height($this, @_)\n";

	return $this->{line_height};
}


sub set_form_width {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_form_width($this, @_)\n";

	$this->{form_width} = shift;
}

sub get_form_width {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_form_width($this, @_)\n";

	return $this->{form_width};
}


sub set_form_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_form_height($this, @_)\n";

	$this->{form_height} = shift;
}

sub get_form_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_form_height($this, @_)\n";

	return $this->{form_height};
}


sub set_mask {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_mask($this, @_)\n";

	$this->{mask} = shift;
}

sub get_mask {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_mask($this, @_)\n";

	return $this->{mask};
}


sub set_form {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_form($this, @_)\n";

	$this->{form} = shift;
}

sub get_form {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_form($this, @_)\n";

	return $this->{form};
}


sub set_field_names {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_field_names($this, @_)\n";

	$this->{field_names} = shift;
}

sub get_field_names {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_field_names($this, @_)\n";

	return $this->{field_names};
}

sub add_field_names {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::add_field_names($this, @_)\n";

	my( @new_names ) = @_;

	my(	$rnames,
	);

	$rnames = $this->get_field_names;

	unless ( ref($rnames) ) {
		$rnames = [];
		$this->set_field_names($rnames);
	}

	push(@$rnames, @new_names);
}


sub set_button_names {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_button_names($this, @_)\n";

	$this->{button_names} = shift;
}

sub get_button_names {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_button_names($this, @_)\n";

	return $this->{button_names};
}


sub add_button_names {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::add_button_names($this, @_)\n";

	my( @new_names ) = @_;

	my(	$rnames,
	);

	$rnames = $this->get_button_names;

	unless ( ref($rnames) ) {
		$rnames = [];
		$this->set_button_names($rnames);
	}

	push(@$rnames, @new_names);
}


sub set_window {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_window($this, @_)\n";

	$this->{window} = shift;
}

sub get_window {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_window($this, @_)\n";

	return $this->{window};
}


sub set_window_width {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_window_width($this, @_)\n";

	$this->{window_width} = shift;
}

sub get_window_width {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_window_width($this, @_)\n";

	return $this->{window_width};
}


sub set_window_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_window_height($this, @_)\n";

	$this->{window_height} = shift;
}

sub get_window_height {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_window_height($this, @_)\n";

	return $this->{window_height};
}


sub set_window_name {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_window_name($this, @_)\n";

	$_ = shift;
	$_ =~ s(^\s+)();
	$_ =~ s(\s+$)();

	$this->{window_name} = $_;
}

sub get_window_name {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_window_name($this, @_)\n";

	return $this->{window_name};
}


sub set_window_title {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_window_title($this, @_)\n";

	$_ = shift;
	$_ =~ s(^\s+)();
	$_ =~ s(\s+$)();

	$this->{window_title} = $_;
}

sub get_window_title {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_window_title($this, @_)\n";

	return $this->{window_title};
}


sub set_first_field {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_first_field($this, @_)\n";

	$this->{first_field} = shift;
}

sub get_first_field {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_first_field($this, @_)\n";

	return $this->{first_field};
}


sub set_button_action {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::set_button_action($this, @_)\n";

	$_ = shift;
	$_ =~ s(^\s+)();
	$_ =~ s(\s+$)();
	my $button = $_;
	my @action = @_;

#	unshift(@action, 'print STDERR ">>BA:'.$button.': W=WIN, ",join("~", @_),"\n"');

	grep($_ =~ s(\bWIN\b)(\$main::rWIN)g, @action);

	$this->{button_action}->{$button} = \@action;
}

sub get_button_action {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::get_button_action($this, @_)\n";

	my $button = shift;

	return $this->{button_action}->{$button};
}

sub create_buttons_action {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::create_buttons_action($this, @_)\n";

	my $ractions = $this->{button_action};

	return  unless ref($ractions);

	foreach my $button ( keys(%$ractions) ) {
		@_ = @{$ractions->{$button}};
		$_ = "\tsub main::${button}_Click { ". join(";\n\t", @_).";\n\t}";
#		print STDERR "Create action: $button\n\t$_\n";
		eval($_);
		die "ERROR in Button action for '$button':\n>> ".$!." <<\n$_\n"  if $!;
	}
}


sub def_file {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::def_file($this, @_)\n";

	my($filename) = @_;

	open(INP, $filename) || die "ERROR: Could not open '$filename', stopped";
	my @list = <INP>;
	close(INP);

	$this->def_list(@list);
}


sub def_list {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::def_list($this, @_)\n";

	my @list = @_;

	grep(chomp($_), @list);

	$this->set_mask(\@list)
}


sub build_form {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::build_form($this, @_)\n";

	my(	@mask, $mindex, $mline, $state, $name,
		@form, $formrow, $formwidth,
	);

	$_ = $this->get_mask;
	return  if !defined($_) || !ref($_);
	@mask = @$_;

	$this->set_window_name("MaskForm");
	$this->set_window_title("MaskForm");

	# start at top
	$formrow = 0;

	# haven't measured anything
	$formwidth = 0;

	# outside mask
	$state = 0;

	for ( $mindex = 0; $mindex <= $#mask; $mindex++ ) {
		$mline = $mask[$mindex];
		if ( $mline =~ m(^\s*#.*$) ) {
			# comment line
			# ignore
		} elsif ( $mline =~ m(^\s*\[BEGIN\]\s*$)i ) {
			$state = 1;								# entering mask
		} elsif ( $mline =~ m(^\s*\[END\]\s*$)i ) {
			$state = 0;								# exiting mask
		} elsif ( $mline =~ m(^\s*\[\s*Button\s*:\s*([^\]]+)\s*\]\s*$)i ) {
			$name = $1;
			die "ERROR: Mask syntax: Button action inside mask definition at line #".(1+$mindex).": '$mline' \n"
				if $state == 1;
			# find end of definition
			# (next section or EOF)
			$_ = $mindex;
			while ( $_ <= $#mask && $mask[++$_] !~ m(^\s*\[) ) {
			}
			$this->set_button_action($name, @mask[($mindex+1)..($_-1)]);
		} elsif ( $state == 1 ) {
			# processing mask
			unless ( $mline =~ m(^\s*$) ) {			# empty lines just affect position
				# check for widest line
				$formwidth = length($mline)  if length($mline) > $formwidth;
				# process mask line
				$_ = $this->build_line($mline, $formrow);
				push(@form, @$_);
			}
			$formrow++;
		} else {
			# not in mask
			if ( $mline =~ m(^\s*name\s*=\s*(.*))i ) {
				$this->set_window_name($1);
			} elsif ( $mline =~ m(^\s*title\s*=\s*(.*))i ) {
				$this->set_window_title($1);
			} elsif ( $mline =~ m(^\s*fields?\s*=\s*(.*))i ) {
				@_ = split("[ \t,]+",$1);
				$this->add_field_names(@_)  if $#_ ge 0;
			} elsif ( $mline =~ m(^\s*buttons?\s*=\s*(.*))i ) {
				@_ = split("[ \t,]+",$1);
				$this->add_button_names(@_)  if $#_ ge 0;
			}

			# ignore line
		}
	}

	$this->set_form(\@form);
	$this->set_form_width($formwidth);
	$this->set_form_height($formrow);
}


sub build_line {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::build_line($this, @_)\n";

	my(	$mline, $formrow ) = @_;

	my(	$original,
		@formline, $formcol,
		$part, $partsize,
		$curlyleft, $curlyright,
	);

	$curlyleft = "{";		# } keep editors happy {
	$curlyright= "}";

	$original = $mline;

	# remove trailing spaces
	$mline =~ s( +$)();

	while ( length($mline) ) {
		$formcol += $partsize;
		if ( $mline =~ s(^ +)() ) {
			# spaces: move to the right
			$partsize = length($&);
		} elsif ( $mline =~ s(^[^_$curlyleft]+)() ) {
			# label
			$part = $&;
			# include trailing spaces in moving to the right
			$partsize = length($&);
			# remove trailing spaces
			$part =~ s( +$)();
			# add label
			push(@formline, [ 1, $formrow, $formcol, length($part), $part ])
		} elsif ( $mline =~ s(_+)() ) {
			# field
			$partsize = length($&);
			push(@formline, [ 2, $formrow, $formcol, $partsize, "" ])
		} elsif ( $mline =~ s(^$curlyleft([^$curlyright]+)$curlyright)() ) {
			# button
			$part = $1;
			# allow leading/trailing spaces to affect width
			# include the curlies in the width
			$partsize = length($part)+2;
			# remove leading and trailing spaces
			$part =~ s(^ +)();
			$part =~ s( +$)();
			push(@formline, [ 3, $formrow, $formcol, $partsize, $part ]);
		} else {
			# unknown
			die "ERROR: Mask line '$original' had unexpected pattern (part='$part', rest='$mline', col=$formcol), stopped ";
		}
	}

	return \@formline;
}


sub print_mask {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::print_mask($this, @_)\n";

	my(	@mask,
	);

	$_ = $this->get_mask;
	return  if !defined($_) || !ref($_);
	@mask = @$_;

	print "Mask:\n",
		  "vvvvv\n",
			join("\n", @mask), "\n",
		  "^^^^^\n";
}


sub print_form {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::print_form($this, @_)\n";

	my(	@form, @findex, $fw, $fh,
		@fitem,
		@type, @fld, @btn,
		$fldnum, $btnnum,
	);

	$_ = $this->get_form;
	return if !defined($_) || !ref($_);
	@form = @$_;

	$fw = $this->get_form_width;
	$fh = $this->get_form_height;

	@type = ( "???", "Label", "Text", "Button" );

	$_ = $this->get_field_names;
	@fld = @$_  if ref($_);

	$_ = $this->get_button_names;
	@btn = @$_  if ref($_);

	print "Form:  $fw columns by $fh rows\n",
		  "vvvvv\n";
	for ( $findex = 0; $findex <= $#form; $findex++ ) {
		$_ = $form[$findex];
		die "ERROR: Form list contains a non-reference '$_' at position $findex, stopped "
			unless ref($_);
		@fitem = @$_;
		$_ = $fitem[0];
		printf("%-8s at %4d,%4d: %s\n", $type[$_], $fitem[2], $fitem[1],
			$_ == 1
			? "'$fitem[4]'"
			: $_ == 2
			  ? "$fitem[3] wide, Field: ".$fld[$fldnum++]
			  : "'$fitem[4]', $fitem[3] wide, Button: ".$btn[$btnnum++]
			);
	}
	print "^^^^^\n";
}


sub build_window {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::build_window($this, @_)\n";

	my(	$rwin, $ww, $wh,
		@form, @findex, @fitem, $type, $name,
		@fld, @btn,
		$lblnum, $fldnum, $btnnum, $unknum,
	);

	$_ = $this->get_form;
	return if !defined($_) || !ref($_);
	@form = @$_;

	$ww = $this->get_form_width * ( $this->get_char_width + 2 );
	$wh = $this->get_form_height * ( $this->get_line_height + 4);

	$this->set_window_width($ww);
	$this->set_window_height($wh);

	$_ = $this->get_field_names;
	@fld = @$_  if ref($_);

	$_ = $this->get_button_names;
	@btn = @$_  if ref($_);

	$name = $this->get_window_name;
	$type = $this->get_window_title;

	$rwin = new Win32::GUI::Window(
#	$rwin = new Win32::GUI::DialogBox(
		-name => $name,
		-text => $title,
		-top => 100,
		-left => 100,
		-width => $ww,
		-height => $wh,
#		-font => $Font,
	);
	die "ERROR: Could not create window, stopped "  unless ref($rwin);

	$this->set_window($rwin);

	for ( $findex = 0; $findex <= $#form; $findex++ ) {
		$_ = $form[$findex];
		die "ERROR: Form list contains a non-reference '$_' at position $findex, stopped "
			unless ref($_);
		@fitem = @$_;
		$type = $fitem[0];
		$name = $type == 1
				? ( "label".(1+$lblnum++) )
				: $type == 2
				? ( $fld[$fldnum++] || ( "Field".(1+$lblnum++) ) )
				: $type == 3
				? ( $btn[$btnnum++] || ( "Button".(1+$btnnum++) ) )
				: ( "Unknown".(1+$unknum++) );
		$this->add_widget($rwin, @fitem, $name);
	}

	$this->set_first_field($rwin->{$fld[0]});
	$this->set_form_ready(1);

	return $rwin;
}


sub add_widget {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::add_widget($this, @_)\n";

	my(	$rwin, $type, $top, $left, $width, $caption, $name ) = @_;

	my(	@settings, $height,
	);

	$width = length($caption)+($type==3?2:0)  if $width < length($caption);

	$top *= $this->get_line_height - 2;
	$_ = $this->get_char_width;
	$left  *= $_;
	$width *= $_;
	$height = $this->get_char_height + 4;

	@settings = (
		-name	=> $name,
		-text   => $caption,
		-top    => $top,
		-left   => $left,
		-width  => $width,
		-height => $height,
		-tabstop => ($type==1?0:1),
	);

#	print STDERR "Widget: $type - \n\t", join("~", @settings), "\n";

	if ( $type == 1 ) {
		$rwin->AddLabel(@settings);
	} elsif ( $type == 2 ) {
		$rwin->AddTextfield(@settings);
	} elsif ( $type == 3 ) {
		$rwin->AddButton(@settings);
	} else {
		die "ERROR: Unknow widget type '$type' (@_), stopped ";
	}
}


sub show {
	my $this = shift;
#	print STDERR "trace <$ME>",ref($this),"::show($this, @_)\n";

	my(	$rwin,
	);

	$this->build_window  unless $this->get_form_ready;

	$rwin = $this->get_window;
	return  unless ref($rwin);


 if ( 0 ) {
	my $ww = $rwin->{width};
	my $wh = $rwin->{height};

	while($rwin->ScaleWidth < $ww) {
		$rwin->Width($rwin->Width+1);
	}

	while($rwin->ScaleHeight < $wh) {
		$rwin->Height($rwin->Height+1);
	}
 }

	my $wname = $this->get_window_name;
	$_ = undef;
#	$_ = 'print STDERR ">>Terminate: W=$main::rWIN, ",join("~", @_),"\n";';
	$_ = "sub main::${wname}_Terminate { $_ return -1; }";
#	print STDERR "T: $_\n";
	eval($_);
	die "ERROR in Terminate for '$wname':\n>> ".$!." <<\n$_\n"  if $!;
	$this->create_buttons_action;
	local($main::rWIN) = $rwin;

#	print STDERR "show time...\n";
	$rwin->Show();
	$this->get_first_field->SetFocus;
	my $result = Win32::GUI::Dialog();
#	print STDERR "...exit with value $ww\n";

	return $result;
}



#====================================================================================x=============================
1;