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

#!/usr/local/bin/perl 

# Perl script to make a query GUI using tk/tcl (requires tk's "wish")
$version = "tkquery version 0.3  Copyright (c) Karl J. Runge 1994.\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		
    -examples => print examples
    -h => print help   
    -v => print version information  
    -d => debug mode
    -stayalive => only clicking a -bd button or -ed entry will terminate
    -be => button widget returns "FLAG"."contents of EntryBox"
    -nok => No "OK" button	 
    -nocancel => No "Cancel" button -no => both.
    -m => Message at top (-m optional if this is last entry)
    -j (left|center|right) => justification of message.
    -f <font> => font (possibly just a number) for message.
    -cr <str> => Prepend "str" to carriage return <cr> entry string.

    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 got $x
        done
}


EOQ

# Parameters
$FONT1 = " -adobe-helvetica-bold-r-*-*-*-";
$FONT2 = "140";
$FONT3 = "-*-*-*-*-*-*";
$Width='12';
$Geometry='+400+300';
$Justify='center';

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

$nullcount='0';

# Process command line args

while (@ARGV) {	
    $_ = shift;
    CASE: {
	/^-e$/ && ( $Entry = &ArgTest('E'), $EntryOn = 'True', last CASE);
	/^-ed$/ && ( $Entry = &ArgTest('E'), $EntryOn = 'True', $EntryDel = 'True', last CASE);
	/^-esc$/ && ( $EscapeQuit = 'True', last CASE);
	/^-b$/ && ( $Button[$button++] = &ArgTest('B'), last CASE);
	/^-bd$/ && ( $ButtonDel[$button] = 'True', $Button[$button++] = &ArgTest('B'), last CASE);
	/^-be$/ && ( $ButtonEnt[$button] = 'True', $Button[$button++] = &ArgTest('B'), last CASE);
	/^-m$/ && ( $Message = shift, last CASE);
	/^-geom/ && ( $Geometry = shift, last CASE);
	/^-f$/ && ( $FONT = shift, last CASE);
	/^-j/ && ( $Justify = shift, last CASE);
	/^-cr$/ && ( $cr_string = shift, last CASE);
	/^-stay/ && ( $StayAlive = 'True', last CASE);
	/^-t/ && ( $Title = shift, last CASE);
	/^-d/ && ( $Debug = 'True', last CASE);
	/^-no$/ && ( $NOK = 'True', $NOCANCEL = 'True', last CASE);
	/^-nok/ && ( $NOK = 'True', last CASE);
	/^-noca/ && ( $NOCANCEL = 'True', last CASE);
	/^-h/ && ( (print "$Usage"), exit 0, last CASE);
	/^-exam/ && ( (print "$Examples"), exit 0, last CASE);
	/^-v/ && ( (print "$version"), exit 0, 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 !~ /-/ && $FONT > 0 ) {
		$FONT = "$FONT1"."$FONT"."$FONT3";
	}
} else {
	$FONT = "$FONT1"."$FONT2"."$FONT3";
}

# Code for Message widget:

if ( $Message ) {
	$message = "message .msg -text \"$Message\" -justify $Justify -font $FONT -aspect 300;";
	$pack = '.msg ';
} else {
	$message = '';
	$pack = '';
}

# Standard Destroy command:

$Destroy = "flush stdout; destroy .";

# 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] = 'True' 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> \"puts stdout $cr_string\\[.entry.e get\\]; $destroy\";";
	$entry .= "bind . <Escape> \"$Destroy\";";
	$entry .= "bind .entry.e <Enter> \"focus .entry.e\";";
	
	$pack = "$pack"." ".".entry";
} else {
	$entry = '';
	
}

print "$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 -text \"$label\" -command \"puts stdout $flag; $destroy\" -font $FONT;\n";
	$pack = "$pack"." ".".b$i";
}

print "$ButtonMake\n" if $Debug;

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

open(WISH, "| $WISH");		# open input pipe to wish.

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;
	wm geometry . \"$Geometry\";
	wm title . \"$Title\";
	wm minsize . 1 1;

	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 1
	option add      *Button*padX 1

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

# guess we don't need this: $WISH stdout is hooked to present stdout anyway!
#				I mean, WISH is an *INPUT* pipe!!!
#while (<WISH>) {	# wait for response(s)
#	print STDOUT $_;
#}

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";
	}
}