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