#!/bin/sh -- # A comment mentioning perl, to prevent perl from looping. Indented to work with bash.
eval 'exec perl -S $0 ${1+"$@"}'
        if 0;

# Perl script to make a query GUI using tk/tcl (requires tk's "wish")
$version = "tkquery version 0.3 Copyright (c) 1994, 2001 by Karl J. Runge <runge\@karlrunge.com>\n";

chop ($program = `basename $0`);	# get name of this file

# Make Usage string:

$Usage=<<"EOQ"; 

$version
tkquery: Query user for button click response or text entry, then
         send response to standard output and terminate. (with option
         to stay active)

Usage: $program [-e -ed "LABEL::TEXT::WIDTH" ] [ -b -bd -be "LABEL::FLAG" ]
		 ... [ -b ... ] [-stayalive] [-d] [-t title] [-j <side>]
		[-f font]
                [-v] [-examples] [-h -help] [-nok -nocancel] [-m] "MESSAGE"

    -e 		entry  widget (one only) with label LABEL and initial text TEXT
    -b		button widget (any number)with label LABEL and stdout reply FLAG
    -t		window manager title		
    -be		button widget returns "FLAG"."contents of EntryBox"
    -nok	No "OK" button	 
    -nocancel	No "Cancel" button -no => both.
    -i "keysym:text"	bind keysym to insert "text" into entry.
    -m		Message at top (-m optional if this is last entry)
    -f <font>	font (possibly just a number) for message.
    -cr <str>	Prepend "str" to carriage return <cr> entry string.
    -j (left|center|right)	justification of message. whoops: (w|c|e)

    -d		debug mode

    -s <n>	sleep n seconds and go away
    -stayalive	only clicking a -bd button or -ed entry will terminate
    -warp	try to warp cursor into our window (needs xwit(1))
    -space	map the spacebar keypress to invoke the button the mouse is on.
    -pid	print the pid of the GUI process:  GUIPID:NNNNN

    -examples	print examples
    -h		print help   
    -v		print version information  

    When a button is pressed the contents of it''s corresponding FLAG
    is returned to the standard output of tkquery, which then exits.
    Default FLAG for OK button is 'OK' and for Cancel button is 'CANCEL'.
    If the entry box is present (via -e), then the contents of the entry
    box is returned to the standard output.

    If entry widget exists, then OK or <Return> in entry returns contents of
    entry box, otherwise OK returns ``OK''. Here are two examples:

    tkquery -e "Host: ::my-pc.wu.edu::16" "Enter IP address of remote host"

    tkquery -b Quit::QUIT -b "Sleep 60 sec::SLEEP" -b "Reboot::REBOOT" \\
            -no "What should we do next??"

EOQ

# Make Examples string:

$Examples = <<"EOQ";

$version
Examples:

    tkquery -e "Host:" "Enter IP address of remote host"

    tkquery -e "Host: ::rtfm.mit.edu::16" "Enter IP address of remote host"

    tkquery -b Quit::QUIT -b "Sleep 60 sec::SLEEP" -b "Reboot::REBOOT" \\
            -no "What should we do next??"

    tkquery -no -b Dismiss::D "Backup complete"

    tkquery -stay -no -b Check::CHECK -bd Quit::QUIT "Tell me when \\
            to Check..."

    Here is a little script using tkquery as a gui frontend to gopher:
    #!/bin/sh
    RESPONSE="`tkquery "Enter Gopher host (Blank for default)" -e "Host:"`";
    if [ "\$RESPONSE" != "CANCEL" ]; then
        xterm -e gopher \$RESPONSE;
    fi

    Here is an endless loop of user event responses.
#!/bin/sh
tkquery -stay -no -b A::A -b B::B -b C::C -bd Quit::QUIT 'What next?' | {
        while read x 
        do
                echo Hey, I\'ve got $x
        done
}


EOQ

# Parameters
$FONT1 = " -adobe-helvetica-bold-r-*-*-*-";
$FONT2 = "140";
$FONT3 = "-*-*-*-*-*-*";
$Width='12';
$Aspect='600';
srand();
$X = int(400.*(1. + rand(0.5)));
$Y = int(200.*(1. + rand(0.5)));

$Geometry="+${X}+${Y}";
$Justify='center';

