1#!/usr/bin/perl -w 2 3use lib './t','../t','./blib/lib','../blib/lib'; 4 # can run from here or distribution base 5 6use Device::SerialPort 0.06; 7require "DefaultPort.pm"; 8use strict; 9 10# tests start using file created by test1.t unless overridden 11 12my $file = "/dev/ttyS0"; 13if ($SerialJunk::Makefile_Test_Port) { 14 $file = $SerialJunk::Makefile_Test_Port; 15} 16if (exists $ENV{Makefile_Test_Port}) { 17 $file = $ENV{Makefile_Test_Port}; 18} 19if (@ARGV) { 20 $file = shift @ARGV; 21} 22 23my $cfgfile = $file."_test.cfg"; 24$cfgfile =~ s/.*\///; 25 26if (-e "../t/$cfgfile") { $cfgfile = "../t/$cfgfile"; } 27elsif (-e "../$cfgfile") { $cfgfile = "../$cfgfile"; } 28elsif (-e "t/$cfgfile") { $cfgfile = "t/$cfgfile"; } 29else { die "$cfgfile not found" unless (-e $cfgfile); } 30 31# Constructor 32 33my $head = "\r\n\r\n+++++++++++ Tied FileHandle Demo ++++++++++\r\n"; 34my $e="\r\n....Bye\r\n"; 35 36# =============== execution begins here ======================= 37 38 # constructor = TIEHANDLE method 39my $tie_ob = tie(*PORT,'Device::SerialPort', $cfgfile) 40 || die "Can't start $cfgfile\n"; 41 42 # timeouts 43$tie_ob->read_char_time(0); 44$tie_ob->read_const_time(10000); 45### $tie_ob->read_interval(0); 46### $tie_ob->write_char_time(0); 47### $tie_ob->write_const_time(3000); 48### 49### # match parameters 50### $tie_ob->are_match("\n"); 51$tie_ob->lookclear; 52### $tie_ob->is_prompt("\r\nPrompt! "); 53 54 # other parameters 55$tie_ob->error_msg(1); # use built-in error messages 56$tie_ob->user_msg(1); 57$tie_ob->handshake("xoff"); 58### $tie_ob->handshake("rts"); # will cause output timeouts if no connect 59### $tie_ob->stty_onlcr(1); # depends on terminal 60### $tie_ob->stty_opost(1); # depends on terminal 61$tie_ob->stty_icrnl(1); # depends on terminal 62$tie_ob->stty_echo(0); # depends on terminal 63 64 # Print Prompts to Port and Main Screen 65print $head; 66print PORT $head; 67 68 # tie to PRINT method 69print PORT "\r\nEnter one character (10 seconds): " 70 or print "PRINT timed out\n\n"; 71 72 # tie to GETC method 73my $char = getc PORT; 74if (!defined $char) { 75 print "GETC timed out\n"; 76 print PORT "...GETC timed_out\r\n"; 77} 78else { 79 print PORT "$char\r\n"; 80} 81 82 # tie to WRITE method 83if ( $] < 5.005 ) { 84 print "syswrite tie to WRITE not supported in this Perl\n\n"; 85} 86else { 87 my $out = "\r\nThis is a 'syswrite' test\r\n\r\n"; 88 syswrite PORT, $out, length($out), 0 89 or print "WRITE timed out\n\n"; 90} 91 92 93 # tie to READLINE method 94$tie_ob->stty_echo(1); # depends on terminal 95print PORT "enter line: "; 96my $line = <PORT>; 97if (defined $line) { 98 print "READLINE received: $line"; # no chomp 99 print PORT "\r\nREADLINE received: $line\r"; 100} 101else { 102 print "READLINE timed out\n\n"; 103 print PORT "...READLINE timed out\r\n"; 104 my ($patt, $after, $match, $instead) = $tie_ob->lastlook; ## NEW 105 print "got_instead = $instead\n" if ($instead); ## NEW 106} 107 108 # tie to READ method 109my $in = "FIRST:12345, SECOND:67890, END"; 110$tie_ob->stty_echo(0); # depends on terminal 111print PORT "\r\nenter 5 char (no echo): "; 112unless (defined sysread (PORT, $in, 5, 6)) { 113 print "READ timed out:\n"; 114 print PORT "...READ timed out\r\n"; 115} 116 117$tie_ob->stty_echo(1); # depends on terminal 118print PORT "\r\nenter 5 more char (with echo): "; 119unless (defined sysread (PORT, $in, 5, 20)) { 120 print "READ timed out:\n"; 121 print PORT "...READ timed out\r\n"; 122} 123 124 # tie to PRINTF method 125printf PORT "\r\nreceived: %s\r\n", $in 126 or print "PRINTF timed out\n\n"; 127 128 # PORT-specific versions of the $, and $\ variables 129my $n1 = ".number1_"; 130my $n2 = ".number2_"; 131my $n3 = ".number3_"; 132 133print PORT $n1, $n2, $n3; 134print PORT "\r\n"; 135 136$tie_ob->output_field_separator("COMMA"); 137print PORT $n1, $n2, $n3; 138print PORT "\r\n"; 139 140$tie_ob->output_record_separator("RECORD"); 141print PORT $n1, $n2, $n3; 142$tie_ob->output_record_separator(""); 143print PORT "\r\n"; 144 # the $, and $\ variables will also work 145 146print PORT $e; 147 148 # destructor = CLOSE method 149if ( $] < 5.005 ) { 150 print "close tie to CLOSE not supported in this Perl\n\n"; 151 $tie_ob->close || print "port close failed\n\n"; 152} 153else { 154 close PORT || print "CLOSE failed\n\n"; 155} 156 157 # destructor = DESTROY method 158undef $tie_ob; # Don't forget this one!! 159untie *PORT; 160 161print $e; 162