1#!/usr/bin/perl -w
2#
3# a perl/Tk based simple chat program
4# demonstrates use of non-blocking I/O with event loop
5# uses same setup as other demo?.plx programs in SerialPort distribution
6#
7# Send-Button does not add "\n", <Return> = <Enter> does
8
9use lib './t','../t','./blib/lib','../blib/lib';
10	# can run from here or distribution base
11
12BEGIN { require 5.004; }
13use Tk;
14use Tk::ROText;
15use Tk::LabEntry;
16use Device::SerialPort 0.06;
17require "DefaultPort.pm";
18
19## use subs qw/newline sendline/;
20use strict;
21
22# tests start using file created by test1.t unless overridden
23
24my $file = "/dev/ttyS0";
25if ($SerialJunk::Makefile_Test_Port) {
26    $file = $SerialJunk::Makefile_Test_Port;
27}
28if (exists $ENV{Makefile_Test_Port}) {
29    $file = $ENV{Makefile_Test_Port};
30}
31if (@ARGV) {
32    $file = shift @ARGV;
33}
34
35my $cfgfile = $file."_test.cfg";
36$cfgfile =~ s/.*\///;
37
38if (-e "../t/$cfgfile") { $cfgfile = "../t/$cfgfile"; }
39elsif (-e "../$cfgfile") { $cfgfile = "../$cfgfile"; }
40elsif (-e "t/$cfgfile") { $cfgfile = "t/$cfgfile"; }
41else { die "$cfgfile not found" unless (-e $cfgfile); }
42
43# =============== execution begins here =======================
44
45    # constructor
46my $ob = Device::SerialPort->start ($cfgfile) or die "Can't start $cfgfile\n";
47    # next test will die at runtime unless $ob
48
49my $poll = 0;
50my $polltime = 200;	# milliseconds
51my $maxpoll = 150;	# 30 seconds
52my $msg = "";
53my $send = "";
54my $senttext = "";
55
56my $mw= MainWindow->new('-title' => 'Device::SerialPort Chat Demo7');
57
58my $f = $mw->Frame;
59my $s = $f->LabEntry(-label => 'Local: ', -width => 60,
60                     -labelPack => [qw/-side left -anchor w/],
61                     -textvariable => \$send)->pack(qw/-side left/);
62$s->Subwidget('entry')->focus;
63
64my $sendret = sub { $send .= "\n"; &sendline; };
65my $sendcmd = \&sendline;
66my $b = $f->Button(-text => 'Send');
67$b->pack(qw/-side left/);
68$b->configure(-command => $sendcmd);
69$s->bind('<Return>' => $sendret);
70
71$f->pack(qw/-side bottom -fill x/);
72
73my $t = $mw->Scrolled(qw/ROText -setgrid true -height 20 -scrollbars e/);
74$t->pack(qw/-expand yes -fill both/);
75$t->tagConfigure(qw/Win32 -foreground black -background white/);
76$t->tagConfigure(qw/Serial -foreground white -background red/);
77$t->insert('end',"        Welcome to the Tk SerialPort Demo\n", 'Win32');
78$t->insert('end',"                REMOTE messages\n", 'Serial');
79$t->insert('end',"                LOCAL messages\n\n", 'Win32');
80
81my $stty_onlcr = 1;			# on my terminal, but not POSIX
82$ob->stty_opost(1);			# on my terminal
83$ob->stty_icrnl(1);			# but you might change
84$ob->stty_echo(1);
85$ob->stty_icanon(1);
86$ob->are_match("\n");			# possible end strings
87$ob->lookclear;				# empty buffer
88$ob->write("\nSerialPort Demo\n");	# "write" first to init "write_done"
89$msg = "\nTalking to Tk\n";		# initial prompt
90## $ob->is_prompt("Again?");		# new prompt after "kill" char
91
92&newline;
93MainLoop();
94
95sub newline {
96    my $gotit = "";		# poll until data ready
97##    if ($ob->write_done(0)) {
98        $gotit = $ob->lookfor;		# poll until data ready
99##    }
100    die "Aborted without match\n" unless (defined $gotit);
101    my $match = $ob->matchclear;
102    if ( ($gotit ne "") || ($match ne "") ) {
103        $t->insert('end',"$gotit\n",'Serial');
104        $poll = 0;
105        $t->see('end');
106        $ob->write("\r") if ($stty_onlcr);
107    }
108    if ($maxpoll < $poll++) {
109        $t->insert('end',"\nCOUNTER: long time with no input\n",'Win32');
110        $poll = 0;
111        $msg = "\nAnybody there?\n";
112    }
113    if ($senttext) {
114        $t->insert('end',"\n$senttext",'Win32');
115        $senttext = "";
116    }
117##     if ($msg && $ob->write_done(0)) {
118    if ($msg) {
119        if ($stty_onlcr) { $msg =~ s/\n/\r\n/osg; }
120##         $ob->write_bg($msg);
121        $ob->write($msg);
122        $msg = "";
123        $t->see('end');
124    }
125    $mw->after($polltime, \&newline);
126}
127
128sub sendline {
129    $msg .= "\n$send";
130    $senttext = "$send";
131    $send = "";
132}
133