# Initialize some flags
$Warp  =  '';
$Text = '';
$Title = "$program";
$Entry = '';
$EntryOn = '';
$EntryDel = '';				# for -stayalive
$Message = '';
$StayAlive = '';
$Space_Invoke = '';
$Debug = '';
$Sleep = '';
$Print_Pid = 0;
		# first two buttons are "OK" and "Cancel":
$button = 0;
$Button[$button++] = "OK::OK";	$NOK = '';
$ButtonDel[$button] = '1';		# for -stayalive
$Button[$button++] = "Cancel::CANCEL"; $NOCANCEL = '';

$nullcount = 0;

# Process command line args

while (@ARGV) {	
    $_ = shift;
    CASE: {
	/^-e$/ && ( $Entry = &ArgTest('E'), $EntryOn = '1', last CASE);
	/^-ed$/ && ( $Entry = &ArgTest('E'), $EntryOn = '1', $EntryDel = '1', last CASE);
	/^-esc$/ && ( $EscapeQuit = '1', last CASE);
	/^-b$/ && ( $Button[$button++] = &ArgTest('B'), last CASE);
	/^-bd$/ && ( $ButtonDel[$button] = '1', $Button[$button++] = &ArgTest('B'), last CASE);
	/^-be$/ && ( $ButtonEnt[$button] = '1', $Button[$button++] = &ArgTest('B'), last CASE);
	/^-m$/ && ( $Message = shift, last CASE);
	/^-geom/ && ( $Geometry = shift, last CASE);
	/^-f$/ && ( $FONT = shift, last CASE);
	/^-aspect$/ && ( $Aspect = shift, last CASE);
	/^-oneline$/ && ( $Aspect = 10000, last CASE);
	/^-j$/ && ( $Justify = shift, last CASE);
	/^-i$/ && ( push(@Inserts, shift), last CASE);
	/^-cr$/ && ( $cr_string = shift, last CASE);
	/^-s$/ && ( $Sleep = shift, last CASE);
	/^-stay/ && ( $StayAlive = '1', last CASE);
	/^-pid/ && ( $Print_Pid = '1', last CASE);
	/^-warp/ && ( $Warp = '1', last CASE);
	/^-M$/ && ( $Extra_Message = shift, last CASE);
	/^-space/ && ( $Space_Invoke = '1', last CASE);
	/^-t$/ && ( $Title = shift, last CASE);
	/^-d$/ && ( $Debug = '1', last CASE);
	/^-no$/ && ( $NOK = '1', $NOCANCEL = '1', last CASE);
	/^-nok/ && ( $NOK = '1', last CASE);
	/^-noc/ && ( $NOCANCEL = '1', last CASE);
	/^-h/ && ( (print "$Usage"), exit 0, last CASE);
	/^-exam/ && ( (print "$Examples"), exit 0, last CASE);
	/^-v$/ && ( (print "$version"), exit 0, last CASE);
	/^--$/ && (last LOOP);	# -- means end of switches
	/^-(-.*)$/ && (unshift(@ARGV, $1), last CASE);
	if ( /^-(..+)$/ ) {	# split bundled switches:
		local($y, $x) = ($1, '');
		foreach $x (reverse(split(//, $y))) { unshift(@ARGV,"-$x") };
		last CASE;
	}
	/^-/ && ( (print "$Usage\n$_ is not an option, Bye!\n"), exit 0, last CASE);
	( $Message = "$Message"."$_"." ", last CASE);
    }
}

# Try to find wish (tcl/tk windowing shell):

if ( ! $ENV{WISH} ) {
    $WISH = 'wish' unless `sh -c "type wish 2>&1"` =~ /not.*found/; 
    if ( ! $WISH ) {
	WISH: {
	    $WISH = "/usr/bin/wish" && (-x "/usr/bin/wish", last WISH) ;
	    $WISH = "/usr/local/bin/wish" && (-x "/usr/local/bin/wish", last WISH) ;
	    $WISH = "$ENV{'HOME'}/bin/wish" && (-x "$ENV{'HOME'}/bin/wish", last WISH) ;
	} 
    }
} else {
	$WISH =  "$ENV{WISH}";
}

$WISH = 'wish' unless $WISH;	# last resort, will probably fail later...

# Font:

if ( $FONT ) {
	if ( $FONT =~ /^\d+$/ ) {
		$FONT = "$FONT1"."$FONT"."$FONT3";
	}
} else {
	$FONT = "$FONT1"."$FONT2"."$FONT3";
}

# Code for Message widget:

if ( $Message ) {
	$message = "message .msg -text \"$Message\" -anchor $Justify -font $FONT -aspect $Aspect;";
	$pack = '.msg ';
	if ($Extra_Message || $ENV{EXTRA_MESSAGE} ne '') {
		my $text = '';
		if ($Extra_Message) {
			$text = `cat '$Extra_Message'`;
		} else {
			$text = $ENV{EXTRA_MESSAGE};
			$text =~ s/\\n/\n/g;
		}
		my $w = 0; 
		my $h = 0; 
		foreach my $line (split(/\n/, $text)) {
			$h++;
			my $l = length($line) + 5;
			if ($l > $w) {
				$w = $l;
			}
		}
		$text = "\n$text";
		$h += 2;
		$message .= "\nproc extra_msg {} {catch {destroy .txtmsg}; toplevel .txtmsg;";
		$message .= "wm transient .txtmsg .; text .txtmsg.t -width $w -height $h -font fixed;";
		$message .= ".txtmsg.t insert end {$text};\n; set tx [winfo rootx .msg];";
		$message .= "set ty [winfo rooty .msg]; set ty [expr \$ty + 50];";
		$message .= "wm geometry .txtmsg +\$tx+\$ty; catch {pack .txtmsg.t}; update}\n";
		$message .= "bind .msg <Enter> extra_msg;\n"; 
		$message .= "bind .msg <Leave> {catch {destroy .txtmsg}};\n"; 
		$message .= "bind .txtmsg <KeyPress-Escape> {catch {destroy .txtmsg}};\n"; 
	}
} else {
	$message = '';
	$pack = '';
}

# Standard Destroy command:

$Destroy = "flush stdout; destroy .; exit";

# tcl/tk Code for Entry widget

if ( $EntryOn ) {
	($label, $text, $width) = split (/::/,$Entry,3); 
	$Width = "$width" if $width;
	$Text = "$text" if $text;
	$destroy = 'flush stdout; ';
	if ( ! $StayAlive ) {
		$destroy = "$Destroy";
	} else {
		$destroy = "$Destroy" if $EntryDel;
		$ButtonDel[0] = '1' if $EntryDel;
	}
	$entry = '';
	$entry .= "global entryVar;";
	# $entry .= "bind Entry <2> { %W insert insert [selection get] };";
	$entry .= "bind Entry <Control-u> {%W delete 0 end};";
	$entry .= "bind Entry <B3-Motion> {%W scan dragto %x};";
	$entry .= "bind Entry <B2-Motion> {};";
	$entry .= "bind Entry <Right> { %W icursor [expr \"[%W index insert] + 1\"]};";
	$entry .= "bind Entry <Left>  { %W icursor [expr \"[%W index insert] - 1\"]};";
	$entry .= "frame .entry -bd 1m;";
	$entry .= "set entryVar \"$Text\"; entry .entry.e -relief sunken -width $Width -textvariable entryVar -font $FONT;";
	$entry .= "label .entry.l; .entry.l config -text \"$label\" -font $FONT;";
###	$entry .= "pack .entry.l .entry.e -side left;";
	$entry .= "pack .entry.l -side left;";
	$entry .= "pack .entry.e -side left -expand 1 -fill x;";
	$entry .= "bind .entry.e <Return> \"catch \{puts stdout $cr_string\\[.entry.e get\\]\}; $destroy\";";
	$entry .= "bind . <Escape> \"$Destroy\";";
	$entry .= "bind .entry.e <Enter> \"focus .entry.e\";";
	$entry .= "focus .entry.e;";

	foreach $ins (@Inserts) {
		local($keysym, $text) = split(/:/, $ins, 2);
		$entry .= "bind .entry.e <$keysym> \".entry.e insert insert {$text}\";";
	}
	
	$pack = "$pack"." ".".entry";
} else {
	$entry = '';
}

print STDERR "$entry\n" if $Debug;

# tcl/tk Code for Button widgets

$ButtonMake='';
for( $i = 0; $i < $button; $i++ ) {
	next if $NOK &&  $Button[$i] =~ /OK::OK/;
	next if $NOCANCEL &&  $Button[$i] =~ /Cancel::CANCEL/;
	($label, $flag) = split (/::/,$Button[$i],2); 
	$destroy = 'flush stdout; ';
	if ( ! $StayAlive ) {
		$destroy = "$Destroy";
	} else {
		$destroy = "$Destroy" if $ButtonDel[$i];
	}
	if ( $Button[$i] =~ /OK::OK/ && $EntryOn ) {
		$flag = '\\[.entry.e get\\]';
	}
	if ( $ButtonEnt[$i] && $EntryOn ) {
		$flag = "$flag".'\\[.entry.e get\\]';
	}
	$ButtonMake .= "button .b$i -anchor $Justify -text \"$label\" -command \"catch \{puts stdout $flag\}; $destroy\" -font $FONT;\n";
	if ( $Space_Invoke ) {
		$b = ".b$i";
		$ButtonMake .= "bind $b <Enter> \"focus $b\"; bind $b <KeyPress-space> \"$b flash; $b invoke\"\n";
	
		if ( $i == 0 ) {
			$ButtonMake .= "bind . <KeyPress-space> \"$b flash; $b invoke\"\n";
		}
	}
	$pack = "$pack"." ".".b$i";
}

print STDERR "$ButtonMake\n" if $Debug;

if ( $Warp ) {
	$Warp = '';
	$xwit = `type xwit 1>/dev/null 2>&1`;
	if ( $? == 0 ) {
		$Warp = <<'END';
# begin warp
update;
if [winfo exists .b0] {
	catch {exec xwit -root -warp [expr [winfo rootx .b0]+30] [expr [winfo rooty .b0]+12]}
} elseif [winfo exists .b1] {
	catch {exec xwit -root -warp [expr [winfo rootx .b1]+30] [expr [winfo rooty .b1]+12]}
} elseif [winfo exists .b2] {
	catch {exec xwit -root -warp [expr [winfo rootx .b2]+30] [expr [winfo rooty .b2]+12]}
} else {
	catch {exec xwit -root -warp [expr [winfo rootx .]+20] [expr [winfo rooty .]+20]}
}
# end warp
END
	}

}

print STDERR "$Warp\n" if $Debug;

#print STDERR "wish: $WISH\n";

$pid = open(WISH, "| $WISH");		# open input pipe to wish.
#open(WISH, ">/tmp/wishcode");
if ($Print_Pid) {
	print "GUIPID:$pid\n";
}

select WISH; $| = 1;		# make all possible pipes hot!
select STDOUT; $| = 1;

# Go run tcl/tk script and get response(s) sent to stdout

print WISH <<_EOTK;
	catch {	rename send {}}
	wm geometry . "$Geometry";
	wm title . "$Title";
	wm minsize . 1 1
	wm command . "tkquery";

#	option add	*selectBackground         grey70
#	option add	*activeBackground         grey65
#	option add	*background               grey80
#	option add	*scrolly*foreground       grey80
#	option add	*scrolly*activeForeground grey65
#	option add	*scrollx*foreground       grey80
#	option add	*scrollx*activeForeground grey65
#	. configure -bg grey80
#
	option add      *Button*padY 2
	option add      *Button*padX 1m
	option add      *Button*highlightThickness 0

	$message
	$entry
	$ButtonMake
	pack $pack -side top -fill x; 
	$Warp


_EOTK

if ( $Sleep ) {
	# print STDERR "sleeping ... $Sleep $WISH\n";
	sleep $Sleep;
	kill TERM, $pid;
	kill KILL, $pid;
} else {
	close(WISH);
	wait;			# wait for wish to end
}

exit 0;

sub ArgTest {
	local($x) = $_[0]; 
	local($return);
	if ( $x =~ /^E/ ) {
		$return = "::::";
	} else {
		$return = "Button $nullcount::BUTTON$nullcount";
		$nullcount++
	}
	if ( $ARGV[0] =~ /^-/ || $ARGV[0] eq "" ) {
#		print STDERR "ArgTest return $return\n";
		return "$return";
	} else {
		if ( $x =~ /^B/ ) { $nullcount--; }
		$return = shift @ARGV;
#		print STDERR "ArgTest return $return\n";
		return "$return";
	}
}