#!/usr/bin/perl
#####################################################################
#  An example of calling wish as a subshell under Perl and
#  interactively communicating with it through sockets.
#
#  The script is directly based on Gustaf Neumann's perlwafe script.
#
#  Dov Grobgeld dov@menora.weizmann.ac.il
#  1993-05-17
#
# NOTE: the Perl Tk module is now working very well. Wish should not be
# required by perl scripts.
#####################################################################

$wishbin = "/usr/bin/wish";

die "socketpair unsuccessful: $!!\n" unless socketpair(W0,WISH,1,1,0);
if ($pid=fork) {
    select(WISH); $| = 1;
    select(STDOUT);

    # Create some TCL procedures
    print WISH 'proc echo {s} {puts stdout $s; flush stdout}',"\n";

    # Create the widgets
    print WISH <<TCL;
      # This is a comment "inside" wish

      frame .f -relief raised -border 1 -bg green
      pack append . .f {top fill expand}

      button .f.button-pressme -text "Press me" -command {
          echo "That's nice."
      }
      button .f.button-quit -text quit -command {
          echo "quit"
      }
      pack append .f .f.button-pressme {top fill expand} \\
                    .f.button-quit {top expand}
TCL

    # Here is the main loop which receives and sends commands
    # to wish.
    while (<WISH>) {
        chop;
        print "Wish sais: <$_>\n";
        if (/^quit/) {
          print WISH "destroy .\n";
          last;
        }
    }
        wait;
} elsif (defined $pid) {
    open(STDOUT, ">&W0");
    open(STDIN, ">&W0");
    close(W0);
    select(STDOUT); $| = 1;
    exec "$wishbin --";
} else {
    die "fork error: $!\n";
}