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