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