/MissionCockpit/tags/V0.4.1/perl/lib/Win32/SerialPort.pm |
---|
0,0 → 1,2969 |
package Win32::SerialPort; |
use Win32; |
use Win32API::CommPort qw( :STAT :PARAM 0.17 ); |
use Carp; |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
$VERSION = '0.19'; |
require Exporter; |
## require AutoLoader; |
@ISA = qw( Exporter Win32API::CommPort ); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= @Win32API::CommPort::EXPORT_OK; |
%EXPORT_TAGS = %Win32API::CommPort::EXPORT_TAGS; |
# parameters that must be included in a "save" and "checking subs" |
my %validate = ( |
ALIAS => "alias", |
BAUD => "baudrate", |
BINARY => "binary", |
DATA => "databits", |
E_MSG => "error_msg", |
EOFCHAR => "eof_char", |
ERRCHAR => "error_char", |
EVTCHAR => "event_char", |
HSHAKE => "handshake", |
PARITY => "parity", |
PARITY_EN => "parity_enable", |
RCONST => "read_const_time", |
READBUF => "set_read_buf", |
RINT => "read_interval", |
RTOT => "read_char_time", |
STOP => "stopbits", |
U_MSG => "user_msg", |
WCONST => "write_const_time", |
WRITEBUF => "set_write_buf", |
WTOT => "write_char_time", |
XOFFCHAR => "xoff_char", |
XOFFLIM => "xoff_limit", |
XONCHAR => "xon_char", |
XONLIM => "xon_limit", |
intr => "is_stty_intr", |
quit => "is_stty_quit", |
s_eof => "is_stty_eof", |
eol => "is_stty_eol", |
erase => "is_stty_erase", |
s_kill => "is_stty_kill", |
bsdel => "stty_bsdel", |
clear => "is_stty_clear", |
echo => "stty_echo", |
echoe => "stty_echoe", |
echok => "stty_echok", |
echonl => "stty_echonl", |
echoke => "stty_echoke", |
echoctl => "stty_echoctl", |
istrip => "stty_istrip", |
icrnl => "stty_icrnl", |
ocrnl => "stty_ocrnl", |
opost => "stty_opost", |
igncr => "stty_igncr", |
inlcr => "stty_inlcr", |
onlcr => "stty_onlcr", |
isig => "stty_isig", |
icanon => "stty_icanon", |
DVTYPE => "devicetype", |
HNAME => "hostname", |
HADDR => "hostaddr", |
DATYPE => "datatype", |
CFG_1 => "cfg_param_1", |
CFG_2 => "cfg_param_2", |
CFG_3 => "cfg_param_3", |
); |
# parameters supported by the stty method |
my %opts = ( "intr" => "is_stty_intr:argv_char", |
"quit" => "is_stty_quit:argv_char", |
"eof" => "is_stty_eof:argv_char", |
"eol" => "is_stty_eol:argv_char", |
"erase" => "is_stty_erase:argv_char", |
"kill" => "is_stty_kill:argv_char", |
"echo" => "stty_echo:1", |
"-echo" => "stty_echo:0", |
"echoe" => "stty_echoe:1", |
"-echoe" => "stty_echoe:0", |
"echok" => "stty_echok:1", |
"-echok" => "stty_echok:0", |
"echonl" => "stty_echonl:1", |
"-echonl" => "stty_echonl:0", |
"echoke" => "stty_echoke:1", |
"-echoke" => "stty_echoke:0", |
"echoctl" => "stty_echoctl:1", |
"-echoctl" => "stty_echoctl:0", |
"istrip" => "stty_istrip:1", |
"-istrip" => "stty_istrip:0", |
"icrnl" => "stty_icrnl:1", |
"-icrnl" => "stty_icrnl:0", |
"ocrnl" => "stty_ocrnl:1", |
"-ocrnl" => "stty_ocrnl:0", |
"igncr" => "stty_igncr:1", |
"-igncr" => "stty_igncr:0", |
"inlcr" => "stty_inlcr:1", |
"-inlcr" => "stty_inlcr:0", |
"onlcr" => "stty_onlcr:1", |
"-onlcr" => "stty_onlcr:0", |
"opost" => "stty_opost:1", |
"-opost" => "stty_opost:0", |
"isig" => "stty_isig:1", |
"-isig" => "stty_isig:0", |
"icanon" => "stty_icanon:1", |
"-icanon" => "stty_icanon:0", |
"parenb" => "parity_enable:1", |
"-parenb" => "parity_enable:0", |
"inpck" => "parity_enable:1", |
"-inpck" => "parity:none", |
"cs5" => "databits:5", |
"cs6" => "databits:6", |
"cs7" => "databits:7", |
"cs8" => "databits:8", |
"cstopb" => "stopbits:2", |
"-cstopb" => "stopbits:1", |
"parodd" => "parity:odd", |
"-parodd" => "parity:even", |
"clocal" => "handshake:none", |
"-clocal" => "handshake:dtr", |
"crtscts" => "handshake:rts", |
"-crtscts" => "handshake:none", |
"ixon" => "handshake:xoff", |
"-ixon" => "handshake:none", |
"ixoff" => "handshake:xoff", |
"-ixoff" => "handshake:none", |
"start" => "xon_char:argv_char", |
"stop" => "xoff_char:argv_char", |
); |
#### Package variable declarations #### |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $cfg_file_sig="Win32::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
my $Verbose = 0; |
# test*.t only - suppresses default messages |
sub set_test_mode_active { |
return unless (@_ == 2); |
Win32API::CommPort->set_no_messages($_[1]); |
# object not defined but :: upsets strict |
return (keys %validate); |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $device = shift; |
my @new_cmd = ($device); |
my $quiet = shift; |
if ($quiet) { |
push @new_cmd, 1; |
} |
my $self = $class->SUPER::new(@new_cmd); |
unless ($self) { |
return 0 if ($quiet); |
return; |
} |
# "private" data |
$self->{"_DEBUG"} = 0; |
$self->{U_MSG} = 0; |
$self->{E_MSG} = 0; |
$self->{OFS} = ""; |
$self->{ORS} = ""; |
$self->{"_T_INPUT"} = ""; |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
$self->{"_LASTLINE"} = ""; |
$self->{"_CLASTLINE"} = ""; |
$self->{"_SIZE"} = 1; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
$self->{"_PROMPT"} = ""; |
$self->{"_MATCH"} = []; |
$self->{"_CMATCH"} = []; |
@{ $self->{"_MATCH"} } = "\n"; |
@{ $self->{"_CMATCH"} } = "\n"; |
$self->{DVTYPE} = "none"; |
$self->{HNAME} = "localhost"; |
$self->{HADDR} = 0; |
$self->{DATYPE} = "raw"; |
$self->{CFG_1} = "none"; |
$self->{CFG_2} = "none"; |
$self->{CFG_3} = "none"; |
# user settable options for lookfor (the "stty" collection) |
# defaults like RedHat linux unless indicated |
# char to abort nextline subroutine |
$self->{intr} = "\cC"; # MUST be single char |
# char to abort perl |
$self->{quit} = "\cD"; # MUST be single char |
# end_of_file char (linux typ: "\cD") |
$self->{s_eof} = "\cZ"; # MUST be single char |
# end_of_line char |
$self->{eol} = "\cJ"; # MUST be single char |
# delete one character from buffer (backspace) |
$self->{erase} = "\cH"; # MUST be single char |
# clear line buffer |
$self->{s_kill} = "\cU"; # MUST be single char |
# written after erase character |
$self->{bsdel} = "\cH \cH"; |
# written after kill character |
my $space76 = " "x76; |
$self->{clear} = "\r$space76\r"; # 76 spaces |
# echo every character |
$self->{echo} = 0; |
# echo erase character with bsdel string |
$self->{echoe} = 1; |
# echo \n after kill character |
$self->{echok} = 1; |
# echo \n |
$self->{echonl} = 0; |
# echo clear string after kill character |
$self->{echoke} = 1; # linux console yes, serial no |
# echo "^Char" for control chars |
$self->{echoctl} = 0; # linux console yes, serial no |
# strip input to 7-bits |
$self->{istrip} = 0; |
# map \r to \n on input |
$self->{icrnl} = 0; |
# map \r to \n on output |
$self->{ocrnl} = 0; |
# ignore \r on input |
$self->{igncr} = 0; |
# map \n to \r on input |
$self->{inlcr} = 0; |
# map \n to \r\n on output |
$self->{onlcr} = 1; |
# enable output mapping |
$self->{opost} = 0; |
# enable quit and intr characters |
$self->{isig} = 0; # linux actually SUPPORTS signals |
# enable erase and kill characters |
$self->{icanon} = 0; |
my $token; |
my @bauds = $self->are_baudrate; |
foreach $token (@bauds) { $opts{$token} = "baudrate:$token"; } |
# initialize (in CommPort) and write_settings need these defined |
$self->{"_N_U_MSG"} = 0; |
$self->{"_N_E_MSG"} = 0; |
$self->{"_N_ALIAS"} = 0; |
$self->{"_N_intr"} = 0; |
$self->{"_N_quit"} = 0; |
$self->{"_N_s_eof"} = 0; |
$self->{"_N_eol"} = 0; |
$self->{"_N_erase"} = 0; |
$self->{"_N_s_kill"} = 0; |
$self->{"_N_bsdel"} = 0; |
$self->{"_N_clear"} = 0; |
$self->{"_N_echo"} = 0; |
$self->{"_N_echoe"} = 0; |
$self->{"_N_echok"} = 0; |
$self->{"_N_echonl"} = 0; |
$self->{"_N_echoke"} = 0; |
$self->{"_N_echoctl"} = 0; |
$self->{"_N_istrip"} = 0; |
$self->{"_N_icrnl"} = 0; |
$self->{"_N_ocrnl"} = 0; |
$self->{"_N_opost"} = 0; |
$self->{"_N_igncr"} = 0; |
$self->{"_N_inlcr"} = 0; |
$self->{"_N_onlcr"} = 0; |
$self->{"_N_isig"} = 0; |
$self->{"_N_icanon"} = 0; |
$self->{"_N_DVTYPE"} = 0; |
$self->{"_N_HNAME"} = 0; |
$self->{"_N_HADDR"} = 0; |
$self->{"_N_DATYPE"} = 0; |
$self->{"_N_CFG_1"} = 0; |
$self->{"_N_CFG_2"} = 0; |
$self->{"_N_CFG_3"} = 0; |
$self->{ALIAS} = $device; # so "\\.\+++" can be changed |
$self->{DEVICE} = $device; # clone so NAME stays in CommPort |
($self->{MAX_RXB}, $self->{MAX_TXB}) = $self->buffer_max; |
bless ($self, $class); |
return $self; |
} |
sub stty_intr { |
my $self = shift; |
if (@_ == 1) { $self->{intr} = shift; } |
return if (@_); |
return $self->{intr}; |
} |
sub stty_quit { |
my $self = shift; |
if (@_ == 1) { $self->{quit} = shift; } |
return if (@_); |
return $self->{quit}; |
} |
sub is_stty_eof { |
my $self = shift; |
if (@_ == 1) { $self->{s_eof} = chr(shift); } |
return if (@_); |
return ord($self->{s_eof}); |
} |
sub is_stty_eol { |
my $self = shift; |
if (@_ == 1) { $self->{eol} = chr(shift); } |
return if (@_); |
return ord($self->{eol}); |
} |
sub is_stty_quit { |
my $self = shift; |
if (@_ == 1) { $self->{quit} = chr(shift); } |
return if (@_); |
return ord($self->{quit}); |
} |
sub is_stty_intr { |
my $self = shift; |
if (@_ == 1) { $self->{intr} = chr(shift); } |
return if (@_); |
return ord($self->{intr}); |
} |
sub is_stty_erase { |
my $self = shift; |
if (@_ == 1) { $self->{erase} = chr(shift); } |
return if (@_); |
return ord($self->{erase}); |
} |
sub is_stty_kill { |
my $self = shift; |
if (@_ == 1) { $self->{s_kill} = chr(shift); } |
return if (@_); |
return ord($self->{s_kill}); |
} |
sub is_stty_clear { |
my $self = shift; |
my @chars; |
if (@_ == 1) { |
@chars = split (//, shift); |
for (@chars) { |
$_ = chr ( ord($_) - 32 ); |
} |
$self->{clear} = join("", @chars); |
return $self->{clear}; |
} |
return if (@_); |
@chars = split (//, $self->{clear}); |
for (@chars) { |
$_ = chr ( ord($_) + 32 ); |
} |
my $permute = join("", @chars); |
return $permute; |
} |
sub stty_eof { |
my $self = shift; |
if (@_ == 1) { $self->{s_eof} = shift; } |
return if (@_); |
return $self->{s_eof}; |
} |
sub stty_eol { |
my $self = shift; |
if (@_ == 1) { $self->{eol} = shift; } |
return if (@_); |
return $self->{eol}; |
} |
sub stty_erase { |
my $self = shift; |
if (@_ == 1) { |
my $tmp = shift; |
return unless (length($tmp) == 1); |
$self->{erase} = $tmp; |
} |
return if (@_); |
return $self->{erase}; |
} |
sub stty_kill { |
my $self = shift; |
if (@_ == 1) { |
my $tmp = shift; |
return unless (length($tmp) == 1); |
$self->{s_kill} = $tmp; |
} |
return if (@_); |
return $self->{s_kill}; |
} |
sub stty_bsdel { |
my $self = shift; |
if (@_ == 1) { $self->{bsdel} = shift; } |
return if (@_); |
return $self->{bsdel}; |
} |
sub stty_clear { |
my $self = shift; |
if (@_ == 1) { $self->{clear} = shift; } |
return if (@_); |
return $self->{clear}; |
} |
sub stty_echo { |
my $self = shift; |
if (@_ == 1) { $self->{echo} = yes_true ( shift ) } |
return if (@_); |
return $self->{echo}; |
} |
sub stty_echoe { |
my $self = shift; |
if (@_ == 1) { $self->{echoe} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoe}; |
} |
sub stty_echok { |
my $self = shift; |
if (@_ == 1) { $self->{echok} = yes_true ( shift ) } |
return if (@_); |
return $self->{echok}; |
} |
sub stty_echonl { |
my $self = shift; |
if (@_ == 1) { $self->{echonl} = yes_true ( shift ) } |
return if (@_); |
return $self->{echonl}; |
} |
sub stty_echoke { |
my $self = shift; |
if (@_ == 1) { $self->{echoke} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoke}; |
} |
sub stty_echoctl { |
my $self = shift; |
if (@_ == 1) { $self->{echoctl} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoctl}; |
} |
sub stty_istrip { |
my $self = shift; |
if (@_ == 1) { $self->{istrip} = yes_true ( shift ) } |
return if (@_); |
return $self->{istrip}; |
} |
sub stty_icrnl { |
my $self = shift; |
if (@_ == 1) { $self->{icrnl} = yes_true ( shift ) } |
return if (@_); |
return $self->{icrnl}; |
} |
sub stty_ocrnl { |
my $self = shift; |
if (@_ == 1) { $self->{ocrnl} = yes_true ( shift ) } |
return if (@_); |
return $self->{ocrnl}; |
} |
sub stty_opost { |
my $self = shift; |
if (@_ == 1) { $self->{opost} = yes_true ( shift ) } |
return if (@_); |
return $self->{opost}; |
} |
sub stty_igncr { |
my $self = shift; |
if (@_ == 1) { $self->{igncr} = yes_true ( shift ) } |
return if (@_); |
return $self->{igncr}; |
} |
sub stty_inlcr { |
my $self = shift; |
if (@_ == 1) { $self->{inlcr} = yes_true ( shift ) } |
return if (@_); |
return $self->{inlcr}; |
} |
sub stty_onlcr { |
my $self = shift; |
if (@_ == 1) { $self->{onlcr} = yes_true ( shift ) } |
return if (@_); |
return $self->{onlcr}; |
} |
sub stty_isig { |
my $self = shift; |
if (@_ == 1) { $self->{isig} = yes_true ( shift ) } |
return if (@_); |
return $self->{isig}; |
} |
sub stty_icanon { |
my $self = shift; |
if (@_ == 1) { $self->{icanon} = yes_true ( shift ) } |
return if (@_); |
return $self->{icanon}; |
} |
sub is_prompt { |
my $self = shift; |
if (@_ == 1) { $self->{"_PROMPT"} = shift; } |
return if (@_); |
return $self->{"_PROMPT"}; |
} |
sub are_match { |
my $self = shift; |
my $pat; |
my $patno = 0; |
my $reno = 0; |
my $re_next = 0; |
if (@_) { |
@{ $self->{"_MATCH"} } = @_; |
if ($] >= 5.005) { |
@{ $self->{"_CMATCH"} } = (); |
while ($pat = shift) { |
if ($re_next) { |
$re_next = 0; |
eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)'; |
} else { |
push (@{ $self->{"_CMATCH"} }, $pat); |
} |
if ($pat eq "-re") { |
$re_next++; |
} |
} |
} else { |
@{ $self->{"_CMATCH"} } = @_; |
} |
} |
return @{ $self->{"_MATCH"} }; |
} |
# parse values for start/restart |
sub get_start_values { |
return unless (@_ == 2); |
my $self = shift; |
my $filename = shift; |
unless ( open CF, "<$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
my ($signature, $name, @values) = <CF>; |
close CF; |
unless ( $cfg_file_sig eq $signature ) { |
carp "Invalid signature in $filename: $signature"; |
return; |
} |
chomp $name; |
unless ( $self->{DEVICE} eq $name ) { |
carp "Invalid Port DEVICE=$self->{DEVICE} in $filename: $name"; |
return; |
} |
if ($Verbose or not $self) { |
print "signature = $signature"; |
print "name = $name\n"; |
if ($Verbose) { |
print "values:\n"; |
foreach (@values) { print " $_"; } |
} |
} |
my $item; |
my $key; |
my $value; |
my $gosub; |
my $fault = 0; |
no strict 'refs'; # for $gosub |
foreach $item (@values) { |
chomp $item; |
($key, $value) = split (/,/, $item); |
if ($value eq "") { $fault++ } |
else { |
$gosub = $validate{$key}; |
unless (defined &$gosub ($self, $value)) { |
carp "Invalid parameter for $key=$value "; |
return; |
} |
} |
} |
use strict 'refs'; |
if ($fault) { |
carp "Invalid value in $filename"; |
undef $self; |
return; |
} |
1; |
} |
sub restart { |
return unless (@_ == 2); |
my $self = shift; |
my $filename = shift; |
unless ( $self->init_done ) { |
carp "Can't restart before Port has been initialized"; |
return; |
} |
get_start_values($self, $filename); |
write_settings($self); |
} |
sub start { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
return unless (@_); |
my $filename = shift; |
unless ( open CF, "<$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
my ($signature, $name, @values) = <CF>; |
close CF; |
unless ( $cfg_file_sig eq $signature ) { |
carp "Invalid signature in $filename: $signature"; |
return; |
} |
chomp $name; |
my $self = new ($class, $name); |
if ($Verbose or not $self) { |
print "signature = $signature"; |
print "class = $class\n"; |
print "name = $name\n"; |
if ($Verbose) { |
print "values:\n"; |
foreach (@values) { print " $_"; } |
} |
} |
if ($self) { |
if ( get_start_values($self, $filename) ) { |
write_settings ($self); |
} |
else { |
carp "Invalid value in $filename"; |
undef $self; |
return; |
} |
} |
return $self; |
} |
sub write_settings { |
my $self = shift; |
my @items = keys %validate; |
# initialize returns number of faults |
if ( $self->initialize(@items) ) { |
unless (nocarp) { |
carp "write_settings failed, closing port"; |
$self->close; |
} |
return; |
} |
$self->update_DCB; |
if ($Verbose) { |
print "writing settings to $self->{ALIAS}\n"; |
} |
1; |
} |
sub save { |
my $self = shift; |
my $item; |
my $getsub; |
my $value; |
return unless (@_); |
unless ($self->init_done) { |
carp "can't save until init_done"; |
return; |
} |
my $filename = shift; |
unless ( open CF, ">$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
print CF "$cfg_file_sig"; |
print CF "$self->{DEVICE}\n"; |
# used to "reopen" so must be DEVICE=NAME |
no strict 'refs'; # for $gosub |
while (($item, $getsub) = each %validate) { |
chomp $getsub; |
$value = scalar &$getsub($self); |
print CF "$item,$value\n"; |
} |
use strict 'refs'; |
close CF; |
if ($Verbose) { |
print "wrote file $filename for $self->{ALIAS}\n"; |
} |
1; |
} |
##### tied FileHandle support |
sub TIEHANDLE { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
return unless (@_); |
my $self = start($class, shift); |
return $self; |
} |
# WRITE this, LIST |
# This method will be called when the handle is written to via the |
# syswrite function. |
sub WRITE { |
return if (@_ < 3); |
my $self = shift; |
my $buf = shift; |
my $len = shift; |
my $offset = 0; |
if (@_) { $offset = shift; } |
my $out2 = substr($buf, $offset, $len); |
return unless ($self->post_print($out2)); |
return length($out2); |
} |
# PRINT this, LIST |
# This method will be triggered every time the tied handle is printed to |
# with the print() function. Beyond its self reference it also expects |
# the list that was passed to the print function. |
sub PRINT { |
my $self = shift; |
return unless (@_); |
my $ofs = $, ? $, : ""; |
if ($self->{OFS}) { $ofs = $self->{OFS}; } |
my $ors = $\ ? $\ : ""; |
if ($self->{ORS}) { $ors = $self->{ORS}; } |
my $output = join($ofs,@_); |
$output .= $ors; |
return $self->post_print($output); |
} |
sub output_field_separator { |
my $self = shift; |
my $prev = $self->{OFS}; |
if (@_) { $self->{OFS} = shift; } |
return $prev; |
} |
sub output_record_separator { |
my $self = shift; |
my $prev = $self->{ORS}; |
if (@_) { $self->{ORS} = shift; } |
return $prev; |
} |
sub post_print { |
my $self = shift; |
return unless (@_); |
my $output = shift; |
if ($self->stty_opost) { |
if ($self->stty_ocrnl) { $output =~ s/\r/\n/osg; } |
if ($self->stty_onlcr) { $output =~ s/\n/\r\n/osg; } |
} |
my $to_do = length($output); |
my $done = 0; |
my $written = 0; |
while ($done < $to_do) { |
my $out2 = substr($output, $done); |
$written = $self->write($out2); |
if (! defined $written) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
return 0 unless ($written); |
$done += $written; |
} |
$^E = 0; |
1; |
} |
# PRINTF this, LIST |
# This method will be triggered every time the tied handle is printed to |
# with the printf() function. Beyond its self reference it also expects |
# the format and list that was passed to the printf function. |
sub PRINTF { |
my $self = shift; |
my $fmt = shift; |
return unless ($fmt); |
return unless (@_); |
my $output = sprintf($fmt, @_); |
$self->PRINT($output); |
} |
# READ this, LIST |
# This method will be called when the handle is read from via the read |
# or sysread functions. |
sub READ { |
return if (@_ < 3); |
my $buf = \$_[1]; |
my ($self, $junk, $len, $offset) = @_; |
unless (defined $offset) { $offset = 0; } |
my $done = 0; |
my $count_in = 0; |
my $string_in = ""; |
my $in2 = ""; |
my $bufsize = $self->internal_buffer; |
while ($done < $len) { |
my $size = $len - $done; |
if ($size > $bufsize) { $size = $bufsize; } |
($count_in, $string_in) = $self->read($size); |
if ($count_in) { |
$in2 .= $string_in; |
$done += $count_in; |
$^E = 0; |
} |
elsif ($done) { |
$^E = 0; |
last; |
} |
else { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
last; |
} |
} |
my $tail = substr($$buf, $offset + $done); |
my $head = substr($$buf, 0, $offset); |
if ($self->{icrnl}) { $in2 =~ tr/\r/\n/; } |
if ($self->{inlcr}) { $in2 =~ tr/\n/\r/; } |
if ($self->{igncr}) { $in2 =~ s/\r//gos; } |
$$buf = $head.$in2.$tail; |
return $done if ($done); |
return; |
} |
# READLINE this |
# This method will be called when the handle is read from via <HANDLE>. |
# The method should return undef when there is no more data. |
sub READLINE { |
my $self = shift; |
return if (@_); |
my $gotit = ""; |
my $match = ""; |
my $was; |
if (wantarray) { |
my @lines; |
for (;;) { |
$was = $self->reset_error; |
if ($was) { |
$^E = 1117; # ERROR_IO_DEVICE |
return @lines if (@lines); |
return; |
} |
if (! defined ($gotit = $self->streamline($self->{"_SIZE"}))) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return @lines if (@lines); |
return; |
} |
$match = $self->matchclear; |
if ( ($gotit ne "") || ($match ne "") ) { |
$^E = 0; |
$gotit .= $match; |
push (@lines, $gotit); |
return @lines if ($gotit =~ /$self->{"_CLASTLINE"}/s); |
} |
} |
} |
else { |
for (;;) { |
$was = $self->reset_error; |
if ($was) { |
$^E = 1117; # ERROR_IO_DEVICE |
return; |
} |
if (! defined ($gotit = $self->lookfor($self->{"_SIZE"}))) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
$match = $self->matchclear; |
if ( ($gotit ne "") || ($match ne "") ) { |
$^E = 0; |
return $gotit.$match; # traditional <HANDLE> behavior |
} |
} |
} |
} |
# GETC this |
# This method will be called when the getc function is called. |
sub GETC { |
my $self = shift; |
my ($count, $in) = $self->read(1); |
if ($count == 1) { |
$^E = 0; |
return $in; |
} |
else { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
} |
# CLOSE this |
# This method will be called when the handle is closed via the close |
# function. |
sub CLOSE { |
my $self = shift; |
my $success = $self->close; |
if ($Verbose) { printf "CLOSE result:%d\n", $success; } |
return $success; |
} |
# DESTROY this |
# As with the other types of ties, this method will be called when the |
# tied handle is about to be destroyed. This is useful for debugging and |
# possibly cleaning up. |
sub DESTROY { |
my $self = shift; |
if ($Verbose) { print "SerialPort::DESTROY called.\n"; } |
$self->SUPER::DESTROY(); |
} |
############### |
sub alias { |
my $self = shift; |
if (@_) { $self->{ALIAS} = shift; } # should return true for legal names |
return $self->{ALIAS}; |
} |
sub user_msg { |
my $self = shift; |
if (@_) { $self->{U_MSG} = yes_true ( shift ) } |
return wantarray ? @binary_opt : $self->{U_MSG}; |
} |
sub error_msg { |
my $self = shift; |
if (@_) { $self->{E_MSG} = yes_true ( shift ) } |
return wantarray ? @binary_opt : $self->{E_MSG}; |
} |
sub devicetype { |
my $self = shift; |
if (@_) { $self->{DVTYPE} = shift; } # return true for legal names |
return $self->{DVTYPE}; |
} |
sub hostname { |
my $self = shift; |
if (@_) { $self->{HNAME} = shift; } # return true for legal names |
return $self->{HNAME}; |
} |
sub hostaddr { |
my $self = shift; |
if (@_) { $self->{HADDR} = shift; } # return true for assigned port |
return $self->{HADDR}; |
} |
sub datatype { |
my $self = shift; |
if (@_) { $self->{DATYPE} = shift; } # return true for legal types |
return $self->{DATYPE}; |
} |
sub cfg_param_1 { |
my $self = shift; |
if (@_) { $self->{CFG_1} = shift; } # return true for legal param |
return $self->{CFG_1}; |
} |
sub cfg_param_2 { |
my $self = shift; |
if (@_) { $self->{CFG_2} = shift; } # return true for legal param |
return $self->{CFG_2}; |
} |
sub cfg_param_3 { |
my $self = shift; |
if (@_) { $self->{CFG_3} = shift; } # return true for legal param |
return $self->{CFG_3}; |
} |
sub baudrate { |
my $self = shift; |
if (@_) { |
unless ( defined $self->is_baudrate( shift ) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set baudrate on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_baudrate : $self->is_baudrate; |
} |
sub status { |
my $self = shift; |
my $ok = 0; |
my $fmask = 0; |
my $v1 = $Verbose | $self->{"_DEBUG"}; |
my $v2 = $v1 | $self->{U_MSG}; |
my $v3 = $v1 | $self->{E_MSG}; |
my @stat = $self->is_status; |
return unless (scalar @stat); |
$fmask=$stat[ST_BLOCK]; |
if ($v1) { printf "BlockingFlags= %lx\n", $fmask; } |
if ($v2 && $fmask) { |
printf "Waiting for CTS\n" if ($fmask & BM_fCtsHold); |
printf "Waiting for DSR\n" if ($fmask & BM_fDsrHold); |
printf "Waiting for RLSD\n" if ($fmask & BM_fRlsdHold); |
printf "Waiting for XON\n" if ($fmask & BM_fXoffHold); |
printf "Waiting, XOFF was sent\n" if ($fmask & BM_fXoffSent); |
printf "End_of_File received\n" if ($fmask & BM_fEof); |
printf "Character waiting to TX\n" if ($fmask & BM_fTxim); |
} |
$fmask=$stat[ST_ERROR]; |
if ($v1) { printf "Error_BitMask= %lx\n", $fmask; } |
if ($v3 && $fmask) { |
# only prints if error is new (API resets each call) |
printf "Invalid MODE or bad HANDLE\n" if ($fmask & CE_MODE); |
printf "Receive Overrun detected\n" if ($fmask & CE_RXOVER); |
printf "Buffer Overrun detected\n" if ($fmask & CE_OVERRUN); |
printf "Parity Error detected\n" if ($fmask & CE_RXPARITY); |
printf "Framing Error detected\n" if ($fmask & CE_FRAME); |
printf "Break Signal detected\n" if ($fmask & CE_BREAK); |
printf "Transmit Buffer is full\n" if ($fmask & CE_TXFULL); |
} |
return @stat; |
} |
sub handshake { |
my $self = shift; |
if (@_) { |
unless ( $self->is_handshake(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set handshake on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_handshake : $self->is_handshake; |
} |
sub parity { |
my $self = shift; |
if (@_) { |
unless ( $self->is_parity(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set parity on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_parity : $self->is_parity; |
} |
sub databits { |
my $self = shift; |
if (@_) { |
unless ( $self->is_databits(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set databits on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_databits : $self->is_databits; |
} |
sub stopbits { |
my $self = shift; |
if (@_) { |
unless ( $self->is_stopbits(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set stopbits on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_stopbits : $self->is_stopbits; |
} |
# single value for save/start |
sub set_read_buf { |
my $self = shift; |
if (@_) { |
return unless (@_ == 1); |
my $rbuf = int shift; |
return unless (($rbuf > 0) and ($rbuf <= $self->{MAX_RXB})); |
$self->is_read_buf($rbuf); |
} |
return $self->is_read_buf; |
} |
# single value for save/start |
sub set_write_buf { |
my $self = shift; |
if (@_) { |
return unless (@_ == 1); |
my $wbuf = int shift; |
return unless (($wbuf >= 0) and ($wbuf <= $self->{MAX_TXB})); |
$self->is_write_buf($wbuf); |
} |
return $self->is_write_buf; |
} |
sub buffers { |
my $self = shift; |
if (@_ == 2) { |
my $rbuf = shift; |
my $wbuf = shift; |
unless (defined set_read_buf ($self, $rbuf)) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Can't set read buffer on $self->{ALIAS}"; |
} |
return; |
} |
unless (defined set_write_buf ($self, $wbuf)) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Can't set write buffer on $self->{ALIAS}"; |
} |
return; |
} |
$self->is_buffers($rbuf, $wbuf) || return; |
} |
elsif (@_) { return; } |
return wantarray ? $self->are_buffers : 1; |
} |
sub read { |
return unless (@_ == 2); |
my $self = shift; |
my $wanted = shift; |
my $ok = 0; |
my $result = ""; |
return unless ($wanted > 0); |
my $got = $self->read_bg ($wanted); |
if ($got != $wanted) { |
($ok, $got, $result) = $self->read_done(1); # block until done |
} |
else { ($ok, $got, $result) = $self->read_done(0); } |
print "read=$got\n" if ($Verbose); |
return ($got, $result); |
} |
sub lookclear { |
my $self = shift; |
if (nocarp && (@_ == 1)) { |
$self->{"_T_INPUT"} = shift; |
} |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
return if (@_); |
1; |
} |
sub linesize { |
my $self = shift; |
if (@_) { |
my $val = int shift; |
return if ($val < 0); |
$self->{"_SIZE"} = $val; |
} |
return $self->{"_SIZE"}; |
} |
sub lastline { |
my $self = shift; |
if (@_) { |
$self->{"_LASTLINE"} = shift; |
if ($] >= 5.005) { |
eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/'; |
} else { |
$self->{"_CLASTLINE"} = $self->{"_LASTLINE"}; |
} |
} |
return $self->{"_LASTLINE"}; |
} |
sub matchclear { |
my $self = shift; |
my $found = $self->{"_LMATCH"}; |
$self->{"_LMATCH"} = ""; |
return if (@_); |
return $found; |
} |
sub lastlook { |
my $self = shift; |
return if (@_); |
return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"}, |
$self->{"_LPATT"}, $self->{"_LOOK"} ); |
} |
sub lookfor { |
my $self = shift; |
my $size = 0; |
if (@_) { $size = shift; } |
my $loc = ""; |
my $count_in = 0; |
my $string_in = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
if ( ! $self->{"_LOOK"} ) { |
$loc = $self->{"_LASTLOOK"}; |
} |
if ($size) { |
my ($bbb, $iii, $ooo, $eee) = status($self); |
if ($iii > $size) { $size = $iii; } |
($count_in, $string_in) = $self->read($size); |
return unless ($count_in); |
$loc .= $string_in; |
} |
else { |
$loc .= $self->input; |
} |
if ($loc ne "") { |
if ($self->{icrnl}) { $loc =~ tr/\r/\n/; } |
my $n_char; |
my $mpos; |
my $erase_is_bsdel = 0; |
my $nl_after_kill = ""; |
my $clear_after_kill = 0; |
my $echo_ctl = 0; |
my $lookbuf; |
my $re_next = 0; |
my $got_match = 0; |
my $pat; |
my $lf_erase = ""; |
my $lf_kill = ""; |
my $lf_eof = ""; |
my $lf_quit = ""; |
my $lf_intr = ""; |
my $nl_2_crnl = 0; |
my $cr_2_nl = 0; |
if ($self->{opost}) { |
$nl_2_crnl = $self->{onlcr}; |
$cr_2_nl = $self->{ocrnl}; |
} |
if ($self->{echo}) { |
$erase_is_bsdel = $self->{echoe}; |
if ($self->{echok}) { |
$nl_after_kill = $self->{onlcr} ? "\r\n" : "\n"; |
} |
$clear_after_kill = $self->{echoke}; |
$echo_ctl = $self->{echoctl}; |
} |
if ($self->{icanon}) { |
$lf_erase = $self->{erase}; |
$lf_kill = $self->{s_kill}; |
$lf_eof = $self->{s_eof}; |
} |
if ($self->{isig}) { |
$lf_quit = $self->{quit}; |
$lf_intr = $self->{intr}; |
} |
my @loc_char = split (//, $loc); |
while (defined ($n_char = shift @loc_char)) { |
## printf STDERR "0x%x ", ord($n_char); |
if ($n_char eq $lf_erase) { |
if ($erase_is_bsdel && (length $self->{"_LOOK"}) ) { |
$mpos = chop $self->{"_LOOK"}; |
$self->write($self->{bsdel}); |
if ($echo_ctl && (($mpos lt "@")|($mpos eq chr(127)))) { |
$self->write($self->{bsdel}); |
} |
} |
} |
elsif ($n_char eq $lf_kill) { |
$self->{"_LOOK"} = ""; |
$self->write($self->{clear}) if ($clear_after_kill); |
$self->write($nl_after_kill); |
$self->write($self->{"_PROMPT"}); |
} |
elsif ($n_char eq $lf_intr) { |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
return; |
} |
elsif ($n_char eq $lf_quit) { |
exit; |
} |
else { |
$mpos = ord $n_char; |
if ($self->{istrip}) { |
if ($mpos > 127) { $n_char = chr($mpos - 128); } |
} |
$self->{"_LOOK"} .= $n_char; |
## print $n_char; |
if ($cr_2_nl) { $n_char =~ s/\r/\n/os; } |
if ($nl_2_crnl) { $n_char =~ s/\n/\r\n/os; } |
if (($mpos < 32) && $echo_ctl && |
($mpos != is_stty_eol($self))) { |
$n_char = chr($mpos + 64); |
$self->write("^$n_char"); |
} |
elsif (($mpos == 127) && $echo_ctl) { |
$self->write("^."); |
} |
elsif ($self->{echonl} && ($n_char =~ "\n")) { |
# also writes "\r\n" for onlcr |
$self->write($n_char); |
} |
elsif ($self->{echo}) { |
# also writes "\r\n" for onlcr |
$self->write($n_char); |
} |
$lookbuf = $self->{"_LOOK"}; |
if (($lf_eof ne "") and ($lookbuf =~ /$lf_eof$/)) { |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
return $lookbuf; |
} |
$count_in = 0; |
foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
if ($pat eq "-re") { |
$re_next++; |
$count_in++; |
next; |
} |
if ($re_next) { |
$re_next = 0; |
# always at $lookbuf end when processing single char |
if ( $lookbuf =~ s/$pat//s ) { |
$self->{"_LMATCH"} = $&; |
$got_match++; |
} |
} |
elsif (($mpos = index($lookbuf, $pat)) > -1) { |
$got_match++; |
$lookbuf = substr ($lookbuf, 0, $mpos); |
$self->{"_LMATCH"} = $pat; |
} |
if ($got_match) { |
$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
if (scalar @loc_char) { |
$self->{"_LASTLOOK"} = join("", @loc_char); |
## print ".$self->{\"_LASTLOOK\"}."; |
} |
else { |
$self->{"_LASTLOOK"} = ""; |
} |
$self->{"_LOOK"} = ""; |
return $lookbuf; |
} |
$count_in++; |
} |
} |
} |
} |
return ""; |
} |
sub streamline { |
my $self = shift; |
my $size = 0; |
if (@_) { $size = shift; } |
my $loc = ""; |
my $mpos; |
my $count_in = 0; |
my $string_in = ""; |
my $re_next = 0; |
my $got_match = 0; |
my $best_pos = 0; |
my $pat; |
my $match = ""; |
my $before = ""; |
my $after = ""; |
my $best_match = ""; |
my $best_before = ""; |
my $best_after = ""; |
my $best_pat = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
if ( ! $self->{"_LOOK"} ) { |
$loc = $self->{"_LASTLOOK"}; |
} |
if ($size) { |
my ($bbb, $iii, $ooo, $eee) = status($self); |
if ($iii > $size) { $size = $iii; } |
($count_in, $string_in) = $self->read($size); |
return unless ($count_in); |
$loc .= $string_in; |
} |
else { |
$loc .= $self->input; |
} |
if ($loc ne "") { |
$self->{"_LOOK"} .= $loc; |
$count_in = 0; |
foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
if ($pat eq "-re") { |
$re_next++; |
$count_in++; |
next; |
} |
if ($re_next) { |
$re_next = 0; |
if ( $self->{"_LOOK"} =~ /$pat/s ) { |
( $match, $before, $after ) = ( $&, $`, $' ); |
$got_match++; |
$mpos = length($before); |
if ($mpos) { |
next if ($best_pos && ($mpos > $best_pos)); |
$best_pos = $mpos; |
$best_pat = $self->{"_MATCH"}[$count_in]; |
$best_match = $match; |
$best_before = $before; |
$best_after = $after; |
} else { |
$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
$self->{"_LMATCH"} = $match; |
$self->{"_LASTLOOK"} = $after; |
$self->{"_LOOK"} = ""; |
return $before; |
# pattern at start will be best |
} |
} |
} |
elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) { |
$got_match++; |
$before = substr ($self->{"_LOOK"}, 0, $mpos); |
if ($mpos) { |
next if ($best_pos && ($mpos > $best_pos)); |
$best_pos = $mpos; |
$best_pat = $pat; |
$best_match = $pat; |
$best_before = $before; |
$mpos += length($pat); |
$best_after = substr ($self->{"_LOOK"}, $mpos); |
} else { |
$self->{"_LPATT"} = $pat; |
$self->{"_LMATCH"} = $pat; |
$before = substr ($self->{"_LOOK"}, 0, $mpos); |
$mpos += length($pat); |
$self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos); |
$self->{"_LOOK"} = ""; |
return $before; |
# match at start will be best |
} |
} |
$count_in++; |
} |
if ($got_match) { |
$self->{"_LPATT"} = $best_pat; |
$self->{"_LMATCH"} = $best_match; |
$self->{"_LASTLOOK"} = $best_after; |
$self->{"_LOOK"} = ""; |
return $best_before; |
} |
} |
return ""; |
} |
sub input { |
return unless (@_ == 1); |
my $self = shift; |
my $result = ""; |
if (nocarp && $self->{"_T_INPUT"}) { |
$result = $self->{"_T_INPUT"}; |
$self->{"_T_INPUT"} = ""; |
return $result; |
} |
my $ok = 0; |
my $got_p = " "x4; |
my ($bbb, $wanted, $ooo, $eee) = status($self); |
return "" if ($eee); |
return "" unless $wanted; |
my $got = $self->read_bg ($wanted); |
if ($got != $wanted) { |
# block if unexpected happens |
($ok, $got, $result) = $self->read_done(1); # block until done |
} |
else { ($ok, $got, $result) = $self->read_done(0); } |
### print "input: got= $got result=$result\n"; |
return $got ? $result : ""; |
} |
sub write { |
return unless (@_ == 2); |
my $self = shift; |
my $wbuf = shift; |
my $ok = 1; |
return 0 if ($wbuf eq ""); |
my $lbuf = length ($wbuf); |
my $written = $self->write_bg ($wbuf); |
if ($written != $lbuf) { |
($ok, $written) = $self->write_done(1); # block until done |
} |
if ($Verbose) { |
print "wbuf=$wbuf\n"; |
print "lbuf=$lbuf\n"; |
print "written=$written\n"; |
} |
return unless ($ok); |
return $written; |
} |
sub transmit_char { |
my $self = shift; |
return unless (@_ == 1); |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
return unless $self->xmit_imm_char ($v); |
return wantarray ? @byte_opt : 1; |
} |
sub xon_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_xon_char($v); |
} |
return wantarray ? @byte_opt : $self->is_xon_char; |
} |
sub xoff_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_xoff_char($v); |
} |
return wantarray ? @byte_opt : $self->is_xoff_char; |
} |
sub eof_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_eof_char($v); |
} |
return wantarray ? @byte_opt : $self->is_eof_char; |
} |
sub event_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_event_char($v); |
} |
return wantarray ? @byte_opt : $self->is_event_char; |
} |
sub error_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_error_char($v); |
} |
return wantarray ? @byte_opt : $self->is_error_char; |
} |
sub xon_limit { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->is_xon_limit($v); |
} |
return wantarray ? (0, SHORTsize) : $self->is_xon_limit; |
} |
sub xoff_limit { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->is_xoff_limit($v); |
} |
return wantarray ? (0, SHORTsize) : $self->is_xoff_limit; |
} |
sub read_interval { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_interval( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_interval; |
} |
sub read_char_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_char_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_char_time; |
} |
sub read_const_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_const_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_const_time; |
} |
sub write_const_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_write_const_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_write_const_time; |
} |
sub write_char_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_write_char_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_write_char_time; |
} |
# true/false parameters |
sub binary { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_binary( shift ); |
} |
return $self->is_binary; |
} |
sub parity_enable { |
my $self = shift; |
if (@_) { |
if ( $self->can_parity_enable ) { |
$self->is_parity_enable( shift ); |
} |
elsif ($self->{U_MSG}) { |
carp "Can't set parity enable on $self->{ALIAS}"; |
} |
} |
return $self->is_parity_enable; |
} |
sub modemlines { |
return unless (@_ == 1); |
my $self = shift; |
my $result = $self->is_modemlines; |
if ($Verbose) { |
print "CTS is ON\n" if ($result & MS_CTS_ON); |
print "DSR is ON\n" if ($result & MS_DSR_ON); |
print "RING is ON\n" if ($result & MS_RING_ON); |
print "RLSD is ON\n" if ($result & MS_RLSD_ON); |
} |
return $result; |
} |
sub stty { |
my $ob = shift; |
my $token; |
if (@_) { |
my $ok = 1; |
no strict 'refs'; # for $gosub |
while ($token = shift) { |
if (exists $opts{$token}) { |
## print " $opts{$token}\n"; |
my ($gosub, $value) = split (':', $opts{$token}); |
if ($value eq "argv_char") { $value = &argv_char(shift); } |
if (defined $value) { |
&$gosub($ob, $value); |
} else { |
nocarp or carp "bad value for parameter $token\n"; |
$ok = 0; |
} |
} |
else { |
nocarp or carp "parameter $token not found\n"; |
$ok = 0; |
} |
} |
use strict 'refs'; |
return $ok; |
} |
else { |
my @settings; # array returned by () |
my $current = $ob->baudrate; |
push @settings, "$current"; |
push @settings, "intr"; |
push @settings, cntl_char($ob->stty_intr); |
push @settings, "quit"; |
push @settings, cntl_char($ob->stty_quit); |
push @settings, "erase"; |
push @settings, cntl_char($ob->stty_erase); |
push @settings, "kill"; |
push @settings, cntl_char($ob->stty_kill); |
push @settings, "eof"; |
push @settings, cntl_char($ob->stty_eof); |
push @settings, "eol"; |
push @settings, cntl_char($ob->stty_eol); |
push @settings, "start"; |
push @settings, cntl_char(chr $ob->xon_char); |
push @settings, "stop"; |
push @settings, cntl_char(chr $ob->xoff_char); |
# "stop" is last CHAR type |
push @settings, ($ob->stty_echo ? "" : "-")."echo"; |
push @settings, ($ob->stty_echoe ? "" : "-")."echoe"; |
push @settings, ($ob->stty_echok ? "" : "-")."echok"; |
push @settings, ($ob->stty_echonl ? "" : "-")."echonl"; |
push @settings, ($ob->stty_echoke ? "" : "-")."echoke"; |
push @settings, ($ob->stty_echoctl ? "" : "-")."echoctl"; |
push @settings, ($ob->stty_istrip ? "" : "-")."istrip"; |
push @settings, ($ob->stty_icrnl ? "" : "-")."icrnl"; |
push @settings, ($ob->stty_ocrnl ? "" : "-")."ocrnl"; |
push @settings, ($ob->stty_igncr ? "" : "-")."igncr"; |
push @settings, ($ob->stty_inlcr ? "" : "-")."inlcr"; |
push @settings, ($ob->stty_onlcr ? "" : "-")."onlcr"; |
push @settings, ($ob->stty_opost ? "" : "-")."opost"; |
push @settings, ($ob->stty_isig ? "" : "-")."isig"; |
push @settings, ($ob->stty_icanon ? "" : "-")."icanon"; |
$current = $ob->databits; |
push @settings, "cs$current"; |
push @settings, (($ob->stopbits == 2) ? "" : "-")."cstopb"; |
$current = $ob->handshake; |
push @settings, (($current eq "dtr") ? "" : "-")."clocal"; |
push @settings, (($current eq "rts") ? "" : "-")."crtscts"; |
push @settings, (($current eq "xoff") ? "" : "-")."ixoff"; |
push @settings, (($current eq "xoff") ? "" : "-")."ixon"; |
my $parity = $ob->parity; |
if ($parity eq "none") { |
push @settings, "-parenb"; |
push @settings, "-parodd"; |
push @settings, "-inpck"; |
} |
else { |
$current = $ob->is_parity_enable; |
push @settings, ($current ? "" : "-")."parenb"; |
push @settings, (($parity eq "odd") ? "" : "-")."parodd"; |
push @settings, ($current ? "" : "-")."inpck"; |
# mark and space not supported |
} |
return @settings; |
} |
} |
sub cntl_char { |
my $n_char = shift; |
return "<undef>" unless (defined $n_char); |
my $pos = ord $n_char; |
if ($pos < 32) { |
$n_char = "^".chr($pos + 64); |
} |
if ($pos > 126) { |
$n_char = sprintf "0x%x", $pos; |
} |
return $n_char; |
} |
sub argv_char { |
my $n_char = shift; |
return unless (defined $n_char); |
my $pos = $n_char; |
if ($n_char =~ s/^\^//) { |
$pos = ord($n_char) - 64; |
} |
elsif ($n_char =~ s/^0x//) { |
$pos = hex($n_char); |
} |
elsif ($n_char =~ /^0/) { |
$pos = oct($n_char); |
} |
## print "pos = $pos\n"; |
return $pos; |
} |
sub debug { |
my $self = shift; |
if (ref($self)) { |
if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); } |
else { |
my $tmp = $self->{"_DEBUG"}; |
nocarp || carp "Debug level: $self->{ALIAS} = $tmp"; |
$self->debug_comm($tmp); |
return $self->{"_DEBUG"}; |
} |
} else { |
$Verbose = yes_true ($self); |
nocarp || carp "SerialPort Debug Class = $Verbose"; |
Win32API::CommPort::debug_comm($Verbose); |
return $Verbose; |
} |
} |
sub close { |
my $self = shift; |
return unless (defined $self->{ALIAS}); |
if ($Verbose or $self->{"_DEBUG"}) { |
carp "Closing $self " . $self->{ALIAS}; |
} |
my $success = $self->SUPER::close; |
$self->{DEVICE} = undef; |
$self->{ALIAS} = undef; |
if ($Verbose) { |
printf "SerialPort close result:%d\n", $success; |
} |
return $success; |
} |
1; # so the require or use succeeds |
# Autoload methods go after =cut, and are processed by the autosplit program. |
__END__ |
=pod |
=head1 NAME |
Win32::SerialPort - User interface to Win32 Serial API calls |
=head1 SYNOPSIS |
require 5.003; |
use Win32::SerialPort qw( :STAT 0.19 ); |
=head2 Constructors |
$PortObj = new Win32::SerialPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
$PortObj = start Win32::SerialPort ($Configuration_File_Name) |
|| die "Can't start $Configuration_File_Name: $^E\n"; |
$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die "Can't tie using $Configuration_File_Name: $^E\n"; |
=head2 Configuration Utility Methods |
$PortObj->alias("MODEM1"); |
# before using start, restart, or tie |
$PortObj->save($Configuration_File_Name) |
|| warn "Can't save $Configuration_File_Name: $^E\n"; |
# after new, must check for failure |
$PortObj->write_settings || undef $PortObj; |
print "Can't change Device_Control_Block: $^E\n" unless ($PortObj); |
# rereads file to either return open port to a known state |
# or switch to a different configuration on the same port |
$PortObj->restart($Configuration_File_Name) |
|| warn "Can't reread $Configuration_File_Name: $^E\n"; |
# "app. variables" saved in $Configuration_File, not used internally |
$PortObj->devicetype('none'); # CM11, CM17, 'weeder', 'modem' |
$PortObj->hostname('localhost'); # for socket-based implementations |
$PortObj->hostaddr(0); # false unless specified |
$PortObj->datatype('raw'); # in case an application needs_to_know |
$PortObj->cfg_param_1('none'); # null string '' hard to save/restore |
$PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
$PortObj->cfg_param_3('none'); # one may end up as a log file path |
# specials for test suite only |
@necessary_param = Win32::SerialPort->set_test_mode_active(1); |
$PortObj->lookclear("loopback to next 'input' method"); |
=head2 Configuration Parameter Methods |
# most methods can be called three ways: |
$PortObj->handshake("xoff"); # set parameter |
$flowcontrol = $PortObj->handshake; # current value (scalar) |
@handshake_opts = $PortObj->handshake; # permitted choices (list) |
# similar |
$PortObj->baudrate(9600); |
$PortObj->parity("odd"); |
$PortObj->databits(8); |
$PortObj->stopbits(1); |
# range parameters return (minimum, maximum) in list context |
$PortObj->xon_limit(100); # bytes left in buffer |
$PortObj->xoff_limit(100); # space left in buffer |
$PortObj->xon_char(0x11); |
$PortObj->xoff_char(0x13); |
$PortObj->eof_char(0x0); |
$PortObj->event_char(0x0); |
$PortObj->error_char(0); # for parity errors |
$PortObj->buffers(4096, 4096); # read, write |
# returns current in list context |
$PortObj->read_interval(100); # max time between read char (milliseconds) |
$PortObj->read_char_time(5); # avg time between read char |
$PortObj->read_const_time(100); # total = (avg * bytes) + const |
$PortObj->write_char_time(5); |
$PortObj->write_const_time(100); |
# true/false parameters (return scalar context only) |
$PortObj->binary(T); # just say Yes (Win 3.x option) |
$PortObj->parity_enable(F); # faults during input |
$PortObj->debug(0); |
=head2 Operating Methods |
($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->status |
|| warn "could not get port status\n"; |
if ($BlockingFlags) { warn "Port is blocked"; } |
if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
# The API resets errors when reading status, $LatchErrorFlags |
# is all $ErrorFlags seen since the last reset_error |
Additional useful constants may be exported eventually. If the only fault |
action desired is a message, B<status> provides I<Built-In> BitMask processing: |
$PortObj->error_msg(1); # prints hardware messages like "Framing Error" |
$PortObj->user_msg(1); # prints function messages like "Waiting for CTS" |
($count_in, $string_in) = $PortObj->read($InBytes); |
warn "read unsuccessful\n" unless ($count_in == $InBytes); |
$count_out = $PortObj->write($output_string); |
warn "write failed\n" unless ($count_out); |
warn "write incomplete\n" if ( $count_out != length($output_string) ); |
if ($string_in = $PortObj->input) { PortObj->write($string_in); } |
# simple echo with no control character processing |
$PortObj->transmit_char(0x03); # bypass buffer (and suspend) |
$ModemStatus = $PortObj->modemlines; |
if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
=head2 Methods used with Tied FileHandles |
$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die "Can't tie: $^E\n"; ## TIEHANDLE ## |
print FH "text"; ## PRINT ## |
$char = getc FH; ## GETC ## |
syswrite FH, $out, length($out), 0; ## WRITE ## |
$line = <FH>; ## READLINE ## |
@lines = <FH>; ## READLINE ## |
printf FH "received: %s", $line; ## PRINTF ## |
read (FH, $in, 5, 0) or die "$^E"; ## READ ## |
sysread (FH, $in, 5, 0) or die "$^E"; ## READ ## |
close FH || warn "close failed"; ## CLOSE ## |
undef $PortObj; |
untie *FH; ## DESTROY ## |
$PortObj->linesize(10); # with READLINE |
$PortObj->lastline("_GOT_ME_"); # with READLINE, list only |
$old_ors = $PortObj->output_record_separator("RECORD"); # with PRINT |
$old_ofs = $PortObj->output_field_separator("COMMA"); # with PRINT |
=head2 Destructors |
$PortObj->close || warn "close failed"; |
# passed to CommPort to release port to OS - needed to reopen |
# close will not usually DESTROY the object |
# also called as: close FH || warn "close failed"; |
undef $PortObj; |
# preferred unless reopen expected since it triggers DESTROY |
# calls $PortObj->close but does not confirm success |
# MUST precede untie - do all three IN THIS SEQUENCE before re-tie. |
untie *FH; |
=head2 Methods for I/O Processing |
$PortObj->are_match("text", "\n"); # possible end strings |
$PortObj->lookclear; # empty buffers |
$PortObj->write("Feed Me:"); # initial prompt |
$PortObj->is_prompt("More Food:"); # new prompt after "kill" char |
my $gotit = ""; |
my $match1 = ""; |
until ("" ne $gotit) { |
$gotit = $PortObj->lookfor; # poll until data ready |
die "Aborted without match\n" unless (defined $gotit); |
last if ($gotit); |
$match1 = $PortObj->matchclear; # match is first thing received |
last if ($match1); |
sleep 1; # polling sample time |
} |
printf "gotit = %s\n", $gotit; # input BEFORE the match |
my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
# input that MATCHED, input AFTER the match, PATTERN that matched |
# input received INSTEAD when timeout without match |
if ($match1) { |
$match = $match1; |
} |
printf "lastlook-match = %s -after = %s -pattern = %s\n", |
$match, $after, $pattern; |
$gotit = $PortObj->lookfor($count); # block until $count chars received |
$PortObj->are_match("-re", "pattern", "text"); |
# possible match strings: "pattern" is a regular expression, |
# "text" is a literal string |
$gotit = $PortObj->streamline; # poll until data ready |
$gotit = $PortObj->streamline($count);# block until $count chars received |
# fast alternatives to lookfor with no character processing |
$PortObj->stty_intr("\cC"); # char to abort lookfor method |
$PortObj->stty_quit("\cD"); # char to abort perl |
$PortObj->stty_eof("\cZ"); # end_of_file char |
$PortObj->stty_eol("\cJ"); # end_of_line char |
$PortObj->stty_erase("\cH"); # delete one character from buffer (backspace) |
$PortObj->stty_kill("\cU"); # clear line buffer |
$PortObj->is_stty_intr(3); # ord(char) to abort lookfor method |
$qc = $PortObj->is_stty_quit; # ($qc == 4) for "\cD" |
$PortObj->is_stty_eof(26); |
$PortObj->is_stty_eol(10); |
$PortObj->is_stty_erase(8); |
$PortObj->is_stty_kill(21); |
my $air = " "x76; |
$PortObj->stty_clear("\r$air\r"); # written after kill character |
$PortObj->is_stty_clear; # internal version for config file |
$PortObj->stty_bsdel("\cH \cH"); # written after erase character |
$PortObj->stty_echo(0); # echo every character |
$PortObj->stty_echoe(1); # if echo erase character with bsdel string |
$PortObj->stty_echok(1); # if echo \n after kill character |
$PortObj->stty_echonl(0); # if echo \n |
$PortObj->stty_echoke(1); # if echo clear string after kill character |
$PortObj->stty_echoctl(0); # if echo "^Char" for control chars |
$PortObj->stty_istrip(0); # strip input to 7-bits |
$PortObj->stty_icrnl(0); # map \r to \n on input |
$PortObj->stty_ocrnl(0); # map \r to \n on output |
$PortObj->stty_igncr(0); # ignore \r on input |
$PortObj->stty_inlcr(0); # map \n to \r on input |
$PortObj->stty_onlcr(1); # map \n to \r\n on output |
$PortObj->stty_opost(0); # enable output mapping |
$PortObj->stty_isig(0); # enable quit and intr characters |
$PortObj->stty_icanon(0); # enable erase and kill characters |
$PortObj->stty("-icanon"); # disable eof, erase and kill char, Unix-style |
@stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
=head2 Capability Methods inherited from Win32API::CommPort |
These return scalar context only. |
can_baud can_databits can_stopbits |
can_dtrdsr can_handshake can_parity_check |
can_parity_config can_parity_enable can_rlsd |
can_16bitmode is_rs232 is_modem |
can_rtscts can_xonxoff can_xon_char |
can_spec_char can_interval_timeout can_total_timeout |
buffer_max can_rlsd_config |
=head2 Operating Methods inherited from Win32API::CommPort |
write_bg write_done read_bg |
read_done reset_error suspend_tx |
resume_tx dtr_active rts_active |
break_active xoff_active xon_active |
purge_all purge_rx purge_tx |
pulse_rts_on pulse_rts_off pulse_dtr_on |
pulse_dtr_off ignore_null ignore_no_dsr |
subst_pe_char abort_on_error output_xoff |
output_dsr output_cts tx_on_xoff |
input_xoff get_tick_count |
=head1 DESCRIPTION |
This module uses Win32API::CommPort for raw access to the API calls and |
related constants. It provides an object-based user interface to allow |
higher-level use of common API call sequences for dealing with serial |
ports. |
Uses features of the Win32 API to implement non-blocking I/O, serial |
parameter setting, event-loop operation, and enhanced error handling. |
To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
This is expected to change to an empty list reference, C<[]>, when Perl |
supports that form in this usage. |
=head2 Initialization |
The primary constructor is B<new> with a F<PortName> (as the Registry |
knows it) specified. This will create an object, and get the available |
options and capabilities via the Win32 API. The object is a superset |
of a B<Win32API::CommPort> object, and supports all of its methods. |
The port is not yet ready for read/write access. First, the desired |
I<parameter settings> must be established. Since these are tuning |
constants for an underlying hardware driver in the Operating System, |
they are all checked for validity by the methods that set them. The |
B<write_settings> method writes a new I<Device Control Block> to the |
driver. The B<write_settings> method will return true if the port is |
ready for access or C<undef> on failure. Ports are opened for binary |
transfers. A separate C<binmode> is not needed. The USER must release |
the object if B<write_settings> does not succeed. |
Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
to open a port prints a error message to STDOUT by default. Since only |
one application at a time can "own" the port, one source of failure was |
"port in use". There was previously no way to check this without getting |
a "fail message". Setting C<$quiet> disables this built-in message. It |
also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
used for testing this condition - other faults may still return C<undef>). |
Use of C<$quiet> only applies to B<new>. |
=over 8 |
Certain parameters I<MUST> be set before executing B<write_settings>. |
Others will attempt to deduce defaults from the hardware or from other |
parameters. The I<Required> parameters are: |
=item baudrate |
Any legal value. |
=item parity |
One of the following: "none", "odd", "even", "mark", "space". |
If you select anything except "none", you will need to set B<parity_enable>. |
=item databits |
An integer from 5 to 8. |
=item stopbits |
Legal values are 1, 1.5, and 2. But 1.5 only works with 5 databits, 2 does |
not work with 5 databits, and other combinations may not work on all |
hardware if parity is also used. |
=back |
The B<handshake> setting is recommended but no longer required. Select one |
of the following: "none", "rts", "xoff", "dtr". |
Some individual parameters (eg. baudrate) can be changed after the |
initialization is completed. These will be validated and will |
update the I<Device Control Block> as required. The B<save> |
method will write the current parameters to a file that B<start, tie,> and |
B<restart> can use to reestablish a functional setup. |
$PortObj = new Win32::SerialPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
$PortObj->user_msg(ON); |
$PortObj->databits(8); |
$PortObj->baudrate(9600); |
$PortObj->parity("none"); |
$PortObj->stopbits(1); |
$PortObj->handshake("rts"); |
$PortObj->buffers(4096, 4096); |
$PortObj->write_settings || undef $PortObj; |
$PortObj->save($Configuration_File_Name); |
$PortObj->baudrate(300); |
$PortObj->restart($Configuration_File_Name); # back to 9600 baud |
$PortObj->close || die "failed to close"; |
undef $PortObj; # frees memory back to perl |
The F<PortName> maps to both the Registry I<Device Name> and the |
I<Properties> associated with that device. A single I<Physical> port |
can be accessed using two or more I<Device Names>. But the options |
and setup data will differ significantly in the two cases. A typical |
example is a Modem on port "COM2". Both of these F<PortNames> open |
the same I<Physical> hardware: |
$P1 = new Win32::SerialPort ("COM2"); |
$P2 = new Win32::SerialPort ("\\\\.\\Nanohertz Modem model K-9"); |
$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
of modem-specific added options and features. The "raw" API calls return |
different size configuration structures in the two cases. Win32 uses the |
"\\.\" prefix to identify "named" devices. Since both names use the same |
I<Physical> hardware, they can not both be used at the same time. The OS |
will complain. Consider this A Good Thing. Use B<alias> to convert the |
name used by "built-in" messages. |
$P2->alias("FIDO"); |
The second constructor, B<start> is intended to simplify scripts which |
need a constant setup. It executes all the steps from B<new> to |
B<write_settings> based on a previously saved configuration. This |
constructor will return C<undef> on a bad configuration file or failure |
of a validity check. The returned object is ready for access. |
$PortObj2 = start Win32::SerialPort ($Configuration_File_Name) |
|| die; |
The third constructor, B<tie>, combines the B<start> with Perl's |
support for tied FileHandles (see I<perltie>). Win32::SerialPort |
implements the complete set of methods: TIEHANDLE, PRINT, PRINTF, |
WRITE, READ, GETC, READLINE, CLOSE, and DESTROY. Tied FileHandle |
support was new with Version 0.14. |
$PortObj2 = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die; |
The implementation attempts to mimic STDIN/STDOUT behaviour as closely |
as possible: calls block until done, data strings that exceed internal |
buffers are divided transparently into multiple calls, and B<stty_onlcr> |
and B<stty_ocrnl> are applied to output data (WRITE, PRINT, PRINTF) when |
B<stty_opost> is true. In Version 0.17, the output separators C<$,> and |
C<$\> are also applied to PRINT if set. Since PRINTF is treated internally |
as a single record PRINT, C<$\> will be applied. Output separators are not |
applied to WRITE (called as C<syswrite FH, $scalar, $length, [$offset]>). |
The B<output_record_separator> and B<output_field_separator> methods can set |
I<Port-FileHandle-Specific> versions of C<$,> and C<$\> if desired. |
The input_record_separator C<$/> is not explicitly supported - but an |
identical function can be obtained with a suitable B<are_match> setting. |
Record separators are experimental in Version 0.17. They are not saved |
in the configuration_file. |
The tied FileHandle methods may be combined with the Win32::SerialPort |
methods for B<read, input>, and B<write> as well as other methods. The |
typical restrictions against mixing B<print> with B<syswrite> do not |
apply. Since both B<(tied) read> and B<sysread> call the same C<$ob-E<gt>READ> |
method, and since a separate C<$ob-E<gt>read> method has existed for some |
time in Win32::SerialPort, you should always use B<sysread> with the |
tied interface. Beginning in Version 0.17, B<sysread> checks the input |
against B<stty_icrnl>, B<stty_inlcr>, and B<stty_igncr>. With B<stty_igncr> |
active, the B<sysread> returns the count of all characters received including |
and C<\r> characters subsequently deleted. |
Because all the tied methods block, they should ALWAYS be used with |
timeout settings and are not suitable for background operations and |
polled loops. The B<sysread> method may return fewer characters than |
requested when a timeout occurs. The method call is still considered |
successful. If a B<sysread> times out after receiving some characters, |
the actual elapsed time may be as much as twice the programmed limit. |
If no bytes are received, the normal timing applies. |
=head2 Configuration and Capability Methods |
Starting in Version 0.18, a number of I<Application Variables> are saved |
in B<$Configuration_File>. These parameters are not used internally. But |
methods allow setting and reading them. The intent is to facilitate the |
use of separate I<configuration scripts> to create the files. Then an |
application can use B<start> as the Constructor and not bother with |
command line processing or managing its own small configuration file. |
The default values and number of parameters is subject to change. |
$PortObj->devicetype('none'); |
$PortObj->hostname('localhost'); # for socket-based implementations |
$PortObj->hostaddr(0); # a "false" value |
$PortObj->datatype('raw'); # 'record' is another possibility |
$PortObj->cfg_param_1('none'); |
$PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
$PortObj->cfg_param_3('none'); |
The Win32 Serial Comm API provides extensive information concerning |
the capabilities and options available for a specific port (and |
instance). "Modem" ports have different capabilties than "RS-232" |
ports - even if they share the same Hardware. Many traditional modem |
actions are handled via TAPI. "Fax" ports have another set of options - |
and are accessed via MAPI. Yet many of the same low-level API commands |
and data structures are "common" to each type ("Modem" is implemented |
as an "RS-232" superset). In addition, Win95 supports a variety of |
legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
16-data-bit paths, and 256Kbaud. |
=over 8 |
Binary selections will accept as I<true> any of the following: |
C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
Anything else is I<false>. |
There are a large number of possible configuration and option parameters. |
To facilitate checking option validity in scripts, most configuration |
methods can be used in three different ways: |
=item method called with an argument |
The parameter is set to the argument, if valid. An invalid argument |
returns I<false> (undef) and the parameter is unchanged. The function |
will also I<carp> if B<$user_msg> is I<true>. After B<write_settings>, |
the port will be updated immediately if allowed. Otherwise, the value |
will be applied when B<write_settings> is called. |
=item method called with no argument in scalar context |
The current value is returned. If the value is not initialized either |
directly or by default, return "undef" which will parse to I<false>. |
For binary selections (true/false), return the current value. All |
current values from "multivalue" selections will parse to I<true>. |
Current values may differ from requested values until B<write_settings>. |
There is no way to see requests which have not yet been applied. |
Setting the same parameter again overwrites the first request. Test |
the return value of the setting method to check "success". |
=item method called with no argument in list context |
Return a list consisting of all acceptable choices for parameters with |
discrete choices. Return a list C<(minimum, maximum)> for parameters |
which can be set to a range of values. Binary selections have no need |
to call this way - but will get C<(0,1)> if they do. Beginning in |
Version 0.16, Binary selections inherited from Win32API::CommPort may |
not return anything useful in list context. The null list C<(undef)> |
will be returned for failed calls in list context (e.g. for an invalid |
or unexpected argument). |
=item Asynchronous (Background) I/O |
The module handles Polling (do if Ready), Synchronous (block until |
Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
choices provided by the API. No effort has yet been made to interact with |
Windows events. But background I/O has been used successfully with the |
Perl Tk modules and callbacks from the event loop. |
=item Timeouts |
The API provides two timing models. The first applies only to reading and |
essentially determines I<Read Not Ready> by checking the time between |
consecutive characters. The B<ReadFile> operation returns if that time |
exceeds the value set by B<read_interval>. It does this by timestamping |
each character. It appears that at least one character must by received in |
I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
is then reset by each succeeding character. If no characters are received, |
the read will block indefinitely. |
Setting B<read_interval> to C<0xffffffff> will do a non-blocking read. |
The B<ReadFile> returns immediately whether or not any characters are |
actually read. This replicates the behavior of the API. |
The other model defines the total time allowed to complete the operation. |
A fixed overhead time is added to the product of bytes and per_byte_time. |
A wide variety of timeout options can be defined by selecting the three |
parameters: fixed, each, and size. |
Read_Total = B<read_const_time> + (B<read_char_time> * bytes_to_read) |
Write_Total = B<write_const_time> + (B<write_char_time> * bytes_to_write) |
When reading a known number of characters, the I<Read_Total> mechanism is |
recommended. This mechanism I<MUST> be used with I<tied FileHandles> because |
the tie methods can make multiple internal API calls in response to a single |
B<sysread> or B<READLINE>. The I<Read_Interval> mechanism is suitable for |
a B<read> method that expects a response of variable or unknown size. You |
should then also set a long I<Read_Total> timeout as a "backup" in case |
no bytes are received. |
=back |
=head2 Exports |
Nothing is exported by default. Nothing is currently exported. Optional |
tags from Win32API::CommPort are passed through. |
=over 4 |
=item :PARAM |
Utility subroutines and constants for parameter setting and test: |
LONGsize SHORTsize nocarp yes_true |
OS_Error internal_buffer |
=item :STAT |
Serial communications constants from Win32API::CommPort. Included are the |
constants for ascertaining why a transmission is blocked: |
BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
Which incoming bits are active: |
MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
What hardware errors have been detected: |
CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL CE_MODE |
Offsets into the array returned by B<status:> |
ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
=back |
=head2 Stty Emulation |
Nothing wrong with dreaming! A subset of stty options is available |
through a B<stty> method. The purpose is support of existing serial |
devices which have embedded knowledge of Unix communication line and |
login practices. It is also needed by Tom Christiansen's Perl Power Tools |
project. This is new and experimental in Version 0.15. The B<stty> method |
returns an array of "traditional stty values" when called with no |
arguments. With arguments, it sets the corresponding parameters. |
$ok = $PortObj->stty("-icanon"); # equivalent to stty_icanon(0) |
@stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
$ok = $PortObj->stty("cs7",19200); # multiple parameters |
$ok = $PortObj->stty(@stty_save); # many parameters |
The distribution includes a demo script, stty.plx, which gives details |
of usage. Not all Unix parameters are currently supported. But the array |
will contain all those which can be set. The order in C<@stty_all> will |
match the following pattern: |
baud, # numeric, always first |
"intr", character, # the parameters which set special characters |
"name", character, ... |
"stop", character, # "stop" will always be the last "pair" |
"parameter", # the on/off settings |
"-parameter", ... |
Version 0.13 added the primitive functions required to implement this |
feature. A number of methods named B<stty_xxx> do what an |
I<experienced stty user> would expect. |
Unlike B<stty> on Unix, the B<stty_xxx> operations apply only to I/O |
processed via the B<lookfor> method or the I<tied FileHandle> methods. |
The B<read, input, read_done, write> methods all treat data as "raw". |
The following stty functions have related SerialPort functions: |
--------------------------------------------------------------- |
stty (control) SerialPort Default Value |
---------------- ------------------ ------------- |
parenb inpck parity_enable from port |
parodd parity from port |
cs5 cs6 cs7 cs8 databits from port |
cstopb stopbits from port |
clocal crtscts handshake from port |
ixon ixoff handshake from port |
time read_const_time from port |
110 300 600 1200 2400 baudrate from port |
4800 9600 19200 38400 baudrate |
75 134.5 150 1800 fixed baud only - not selectable |
g, "stty < /dev/x" start, save none |
sane restart none |
stty (input) SerialPort Default Value |
---------------- ------------------ ------------- |
istrip stty_istrip off |
igncr stty_igncr off |
inlcr stty_inlcr off |
icrnl stty_icrnl on |
parmrk error_char from port (off typ) |
stty (output) SerialPort Default Value |
---------------- ------------------ ------------- |
ocrnl stty_ocrnl off if opost |
onlcr stty_onlcr on if opost |
opost stty_opost off |
stty (local) SerialPort Default Value |
---------------- ------------------ ------------- |
raw read, write, input none |
cooked lookfor none |
echo stty_echo off |
echoe stty_echoe on if echo |
echok stty_echok on if echo |
echonl stty_echonl off |
echoke stty_echoke on if echo |
echoctl stty_echoctl off |
isig stty_isig off |
icanon stty_icanon off |
stty (char) SerialPort Default Value |
---------------- ------------------ ------------- |
intr stty_intr "\cC" |
is_stty_intr 3 |
quit stty_quit "\cD" |
is_stty_quit 4 |
erase stty_erase "\cH" |
is_stty_erase 8 |
(erase echo) stty_bsdel "\cH \cH" |
kill stty_kill "\cU" |
is_stty_kill 21 |
(kill echo) stty_clear "\r {76}\r" |
is_stty_clear "-@{76}-" |
eof stty_eof "\cZ" |
is_stty_eof 26 |
eol stty_eol "\cJ" |
is_stty_eol 10 |
start xon_char from port ("\cQ" typ) |
is_xon_char 17 |
stop xoff_char from port ("\cS" typ) |
is_xoff_char 19 |
The following stty functions have no equivalent in SerialPort: |
-------------------------------------------------------------- |
[-]hup [-]ignbrk [-]brkint [-]ignpar |
[-]tostop susp 0 50 |
134 200 exta extb |
[-]cread [-]hupcl |
The stty function list is taken from the documentation for IO::Stty by |
Austin Schutz. |
=head2 Lookfor and I/O Processing |
Many of the B<stty_xxx> methods support features which are necessary for |
line-oriented input (such as command-line handling). These include methods |
which select control-keys to delete characters (B<stty_erase>) and lines |
(B<stty_kill>), define input boundaries (B<stty_eol, stty_eof>), and abort |
processing (B<stty_intr, stty_quit>). These keys also have B<is_stty_xxx> |
methods which convert the key-codes to numeric equivalents which can be |
saved in the configuration file. |
Some communications programs have a different but related need - to collect |
(or discard) input until a specific pattern is detected. For lines, the |
pattern is a line-termination. But there are also requirements to search |
for other strings in the input such as "username:" and "password:". The |
B<lookfor> method provides a consistant mechanism for solving this problem. |
It searches input character-by-character looking for a match to any of the |
elements of an array set using the B<are_match> method. It returns the |
entire input up to the match pattern if a match is found. If no match |
is found, it returns "" unless an input error or abort is detected (which |
returns undef). |
The actual match and the characters after it (if any) may also be viewed |
using the B<lastlook> method. In Version 0.13, the match test included |
a C<s/$pattern//s> test which worked fine for literal text but returned |
the I<Regular Expression> that matched when C<$pattern> contained any Perl |
metacharacters. That was probably a bug - although no one reported it. |
In Version 0.14, B<lastlook> returns both the input and the pattern from |
the match test. It also adopts the convention from Expect.pm that match |
strings are literal text (tested using B<index>) unless preceeded in the |
B<are_match> list by a B<"-re",> entry. The default B<are_match> list |
is C<("\n")>, which matches complete lines. |
my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
# input that MATCHED, input AFTER the match, PATTERN that matched |
# input received INSTEAD when timeout without match ("" if match) |
$PortObj->are_match("text1", "-re", "pattern", "text2"); |
# possible match strings: "pattern" is a regular expression, |
# "text1" and "text2" are literal strings |
The I<Regular Expression> handling in B<lookfor> is still |
experimental. Please let me know if you use it (or can't use it), so |
I can confirm bug fixes don't break your code. For literal strings, |
C<$match> and C<$pattern> should be identical. The C<$instead> value |
returns the internal buffer tested by the match logic. A successful |
match or a B<lookclear> resets it to "" - so it is only useful for error |
handling such as timeout processing or reporting unexpected responses. |
The B<lookfor> method is designed to be sampled periodically (polled). Any |
characters after the match pattern are saved for a subsequent B<lookfor>. |
Internally, B<lookfor> is implemented using the nonblocking B<input> method |
when called with no parameter. If called with a count, B<lookfor> calls |
C<$PortObj-E<gt>read(count)> which blocks until the B<read> is I<Complete> or |
a I<Timeout> occurs. The blocking alternative should not be used unless a |
fault time has been defined using B<read_interval, read_const_time, and |
read_char_time>. It exists mostly to support the I<tied FileHandle> |
functions B<sysread, getc,> and B<E<lt>FHE<gt>>. |
The internal buffers used by B<lookfor> may be purged by the B<lookclear> |
method (which also clears the last match). For testing, B<lookclear> can |
accept a string which is "looped back" to the next B<input>. This feature |
is enabled only when C<set_test_mode_active(1)>. Normally, B<lookclear> |
will return C<undef> if given parameters. It still purges the buffers and |
last_match in that case (but nothing is "looped back"). You will want |
B<stty_echo(0)> when exercising loopback. |
Version 0.15 adds a B<matchclear> method. It is designed to handle the |
"special case" where the match string is the first character(s) received |
by B<lookfor>. In this case, C<$lookfor_return == "">, B<lookfor> does |
not provide a clear indication that a match was found. The B<matchclear> |
returns the same C<$match> that would be returned by B<lastlook> and |
resets it to "" without resetting any of the other buffers. Since the |
B<lookfor> already searched I<through> the match, B<matchclear> is used |
to both detect and step-over "blank" lines. |
The character-by-character processing used by B<lookfor> to support the |
I<stty emulation> is fine for interactive activities and tasks which |
expect short responses. But it has too much "overhead" to handle fast |
data streams. Version 0.15 adds a B<streamline> method which is a fast, |
line-oriented alternative with no echo support or input handling except |
for pattern searching. Exact benchmarks will vary with input data and |
patterns, but my tests indicate B<streamline> is 10-20 times faster then |
B<lookfor> when uploading files averaging 25-50 characters per line. |
Since B<streamline> uses the same internal buffers, the B<lookclear, |
lastlook, are_match, and matchclear> methods act the same in both cases. |
In fact, calls to B<streamline> and B<lookfor> can be interleaved if desired |
(e.g. an interactive task that starts an upload and returns to interactive |
activity when it is complete). |
Beginning in Version 0.15, the B<READLINE> method supports "list context". |
A tied FileHandle can slurp in a whole file with an "@lines = E<lt>FHE<gt>" |
construct. In "scalar context", B<READLINE> calls B<lookfor>. But it calls |
B<streamline> in "list context". Both contexts also call B<matchclear> |
to detect "empty" lines and B<reset_error> to detect hardware problems. |
The existance of a hardware fault is reported with C<$^E>, although the |
specific fault is only reported when B<error_msg> is true. |
There are two additional methods for supporting "list context" input: |
B<lastline> sets an "end_of_file" I<Regular Expression>, and B<linesize> |
permits changing the "packet size" in the blocking read operation to allow |
tuning performance to data characteristics. These two only apply during |
B<READLINE>. The default for B<linesize> is 1. There is no default for |
the B<lastline> method. |
In Version 0.15, I<Regular Expressions> set by B<are_match> and B<lastline> |
will be pre-compiled using the I<qr//> construct on Perl 5.005 and higher. |
This doubled B<lookfor> and B<streamline> speed in my tests with |
I<Regular Expressions> - but actual improvements depend on both patterns |
and input data. |
The functionality of B<lookfor> includes a limited subset of the capabilities |
found in Austin Schutz's I<Expect.pm> for Unix (and Tcl's expect which it |
resembles). The C<$before, $match, $pattern, and $after> return values are |
available if someone needs to create an "expect" subroutine for porting a |
script. When using multiple patterns, there is one important functional |
difference: I<Expect.pm> looks at each pattern in turn and returns the first |
match found; B<lookfor> and B<streamline> test all patterns and return the |
one found I<earliest> in the input if more than one matches. |
Because B<lookfor> can be used to manage a command-line environment much |
like a Unix serial login, a number of "stty-like" methods are included to |
handle the issues raised by serial logins. One issue is dissimilar line |
terminations. This is addressed by the following methods: |
$PortObj->stty_icrnl; # map \r to \n on input |
$PortObj->stty_igncr; # ignore \r on input |
$PortObj->stty_inlcr; # map \n to \r on input |
$PortObj->stty_ocrnl; # map \r to \n on output |
$PortObj->stty_onlcr; # map \n to \r\n on output |
$PortObj->stty_opost; # enable output mapping |
The default specifies a raw device with no input or output processing. |
In Version 0.14, the default was a device which sends "\r" at the end |
of a line, requires "\r\n" to terminate incoming lines, and expects the |
"host" to echo every keystroke. Many "dumb terminals" act this way and |
the defaults were similar to Unix defaults. But some users found this |
ackward and confusing. |
Sometimes, you want perl to echo input characters back to the serial |
device (and other times you don't want that). |
$PortObj->stty_echo; # echo every character |
$PortObj->stty_echoe; # if echo erase with bsdel string (default) |
$PortObj->stty_echok; # if echo \n after kill character (default) |
$PortObj->stty_echonl; # echo \n even if stty_echo(0) |
$PortObj->stty_echoke; # if echo clear string after kill (default) |
$PortObj->stty_echoctl; # if echo "^Char" for control chars |
$PortObj->stty_istrip; # strip input to 7-bits |
my $air = " "x76; # overwrite entire line with spaces |
$PortObj->stty_clear("\r$air\r"); # written after kill character |
$PortObj->is_prompt("PROMPT:"); # need to write after kill |
$PortObj->stty_bsdel("\cH \cH"); # written after erase character |
# internal method that permits clear string with \r in config file |
my $plus32 = "@"x76; # overwrite line with spaces (ord += 32) |
$PortObj->is_stty_clear("-$plus32-"); # equivalent to stty_clear |
=head1 NOTES |
The object returned by B<new> or B<start> is NOT a I<FileHandle>. You |
will be disappointed if you try to use it as one. If you need a |
I<FileHandle>, you must use B<tie> as the constructor. |
e.g. the following is WRONG!!____C<print $PortObj "some text";> |
You need something like this (Perl 5.005): |
# construct |
$tie_ob = tie(*FOO,'Win32::SerialPort', $cfgfile) |
or die "Can't start $cfgfile\n"; |
print FOO "enter char: "; # destination is FileHandle, not Object |
my $in = getc FOO; |
syswrite FOO, "$in\n", 2, 0; |
print FOO "enter line: "; |
$in = <FOO>; |
printf FOO "received: %s\n", $in; |
print FOO "enter 5 char: "; |
sysread (FOO, $in, 5, 0) or die; |
printf FOO "received: %s\n", $in; |
# destruct |
close FOO || print "close failed\n"; |
undef $tie_ob; # Don't forget this one!! |
untie *FOO; |
Always include the C<undef $tie_ob> before the B<untie>. See the I<Gotcha> |
description in I<perltie>. |
The Perl 5.004 implementation of I<tied FileHandles> is missing |
B<close> and B<syswrite>. The Perl 5.003 version is essentially unusable. |
If you need these functions, consider Perl 5.005 seriously. |
An important note about Win32 filenames. The reserved device names such |
as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
Thanks to Ken White for testing on NT. |
There is a linux clone of this module implemented using I<POSIX.pm>. |
It also runs on AIX and Solaris, and will probably run on other POSIX |
systems as well. It does not currently support the complete set of methods - |
although portability of user programs is excellent for the calls it does |
support. It is available from CPAN as I<Device::SerialPort>. |
=head1 KNOWN LIMITATIONS |
Since everything is (sometimes convoluted but still pure) Perl, you can |
fix flaws and change limits if required. But please file a bug report if |
you do. This module has been tested with each of the binary perl versions |
for which Win32::API is supported: AS builds 315, 316, 500-509 and GS |
5.004_02. It has only been tested on Intel hardware. |
Although the B<lookfor, stty_xxx, and Tied FileHandle> mechanisms are |
considered stable, they have only been tested on a small subset of possible |
applications. While "\r" characters may be included in the clear string |
using B<is_stty_clear> internally, "\n" characters may NOT be included |
in multi-character strings if you plan to save the strings in a configuration |
file (which uses "\n" as an internal terminator). |
=over 4 |
=item Tutorial |
With all the options, this module needs a good tutorial. It doesn't |
have a complete one yet. A I<"How to get started"> tutorial appeared |
B<The Perl Journal #13> (March 1999). Examples from the article are |
available from http://tpj.com and from http://members.aol.com/Bbirthisel. |
The demo programs in the distribution are a good starting point for |
additional examples. |
=item Buffers |
The size of the Win32 buffers are selectable with B<buffers>. But each read |
method currently uses a fixed internal buffer of 4096 bytes. This can be |
changed in the Win32API::CommPort source and read with B<internal_buffer>. |
The XS version will support dynamic buffer sizing. Large operations are |
automatically converted to multiple smaller ones by the B<tied FileHandle> |
methods. |
=item Modems |
Lots of modem-specific options are not supported. The same is true of |
TAPI, MAPI. I<API Wizards> are welcome to contribute. |
=item API Options |
Lots of options are just "passed through from the API". Some probably |
shouldn't be used together. The module validates the obvious choices when |
possible. For something really fancy, you may need additional API |
documentation. Available from I<Micro$oft Pre$$>. |
=back |
=head1 BUGS |
On Win32, a port must B<close> before it can be reopened again by the same |
process. If a physical port can be accessed using more than one name (see |
above), all names are treated as one. The perl script can also be run |
multiple times within a single batch file or shell script. The I<Makefile.PL> |
spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
but it works. |
On NT, a B<read_done> or B<write_done> returns I<False> if a background |
operation is aborted by a purge. Win95 returns I<True>. |
EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
A few NT systems seem to set B<can_parity_enable> true, but do not actually |
support setting B<parity_enable>. This may be a characteristic of certain |
third-party serial drivers. |
__Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
=head1 AUTHORS |
Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
=head1 SEE ALSO |
Win32API::CommPort - the low-level API calls which support this module |
Win32API::File I<when available> |
Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
Expect.pm - Austin Schutz's adaptation of TCL's "expect" for Unix Perls |
=head1 COPYRIGHT |
Copyright (C) 1999, Bill Birthisel. All rights reserved. |
This module is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head2 COMPATIBILITY |
Most of the code in this module has been stable since version 0.12. |
Except for items indicated as I<Experimental>, I do not expect functional |
changes which are not fully backwards compatible. However, Version 0.16 |
removes the "dummy (0, 1) list" which was returned by many binary methods |
in case they were called in list context. I do not know of any use outside |
the test suite for that feature. |
Version 0.12 added an I<Install.PL> script to put modules into the documented |
Namespaces. The script uses I<MakeMaker> tools not available in |
ActiveState 3xx builds. Users of those builds will need to install |
differently (see README). Programs in the test suite are modified for |
the current version. Additions to the configurtion files generated by |
B<save> prevent those created by Version 0.18 from being used by earlier |
Versions. 4 November 1999. |
=cut |
/MissionCockpit/tags/V0.4.1/perl/lib/Win32API/CommPort-Orig.pm |
---|
0,0 → 1,3146 |
# This part includes the low-level API calls |
package Win32API::CommPort; |
use Win32; |
use Win32::API 0.01; |
if ( $] < 5.004 ) { |
my $no_silly_warning = $Win32::API::VERSION; |
$no_silly_warning = $Win32::API::pack; |
} |
use Carp; |
use strict; |
#### API declarations #### |
no strict 'subs'; # these may be imported someday |
use vars qw( |
$_CloseHandle $_CreateFile $_GetCommState |
$_ReadFile $_SetCommState $_SetupComm |
$_PurgeComm $_CreateEvent $_GetCommTimeouts |
$_SetCommTimeouts $_GetCommProperties $_ClearCommBreak |
$_ClearCommError $_EscapeCommFunction $_GetCommConfig |
$_GetCommMask $_GetCommModemStatus $_SetCommBreak |
$_SetCommConfig $_SetCommMask $_TransmitCommChar |
$_WaitCommEvent $_WriteFile $_ResetEvent |
$_GetOverlappedResult |
); |
$_CreateFile = new Win32::API("kernel32", "CreateFile", |
[P, N, N, N, N, N, N], N); |
$_CloseHandle = new Win32::API("kernel32", "CloseHandle", [N], N); |
$_GetCommState = new Win32::API("kernel32", "GetCommState", [N, P], I); |
$_SetCommState = new Win32::API("kernel32", "SetCommState", [N, P], I); |
$_SetupComm = new Win32::API("kernel32", "SetupComm", [N, N, N], I); |
$_PurgeComm = new Win32::API("kernel32", "PurgeComm", [N, N], I); |
$_CreateEvent = new Win32::API("kernel32", "CreateEvent", [P, I, I, P], N); |
$_GetCommTimeouts = new Win32::API("kernel32", "GetCommTimeouts", |
[N, P], I); |
$_SetCommTimeouts = new Win32::API("kernel32", "SetCommTimeouts", |
[N, P], I); |
$_GetCommProperties = new Win32::API("kernel32", "GetCommProperties", |
[N, P], I); |
$_ReadFile = new Win32::API("kernel32", "ReadFile", [N, P, N, P, P], I); |
$_WriteFile = new Win32::API("kernel32", "WriteFile", [N, P, N, P, P], I); |
$_TransmitCommChar = new Win32::API("kernel32", "TransmitCommChar", [N, I], I); |
$_ClearCommBreak = new Win32::API("kernel32", "ClearCommBreak", [N], I); |
$_SetCommBreak = new Win32::API("kernel32", "SetCommBreak", [N], I); |
$_ClearCommError = new Win32::API("kernel32", "ClearCommError", [N, P, P], I); |
$_EscapeCommFunction = new Win32::API("kernel32", "EscapeCommFunction", |
[N, N], I); |
$_GetCommModemStatus = new Win32::API("kernel32", "GetCommModemStatus", |
[N, P], I); |
$_GetOverlappedResult = new Win32::API("kernel32", "GetOverlappedResult", |
[N, P, P, I], I); |
#### these are not used yet |
$_GetCommConfig = new Win32::API("kernel32", "GetCommConfig", [N, P, P], I); |
$_GetCommMask = new Win32::API("kernel32", "GetCommMask", [N, P], I); |
$_SetCommConfig = new Win32::API("kernel32", "SetCommConfig", [N, P, N], I); |
$_SetCommMask = new Win32::API("kernel32", "SetCommMask", [N, N], I); |
$_WaitCommEvent = new Win32::API("kernel32", "WaitCommEvent", [N, P, P], I); |
$_ResetEvent = new Win32::API("kernel32", "ResetEvent", [N], I); |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $RBUF_Size); |
$VERSION = '0.19'; |
$RBUF_Size = 4096; |
require Exporter; |
## require AutoLoader; |
@ISA = qw(Exporter); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= qw(); |
%EXPORT_TAGS = (STAT => [qw( BM_fCtsHold BM_fDsrHold |
BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof |
BM_fTxim BM_AllBits |
MS_CTS_ON MS_DSR_ON |
MS_RING_ON MS_RLSD_ON |
CE_RXOVER CE_OVERRUN |
CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL |
CE_MODE ST_BLOCK |
ST_INPUT ST_OUTPUT |
ST_ERROR )], |
RAW => [qw( CloseHandle CreateFile |
GetCommState ReadFile |
SetCommState SetupComm |
PurgeComm CreateEvent |
GetCommTimeouts SetCommTimeouts |
GetCommProperties ClearCommBreak |
ClearCommError EscapeCommFunction |
GetCommConfig GetCommMask |
GetCommModemStatus SetCommBreak |
SetCommConfig SetCommMask |
TransmitCommChar WaitCommEvent |
WriteFile ResetEvent |
GetOverlappedResult |
PURGE_TXABORT PURGE_RXABORT |
PURGE_TXCLEAR PURGE_RXCLEAR |
SETXOFF SETXON |
SETRTS CLRRTS |
SETDTR CLRDTR |
SETBREAK CLRBREAK |
EV_RXCHAR EV_RXFLAG |
EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD |
EV_BREAK EV_ERR |
EV_RING EV_PERR |
EV_RX80FULL EV_EVENT1 |
EV_EVENT2 ERROR_IO_INCOMPLETE |
ERROR_IO_PENDING )], |
COMMPROP => [qw( BAUD_USER BAUD_075 BAUD_110 |
BAUD_134_5 BAUD_150 BAUD_300 |
BAUD_600 BAUD_1200 BAUD_1800 |
BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 |
BAUD_38400 BAUD_56K BAUD_57600 |
BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM |
PST_RS232 PST_RS422 PST_RS423 |
PST_RS449 PST_SCANNER PST_X25 |
PST_NETWORK_BRIDGE PST_PARALLELPORT |
PST_TCPIP_TELNET PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK |
PCF_16BITMODE PCF_DTRDSR |
PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR |
PCF_TOTALTIMEOUTS PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING |
SP_PARITY SP_PARITY_CHECK SP_RLSD |
SP_STOPBITS SP_SERIALCOMM |
DATABITS_5 DATABITS_6 DATABITS_7 |
DATABITS_8 DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD |
PARITY_EVEN PARITY_MARK |
COMMPROP_INITIALIZED )], |
DCB => [qw( CBR_110 CBR_300 CBR_600 |
CBR_1200 CBR_2400 CBR_4800 |
CBR_9600 CBR_14400 CBR_19200 |
CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE |
DTR_CONTROL_HANDSHAKE RTS_CONTROL_DISABLE |
RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY |
ODDPARITY SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity |
FM_fOutxCtsFlow FM_fOutxDsrFlow |
FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX |
FM_fInX FM_fErrorChar |
FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 )], |
PARAM => [qw( LONGsize SHORTsize OS_Error |
nocarp internal_buffer yes_true )]); |
Exporter::export_ok_tags('STAT', 'RAW', 'COMMPROP', 'DCB', 'PARAM'); |
$EXPORT_TAGS{ALL} = \@EXPORT_OK; |
#### subroutine wrappers for API calls |
sub CloseHandle { |
return unless ( 1 == @_ ); |
return $_CloseHandle->Call( shift ); |
} |
sub CreateFile { |
return $_CreateFile->Call( @_ ); |
# returns handle |
} |
sub GetCommState { |
return $_GetCommState->Call( @_ ); |
} |
sub SetCommState { |
return $_SetCommState->Call( @_ ); |
} |
sub SetupComm { |
return $_SetupComm->Call( @_ ); |
} |
sub PurgeComm { |
return $_PurgeComm->Call( @_ ); |
} |
sub CreateEvent { |
return $_CreateEvent->Call( @_ ); |
} |
sub GetCommTimeouts { |
return $_GetCommTimeouts->Call( @_ ); |
} |
sub SetCommTimeouts { |
return $_SetCommTimeouts->Call( @_ ); |
} |
sub GetCommProperties { |
return $_GetCommProperties->Call( @_ ); |
} |
sub ReadFile { |
return $_ReadFile->Call( @_ ); |
} |
sub WriteFile { |
return $_WriteFile->Call( @_ ); |
} |
sub TransmitCommChar { |
return $_TransmitCommChar->Call( @_ ); |
} |
sub ClearCommBreak { |
return unless ( 1 == @_ ); |
return $_ClearCommBreak->Call( shift ); |
} |
sub SetCommBreak { |
return unless ( 1 == @_ ); |
return $_SetCommBreak->Call( shift ); |
} |
sub ClearCommError { |
return $_ClearCommError->Call( @_ ); |
} |
sub EscapeCommFunction { |
return $_EscapeCommFunction->Call( @_ ); |
} |
sub GetCommModemStatus { |
return $_GetCommModemStatus->Call( @_ ); |
} |
sub GetOverlappedResult { |
return $_GetOverlappedResult->Call( @_ ); |
} |
sub GetCommConfig { |
return $_GetCommConfig->Call( @_ ); |
} |
sub GetCommMask { |
return $_GetCommMask->Call( @_ ); |
} |
sub SetCommConfig { |
return $_SetCommConfig->Call( @_ ); |
} |
sub SetCommMask { |
return $_SetCommMask->Call( @_ ); |
} |
sub WaitCommEvent { |
return $_WaitCommEvent->Call( @_ ); |
} |
sub ResetEvent { |
return unless ( 1 == @_ ); |
return $_ResetEvent->Call( shift ); |
} |
#### "constant" declarations from Win32 header files #### |
#### compatible with ActiveState #### |
## COMMPROP structure |
sub SP_SERIALCOMM { 0x1 } |
sub BAUD_075 { 0x1 } |
sub BAUD_110 { 0x2 } |
sub BAUD_134_5 { 0x4 } |
sub BAUD_150 { 0x8 } |
sub BAUD_300 { 0x10 } |
sub BAUD_600 { 0x20 } |
sub BAUD_1200 { 0x40 } |
sub BAUD_1800 { 0x80 } |
sub BAUD_2400 { 0x100 } |
sub BAUD_4800 { 0x200 } |
sub BAUD_7200 { 0x400 } |
sub BAUD_9600 { 0x800 } |
sub BAUD_14400 { 0x1000 } |
sub BAUD_19200 { 0x2000 } |
sub BAUD_38400 { 0x4000 } |
sub BAUD_56K { 0x8000 } |
sub BAUD_57600 { 0x40000 } |
sub BAUD_115200 { 0x20000 } |
sub BAUD_128K { 0x10000 } |
sub BAUD_USER { 0x10000000 } |
sub PST_FAX { 0x21 } |
sub PST_LAT { 0x101 } |
sub PST_MODEM { 0x6 } |
sub PST_NETWORK_BRIDGE { 0x100 } |
sub PST_PARALLELPORT { 0x2 } |
sub PST_RS232 { 0x1 } |
sub PST_RS422 { 0x3 } |
sub PST_RS423 { 0x4 } |
sub PST_RS449 { 0x5 } |
sub PST_SCANNER { 0x22 } |
sub PST_TCPIP_TELNET { 0x102 } |
sub PST_UNSPECIFIED { 0 } |
sub PST_X25 { 0x103 } |
sub PCF_16BITMODE { 0x200 } |
sub PCF_DTRDSR { 0x1 } |
sub PCF_INTTIMEOUTS { 0x80 } |
sub PCF_PARITY_CHECK { 0x8 } |
sub PCF_RLSD { 0x4 } |
sub PCF_RTSCTS { 0x2 } |
sub PCF_SETXCHAR { 0x20 } |
sub PCF_SPECIALCHARS { 0x100 } |
sub PCF_TOTALTIMEOUTS { 0x40 } |
sub PCF_XONXOFF { 0x10 } |
sub SP_BAUD { 0x2 } |
sub SP_DATABITS { 0x4 } |
sub SP_HANDSHAKING { 0x10 } |
sub SP_PARITY { 0x1 } |
sub SP_PARITY_CHECK { 0x20 } |
sub SP_RLSD { 0x40 } |
sub SP_STOPBITS { 0x8 } |
sub DATABITS_5 { 1 } |
sub DATABITS_6 { 2 } |
sub DATABITS_7 { 4 } |
sub DATABITS_8 { 8 } |
sub DATABITS_16 { 16 } |
sub DATABITS_16X { 32 } |
sub STOPBITS_10 { 1 } |
sub STOPBITS_15 { 2 } |
sub STOPBITS_20 { 4 } |
sub PARITY_NONE { 256 } |
sub PARITY_ODD { 512 } |
sub PARITY_EVEN { 1024 } |
sub PARITY_MARK { 2048 } |
sub PARITY_SPACE { 4096 } |
sub COMMPROP_INITIALIZED { 0xe73cf52e } |
## DCB structure |
sub CBR_110 { 110 } |
sub CBR_300 { 300 } |
sub CBR_600 { 600 } |
sub CBR_1200 { 1200 } |
sub CBR_2400 { 2400 } |
sub CBR_4800 { 4800 } |
sub CBR_9600 { 9600 } |
sub CBR_14400 { 14400 } |
sub CBR_19200 { 19200 } |
sub CBR_38400 { 38400 } |
sub CBR_56000 { 56000 } |
sub CBR_57600 { 57600 } |
sub CBR_115200 { 115200 } |
sub CBR_128000 { 128000 } |
sub CBR_256000 { 256000 } |
sub DTR_CONTROL_DISABLE { 0 } |
sub DTR_CONTROL_ENABLE { 1 } |
sub DTR_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_DISABLE { 0 } |
sub RTS_CONTROL_ENABLE { 1 } |
sub RTS_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_TOGGLE { 3 } |
sub EVENPARITY { 2 } |
sub MARKPARITY { 3 } |
sub NOPARITY { 0 } |
sub ODDPARITY { 1 } |
sub SPACEPARITY { 4 } |
sub ONESTOPBIT { 0 } |
sub ONE5STOPBITS { 1 } |
sub TWOSTOPBITS { 2 } |
## Flowcontrol bit mask in DCB |
sub FM_fBinary { 0x1 } |
sub FM_fParity { 0x2 } |
sub FM_fOutxCtsFlow { 0x4 } |
sub FM_fOutxDsrFlow { 0x8 } |
sub FM_fDtrControl { 0x30 } |
sub FM_fDsrSensitivity { 0x40 } |
sub FM_fTXContinueOnXoff { 0x80 } |
sub FM_fOutX { 0x100 } |
sub FM_fInX { 0x200 } |
sub FM_fErrorChar { 0x400 } |
sub FM_fNull { 0x800 } |
sub FM_fRtsControl { 0x3000 } |
sub FM_fAbortOnError { 0x4000 } |
sub FM_fDummy2 { 0xffff8000 } |
## COMSTAT bit mask |
sub BM_fCtsHold { 0x1 } |
sub BM_fDsrHold { 0x2 } |
sub BM_fRlsdHold { 0x4 } |
sub BM_fXoffHold { 0x8 } |
sub BM_fXoffSent { 0x10 } |
sub BM_fEof { 0x20 } |
sub BM_fTxim { 0x40 } |
sub BM_AllBits { 0x7f } |
## PurgeComm bit mask |
sub PURGE_TXABORT { 0x1 } |
sub PURGE_RXABORT { 0x2 } |
sub PURGE_TXCLEAR { 0x4 } |
sub PURGE_RXCLEAR { 0x8 } |
## GetCommModemStatus bit mask |
sub MS_CTS_ON { 0x10 } |
sub MS_DSR_ON { 0x20 } |
sub MS_RING_ON { 0x40 } |
sub MS_RLSD_ON { 0x80 } |
## EscapeCommFunction operations |
sub SETXOFF { 0x1 } |
sub SETXON { 0x2 } |
sub SETRTS { 0x3 } |
sub CLRRTS { 0x4 } |
sub SETDTR { 0x5 } |
sub CLRDTR { 0x6 } |
sub SETBREAK { 0x8 } |
sub CLRBREAK { 0x9 } |
## ClearCommError bit mask |
sub CE_RXOVER { 0x1 } |
sub CE_OVERRUN { 0x2 } |
sub CE_RXPARITY { 0x4 } |
sub CE_FRAME { 0x8 } |
sub CE_BREAK { 0x10 } |
sub CE_TXFULL { 0x100 } |
#### LPT only |
# sub CE_PTO { 0x200 } |
# sub CE_IOE { 0x400 } |
# sub CE_DNS { 0x800 } |
# sub CE_OOP { 0x1000 } |
#### LPT only |
sub CE_MODE { 0x8000 } |
## GetCommMask bits |
sub EV_RXCHAR { 0x1 } |
sub EV_RXFLAG { 0x2 } |
sub EV_TXEMPTY { 0x4 } |
sub EV_CTS { 0x8 } |
sub EV_DSR { 0x10 } |
sub EV_RLSD { 0x20 } |
sub EV_BREAK { 0x40 } |
sub EV_ERR { 0x80 } |
sub EV_RING { 0x100 } |
sub EV_PERR { 0x200 } |
sub EV_RX80FULL { 0x400 } |
sub EV_EVENT1 { 0x800 } |
sub EV_EVENT2 { 0x1000 } |
## Allowed OVERLAP errors |
sub ERROR_IO_INCOMPLETE { 996 } |
sub ERROR_IO_PENDING { 997 } |
#### "constant" declarations compatible with ActiveState #### |
my $DCBformat="LLLSSSCCCCCCCCS"; |
my $CP_format1="SSLLLLLLLLLSSLLLLSA*"; # rs232 |
my $CP_format6="SSLLLLLLLLLSSLLLLLLLLLLLLLLLLLLLLLLLA*"; # modem |
my $CP_format0="SA50LA244"; # pre-read |
my $OVERLAPPEDformat="LLLLL"; |
my $TIMEOUTformat="LLLLL"; |
my $COMSTATformat="LLL"; |
my $cfg_file_sig="Win32API::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
sub SHORTsize { 0xffff; } |
sub LONGsize { 0xffffffff; } |
sub ST_BLOCK {0} # status offsets for caller |
sub ST_INPUT {1} |
sub ST_OUTPUT {2} |
sub ST_ERROR {3} # latched |
#### Package variable declarations #### |
my @Yes_resp = ( |
"YES","Y", |
"ON", |
"TRUE","T", |
"1" |
); |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $Babble = 0; |
my $testactive = 0; # test mode active |
## my $null=[]; |
my $null=0; |
my $zero=0; |
# Preloaded methods go here. |
sub OS_Error { print Win32::FormatMessage ( Win32::GetLastError() ); } |
sub get_tick_count { return Win32::GetTickCount(); } |
# test*.t only - suppresses default messages |
sub set_no_messages { |
return unless (@_ == 2); |
$testactive = yes_true($_[1]); |
} |
sub nocarp { return $testactive } |
sub internal_buffer { return $RBUF_Size } |
sub yes_true { |
my $choice = uc shift; |
my $ans = 0; |
foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) } |
return $ans; |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $self = {}; |
my $ok = 0; # API return value |
my $hr = 0; # temporary hashref |
my $fmask = 0; # temporary for bit banging |
my $fix_baud = 0; |
my $key; |
my $value; |
my $CommPropBlank = " "; |
# COMMPROP only used during new |
my $CommProperties = " "x300; # extra buffer for modems |
my $CP_Length = 0; |
my $CP_Version = 0; |
my $CP_ServiceMask = 0; |
my $CP_Reserved1 = 0; |
my $CP_MaxBaud = 0; |
my $CP_ProvCapabilities = 0; |
my $CP_SettableParams = 0; |
my $CP_SettableBaud = 0; |
my $CP_SettableData = 0; |
my $CP_SettableStopParity = 0; |
my $CP_ProvSpec1 = 0; |
my $CP_ProvSpec2 = 0; |
my $CP_ProvChar_start = 0; |
my $CP_Filler = 0; |
# MODEMDEVCAPS |
my $MC_ReqSize = 0; |
my $MC_SpecOffset = 0; |
my $MC_SpecSize = 0; |
my $MC_ProvVersion = 0; |
my $MC_ManfOffset = 0; |
my $MC_ManfSize = 0; |
my $MC_ModOffset = 0; |
my $MC_ModSize = 0; |
my $MC_VerOffset = 0; |
my $MC_VerSize = 0; |
my $MC_DialOpt = 0; |
my $MC_CallFailTime = 0; |
my $MC_IdleTime = 0; |
my $MC_SpkrVol = 0; |
my $MC_SpkrMode = 0; |
my $MC_ModOpt = 0; |
my $MC_MaxDTE = 0; |
my $MC_MaxDCE = 0; |
my $MC_Filler = 0; |
$self->{NAME} = shift; |
my $quiet = shift; |
$self->{"_HANDLE"}=CreateFile("$self->{NAME}", |
0xc0000000, |
0, |
$null, |
3, |
0x40000000, |
$null); |
# device name |
# GENERIC_READ | GENERIC_WRITE |
# no FILE_SHARE_xx |
# no SECURITY_xx |
# OPEN_EXISTING |
# FILE_FLAG_OVERLAPPED |
# template file |
unless ($self->{"_HANDLE"} >= 1) { |
$self->{"_HANDLE"} = 0; |
return 0 if ($quiet); |
return if (nocarp); |
OS_Error; |
carp "can't open device: $self->{NAME}\n"; |
return; |
} |
# let Win32 know we allowed room for modem properties |
$CP_Length = 300; |
$CP_ProvSpec1 = COMMPROP_INITIALIZED; |
$CommProperties = pack($CP_format0, |
$CP_Length, |
$CommPropBlank, |
$CP_ProvSpec1, |
$CommPropBlank); |
$ok=GetCommProperties($self->{"_HANDLE"}, $CommProperties); |
unless ( $ok ) { |
OS_Error; |
carp "can't get COMMPROP block"; |
undef $self; |
return; |
} |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$CP_Filler)= unpack($CP_format1, $CommProperties); |
if (($CP_Length > 64) and ($self->{"_TYPE"} == PST_RS232)) { |
carp "invalid COMMPROP block length= $CP_Length"; |
undef $self; |
return; |
} |
if ($CP_ServiceMask != SP_SERIALCOMM) { |
carp "doesn't claim to be a serial port\n"; |
undef $self; |
return; |
} |
if ($self->{"_TYPE"} == PST_MODEM) { |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$MC_ReqSize, |
$MC_SpecOffset, |
$MC_SpecSize, |
$MC_ProvVersion, |
$MC_ManfOffset, |
$MC_ManfSize, |
$MC_ModOffset, |
$MC_ModSize, |
$MC_VerOffset, |
$MC_VerSize, |
$MC_DialOpt, |
$MC_CallFailTime, |
$MC_IdleTime, |
$MC_SpkrVol, |
$MC_SpkrMode, |
$MC_ModOpt, |
$MC_MaxDTE, |
$MC_MaxDCE, |
$MC_Filler)= unpack($CP_format6, $CommProperties); |
if ($Babble) { |
printf "\nMODEMDEVCAPS:\n"; |
printf "\$MC_ActualSize= %d\n", $CP_ProvChar_start; |
printf "\$MC_ReqSize= %d\n", $MC_ReqSize; |
printf "\$MC_SpecOffset= %d\n", $MC_SpecOffset; |
printf "\$MC_SpecSize= %d\n", $MC_SpecSize; |
if ($MC_SpecOffset) { |
printf " DeviceSpecificData= %s\n", substr ($CommProperties, |
60+$MC_SpecOffset, $MC_SpecSize); |
} |
printf "\$MC_ProvVersion= %d\n", $MC_ProvVersion; |
printf "\$MC_ManfOffset= %d\n", $MC_ManfOffset; |
printf "\$MC_ManfSize= %d\n", $MC_ManfSize; |
if ($MC_ManfOffset) { |
printf " Manufacturer= %s\n", substr ($CommProperties, |
60+$MC_ManfOffset, $MC_ManfSize); |
} |
printf "\$MC_ModOffset= %d\n", $MC_ModOffset; |
printf "\$MC_ModSize= %d\n", $MC_ModSize; |
if ($MC_ModOffset) { |
printf " Model= %s\n", substr ($CommProperties, |
60+$MC_ModOffset, $MC_ModSize); |
} |
printf "\$MC_VerOffset= %d\n", $MC_VerOffset; |
printf "\$MC_VerSize= %d\n", $MC_VerSize; |
if ($MC_VerOffset) { |
printf " Version= %s\n", substr ($CommProperties, |
60+$MC_VerOffset, $MC_VerSize); |
} |
printf "\$MC_DialOpt= %lx\n", $MC_DialOpt; |
printf "\$MC_CallFailTime= %d\n", $MC_CallFailTime; |
printf "\$MC_IdleTime= %d\n", $MC_IdleTime; |
printf "\$MC_SpkrVol= %d\n", $MC_SpkrVol; |
printf "\$MC_SpkrMode= %d\n", $MC_SpkrMode; |
printf "\$MC_ModOpt= %lx\n", $MC_ModOpt; |
printf "\$MC_MaxDTE= %d\n", $MC_MaxDTE; |
printf "\$MC_MaxDCE= %d\n", $MC_MaxDCE; |
$MC_Filler= $MC_Filler; # for -w |
} |
## $MC_ReqSize = 250; |
if ($CP_ProvChar_start != $MC_ReqSize) { |
printf "\nARGH, a Bug! The \$CommProperties buffer must be "; |
printf "at least %d bytes.\n", $MC_ReqSize+60; |
} |
} |
## if (1 | $Babble) { |
if ($Babble) { |
printf "\$CP_Length= %d\n", $CP_Length; |
printf "\$CP_Version= %d\n", $CP_Version; |
printf "\$CP_ServiceMask= %lx\n", $CP_ServiceMask; |
printf "\$CP_Reserved1= %lx\n", $CP_Reserved1; |
printf "\$CP_MaxTxQueue= %lx\n", $self->{"_MaxTxQueue"}; |
printf "\$CP_MaxRxQueue= %lx\n", $self->{"_MaxRxQueue"}; |
printf "\$CP_MaxBaud= %lx\n", $CP_MaxBaud; |
printf "\$CP_ProvSubType= %lx\n", $self->{"_TYPE"}; |
printf "\$CP_ProvCapabilities= %lx\n", $CP_ProvCapabilities; |
printf "\$CP_SettableParams= %lx\n", $CP_SettableParams; |
printf "\$CP_SettableBaud= %lx\n", $CP_SettableBaud; |
printf "\$CP_SettableData= %x\n", $CP_SettableData; |
printf "\$CP_SettableStopParity= %x\n", $CP_SettableStopParity; |
printf "\$CP_CurrentTxQueue= %lx\n", $self->{WRITEBUF}; |
printf "\$CP_CurrentRxQueue= %lx\n", $self->{READBUF}; |
printf "\$CP_ProvSpec1= %lx\n", $CP_ProvSpec1; |
printf "\$CP_ProvSpec2= %lx\n", $CP_ProvSpec2; |
} |
# "private" data |
$self->{"_INIT"} = undef; |
$self->{"_DEBUG_C"} = 0; |
$self->{"_LATCH"} = 0; |
$self->{"_W_BUSY"} = 0; |
$self->{"_R_BUSY"} = 0; |
$self->{"_TBUFMAX"} = $self->{"_MaxTxQueue"} ? |
$self->{"_MaxTxQueue"} : LONGsize; |
$self->{"_RBUFMAX"} = $self->{"_MaxRxQueue"} ? |
$self->{"_MaxRxQueue"} : LONGsize; |
# buffers |
$self->{"_R_OVERLAP"} = " "x24; |
$self->{"_W_OVERLAP"} = " "x24; |
$self->{"_TIMEOUT"} = " "x24; |
$self->{"_RBUF"} = " "x $RBUF_Size; |
# allowed setting hashes |
$self->{"_L_BAUD"} = {}; |
$self->{"_L_STOP"} = {}; |
$self->{"_L_PARITY"} = {}; |
$self->{"_L_DATA"} = {}; |
$self->{"_L_HSHAKE"} = {}; |
# capability flags |
$fmask = $CP_SettableParams; |
$self->{"_C_BAUD"} = $fmask & SP_BAUD; |
$self->{"_C_DATA"} = $fmask & SP_DATABITS; |
$self->{"_C_STOP"} = $fmask & SP_STOPBITS; |
$self->{"_C_HSHAKE"} = $fmask & SP_HANDSHAKING; |
$self->{"_C_PARITY_CFG"} = $fmask & SP_PARITY; |
$self->{"_C_PARITY_EN"} = $fmask & SP_PARITY_CHECK; |
$self->{"_C_RLSD_CFG"} = $fmask & SP_RLSD; |
$fmask = $CP_ProvCapabilities; |
$self->{"_C_RLSD"} = $fmask & PCF_RLSD; |
$self->{"_C_PARITY_CK"} = $fmask & PCF_PARITY_CHECK; |
$self->{"_C_DTRDSR"} = $fmask & PCF_DTRDSR; |
$self->{"_C_16BITMODE"} = $fmask & PCF_16BITMODE; |
$self->{"_C_RTSCTS"} = $fmask & PCF_RTSCTS; |
$self->{"_C_XONXOFF"} = $fmask & PCF_XONXOFF; |
$self->{"_C_XON_CHAR"} = $fmask & PCF_SETXCHAR; |
$self->{"_C_SPECHAR"} = $fmask & PCF_SPECIALCHARS; |
$self->{"_C_INT_TIME"} = $fmask & PCF_INTTIMEOUTS; |
$self->{"_C_TOT_TIME"} = $fmask & PCF_TOTALTIMEOUTS; |
if ($self->{"_C_INT_TIME"}) { |
$self->{"_N_RINT"} = LONGsize; # min interval default |
} |
else { |
$self->{"_N_RINT"} = 0; |
} |
$self->{"_N_RTOT"} = 0; |
$self->{"_N_RCONST"} = 0; |
if ($self->{"_C_TOT_TIME"}) { |
$self->{"_N_WCONST"} = 201; # startup overhead + 1 |
$self->{"_N_WTOT"} = 11; # per char out + 1 |
} |
else { |
$self->{"_N_WTOT"} = 0; |
$self->{"_N_WCONST"} = 0; |
} |
$hr = \%{$self->{"_L_HSHAKE"}}; |
if ($self->{"_C_HSHAKE"}) { |
${$hr}{"xoff"} = "xoff" if ($fmask & PCF_XONXOFF); |
${$hr}{"rts"} = "rts" if ($fmask & PCF_RTSCTS); |
${$hr}{"dtr"} = "dtr" if ($fmask & PCF_DTRDSR); |
${$hr}{"none"} = "none"; |
} |
else { $self->{"_N_HSHAKE"} = undef; } |
#### really just using the keys here, so value = Win32_definition |
#### in case we ever need it for something else |
# first check for programmable baud |
$hr = \%{$self->{"_L_BAUD"}}; |
if ($CP_MaxBaud & BAUD_USER) { |
$fmask = $CP_SettableBaud; |
${$hr}{110} = CBR_110 if ($fmask & BAUD_110); |
${$hr}{300} = CBR_300 if ($fmask & BAUD_300); |
${$hr}{600} = CBR_600 if ($fmask & BAUD_600); |
${$hr}{1200} = CBR_1200 if ($fmask & BAUD_1200); |
${$hr}{2400} = CBR_2400 if ($fmask & BAUD_2400); |
${$hr}{4800} = CBR_4800 if ($fmask & BAUD_4800); |
${$hr}{9600} = CBR_9600 if ($fmask & BAUD_9600); |
${$hr}{14400} = CBR_14400 if ($fmask & BAUD_14400); |
${$hr}{19200} = CBR_19200 if ($fmask & BAUD_19200); |
${$hr}{38400} = CBR_38400 if ($fmask & BAUD_38400); |
${$hr}{56000} = CBR_56000 if ($fmask & BAUD_56K); |
${$hr}{57600} = CBR_57600 if ($fmask & BAUD_57600); |
${$hr}{115200} = CBR_115200 if ($fmask & BAUD_115200); |
${$hr}{128000} = CBR_128000 if ($fmask & BAUD_128K); |
${$hr}{256000} = CBR_256000 if (0); # reserved ?? |
} |
else { |
# get fixed baud from CP_MaxBaud |
$fmask = $CP_MaxBaud; |
$fix_baud = 75 if ($fmask & BAUD_075); |
$fix_baud = 110 if ($fmask & BAUD_110); |
$fix_baud = 134.5 if ($fmask & BAUD_134_5); |
$fix_baud = 150 if ($fmask & BAUD_150); |
$fix_baud = 300 if ($fmask & BAUD_300); |
$fix_baud = 600 if ($fmask & BAUD_600); |
$fix_baud = 1200 if ($fmask & BAUD_1200); |
$fix_baud = 1800 if ($fmask & BAUD_1800); |
$fix_baud = 2400 if ($fmask & BAUD_2400); |
$fix_baud = 4800 if ($fmask & BAUD_4800); |
$fix_baud = 7200 if ($fmask & BAUD_7200); |
$fix_baud = 9600 if ($fmask & BAUD_9600); |
$fix_baud = 14400 if ($fmask & BAUD_14400); |
$fix_baud = 19200 if ($fmask & BAUD_19200); |
$fix_baud = 34800 if ($fmask & BAUD_38400); |
$fix_baud = 56000 if ($fmask & BAUD_56K); |
$fix_baud = 57600 if ($fmask & BAUD_57600); |
$fix_baud = 115200 if ($fmask & BAUD_115200); |
$fix_baud = 128000 if ($fmask & BAUD_128K); |
${$hr}{$fix_baud} = $fix_baud; |
$self->{"_N_BAUD"} = undef; |
} |
#### data bits |
$fmask = $CP_SettableData; |
if ($self->{"_C_DATA"}) { |
$hr = \%{$self->{"_L_DATA"}}; |
${$hr}{5} = 5 if ($fmask & DATABITS_5); |
${$hr}{6} = 6 if ($fmask & DATABITS_6); |
${$hr}{7} = 7 if ($fmask & DATABITS_7); |
${$hr}{8} = 8 if ($fmask & DATABITS_8); |
${$hr}{16} = 16 if ($fmask & DATABITS_16); |
## ${$hr}{16X} = 16 if ($fmask & DATABITS_16X); |
} |
else { $self->{"_N_DATA"} = undef; } |
#### value = (DCB Win32_definition + 1) so 0 means unchanged |
$fmask = $CP_SettableStopParity; |
if ($self->{"_C_STOP"}) { |
$hr = \%{$self->{"_L_STOP"}}; |
${$hr}{1} = 1 + ONESTOPBIT if ($fmask & STOPBITS_10); |
${$hr}{1.5} = 1 + ONE5STOPBITS if ($fmask & STOPBITS_15); |
${$hr}{2} = 1 + TWOSTOPBITS if ($fmask & STOPBITS_20); |
} |
else { $self->{"_N_STOP"} = undef; } |
if ($self->{"_C_PARITY_CFG"}) { |
$hr = \%{$self->{"_L_PARITY"}}; |
${$hr}{"none"} = 1 + NOPARITY if ($fmask & PARITY_NONE); |
${$hr}{"even"} = 1 + EVENPARITY if ($fmask & PARITY_EVEN); |
${$hr}{"odd"} = 1 + ODDPARITY if ($fmask & PARITY_ODD); |
${$hr}{"mark"} = 1 + MARKPARITY if ($fmask & PARITY_MARK); |
${$hr}{"space"} = 1 + SPACEPARITY if ($fmask & PARITY_SPACE); |
} |
else { $self->{"_N_PARITY"} = undef; } |
$hr = 0; # no loops |
# changable dcb parameters |
# 0 = no change requested |
# mask_on: requested value for OR |
# mask_off: complement of requested value for AND |
$self->{"_N_FM_ON"} = 0; |
$self->{"_N_FM_OFF"} = 0; |
$self->{"_N_AUX_ON"} = 0; |
$self->{"_N_AUX_OFF"} = 0; |
### "VALUE" is initialized from DCB by default (but also in %validate) |
# 0 = no change requested |
# integer: requested value or (value+1 if 0 is a legal value) |
# binary: 1=false requested, 2=true requested |
$self->{"_N_XONLIM"} = 0; |
$self->{"_N_XOFFLIM"} = 0; |
$self->{"_N_XOFFCHAR"} = 0; |
$self->{"_N_XONCHAR"} = 0; |
$self->{"_N_ERRCHAR"} = 0; |
$self->{"_N_EOFCHAR"} = 0; |
$self->{"_N_EVTCHAR"} = 0; |
$self->{"_N_BINARY"} = 0; |
$self->{"_N_PARITY_EN"} = 0; |
### "_N_items" for save/start |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
$self->{"_N_HSHAKE"} = 0; |
### The "required" DCB values are deliberately NOT defined. That way, |
### write_settings can verify they "exist" to assure they got set. |
### $self->{"_N_BAUD"} |
### $self->{"_N_DATA"} |
### $self->{"_N_STOP"} |
### $self->{"_N_PARITY"} |
$self->{"_R_EVENT"} = CreateEvent($null, # no security |
1, # explicit reset req |
0, # initial event reset |
$null); # no name |
unless ($self->{"_R_EVENT"}) { |
OS_Error; |
carp "could not create required read event"; |
undef $self; |
return; |
} |
$self->{"_W_EVENT"} = CreateEvent($null, # no security |
1, # explicit reset req |
0, # initial event reset |
$null); # no name |
unless ($self->{"_W_EVENT"}) { |
OS_Error; |
carp "could not create required write event"; |
undef $self; |
return; |
} |
$self->{"_R_OVERLAP"} = pack($OVERLAPPEDformat, |
$zero, # osRead_Internal, |
$zero, # osRead_InternalHigh, |
$zero, # osRead_Offset, |
$zero, # osRead_OffsetHigh, |
$self->{"_R_EVENT"}); |
$self->{"_W_OVERLAP"} = pack($OVERLAPPEDformat, |
$zero, # osWrite_Internal, |
$zero, # osWrite_InternalHigh, |
$zero, # osWrite_Offset, |
$zero, # osWrite_OffsetHigh, |
$self->{"_W_EVENT"}); |
# Device Control Block (DCB) |
unless ( fetch_DCB ($self) ) { |
carp "can't read Device Control Block for $self->{NAME}\n"; |
undef $self; |
return; |
} |
$self->{"_L_BAUD"}{$self->{BAUD}} = $self->{BAUD}; # actual must be ok |
# Read Timeouts |
unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
carp "Error in GetCommTimeouts"; |
undef $self; |
return; |
} |
($self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
bless ($self, $class); |
return $self; |
} |
sub fetch_DCB { |
my $self = shift; |
my $ok; |
my $hr; |
my $fmask; |
my $key; |
my $value; |
my $dcb = " "x32; |
GetCommState($self->{"_HANDLE"}, $dcb) or return; |
($self->{"_DCBLength"}, |
$self->{BAUD}, |
$self->{"_BitMask"}, |
$self->{"_ResvWORD"}, |
$self->{XONLIM}, |
$self->{XOFFLIM}, |
$self->{DATA}, |
$self->{"_Parity"}, |
$self->{"_StopBits"}, |
$self->{XONCHAR}, |
$self->{XOFFCHAR}, |
$self->{ERRCHAR}, |
$self->{EOFCHAR}, |
$self->{EVTCHAR}, |
$self->{"_PackWORD"})= unpack($DCBformat, $dcb); |
if ($self->{"_DCBLength"} > 32) { |
carp "invalid DCB block length"; |
return; |
} |
if ($Babble) { |
printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
printf "BaudRate= %d\n", $self->{BAUD}; |
printf "BitMask= %lx\n", $self->{"_BitMask"}; |
printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
printf "XonLim= %x\n", $self->{XONLIM}; |
printf "XoffLim= %x\n", $self->{XOFFLIM}; |
printf "ByteSize= %d\n", $self->{DATA}; |
printf "Parity= %d\n", $self->{"_Parity"}; |
printf "StopBits= %d\n", $self->{"_StopBits"}; |
printf "XonChar= %x\n", $self->{XONCHAR}; |
printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
printf "EofChar= %x\n", $self->{EOFCHAR}; |
printf "EvtChar= %x\n", $self->{EVTCHAR}; |
printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
printf "handle= %d\n\n", $self->{"_HANDLE"}; |
} |
$fmask = 1 + $self->{"_StopBits"}; |
while (($key, $value) = each %{ $self->{"_L_STOP"} }) { |
if ($value == $fmask) { |
$self->{STOP} = $key; |
} |
} |
$fmask = 1 + $self->{"_Parity"}; |
while (($key, $value) = each %{ $self->{"_L_PARITY"} }) { |
if ($value == $fmask) { |
$self->{PARITY} = $key; |
} |
} |
$fmask = $self->{"_BitMask"}; |
$hr = DTR_CONTROL_HANDSHAKE; |
$ok = RTS_CONTROL_HANDSHAKE; |
if ($fmask & ( $hr << 4) ) { |
$self->{HSHAKE} = "dtr"; |
} |
elsif ($fmask & ( $ok << 12) ) { |
$self->{HSHAKE} = "rts"; |
} |
elsif ($fmask & ( FM_fOutX | FM_fInX ) ) { |
$self->{HSHAKE} = "xoff"; |
} |
else { |
$self->{HSHAKE} = "none"; |
} |
$self->{BINARY} = ($fmask & FM_fBinary); |
$self->{PARITY_EN} = ($fmask & FM_fParity); |
if ($fmask & FM_fDummy2) { |
carp "Unknown DCB Flow Mask Bit in $self->{NAME}"; |
} |
1; |
} |
sub init_done { |
my $self = shift; |
return 0 unless (defined $self->{"_INIT"}); |
return $self->{"_INIT"}; |
} |
sub update_DCB { |
my $self = shift; |
my $ok = 0; |
return unless (defined $self->{"_INIT"}); |
fetch_DCB ($self); |
if ($self->{"_N_HSHAKE"}) { |
$self->{HSHAKE} = $self->{"_N_HSHAKE"}; |
if ($self->{HSHAKE} eq "dtr" ) { |
$self->{"_N_FM_ON"} = 0x1028; |
$self->{"_N_FM_OFF"} = 0xffffdceb; |
} |
elsif ($self->{HSHAKE} eq "rts" ) { |
$self->{"_N_FM_ON"} = 0x2014; |
$self->{"_N_FM_OFF"} = 0xffffecd7; |
} |
elsif ($self->{HSHAKE} eq "xoff" ) { |
$self->{"_N_FM_ON"} = 0x1310; |
$self->{"_N_FM_OFF"} = 0xffffdfd3; |
} |
else { |
$self->{"_N_FM_ON"} = 0x1010; |
$self->{"_N_FM_OFF"} = 0xffffdcd3; |
} |
$self->{"_N_HSHAKE"} = 0; |
} |
if ($self->{"_N_PARITY_EN"}) { |
if (2 == $self->{"_N_PARITY_EN"}) { |
$self->{"_N_FM_ON"} |= FM_fParity; # enable |
if ($self->{"_N_FM_OFF"}) { |
$self->{"_N_FM_OFF"} |= FM_fParity; |
} |
else { $self->{"_N_FM_OFF"} = LONGsize; } |
} |
else { |
if ($self->{"_N_FM_ON"}) { |
$self->{"_N_FM_ON"} &= ~FM_fParity; # disable |
} |
if ($self->{"_N_FM_OFF"}) { |
$self->{"_N_FM_OFF"} &= ~FM_fParity; |
} |
else { $self->{"_N_FM_OFF"} = ~FM_fParity; } |
} |
## DEBUG ## |
## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
## DEBUG ## |
$self->{"_N_PARITY_EN"} = 0; |
} |
## DEBUG ## |
## printf "_N_AUX_ON=%lx\n", $self->{"_N_AUX_ON"}; ## DEBUG ## |
## printf "_N_AUX_OFF=%lx\n", $self->{"_N_AUX_OFF"}; ## DEBUG ## |
## DEBUG ## |
if ( $self->{"_N_AUX_ON"} or $self->{"_N_AUX_OFF"} ) { |
if ( $self->{"_N_FM_OFF"} ) { |
$self->{"_N_FM_OFF"} &= $self->{"_N_AUX_OFF"}; |
} |
else { |
$self->{"_N_FM_OFF"} = $self->{"_N_AUX_OFF"}; |
} |
$self->{"_N_FM_ON"} |= $self->{"_N_AUX_ON"}; |
$self->{"_N_AUX_ON"} = 0; |
$self->{"_N_AUX_OFF"} = 0; |
} |
## DEBUG ## |
## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
## DEBUG ## |
if ( $self->{"_N_FM_ON"} or $self->{"_N_FM_OFF"} ) { |
$self->{"_BitMask"} &= $self->{"_N_FM_OFF"}; |
$self->{"_BitMask"} |= $self->{"_N_FM_ON"}; |
$self->{"_N_FM_ON"} = 0; |
$self->{"_N_FM_OFF"} = 0; |
} |
if ($self->{"_N_XONLIM"}) { |
$self->{XONLIM} = $self->{"_N_XONLIM"} - 1; |
$self->{"_N_XONLIM"} = 0; |
} |
if ($self->{"_N_XOFFLIM"}) { |
$self->{XOFFLIM} = $self->{"_N_XOFFLIM"} - 1; |
$self->{"_N_XOFFLIM"} = 0; |
} |
if ($self->{"_N_BAUD"}) { |
$self->{BAUD} = $self->{"_N_BAUD"}; |
$self->{"_N_BAUD"} = 0; |
} |
if ($self->{"_N_DATA"}) { |
$self->{DATA} = $self->{"_N_DATA"}; |
$self->{"_N_DATA"} = 0; |
} |
if ($self->{"_N_STOP"}) { |
$self->{"_StopBits"} = $self->{"_N_STOP"} - 1; |
$self->{"_N_STOP"} = 0; |
} |
if ($self->{"_N_PARITY"}) { |
$self->{"_Parity"} = $self->{"_N_PARITY"} - 1; |
$self->{"_N_PARITY"} = 0; |
} |
if ($self->{"_N_XONCHAR"}) { |
$self->{XONCHAR} = $self->{"_N_XONCHAR"} - 1; |
$self->{"_N_XONCHAR"} = 0; |
} |
if ($self->{"_N_XOFFCHAR"}) { |
$self->{XOFFCHAR} = $self->{"_N_XOFFCHAR"} - 1; |
$self->{"_N_XOFFCHAR"} = 0; |
} |
if ($self->{"_N_ERRCHAR"}) { |
$self->{ERRCHAR} = $self->{"_N_ERRCHAR"} - 1; |
$self->{"_N_ERRCHAR"} = 0; |
} |
if ($self->{"_N_EOFCHAR"}) { |
$self->{EOFCHAR} = $self->{"_N_EOFCHAR"} - 1; |
$self->{"_N_EOFCHAR"} = 0; |
} |
if ($self->{"_N_EVTCHAR"}) { |
$self->{EVTCHAR} = $self->{"_N_EVTCHAR"} - 1; |
$self->{"_N_EVTCHAR"} = 0; |
} |
my $dcb = pack($DCBformat, |
$self->{"_DCBLength"}, |
$self->{BAUD}, |
$self->{"_BitMask"}, |
$self->{"_ResvWORD"}, |
$self->{XONLIM}, |
$self->{XOFFLIM}, |
$self->{DATA}, |
$self->{"_Parity"}, |
$self->{"_StopBits"}, |
$self->{XONCHAR}, |
$self->{XOFFCHAR}, |
$self->{ERRCHAR}, |
$self->{EOFCHAR}, |
$self->{EVTCHAR}, |
$self->{"_PackWORD"}); |
if ( SetCommState($self->{"_HANDLE"}, $dcb) ) { |
print "updated DCB for $self->{NAME}\n" if ($Babble); |
## DEBUG ## |
## printf "DEBUG BitMask= %lx\n", $self->{"_BitMask"}; ## DEBUG ## |
## DEBUG ## |
} |
else { |
carp "SetCommState failed"; |
OS_Error; |
if ($Babble) { |
printf "\ntried to write:\n"; |
printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
printf "BaudRate= %d\n", $self->{BAUD}; |
printf "BitMask= %lx\n", $self->{"_BitMask"}; |
printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
printf "XonLim= %x\n", $self->{XONLIM}; |
printf "XoffLim= %x\n", $self->{XOFFLIM}; |
printf "ByteSize= %d\n", $self->{DATA}; |
printf "Parity= %d\n", $self->{"_Parity"}; |
printf "StopBits= %d\n", $self->{"_StopBits"}; |
printf "XonChar= %x\n", $self->{XONCHAR}; |
printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
printf "EofChar= %x\n", $self->{EOFCHAR}; |
printf "EvtChar= %x\n", $self->{EVTCHAR}; |
printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
printf "handle= %d\n", $self->{"_HANDLE"}; |
} |
} |
} |
sub initialize { |
my $self = shift; |
my $item; |
my $fault = 0; |
foreach $item (@_) { |
unless (exists $self->{"_N_$item"}) { |
# must be "exists" so undef=not_settable |
$fault++; |
nocarp or carp "Missing REQUIRED setting for $item"; |
} |
} |
unless ($self->{"_INIT"}) { |
$self->{"_INIT"} = 1 unless ($fault); |
$self->{"_BitMask"} = 0x1011; |
$self->{XONLIM} = 100 unless ($self->{"_N_XONLIM"}); |
$self->{XOFFLIM} = 100 unless ($self->{"_N_XOFFLIM"}); |
$self->{XONCHAR} = 0x11 unless ($self->{"_N_XONCHAR"}); |
$self->{XOFFCHAR} = 0x13 unless ($self->{"_N_XOFFCHAR"}); |
$self->{ERRCHAR} = 0 unless ($self->{"_N_ERRCHAR"}); |
$self->{EOFCHAR} = 0 unless ($self->{"_N_EOFCHAR"}); |
$self->{EVTCHAR} = 0 unless ($self->{"_N_EVTCHAR"}); |
update_timeouts($self); |
} |
if ($self->{"_N_READBUF"} or $self->{"_N_WRITEBUF"}) { |
if ($self->{"_N_READBUF"}) { |
$self->{READBUF} = $self->{"_N_READBUF"}; |
} |
if ($self->{"_N_WRITEBUF"}) { |
$self->{WRITEBUF} = $self->{"_N_WRITEBUF"}; |
} |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
SetupComm($self->{"_HANDLE"}, $self->{READBUF}, $self->{WRITEBUF}); |
} |
purge_all($self); |
return $fault; |
} |
sub is_status { |
my $self = shift; |
my $ok = 0; |
my $error_p = " "x4; |
my $CommStatus = " "x12; |
if (@_ and $testactive) { |
$self->{"_LATCH"} |= shift; |
} |
$ok=ClearCommError($self->{"_HANDLE"}, $error_p, $CommStatus); |
my $Error_BitMask = unpack("L", $error_p); |
$self->{"_LATCH"} |= $Error_BitMask; |
my @stat = unpack($COMSTATformat, $CommStatus); |
push @stat, $self->{"_LATCH"}; |
$stat[ST_BLOCK] &= BM_AllBits; |
if ( $Babble or $self->{"_DEBUG_C"} ) { |
printf "Blocking Bits= %d\n", $stat[ST_BLOCK]; |
printf "Input Queue= %d\n", $stat[ST_INPUT]; |
printf "Output Queue= %d\n", $stat[ST_OUTPUT]; |
printf "Latched Errors= %d\n", $stat[ST_ERROR]; |
printf "ok= %d\n", $ok; |
} |
return ($ok ? @stat : undef); |
} |
sub reset_error { |
my $self = shift; |
my $was = $self->{"_LATCH"}; |
$self->{"_LATCH"} = 0; |
return $was; |
} |
sub can_baud { |
my $self = shift; |
return $self->{"_C_BAUD"}; |
} |
sub can_databits { |
my $self = shift; |
return $self->{"_C_DATA"}; |
} |
sub can_stopbits { |
my $self = shift; |
return $self->{"_C_STOP"}; |
} |
sub can_dtrdsr { |
my $self = shift; |
return $self->{"_C_DTRDSR"}; |
} |
sub can_handshake { |
my $self = shift; |
return $self->{"_C_HSHAKE"}; |
} |
sub can_parity_check { |
my $self = shift; |
return $self->{"_C_PARITY_CK"}; |
} |
sub can_parity_config { |
my $self = shift; |
return $self->{"_C_PARITY_CFG"}; |
} |
sub can_parity_enable { |
my $self = shift; |
return $self->{"_C_PARITY_EN"}; |
} |
sub can_rlsd_config { |
my $self = shift; |
return $self->{"_C_RLSD_CFG"}; |
} |
sub can_rlsd { |
my $self = shift; |
return $self->{"_C_RLSD"}; |
} |
sub can_16bitmode { |
my $self = shift; |
return $self->{"_C_16BITMODE"}; |
} |
sub is_rs232 { |
my $self = shift; |
return ($self->{"_TYPE"} == PST_RS232); |
} |
sub is_modem { |
my $self = shift; |
return ($self->{"_TYPE"} == PST_MODEM); |
} |
sub can_rtscts { |
my $self = shift; |
return $self->{"_C_RTSCTS"}; |
} |
sub can_xonxoff { |
my $self = shift; |
return $self->{"_C_XONXOFF"}; |
} |
sub can_xon_char { |
my $self = shift; |
return $self->{"_C_XON_CHAR"}; |
} |
sub can_spec_char { |
my $self = shift; |
return $self->{"_C_SPECHAR"}; |
} |
sub can_interval_timeout { |
my $self = shift; |
return $self->{"_C_INT_TIME"}; |
} |
sub can_total_timeout { |
my $self = shift; |
return $self->{"_C_TOT_TIME"}; |
} |
sub is_handshake { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_HSHAKE"}; |
return unless (defined $self->{"_L_HSHAKE"}{$_[0]}); |
$self->{"_N_HSHAKE"} = $self->{"_L_HSHAKE"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{HSHAKE}; |
} |
sub are_handshake { |
my $self = shift; |
return unless $self->{"_C_HSHAKE"}; |
return if (@_); |
return keys(%{$self->{"_L_HSHAKE"}}); |
} |
sub is_baudrate { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_BAUD"}; |
return unless (defined $self->{"_L_BAUD"}{$_[0]}); |
$self->{"_N_BAUD"} = int shift; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{BAUD}; |
} |
sub are_baudrate { |
my $self = shift; |
return unless $self->{"_C_BAUD"}; |
return if (@_); |
return keys(%{$self->{"_L_BAUD"}}); |
} |
sub is_parity { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_PARITY_CFG"}; |
return unless (defined $self->{"_L_PARITY"}{$_[0]}); |
$self->{"_N_PARITY"} = $self->{"_L_PARITY"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{PARITY}; |
} |
sub are_parity { |
my $self = shift; |
return unless $self->{"_C_PARITY_CFG"}; |
return if (@_); |
return keys(%{$self->{"_L_PARITY"}}); |
} |
sub is_databits { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_DATA"}; |
return unless (defined $self->{"_L_DATA"}{$_[0]}); |
$self->{"_N_DATA"} = $self->{"_L_DATA"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{DATA}; |
} |
sub are_databits { |
my $self = shift; |
return unless $self->{"_C_DATA"}; |
return if (@_); |
return keys(%{$self->{"_L_DATA"}}); |
} |
sub is_stopbits { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_STOP"}; |
return unless (defined $self->{"_L_STOP"}{$_[0]}); |
$self->{"_N_STOP"} = $self->{"_L_STOP"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{STOP}; |
} |
sub are_stopbits { |
my $self = shift; |
return unless $self->{"_C_STOP"}; |
return if (@_); |
return keys(%{$self->{"_L_STOP"}}); |
} |
# single value for save/start |
sub is_read_buf { |
my $self = shift; |
if (@_) { $self->{"_N_READBUF"} = int shift; } |
return $self->{READBUF}; |
} |
# single value for save/start |
sub is_write_buf { |
my $self = shift; |
if (@_) { $self->{"_N_WRITEBUF"} = int shift; } |
return $self->{WRITEBUF}; |
} |
sub is_buffers { |
my $self = shift; |
return unless (@_ == 2); |
my $rbuf = shift; |
my $wbuf = shift; |
SetupComm($self->{"_HANDLE"}, $rbuf, $wbuf) or return; |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
$self->{READBUF} = $rbuf; |
$self->{WRITEBUF} = $wbuf; |
1; |
} |
sub read_bg { |
return unless (@_ == 2); |
my $self = shift; |
my $wanted = shift; |
return unless ($wanted > 0); |
if ($self->{"_R_BUSY"}) { |
nocarp or carp "Second Read attempted before First is done"; |
return; |
} |
my $got_p = " "x4; |
my $ok; |
my $got = 0; |
if ($wanted > $RBUF_Size) { |
$wanted = $RBUF_Size; |
warn "read buffer limited to $RBUF_Size bytes at the moment"; |
} |
$self->{"_R_BUSY"} = 1; |
$ok=ReadFile( $self->{"_HANDLE"}, |
$self->{"_RBUF"}, |
$wanted, |
$got_p, |
$self->{"_R_OVERLAP"}); |
if ($ok) { |
$got = unpack("L", $got_p); |
$self->{"_R_BUSY"} = 0; |
} |
return $got; |
} |
sub write_bg { |
return unless (@_ == 2); |
my $self = shift; |
my $wbuf = shift; |
if ($self->{"_W_BUSY"}) { |
nocarp or carp "Second Write attempted before First is done"; |
return; |
} |
my $ok; |
my $got_p = " "x4; |
return 0 if ($wbuf eq ""); |
my $lbuf = length ($wbuf); |
my $written = 0; |
$self->{"_W_BUSY"} = 1; |
$ok=WriteFile( $self->{"_HANDLE"}, |
$wbuf, |
$lbuf, |
$got_p, |
$self->{"_W_OVERLAP"}); |
if ($ok) { |
$written = unpack("L", $got_p); |
$self->{"_W_BUSY"} = 0; |
} |
if ($Babble) { |
print "error=$ok\n"; |
print "wbuf=$wbuf\n"; |
print "lbuf=$lbuf\n"; |
print "write_bg=$written\n"; |
} |
return $written; |
} |
sub read_done { |
return unless (@_ == 2); |
my $self = shift; |
my $wait = yes_true ( shift ); |
my $ov; |
my $got_p = " "x4; |
my $wanted = 0; |
$self->{"_R_BUSY"} = 1; |
$ov=GetOverlappedResult( $self->{"_HANDLE"}, |
$self->{"_R_OVERLAP"}, |
$got_p, |
$wait); |
if ($ov) { |
$wanted = unpack("L", $got_p); |
$self->{"_R_BUSY"} = 0; |
print "read_done=$wanted\n" if ($Babble); |
return (1, $wanted, substr($self->{"_RBUF"}, 0, $wanted)); |
} |
return (0, 0, ""); |
} |
sub write_done { |
return unless (@_ == 2); |
my $self = shift; |
my $wait = yes_true ( shift ); |
my $ov; |
my $got_p = " "x4; |
my $written = 0; |
$self->{"_W_BUSY"} = 1; |
$ov=GetOverlappedResult( $self->{"_HANDLE"}, |
$self->{"_W_OVERLAP"}, |
$got_p, |
$wait); |
if ($ov) { |
$written = unpack("L", $got_p); |
$self->{"_W_BUSY"} = 0; |
print "write_done=$written\n" if ($Babble); |
return (1, $written); |
} |
return (0, $written); |
} |
sub purge_all { |
my $self = shift; |
return if (@_); |
# PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000f) ) { |
carp "Error in PurgeComm"; |
OS_Error; |
return; |
} |
$self->{"_R_BUSY"} = 0; |
$self->{"_W_BUSY"} = 0; |
return 1; |
} |
sub purge_rx { |
my $self = shift; |
return if (@_); |
# PURGE_RXABORT | PURGE_RXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000a) ) { |
OS_Error; |
carp "Error in PurgeComm"; |
return; |
} |
$self->{"_R_BUSY"} = 0; |
return 1; |
} |
sub purge_tx { |
my $self = shift; |
return if (@_); |
# PURGE_TXABORT | PURGE_TXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x00000005) ) { |
OS_Error; |
carp "Error in PurgeComm"; |
return; |
} |
$self->{"_W_BUSY"} = 0; |
return 1; |
} |
sub are_buffers { |
my $self = shift; |
return if (@_); |
return ($self->{READBUF}, $self->{WRITEBUF}); |
} |
sub buffer_max { |
my $self = shift; |
return if (@_); |
return ($self->{"_RBUFMAX"}, $self->{"_TBUFMAX"}); |
} |
sub suspend_tx { |
my $self = shift; |
return if (@_); |
return SetCommBreak($self->{"_HANDLE"}); |
} |
sub resume_tx { |
my $self = shift; |
return if (@_); |
return ClearCommBreak($self->{"_HANDLE"}); |
} |
sub xmit_imm_char { |
my $self = shift; |
return unless (@_ == 1); |
my $v = int shift; |
unless ( TransmitCommChar($self->{"_HANDLE"}, $v) ) { |
carp "Can't transmit char: $v"; |
return; |
} |
1; |
} |
sub is_xon_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
$self->{"_N_XONCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XONCHAR}; |
} |
sub is_xoff_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
$self->{"_N_XOFFCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XOFFCHAR}; |
} |
sub is_eof_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_EOFCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{EOFCHAR}; |
} |
sub is_event_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_EVTCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{EVTCHAR}; |
} |
sub is_error_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_ERRCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{ERRCHAR}; |
} |
sub is_xon_limit { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_XONXOFF"}); |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->{"_N_XONLIM"} = ++$v; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XONLIM}; |
} |
sub is_xoff_limit { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_XONXOFF"}); |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->{"_N_XOFFLIM"} = ++$v; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XOFFLIM}; |
} |
sub is_read_interval { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_INT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v > LONGsize)); |
if ($v == LONGsize) { |
$self->{"_N_RINT"} = $v; # Win32 uses as flag |
} |
else { |
$self->{"_N_RINT"} = ++$v; |
} |
return unless update_timeouts ($self); |
} |
return $self->{RINT}; |
} |
sub is_read_char_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_RTOT"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{RTOT}; |
} |
sub is_read_const_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_RCONST"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{RCONST}; |
} |
sub is_write_const_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_WCONST"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{WCONST}; |
} |
sub is_write_char_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_WTOT"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{WTOT}; |
} |
sub update_timeouts { |
return unless (@_ == 1); |
my $self = shift; |
unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
carp "Error in GetCommTimeouts"; |
return; |
} |
($self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
if ($self->{"_N_RINT"}) { |
if ($self->{"_N_RINT"} == LONGsize) { |
$self->{RINT} = $self->{"_N_RINT"}; # Win32 uses as flag |
} |
else { |
$self->{RINT} = $self->{"_N_RINT"} -1; |
} |
$self->{"_N_RINT"} = 0; |
} |
if ($self->{"_N_RTOT"}) { |
$self->{RTOT} = $self->{"_N_RTOT"} -1; |
$self->{"_N_RTOT"} = 0; |
} |
if ($self->{"_N_RCONST"}) { |
$self->{RCONST} = $self->{"_N_RCONST"} -1; |
$self->{"_N_RCONST"} = 0; |
} |
if ($self->{"_N_WTOT"}) { |
$self->{WTOT} = $self->{"_N_WTOT"} -1; |
$self->{"_N_WTOT"} = 0; |
} |
if ($self->{"_N_WCONST"}) { |
$self->{WCONST} = $self->{"_N_WCONST"} -1; |
$self->{"_N_WCONST"} = 0; |
} |
$self->{"_TIMEOUT"} = pack($TIMEOUTformat, |
$self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST}); |
if ( SetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
return 1; |
} |
else { |
carp "Error in SetCommTimeouts"; |
return; |
} |
} |
# true/false parameters |
sub is_binary { |
my $self = shift; |
if (@_) { |
$self->{"_N_BINARY"} = 1 + yes_true ( shift ); |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
### printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fBinary); |
} |
sub is_parity_enable { |
my $self = shift; |
if (@_) { |
$self->{"_N_PARITY_EN"} = 1 + yes_true ( shift ); |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ## DEBUG ## |
return ($self->{"_BitMask"} & FM_fParity); |
} |
sub ignore_null { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fNull; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fNull; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fNull; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fNull); |
} |
sub ignore_no_dsr { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fDsrSensitivity; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fDsrSensitivity; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fDsrSensitivity; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fDsrSensitivity); |
} |
sub subst_pe_char { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fErrorChar; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fErrorChar; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fErrorChar; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fErrorChar); |
} |
sub abort_on_error { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fAbortOnError; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fAbortOnError; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fAbortOnError; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fAbortOnError); |
} |
sub output_dsr { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutxDsrFlow; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutxDsrFlow; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutxDsrFlow; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutxDsrFlow); |
} |
sub output_cts { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutxCtsFlow; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutxCtsFlow; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutxCtsFlow; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutxCtsFlow); |
} |
sub input_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fInX; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fInX; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fInX; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fInX); |
} |
sub output_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutX; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutX; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutX; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutX); |
} |
sub tx_on_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fTXContinueOnXoff; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fTXContinueOnXoff; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fTXContinueOnXoff; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fTXContinueOnXoff); |
} |
sub dtr_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETDTR : CLRDTR ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
sub rts_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETRTS : CLRRTS ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
# pulse parameters |
sub pulse_dtr_off { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_dtr_off not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->dtr_active(0) or carp "Did not pulse DTR off"; |
Win32::Sleep($delay); |
$self->dtr_active(1) or carp "Did not restore DTR on"; |
Win32::Sleep($delay); |
} |
sub pulse_rts_off { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_rts_off not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->rts_active(0) or carp "Did not pulse RTS off"; |
Win32::Sleep($delay); |
$self->rts_active(1) or carp "Did not restore RTS on"; |
Win32::Sleep($delay); |
} |
sub pulse_break_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_break_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->break_active(1) or carp "Did not pulse BREAK on"; |
Win32::Sleep($delay); |
$self->break_active(0) or carp "Did not restore BREAK off"; |
Win32::Sleep($delay); |
} |
sub pulse_dtr_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_dtr_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->dtr_active(1) or carp "Did not pulse DTR on"; |
Win32::Sleep($delay); |
$self->dtr_active(0) or carp "Did not restore DTR off"; |
Win32::Sleep($delay); |
} |
sub pulse_rts_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_rts_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->rts_active(1) or carp "Did not pulse RTS on"; |
Win32::Sleep($delay); |
$self->rts_active(0) or carp "Did not restore RTS off"; |
Win32::Sleep($delay); |
} |
sub break_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETBREAK : CLRBREAK ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
sub xon_active { |
return unless (@_ == 1); |
my $self = shift; |
return EscapeCommFunction($self->{"_HANDLE"}, SETXON); |
} |
sub xoff_active { |
return unless (@_ == 1); |
my $self = shift; |
return EscapeCommFunction($self->{"_HANDLE"}, SETXOFF); |
} |
sub is_modemlines { |
return unless (@_ == 1); |
my $self = shift; |
my $mstat = " " x4; |
unless ( GetCommModemStatus($self->{"_HANDLE"}, $mstat) ) { |
carp "Error in GetCommModemStatus"; |
return; |
} |
my $result = unpack ("L", $mstat); |
return $result; |
} |
sub debug_comm { |
my $self = shift; |
if (ref($self)) { |
if (@_) { $self->{"_DEBUG_C"} = yes_true ( shift ); } |
else { |
nocarp or carp "Debug level: $self->{NAME} = $self->{\"_DEBUG_C\"}"; |
return $self->{"_DEBUG_C"}; |
} |
} else { |
$Babble = yes_true ($self); |
nocarp or carp "CommPort Debug Class = $Babble"; |
return $Babble; |
} |
} |
sub close { |
my $self = shift; |
my $ok; |
my $success = 1; |
return unless (defined $self->{NAME}); |
if ($Babble) { |
carp "Closing $self " . $self->{NAME}; |
} |
if ($self->{"_HANDLE"}) { |
purge_all ($self); |
update_timeouts ($self); # if any running ?? |
$ok=CloseHandle($self->{"_HANDLE"}); |
if (! $ok) { |
print "Error Closing handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
elsif ($Babble) { |
print "Closing Device handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
} |
$self->{"_HANDLE"} = undef; |
} |
if ($self->{"_R_EVENT"}) { |
$ok=CloseHandle($self->{"_R_EVENT"}); |
if (! $ok) { |
print "Error closing Read Event handle $self->{\"_R_EVENT\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
$self->{"_R_EVENT"} = undef; |
} |
if ($self->{"_W_EVENT"}) { |
$ok=CloseHandle($self->{"_W_EVENT"}); |
if (! $ok) { |
print "Error closing Write Event handle $self->{\"_W_EVENT\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
$self->{"_W_EVENT"} = undef; |
} |
$self->{NAME} = undef; |
if ($Babble) { |
printf "CommPort close result:%d\n", $success; |
} |
return $success; |
} |
sub DESTROY { |
my $self = shift; |
return unless (defined $self->{NAME}); |
if ($Babble or $self->{"_DEBUG_C"}) { |
print "Destroying $self->{NAME}\n" if (defined $self->{NAME}); |
} |
$self->close; |
} |
1; # so the require or use succeeds |
# Autoload methods go after =cut, and are processed by the autosplit program. |
__END__ |
=pod |
=head1 NAME |
Win32API::CommPort - Raw Win32 system API calls for serial communications. |
=head1 SYNOPSIS |
use Win32; ## not required under all circumstances |
require 5.003; |
use Win32API::CommPort qw( :PARAM :STAT 0.19 ); |
## when available ## use Win32API::File 0.07 qw( :ALL ); |
=head2 Constructors |
$PortObj = new Win32API::CommPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
@required = qw( BAUD DATA STOP ); |
$faults = $PortObj->initialize(@required); |
if ($faults) { die "Required parameters not set before initialize\n"; } |
=head2 Configuration Utility Methods |
set_no_messages(1); # test suite use |
# exported by :PARAM |
nocarp || carp "Something fishy"; |
$a = SHORTsize; # 0xffff |
$a = LONGsize; # 0xffffffff |
$answer = yes_true("choice"); # 1 or 0 |
OS_Error unless ($API_Call_OK); # prints error |
$PortObj->init_done || die "Not done"; |
$PortObj->fetch_DCB || die "Not done"; |
$PortObj->update_DCB || die "Not done"; |
$milliseconds = $PortObj->get_tick_count; |
=head2 Capability Methods (read only) |
# true/false capabilities |
$a = $PortObj->can_baud; # else fixed |
$a = $PortObj->can_databits; |
$a = $PortObj->can_stopbits; |
$a = $PortObj->can_dtrdsr; |
$a = $PortObj->can_handshake; |
$a = $PortObj->can_parity_check; |
$a = $PortObj->can_parity_config; |
$a = $PortObj->can_parity_enable; |
$a = $PortObj->can_rlsd; # receive line signal detect (carrier) |
$a = $PortObj->can_rlsd_config; |
$a = $PortObj->can_16bitmode; |
$a = $PortObj->is_rs232; |
$a = $PortObj->is_modem; |
$a = $PortObj->can_rtscts; |
$a = $PortObj->can_xonxoff; |
$a = $PortObj->can_xon_char; |
$a = $PortObj->can_spec_char; |
$a = $PortObj->can_interval_timeout; |
$a = $PortObj->can_total_timeout; |
# list output capabilities |
($rmax, $wmax) = $PortObj->buffer_max; |
($rbuf, $wbuf) = $PortObj->are_buffers; # current |
@choices = $PortObj->are_baudrate; # legal values |
@choices = $PortObj->are_handshake; |
@choices = $PortObj->are_parity; |
@choices = $PortObj->are_databits; |
@choices = $PortObj->are_stopbits; |
=head2 Configuration Methods |
# most methods can be called two ways: |
$PortObj->is_handshake("xoff"); # set parameter |
$flowcontrol = $PortObj->is_handshake; # current value (scalar) |
# similar |
$PortObj->is_baudrate(9600); |
$PortObj->is_parity("odd"); |
$PortObj->is_databits(8); |
$PortObj->is_stopbits(1); |
$PortObj->debug_comm(0); |
$PortObj->is_xon_limit(100); # bytes left in buffer |
$PortObj->is_xoff_limit(100); # space left in buffer |
$PortObj->is_xon_char(0x11); |
$PortObj->is_xoff_char(0x13); |
$PortObj->is_eof_char(0x0); |
$PortObj->is_event_char(0x0); |
$PortObj->is_error_char(0); # for parity errors |
$rbuf = $PortObj->is_read_buf; # read_only except internal use |
$wbuf = $PortObj->is_write_buf; |
$size = $PortObj->internal_buffer; |
$PortObj->is_buffers(4096, 4096); # read, write |
# returns current in list context |
$PortObj->is_read_interval(100); # max time between read char (millisec) |
$PortObj->is_read_char_time(5); # avg time between read char |
$PortObj->is_read_const_time(100); # total = (avg * bytes) + const |
$PortObj->is_write_char_time(5); |
$PortObj->is_write_const_time(100); |
$PortObj->is_binary(T); # just say Yes (Win 3.x option) |
$PortObj->is_parity_enable(F); # faults during input |
=head2 Operating Methods |
($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->is_status |
|| warn "could not get port status\n"; |
$ClearedErrorFlags = $PortObj->reset_error; |
# The API resets errors when reading status, $LatchErrorFlags |
# is all $ErrorFlags since they were last explicitly cleared |
if ($BlockingFlags) { warn "Port is blocked"; } |
if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
Additional useful constants may be exported eventually. |
$count_in = $PortObj->read_bg($InBytes); |
($done, $count_in, $string_in) = $PortObj->read_done(1); |
# background read with wait until done |
$count_out = $PortObj->write_bg($output_string); # background write |
($done, $count_out) = $PortObj->write_done(0); |
$PortObj->suspend_tx; # output from write buffer |
$PortObj->resume_tx; |
$PortObj->xmit_imm_char(0x03); # bypass buffer (and suspend) |
$PortObj->xoff_active; # simulate received xoff |
$PortObj->xon_active; # simulate received xon |
$PortObj->purge_all; |
$PortObj->purge_rx; |
$PortObj->purge_tx; |
# controlling outputs from the port |
$PortObj->dtr_active(T); # sends outputs direct to hardware |
$PortObj->rts_active(Yes); # returns status of API call |
$PortObj->break_active(N); # NOT state of bit |
$PortObj->pulse_break_on($milliseconds); # off version is implausible |
$PortObj->pulse_rts_on($milliseconds); |
$PortObj->pulse_rts_off($milliseconds); |
$PortObj->pulse_dtr_on($milliseconds); |
$PortObj->pulse_dtr_off($milliseconds); |
# sets_bit, delays, resets_bit, delays |
# pulse_xxx methods not supported on Perl 5.004 |
$ModemStatus = $PortObj->is_modemlines; |
if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
$PortObj->close || die; |
# "undef $PortObj" preferred unless reopening port |
# "close" should precede "undef" if both used |
=head1 DESCRIPTION |
This provides fairly low-level access to the Win32 System API calls |
dealing with serial ports. |
Uses features of the Win32 API to implement non-blocking I/O, serial |
parameter setting, event-loop operation, and enhanced error handling. |
To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
This is expected to change to an empty list reference, C<[]>, when Perl |
supports that form in this usage. |
Beyond raw access to the API calls and related constants, this module |
will eventually handle smart buffer allocation and translation of return |
codes. |
=head2 Initialization |
The constructor is B<new> with a F<PortName> (as the Registry |
knows it) specified. This will do a B<CreateFile>, get the available |
options and capabilities via the Win32 API, and create the object. |
The port is not yet ready for read/write access. First, the desired |
I<parameter settings> must be established. Since these are tuning |
constants for an underlying hardware driver in the Operating System, |
they should all checked for validity by the method calls that set them. |
The B<initialize> method takes a list of required parameters and confirms |
they have been set. For others, it will attempt to deduce defaults from |
the hardware or from other parameters. The B<initialize> method returns |
the number of faults (zero if the port is setup ok). The B<update_DCB> |
method writes a new I<Device Control Block> to complete the startup and |
allow the port to be used. Ports are opened for binary transfers. A |
separate C<binmode> is not needed. The USER must release the object |
if B<initialize> or B<update_DCB> does not succeed. |
Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
to open a port prints a error message to STDOUT by default. Since only |
one application at a time can "own" the port, one source of failure was |
"port in use". There was previously no way to check this without getting |
a "fail message". Setting C<$quiet> disables this built-in message. It |
also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
used for testing this condition - other faults may still return C<undef>). |
Use of C<$quiet> only applies to B<new>. |
The fault checking in B<initialize> consists in verifying an I<_N_$item> |
internal variable exists for each I<$item> in the input list. The |
I<_N_$item> is created for each parameter that is set either directly |
or by default. A derived class must create the I<_N_$items> for any |
varibles it adds to the base class if it wants B<initialize> to check |
them. Win32API::CommPort supports the following: |
$item _N_$item setting method |
------ --------- -------------- |
BAUD "_N_BAUD" is_baudrate |
BINARY "_N_BINARY" is_binary |
DATA "_N_DATA" is_databits |
EOFCHAR "_N_EOFCHAR" is_eof_char |
ERRCHAR "_N_ERRCHAR" is_error_char |
EVTCHAR "_N_EVTCHAR" is_event_char |
HSHAKE "_N_HSHAKE" is_handshake |
PARITY "_N_PARITY" is_parity |
PARITY_EN "_N_PARITY_EN" is_parity_enable |
RCONST "_N_RCONST" is_read_const_time |
READBUF "_N_READBUF" is_read_buf |
RINT "_N_RINT" is_read_interval |
RTOT "_N_RTOT" is_read_char_time |
STOP "_N_STOP" is_stopbits |
WCONST "_N_WCONST" is_write_const_time |
WRITEBUF "_N_WRITEBUF" is_write_buf |
WTOT "_N_WTOT" is_write_char_time |
XOFFCHAR "_N_XOFFCHAR" is_xoff_char |
XOFFLIM "_N_XOFFLIM" is_xoff_limit |
XONCHAR "_N_XONCHAR" is_xon_char |
XONLIM "_N_XONLIM" is_xon_limit |
Some individual parameters (eg. baudrate) can be changed after the |
initialization is completed. These will automatically update the |
I<Device Control Block> as required. The I<init_done> method indicates |
when I<initialize> has completed successfully. |
$PortObj = new Win32API::CommPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
if $PortObj->can_databits { $PortObj->is_databits(8) }; |
$PortObj->is_baudrate(9600); |
$PortObj->is_parity("none"); |
$PortObj->is_stopbits(1); |
$PortObj->is_handshake("rts"); |
$PortObj->is_buffers(4096, 4096); |
$PortObj->dtr_active(T); |
@required = qw( BAUD DATA STOP PARITY ); |
$PortObj->initialize(@required) || undef $PortObj; |
$PortObj->dtr_active(f); |
$PortObj->is_baudrate(300); |
$PortObj->close || die; |
# "undef $PortObj" preferred unless reopening port |
# "close" should precede "undef" if both used |
undef $PortObj; # closes port AND frees memory in perl |
The F<PortName> maps to both the Registry I<Device Name> and the |
I<Properties> associated with that device. A single I<Physical> port |
can be accessed using two or more I<Device Names>. But the options |
and setup data will differ significantly in the two cases. A typical |
example is a Modem on port "COM2". Both of these F<PortNames> open |
the same I<Physical> hardware: |
$P1 = new Win32API::CommPort ("COM2"); |
$P2 = new Win32API::CommPort ("\\\\.\\Nanohertz Modem model K-9"); |
$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
of modem-specific added options and features. The "raw" API calls return |
different size configuration structures in the two cases. Win32 uses the |
"\\.\" prefix to identify "named" devices. Since both names use the same |
I<Physical> hardware, they can not both be used at the same time. The OS |
will complain. Consider this A Good Thing. |
Version 0.16 adds B<pulse> methods for the I<RTS, BREAK, and DTR> bits. The |
B<pulse> methods assume the bit is in the opposite state when the method |
is called. They set the requested state, delay the specified number of |
milliseconds, set the opposite state, and again delay the specified time. |
These methods are designed to support devices, such as the X10 "FireCracker" |
control and some modems, which require pulses on these lines to signal |
specific events or data. Since the 5.00402 Perl distribution from CPAN does |
not support sub-second time delays readily, these methods are not supported |
on that version of Perl. |
$PortObj->pulse_break_on($milliseconds); |
$PortObj->pulse_rts_on($milliseconds); |
$PortObj->pulse_rts_off($milliseconds); |
$PortObj->pulse_dtr_on($milliseconds); |
$PortObj->pulse_dtr_off($milliseconds); |
Version 0.16 also adds I<experimental> support for the rest of the option bits |
available through the I<Device Control Block>. They have not been extensively |
tested and these settings are NOT saved in the B<configuration file> by |
I<Win32::SerialPort>. Please let me know if one does not work as advertised. |
[Win32 API bit designation] |
$PortObj->ignore_null(0); # discard \000 bytes on input [fNull] |
$PortObj->ignore_no_dsr(0); # discard input bytes unless DSR |
# [fDsrSensitivity] |
$PortObj->subst_pe_char(0); # replace parity errors with B<is_error_char> |
# when B<is_parity_enable> [fErrorChar] |
$PortObj->abort_on_error(0); # cancel read/write [fAbortOnError] |
# next one set by $PortObj->is_handshake("dtr"); |
$PortObj->output_dsr(0); # use DSR handshake on output [fOutxDsrFlow] |
# next one set by $PortObj->is_handshake("rts"); |
$PortObj->output_cts(0); # use CTS handshake on output [fOutxCtsFlow] |
# next two set by $PortObj->is_handshake("xoff"); |
$PortObj->input_xoff(0); # use Xon/Xoff handshake on input [fInX] |
$PortObj->output_xoff(0); # use Xon/Xoff handshake on output [fOutX] |
$PortObj->tx_on_xoff(0); # continue output even after input xoff sent |
# [fTXContinueOnXoff] |
The B<get_tick_count> method is a wrapper around the I<Win32::GetTickCount()> |
function. It matches a corresponding method in I<Device::SerialPort> which |
does not have access to the I<Win32::> namespace. It still returns time |
in milliseconds - but can be used in cross-platform scripts. |
=head2 Configuration and Capability Methods |
The Win32 Serial Comm API provides extensive information concerning |
the capabilities and options available for a specific port (and |
instance). "Modem" ports have different capabilties than "RS-232" |
ports - even if they share the same Hardware. Many traditional modem |
actions are handled via TAPI. "Fax" ports have another set of options - |
and are accessed via MAPI. Yet many of the same low-level API commands |
and data structures are "common" to each type ("Modem" is implemented |
as an "RS-232" superset). In addition, Win95 supports a variety of |
legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
16-data-bit paths, and 256Kbaud. |
=over 8 |
Binary selections will accept as I<true> any of the following: |
C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
Anything else is I<false>. |
There are a large number of possible configuration and option parameters. |
To facilitate checking option validity in scripts, most configuration |
methods can be used in two different ways: |
=item method called with an argument |
The parameter is set to the argument, if valid. An invalid argument |
returns I<false> (undef) and the parameter is unchanged. After B<init_done>, |
the port will be updated immediately if allowed. Otherwise, the value |
will be applied when B<update_DCB> is called. |
=item method called with no argument in scalar context |
The current value is returned. If the value is not initialized either |
directly or by default, return "undef" which will parse to I<false>. |
For binary selections (true/false), return the current value. All |
current values from "multivalue" selections will parse to I<true>. |
Current values may differ from requested values until B<init_done>. |
There is no way to see requests which have not yet been applied. |
Setting the same parameter again overwrites the first request. Test |
the return value of the setting method to check "success". |
=item Asynchronous (Background) I/O |
This version now handles Polling (do if Ready), Synchronous (block until |
Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
choices provided by the API. No effort has yet been made to interact with |
Windows events. But background I/O has been used successfully with the |
Perl Tk modules and callbacks from the event loop. |
=item Timeouts |
The API provides two timing models. The first applies only to reading and |
essentially determines I<Read Not Ready> by checking the time between |
consecutive characters. The B<ReadFile> operation returns if that time |
exceeds the value set by B<is_read_interval>. It does this by timestamping |
each character. It appears that at least one character must by received in |
I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
is then reset by each succeeding character. If no characters are received, |
the read will block indefinitely. |
Setting B<is_read_interval> to C<0xffffffff> will do a non-blocking read. |
The B<ReadFile> returns immediately whether or not any characters are |
actually read. This replicates the behavior of the API. |
The other model defines the total time allowed to complete the operation. |
A fixed overhead time is added to the product of bytes and per_byte_time. |
A wide variety of timeout options can be defined by selecting the three |
parameters: fixed, each, and size. |
Read_Total = B<is_read_const_time> + (B<is_read_char_time> * bytes_to_read) |
Write_Total = B<is_write_const_time> + (B<is_write_char_time> * bytes_to_write) |
When reading a known number of characters, the I<Read_Total> mechanism is |
recommended. This mechanism I<MUST> be used with |
I<Win32::SerialPort tied FileHandles> because the tie methods can make |
multiple internal API calls. The I<Read_Interval> mechanism is suitable for |
a B<read_bg> method that expects a response of variable or unknown size. You |
should then also set a long I<Read_Total> timeout as a "backup" in case |
no bytes are received. |
=back |
=head2 Exports |
Nothing is exported by default. The following tags can be used to have |
large sets of symbols exported: |
=over 4 |
=item :PARAM |
Utility subroutines and constants for parameter setting and test: |
LONGsize SHORTsize nocarp yes_true |
OS_Error internal_buffer |
=item :STAT |
Serial communications status constants. Included are the constants for |
ascertaining why a transmission is blocked: |
BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
Which incoming bits are active: |
MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
What hardware errors have been detected: |
CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL CE_MODE |
Offsets into the array returned by B<status:> |
ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
=item :RAW |
The constants and wrapper methods for low-level API calls. Details of |
these methods may change with testing. Some may be inherited from |
Win32API::File when that becomes available. |
$result=ClearCommError($handle, $Error_BitMask_p, $CommStatus); |
$result=ClearCommBreak($handle); |
$result=SetCommBreak($handle); |
$result=GetCommModemStatus($handle, $ModemStatus); |
$result=GetCommProperties($handle, $CommProperties); |
$result=GetCommState($handle, $DCB_Buffer); |
$result=SetCommState($handle, $DCB_Buffer); |
$result=SetupComm($handle, $in_buf_size, $out_buf_size); |
$result=ReadFile($handle, $buffer, $wanted, $got, $template); |
$result=WriteFile($handle, $buffer, $size, $count, $template); |
$result=GetCommTimeouts($handle, $CommTimeOuts); |
$result=SetCommTimeouts($handle, $CommTimeOuts); |
$result=EscapeCommFunction($handle, $Func_ID); |
$result=GetCommConfig($handle, $CommConfig, $Size); |
$result=SetCommConfig($handle, $CommConfig, $Size); |
$result=PurgeComm($handle, $flags); |
$result=GetCommMask($handle, $Event_Bitmask); |
$result=SetCommMask($handle, $Event_Bitmask); |
$hEvent=CreateEvent($security, $reset_req, $initial, $name); |
$handle=CreateFile($file, $access, $share, $security, |
$creation, $flags, $template); |
$result=CloseHandle($handle); |
$result=ResetEvent($hEvent); |
$result=TransmitCommChar($handle, $char); |
$result=WaitCommEvent($handle, $Event_Bitmask, $lpOverlapped); |
$result=GetOverlappedResult($handle, $lpOverlapped, $count, $bool); |
Flags used by B<PurgeComm:> |
PURGE_TXABORT PURGE_RXABORT PURGE_TXCLEAR PURGE_RXCLEAR |
Function IDs used by EscapeCommFunction: |
SETXOFF SETXON SETRTS CLRRTS |
SETDTR CLRDTR SETBREAK CLRBREAK |
Events used by B<WaitCommEvent:> |
EV_RXCHAR EV_RXFLAG EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD EV_BREAK EV_ERR |
EV_RING EV_PERR EV_RX80FULL EV_EVENT1 |
EV_EVENT2 |
Errors specific to B<GetOverlappedResult:> |
ERROR_IO_INCOMPLETE ERROR_IO_PENDING |
=item :COMMPROP |
The constants for the I<CommProperties structure> returned by |
B<GetCommProperties>. Included mostly for completeness. |
BAUD_USER BAUD_075 BAUD_110 BAUD_134_5 |
BAUD_150 BAUD_300 BAUD_600 BAUD_1200 |
BAUD_1800 BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 BAUD_38400 |
BAUD_56K BAUD_57600 BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM PST_PARALLELPORT |
PST_RS232 PST_RS422 PST_X25 PST_NETWORK_BRIDGE |
PST_RS423 PST_RS449 PST_SCANNER PST_TCPIP_TELNET |
PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK PCF_16BITMODE |
PCF_DTRDSR PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR PCF_TOTALTIMEOUTS |
PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING SP_PARITY |
SP_RLSD SP_STOPBITS SP_SERIALCOMM SP_PARITY_CHECK |
DATABITS_5 DATABITS_6 DATABITS_7 DATABITS_8 |
DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD PARITY_EVEN |
PARITY_MARK |
COMMPROP_INITIALIZED |
=item :DCB |
The constants for the I<Device Control Block> returned by B<GetCommState> |
and updated by B<SetCommState>. Again, included mostly for completeness. |
But there are some combinations of "FM_f" settings which are not currently |
supported by high-level commands. If you need one of those, please report |
the lack as a bug. |
CBR_110 CBR_300 CBR_600 CBR_1200 |
CBR_2400 CBR_4800 CBR_9600 CBR_14400 |
CBR_19200 CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE DTR_CONTROL_HANDSHAKE |
RTS_CONTROL_DISABLE RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY ODDPARITY |
SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity FM_fOutxCtsFlow |
FM_fOutxDsrFlow FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX FM_fInX |
FM_fErrorChar FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 |
=item :ALL |
All of the above. Except for the I<test suite>, there is not really a good |
reason to do this. |
=back |
=head1 NOTES |
The object returned by B<new> is NOT a I<Filehandle>. You |
will be disappointed if you try to use it as one. |
e.g. the following is WRONG!!____C<print $PortObj "some text";> |
I<Win32::SerialPort> supports accessing ports via I<Tied Filehandles>. |
An important note about Win32 filenames. The reserved device names such |
as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
This module uses Win32::API extensively. The raw API calls are B<very> |
unforgiving. You will certainly want to start perl with the B<-w> switch. |
If you can, B<use strict> as well. Try to ferret out all the syntax and |
usage problems BEFORE issuing the API calls (many of which modify tuning |
constants in hardware device drivers....not where you want to look for bugs). |
Thanks to Ken White for testing on NT. |
=head1 KNOWN LIMITATIONS |
The current version of the module has been designed for testing using |
the ActiveState and Core (GS 5.004_02) ports of Perl for Win32 without |
requiring a compiler or using XS. In every case, compatibility has been |
selected over performance. Since everything is (sometimes convoluted but |
still pure) Perl, you can fix flaws and change limits if required. But |
please file a bug report if you do. This module has been tested with |
each of the binary perl versions for which Win32::API is supported: AS |
builds 315, 316, and 500-509 and GS 5.004_02. It has only been tested on |
Intel hardware. |
=over 4 |
=item Tutorial |
With all the options, this module needs a good tutorial. It doesn't |
have a complete one yet. A I<"How to get started"> tutorial appeared |
B<The Perl Journal #13> (March 1999). The demo programs are a good |
starting point for additional examples. |
=item Buffers |
The size of the Win32 buffers are selectable with B<is_buffers>. But each read |
method currently uses a fixed internal buffer of 4096 bytes. This can be |
changed in the module source. The read-only B<internal_buffer> method will |
give the current size. There are other fixed internal buffers as well. But |
no one has needed to change those. The XS version will support dynamic buffer |
sizing. |
=item Modems |
Lots of modem-specific options are not supported. The same is true of |
TAPI, MAPI. I<API Wizards> are welcome to contribute. |
=item API Options |
Lots of options are just "passed through from the API". Some probably |
shouldn't be used together. The module validates the obvious choices when |
possible. For something really fancy, you may need additional API |
documentation. Available from I<Micro$oft Pre$$>. |
=back |
=head1 BUGS |
ActiveState ports of Perl for Win32 before build 500 do not support the |
tools for building extensions and so will not support later versions of |
this extension. In particular, the automated install and test scripts in |
this distribution work differently with ActiveState builds 3xx. |
There is no parameter checking on the "raw" API calls. You probably should |
be familiar with using the calls in "C" before doing much experimenting. |
On Win32, a port must B<close> before it can be reopened again by the same |
process. If a physical port can be accessed using more than one name (see |
above), all names are treated as one. The perl script can also be run |
multiple times within a single batch file or shell script. The I<Makefile.PL> |
spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
but it works. |
On NT, a B<read_done> or B<write_done> returns I<False> if a background |
operation is aborted by a purge. Win95 returns I<True>. |
EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
A few NT systems seem to set B<can_parity_enable> true, but do not actually |
support setting B<is_parity_enable>. This may be a characteristic of certain |
third-party serial drivers. Or a Microsoft bug. I have not been able to |
reproduce it on my system. |
__Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
=head1 AUTHORS |
Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
=head1 SEE ALSO |
Wi32::SerialPort - High-level user interface/front-end for this module |
Win32API::File I<when available> |
Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
=head1 COPYRIGHT |
Copyright (C) 1999, Bill Birthisel. All rights reserved. |
This module is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head2 COMPATIBILITY |
Most of the code in this module has been stable since version 0.12. |
Except for items indicated as I<Experimental>, I do not expect functional |
changes which are not fully backwards compatible. However, Version 0.16 |
removes the "dummy (0, 1) list" which was returned by many binary methods |
in case they were called in list context. I do not know of any use outside |
the test suite for that feature. |
Version 0.12 added an I<Install.PL> script to put modules into the documented |
Namespaces. The script uses I<MakeMaker> tools not available in |
ActiveState 3xx builds. Users of those builds will need to install |
differently (see README). Programs in the test suite are modified for |
the current version. Additions to the configurtion files generated by |
B<save> prevent those created by Version 0.15 from being used by earlier |
Versions. 4 November 1999. |
=cut |
/MissionCockpit/tags/V0.4.1/perl/lib/Win32API/CommPort.pm |
---|
0,0 → 1,3146 |
# This part includes the low-level API calls |
package Win32API::CommPort; |
use Win32; |
use Win32::API 0.01; |
if ( $] < 5.004 ) { |
my $no_silly_warning = $Win32::API::VERSION; |
$no_silly_warning = $Win32::API::pack; |
} |
use Carp; |
use strict; |
#### API declarations #### |
no strict 'subs'; # these may be imported someday |
use vars qw( |
$_CloseHandle $_CreateFile $_GetCommState |
$_ReadFile $_SetCommState $_SetupComm |
$_PurgeComm $_CreateEvent $_GetCommTimeouts |
$_SetCommTimeouts $_GetCommProperties $_ClearCommBreak |
$_ClearCommError $_EscapeCommFunction $_GetCommConfig |
$_GetCommMask $_GetCommModemStatus $_SetCommBreak |
$_SetCommConfig $_SetCommMask $_TransmitCommChar |
$_WaitCommEvent $_WriteFile $_ResetEvent |
$_GetOverlappedResult |
); |
$_CreateFile = new Win32::API("kernel32", "CreateFile", |
[P, N, N, N, N, N, N], N); |
$_CloseHandle = new Win32::API("kernel32", "CloseHandle", [N], N); |
$_GetCommState = new Win32::API("kernel32", "GetCommState", [N, P], I); |
$_SetCommState = new Win32::API("kernel32", "SetCommState", [N, P], I); |
$_SetupComm = new Win32::API("kernel32", "SetupComm", [N, N, N], I); |
$_PurgeComm = new Win32::API("kernel32", "PurgeComm", [N, N], I); |
$_CreateEvent = new Win32::API("kernel32", "CreateEvent", [P, I, I, P], N); |
$_GetCommTimeouts = new Win32::API("kernel32", "GetCommTimeouts", |
[N, P], I); |
$_SetCommTimeouts = new Win32::API("kernel32", "SetCommTimeouts", |
[N, P], I); |
$_GetCommProperties = new Win32::API("kernel32", "GetCommProperties", |
[N, P], I); |
$_ReadFile = new Win32::API("kernel32", "ReadFile", [N, P, N, P, P], I); |
$_WriteFile = new Win32::API("kernel32", "WriteFile", [N, P, N, P, P], I); |
$_TransmitCommChar = new Win32::API("kernel32", "TransmitCommChar", [N, I], I); |
$_ClearCommBreak = new Win32::API("kernel32", "ClearCommBreak", [N], I); |
$_SetCommBreak = new Win32::API("kernel32", "SetCommBreak", [N], I); |
$_ClearCommError = new Win32::API("kernel32", "ClearCommError", [N, P, P], I); |
$_EscapeCommFunction = new Win32::API("kernel32", "EscapeCommFunction", |
[N, N], I); |
$_GetCommModemStatus = new Win32::API("kernel32", "GetCommModemStatus", |
[N, P], I); |
$_GetOverlappedResult = new Win32::API("kernel32", "GetOverlappedResult", |
[N, P, P, I], I); |
#### these are not used yet |
$_GetCommConfig = new Win32::API("kernel32", "GetCommConfig", [N, P, P], I); |
$_GetCommMask = new Win32::API("kernel32", "GetCommMask", [N, P], I); |
$_SetCommConfig = new Win32::API("kernel32", "SetCommConfig", [N, P, N], I); |
$_SetCommMask = new Win32::API("kernel32", "SetCommMask", [N, N], I); |
$_WaitCommEvent = new Win32::API("kernel32", "WaitCommEvent", [N, P, P], I); |
$_ResetEvent = new Win32::API("kernel32", "ResetEvent", [N], I); |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $RBUF_Size); |
$VERSION = '0.19'; |
$RBUF_Size = 4096; |
require Exporter; |
## require AutoLoader; |
@ISA = qw(Exporter); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= qw(); |
%EXPORT_TAGS = (STAT => [qw( BM_fCtsHold BM_fDsrHold |
BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof |
BM_fTxim BM_AllBits |
MS_CTS_ON MS_DSR_ON |
MS_RING_ON MS_RLSD_ON |
CE_RXOVER CE_OVERRUN |
CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL |
CE_MODE ST_BLOCK |
ST_INPUT ST_OUTPUT |
ST_ERROR )], |
RAW => [qw( CloseHandle CreateFile |
GetCommState ReadFile |
SetCommState SetupComm |
PurgeComm CreateEvent |
GetCommTimeouts SetCommTimeouts |
GetCommProperties ClearCommBreak |
ClearCommError EscapeCommFunction |
GetCommConfig GetCommMask |
GetCommModemStatus SetCommBreak |
SetCommConfig SetCommMask |
TransmitCommChar WaitCommEvent |
WriteFile ResetEvent |
GetOverlappedResult |
PURGE_TXABORT PURGE_RXABORT |
PURGE_TXCLEAR PURGE_RXCLEAR |
SETXOFF SETXON |
SETRTS CLRRTS |
SETDTR CLRDTR |
SETBREAK CLRBREAK |
EV_RXCHAR EV_RXFLAG |
EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD |
EV_BREAK EV_ERR |
EV_RING EV_PERR |
EV_RX80FULL EV_EVENT1 |
EV_EVENT2 ERROR_IO_INCOMPLETE |
ERROR_IO_PENDING )], |
COMMPROP => [qw( BAUD_USER BAUD_075 BAUD_110 |
BAUD_134_5 BAUD_150 BAUD_300 |
BAUD_600 BAUD_1200 BAUD_1800 |
BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 |
BAUD_38400 BAUD_56K BAUD_57600 |
BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM |
PST_RS232 PST_RS422 PST_RS423 |
PST_RS449 PST_SCANNER PST_X25 |
PST_NETWORK_BRIDGE PST_PARALLELPORT |
PST_TCPIP_TELNET PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK |
PCF_16BITMODE PCF_DTRDSR |
PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR |
PCF_TOTALTIMEOUTS PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING |
SP_PARITY SP_PARITY_CHECK SP_RLSD |
SP_STOPBITS SP_SERIALCOMM |
DATABITS_5 DATABITS_6 DATABITS_7 |
DATABITS_8 DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD |
PARITY_EVEN PARITY_MARK |
COMMPROP_INITIALIZED )], |
DCB => [qw( CBR_110 CBR_300 CBR_600 |
CBR_1200 CBR_2400 CBR_4800 |
CBR_9600 CBR_14400 CBR_19200 |
CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE |
DTR_CONTROL_HANDSHAKE RTS_CONTROL_DISABLE |
RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY |
ODDPARITY SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity |
FM_fOutxCtsFlow FM_fOutxDsrFlow |
FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX |
FM_fInX FM_fErrorChar |
FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 )], |
PARAM => [qw( LONGsize SHORTsize OS_Error |
nocarp internal_buffer yes_true )]); |
Exporter::export_ok_tags('STAT', 'RAW', 'COMMPROP', 'DCB', 'PARAM'); |
$EXPORT_TAGS{ALL} = \@EXPORT_OK; |
#### subroutine wrappers for API calls |
sub CloseHandle { |
return unless ( 1 == @_ ); |
return $_CloseHandle->Call( shift ); |
} |
sub CreateFile { |
return $_CreateFile->Call( @_ ); |
# returns handle |
} |
sub GetCommState { |
return $_GetCommState->Call( @_ ); |
} |
sub SetCommState { |
return $_SetCommState->Call( @_ ); |
} |
sub SetupComm { |
return $_SetupComm->Call( @_ ); |
} |
sub PurgeComm { |
return $_PurgeComm->Call( @_ ); |
} |
sub CreateEvent { |
return $_CreateEvent->Call( @_ ); |
} |
sub GetCommTimeouts { |
return $_GetCommTimeouts->Call( @_ ); |
} |
sub SetCommTimeouts { |
return $_SetCommTimeouts->Call( @_ ); |
} |
sub GetCommProperties { |
return $_GetCommProperties->Call( @_ ); |
} |
sub ReadFile { |
return $_ReadFile->Call( @_ ); |
} |
sub WriteFile { |
return $_WriteFile->Call( @_ ); |
} |
sub TransmitCommChar { |
return $_TransmitCommChar->Call( @_ ); |
} |
sub ClearCommBreak { |
return unless ( 1 == @_ ); |
return $_ClearCommBreak->Call( shift ); |
} |
sub SetCommBreak { |
return unless ( 1 == @_ ); |
return $_SetCommBreak->Call( shift ); |
} |
sub ClearCommError { |
return $_ClearCommError->Call( @_ ); |
} |
sub EscapeCommFunction { |
return $_EscapeCommFunction->Call( @_ ); |
} |
sub GetCommModemStatus { |
return $_GetCommModemStatus->Call( @_ ); |
} |
sub GetOverlappedResult { |
return $_GetOverlappedResult->Call( @_ ); |
} |
sub GetCommConfig { |
return $_GetCommConfig->Call( @_ ); |
} |
sub GetCommMask { |
return $_GetCommMask->Call( @_ ); |
} |
sub SetCommConfig { |
return $_SetCommConfig->Call( @_ ); |
} |
sub SetCommMask { |
return $_SetCommMask->Call( @_ ); |
} |
sub WaitCommEvent { |
return $_WaitCommEvent->Call( @_ ); |
} |
sub ResetEvent { |
return unless ( 1 == @_ ); |
return $_ResetEvent->Call( shift ); |
} |
#### "constant" declarations from Win32 header files #### |
#### compatible with ActiveState #### |
## COMMPROP structure |
sub SP_SERIALCOMM { 0x1 } |
sub BAUD_075 { 0x1 } |
sub BAUD_110 { 0x2 } |
sub BAUD_134_5 { 0x4 } |
sub BAUD_150 { 0x8 } |
sub BAUD_300 { 0x10 } |
sub BAUD_600 { 0x20 } |
sub BAUD_1200 { 0x40 } |
sub BAUD_1800 { 0x80 } |
sub BAUD_2400 { 0x100 } |
sub BAUD_4800 { 0x200 } |
sub BAUD_7200 { 0x400 } |
sub BAUD_9600 { 0x800 } |
sub BAUD_14400 { 0x1000 } |
sub BAUD_19200 { 0x2000 } |
sub BAUD_38400 { 0x4000 } |
sub BAUD_56K { 0x8000 } |
sub BAUD_57600 { 0x40000 } |
sub BAUD_115200 { 0x20000 } |
sub BAUD_128K { 0x10000 } |
sub BAUD_USER { 0x10000000 } |
sub PST_FAX { 0x21 } |
sub PST_LAT { 0x101 } |
sub PST_MODEM { 0x6 } |
sub PST_NETWORK_BRIDGE { 0x100 } |
sub PST_PARALLELPORT { 0x2 } |
sub PST_RS232 { 0x1 } |
sub PST_RS422 { 0x3 } |
sub PST_RS423 { 0x4 } |
sub PST_RS449 { 0x5 } |
sub PST_SCANNER { 0x22 } |
sub PST_TCPIP_TELNET { 0x102 } |
sub PST_UNSPECIFIED { 0 } |
sub PST_X25 { 0x103 } |
sub PCF_16BITMODE { 0x200 } |
sub PCF_DTRDSR { 0x1 } |
sub PCF_INTTIMEOUTS { 0x80 } |
sub PCF_PARITY_CHECK { 0x8 } |
sub PCF_RLSD { 0x4 } |
sub PCF_RTSCTS { 0x2 } |
sub PCF_SETXCHAR { 0x20 } |
sub PCF_SPECIALCHARS { 0x100 } |
sub PCF_TOTALTIMEOUTS { 0x40 } |
sub PCF_XONXOFF { 0x10 } |
sub SP_BAUD { 0x2 } |
sub SP_DATABITS { 0x4 } |
sub SP_HANDSHAKING { 0x10 } |
sub SP_PARITY { 0x1 } |
sub SP_PARITY_CHECK { 0x20 } |
sub SP_RLSD { 0x40 } |
sub SP_STOPBITS { 0x8 } |
sub DATABITS_5 { 1 } |
sub DATABITS_6 { 2 } |
sub DATABITS_7 { 4 } |
sub DATABITS_8 { 8 } |
sub DATABITS_16 { 16 } |
sub DATABITS_16X { 32 } |
sub STOPBITS_10 { 1 } |
sub STOPBITS_15 { 2 } |
sub STOPBITS_20 { 4 } |
sub PARITY_NONE { 256 } |
sub PARITY_ODD { 512 } |
sub PARITY_EVEN { 1024 } |
sub PARITY_MARK { 2048 } |
sub PARITY_SPACE { 4096 } |
sub COMMPROP_INITIALIZED { 0xe73cf52e } |
## DCB structure |
sub CBR_110 { 110 } |
sub CBR_300 { 300 } |
sub CBR_600 { 600 } |
sub CBR_1200 { 1200 } |
sub CBR_2400 { 2400 } |
sub CBR_4800 { 4800 } |
sub CBR_9600 { 9600 } |
sub CBR_14400 { 14400 } |
sub CBR_19200 { 19200 } |
sub CBR_38400 { 38400 } |
sub CBR_56000 { 56000 } |
sub CBR_57600 { 57600 } |
sub CBR_115200 { 115200 } |
sub CBR_128000 { 128000 } |
sub CBR_256000 { 256000 } |
sub DTR_CONTROL_DISABLE { 0 } |
sub DTR_CONTROL_ENABLE { 1 } |
sub DTR_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_DISABLE { 0 } |
sub RTS_CONTROL_ENABLE { 1 } |
sub RTS_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_TOGGLE { 3 } |
sub EVENPARITY { 2 } |
sub MARKPARITY { 3 } |
sub NOPARITY { 0 } |
sub ODDPARITY { 1 } |
sub SPACEPARITY { 4 } |
sub ONESTOPBIT { 0 } |
sub ONE5STOPBITS { 1 } |
sub TWOSTOPBITS { 2 } |
## Flowcontrol bit mask in DCB |
sub FM_fBinary { 0x1 } |
sub FM_fParity { 0x2 } |
sub FM_fOutxCtsFlow { 0x4 } |
sub FM_fOutxDsrFlow { 0x8 } |
sub FM_fDtrControl { 0x30 } |
sub FM_fDsrSensitivity { 0x40 } |
sub FM_fTXContinueOnXoff { 0x80 } |
sub FM_fOutX { 0x100 } |
sub FM_fInX { 0x200 } |
sub FM_fErrorChar { 0x400 } |
sub FM_fNull { 0x800 } |
sub FM_fRtsControl { 0x3000 } |
sub FM_fAbortOnError { 0x4000 } |
sub FM_fDummy2 { 0xffff8000 } |
## COMSTAT bit mask |
sub BM_fCtsHold { 0x1 } |
sub BM_fDsrHold { 0x2 } |
sub BM_fRlsdHold { 0x4 } |
sub BM_fXoffHold { 0x8 } |
sub BM_fXoffSent { 0x10 } |
sub BM_fEof { 0x20 } |
sub BM_fTxim { 0x40 } |
sub BM_AllBits { 0x7f } |
## PurgeComm bit mask |
sub PURGE_TXABORT { 0x1 } |
sub PURGE_RXABORT { 0x2 } |
sub PURGE_TXCLEAR { 0x4 } |
sub PURGE_RXCLEAR { 0x8 } |
## GetCommModemStatus bit mask |
sub MS_CTS_ON { 0x10 } |
sub MS_DSR_ON { 0x20 } |
sub MS_RING_ON { 0x40 } |
sub MS_RLSD_ON { 0x80 } |
## EscapeCommFunction operations |
sub SETXOFF { 0x1 } |
sub SETXON { 0x2 } |
sub SETRTS { 0x3 } |
sub CLRRTS { 0x4 } |
sub SETDTR { 0x5 } |
sub CLRDTR { 0x6 } |
sub SETBREAK { 0x8 } |
sub CLRBREAK { 0x9 } |
## ClearCommError bit mask |
sub CE_RXOVER { 0x1 } |
sub CE_OVERRUN { 0x2 } |
sub CE_RXPARITY { 0x4 } |
sub CE_FRAME { 0x8 } |
sub CE_BREAK { 0x10 } |
sub CE_TXFULL { 0x100 } |
#### LPT only |
# sub CE_PTO { 0x200 } |
# sub CE_IOE { 0x400 } |
# sub CE_DNS { 0x800 } |
# sub CE_OOP { 0x1000 } |
#### LPT only |
sub CE_MODE { 0x8000 } |
## GetCommMask bits |
sub EV_RXCHAR { 0x1 } |
sub EV_RXFLAG { 0x2 } |
sub EV_TXEMPTY { 0x4 } |
sub EV_CTS { 0x8 } |
sub EV_DSR { 0x10 } |
sub EV_RLSD { 0x20 } |
sub EV_BREAK { 0x40 } |
sub EV_ERR { 0x80 } |
sub EV_RING { 0x100 } |
sub EV_PERR { 0x200 } |
sub EV_RX80FULL { 0x400 } |
sub EV_EVENT1 { 0x800 } |
sub EV_EVENT2 { 0x1000 } |
## Allowed OVERLAP errors |
sub ERROR_IO_INCOMPLETE { 996 } |
sub ERROR_IO_PENDING { 997 } |
#### "constant" declarations compatible with ActiveState #### |
my $DCBformat="LLLSSSCCCCCCCCS"; |
my $CP_format1="SSLLLLLLLLLSSLLLLSA*"; # rs232 |
my $CP_format6="SSLLLLLLLLLSSLLLLLLLLLLLLLLLLLLLLLLLA*"; # modem |
my $CP_format0="SA50LA244"; # pre-read |
my $OVERLAPPEDformat="LLLLL"; |
my $TIMEOUTformat="LLLLL"; |
my $COMSTATformat="LLL"; |
my $cfg_file_sig="Win32API::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
sub SHORTsize { 0xffff; } |
sub LONGsize { 0xffffffff; } |
sub ST_BLOCK {0} # status offsets for caller |
sub ST_INPUT {1} |
sub ST_OUTPUT {2} |
sub ST_ERROR {3} # latched |
#### Package variable declarations #### |
my @Yes_resp = ( |
"YES","Y", |
"ON", |
"TRUE","T", |
"1" |
); |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $Babble = 0; |
my $testactive = 0; # test mode active |
## my $null=[]; |
my $null=0; |
my $zero=0; |
# Preloaded methods go here. |
sub OS_Error { print Win32::FormatMessage ( Win32::GetLastError() ); } |
sub get_tick_count { return Win32::GetTickCount(); } |
# test*.t only - suppresses default messages |
sub set_no_messages { |
return unless (@_ == 2); |
$testactive = yes_true($_[1]); |
} |
sub nocarp { return $testactive } |
sub internal_buffer { return $RBUF_Size } |
sub yes_true { |
my $choice = uc shift; |
my $ans = 0; |
foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) } |
return $ans; |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $self = {}; |
my $ok = 0; # API return value |
my $hr = 0; # temporary hashref |
my $fmask = 0; # temporary for bit banging |
my $fix_baud = 0; |
my $key; |
my $value; |
my $CommPropBlank = " "; |
# COMMPROP only used during new |
my $CommProperties = " "x300; # extra buffer for modems |
my $CP_Length = 0; |
my $CP_Version = 0; |
my $CP_ServiceMask = 0; |
my $CP_Reserved1 = 0; |
my $CP_MaxBaud = 0; |
my $CP_ProvCapabilities = 0; |
my $CP_SettableParams = 0; |
my $CP_SettableBaud = 0; |
my $CP_SettableData = 0; |
my $CP_SettableStopParity = 0; |
my $CP_ProvSpec1 = 0; |
my $CP_ProvSpec2 = 0; |
my $CP_ProvChar_start = 0; |
my $CP_Filler = 0; |
# MODEMDEVCAPS |
my $MC_ReqSize = 0; |
my $MC_SpecOffset = 0; |
my $MC_SpecSize = 0; |
my $MC_ProvVersion = 0; |
my $MC_ManfOffset = 0; |
my $MC_ManfSize = 0; |
my $MC_ModOffset = 0; |
my $MC_ModSize = 0; |
my $MC_VerOffset = 0; |
my $MC_VerSize = 0; |
my $MC_DialOpt = 0; |
my $MC_CallFailTime = 0; |
my $MC_IdleTime = 0; |
my $MC_SpkrVol = 0; |
my $MC_SpkrMode = 0; |
my $MC_ModOpt = 0; |
my $MC_MaxDTE = 0; |
my $MC_MaxDCE = 0; |
my $MC_Filler = 0; |
$self->{NAME} = shift; |
my $quiet = shift; |
$self->{"_HANDLE"}=CreateFile("$self->{NAME}", |
0xc0000000, |
0, |
$null, |
3, |
0x40000000, |
$null); |
# device name |
# GENERIC_READ | GENERIC_WRITE |
# no FILE_SHARE_xx |
# no SECURITY_xx |
# OPEN_EXISTING |
# FILE_FLAG_OVERLAPPED |
# template file |
unless ($self->{"_HANDLE"} >= 1) { |
$self->{"_HANDLE"} = 0; |
return 0 if ($quiet); |
return if (nocarp); |
OS_Error; |
carp "can't open device: $self->{NAME}\n"; |
return; |
} |
# let Win32 know we allowed room for modem properties |
$CP_Length = 300; |
$CP_ProvSpec1 = COMMPROP_INITIALIZED; |
$CommProperties = pack($CP_format0, |
$CP_Length, |
$CommPropBlank, |
$CP_ProvSpec1, |
$CommPropBlank); |
$ok=GetCommProperties($self->{"_HANDLE"}, $CommProperties); |
unless ( $ok ) { |
OS_Error; |
carp "can't get COMMPROP block"; |
undef $self; |
return; |
} |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$CP_Filler)= unpack($CP_format1, $CommProperties); |
if (($CP_Length > 66) and ($self->{"_TYPE"} == PST_RS232)) { |
carp "invalid COMMPROP block length= $CP_Length"; |
undef $self; |
return; |
} |
if ($CP_ServiceMask != SP_SERIALCOMM) { |
carp "doesn't claim to be a serial port\n"; |
undef $self; |
return; |
} |
if ($self->{"_TYPE"} == PST_MODEM) { |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$MC_ReqSize, |
$MC_SpecOffset, |
$MC_SpecSize, |
$MC_ProvVersion, |
$MC_ManfOffset, |
$MC_ManfSize, |
$MC_ModOffset, |
$MC_ModSize, |
$MC_VerOffset, |
$MC_VerSize, |
$MC_DialOpt, |
$MC_CallFailTime, |
$MC_IdleTime, |
$MC_SpkrVol, |
$MC_SpkrMode, |
$MC_ModOpt, |
$MC_MaxDTE, |
$MC_MaxDCE, |
$MC_Filler)= unpack($CP_format6, $CommProperties); |
if ($Babble) { |
printf "\nMODEMDEVCAPS:\n"; |
printf "\$MC_ActualSize= %d\n", $CP_ProvChar_start; |
printf "\$MC_ReqSize= %d\n", $MC_ReqSize; |
printf "\$MC_SpecOffset= %d\n", $MC_SpecOffset; |
printf "\$MC_SpecSize= %d\n", $MC_SpecSize; |
if ($MC_SpecOffset) { |
printf " DeviceSpecificData= %s\n", substr ($CommProperties, |
60+$MC_SpecOffset, $MC_SpecSize); |
} |
printf "\$MC_ProvVersion= %d\n", $MC_ProvVersion; |
printf "\$MC_ManfOffset= %d\n", $MC_ManfOffset; |
printf "\$MC_ManfSize= %d\n", $MC_ManfSize; |
if ($MC_ManfOffset) { |
printf " Manufacturer= %s\n", substr ($CommProperties, |
60+$MC_ManfOffset, $MC_ManfSize); |
} |
printf "\$MC_ModOffset= %d\n", $MC_ModOffset; |
printf "\$MC_ModSize= %d\n", $MC_ModSize; |
if ($MC_ModOffset) { |
printf " Model= %s\n", substr ($CommProperties, |
60+$MC_ModOffset, $MC_ModSize); |
} |
printf "\$MC_VerOffset= %d\n", $MC_VerOffset; |
printf "\$MC_VerSize= %d\n", $MC_VerSize; |
if ($MC_VerOffset) { |
printf " Version= %s\n", substr ($CommProperties, |
60+$MC_VerOffset, $MC_VerSize); |
} |
printf "\$MC_DialOpt= %lx\n", $MC_DialOpt; |
printf "\$MC_CallFailTime= %d\n", $MC_CallFailTime; |
printf "\$MC_IdleTime= %d\n", $MC_IdleTime; |
printf "\$MC_SpkrVol= %d\n", $MC_SpkrVol; |
printf "\$MC_SpkrMode= %d\n", $MC_SpkrMode; |
printf "\$MC_ModOpt= %lx\n", $MC_ModOpt; |
printf "\$MC_MaxDTE= %d\n", $MC_MaxDTE; |
printf "\$MC_MaxDCE= %d\n", $MC_MaxDCE; |
$MC_Filler= $MC_Filler; # for -w |
} |
## $MC_ReqSize = 250; |
if ($CP_ProvChar_start != $MC_ReqSize) { |
printf "\nARGH, a Bug! The \$CommProperties buffer must be "; |
printf "at least %d bytes.\n", $MC_ReqSize+60; |
} |
} |
## if (1 | $Babble) { |
if ($Babble) { |
printf "\$CP_Length= %d\n", $CP_Length; |
printf "\$CP_Version= %d\n", $CP_Version; |
printf "\$CP_ServiceMask= %lx\n", $CP_ServiceMask; |
printf "\$CP_Reserved1= %lx\n", $CP_Reserved1; |
printf "\$CP_MaxTxQueue= %lx\n", $self->{"_MaxTxQueue"}; |
printf "\$CP_MaxRxQueue= %lx\n", $self->{"_MaxRxQueue"}; |
printf "\$CP_MaxBaud= %lx\n", $CP_MaxBaud; |
printf "\$CP_ProvSubType= %lx\n", $self->{"_TYPE"}; |
printf "\$CP_ProvCapabilities= %lx\n", $CP_ProvCapabilities; |
printf "\$CP_SettableParams= %lx\n", $CP_SettableParams; |
printf "\$CP_SettableBaud= %lx\n", $CP_SettableBaud; |
printf "\$CP_SettableData= %x\n", $CP_SettableData; |
printf "\$CP_SettableStopParity= %x\n", $CP_SettableStopParity; |
printf "\$CP_CurrentTxQueue= %lx\n", $self->{WRITEBUF}; |
printf "\$CP_CurrentRxQueue= %lx\n", $self->{READBUF}; |
printf "\$CP_ProvSpec1= %lx\n", $CP_ProvSpec1; |
printf "\$CP_ProvSpec2= %lx\n", $CP_ProvSpec2; |
} |
# "private" data |
$self->{"_INIT"} = undef; |
$self->{"_DEBUG_C"} = 0; |
$self->{"_LATCH"} = 0; |
$self->{"_W_BUSY"} = 0; |
$self->{"_R_BUSY"} = 0; |
$self->{"_TBUFMAX"} = $self->{"_MaxTxQueue"} ? |
$self->{"_MaxTxQueue"} : LONGsize; |
$self->{"_RBUFMAX"} = $self->{"_MaxRxQueue"} ? |
$self->{"_MaxRxQueue"} : LONGsize; |
# buffers |
$self->{"_R_OVERLAP"} = " "x24; |
$self->{"_W_OVERLAP"} = " "x24; |
$self->{"_TIMEOUT"} = " "x24; |
$self->{"_RBUF"} = " "x $RBUF_Size; |
# allowed setting hashes |
$self->{"_L_BAUD"} = {}; |
$self->{"_L_STOP"} = {}; |
$self->{"_L_PARITY"} = {}; |
$self->{"_L_DATA"} = {}; |
$self->{"_L_HSHAKE"} = {}; |
# capability flags |
$fmask = $CP_SettableParams; |
$self->{"_C_BAUD"} = $fmask & SP_BAUD; |
$self->{"_C_DATA"} = $fmask & SP_DATABITS; |
$self->{"_C_STOP"} = $fmask & SP_STOPBITS; |
$self->{"_C_HSHAKE"} = $fmask & SP_HANDSHAKING; |
$self->{"_C_PARITY_CFG"} = $fmask & SP_PARITY; |
$self->{"_C_PARITY_EN"} = $fmask & SP_PARITY_CHECK; |
$self->{"_C_RLSD_CFG"} = $fmask & SP_RLSD; |
$fmask = $CP_ProvCapabilities; |
$self->{"_C_RLSD"} = $fmask & PCF_RLSD; |
$self->{"_C_PARITY_CK"} = $fmask & PCF_PARITY_CHECK; |
$self->{"_C_DTRDSR"} = $fmask & PCF_DTRDSR; |
$self->{"_C_16BITMODE"} = $fmask & PCF_16BITMODE; |
$self->{"_C_RTSCTS"} = $fmask & PCF_RTSCTS; |
$self->{"_C_XONXOFF"} = $fmask & PCF_XONXOFF; |
$self->{"_C_XON_CHAR"} = $fmask & PCF_SETXCHAR; |
$self->{"_C_SPECHAR"} = $fmask & PCF_SPECIALCHARS; |
$self->{"_C_INT_TIME"} = $fmask & PCF_INTTIMEOUTS; |
$self->{"_C_TOT_TIME"} = $fmask & PCF_TOTALTIMEOUTS; |
if ($self->{"_C_INT_TIME"}) { |
$self->{"_N_RINT"} = LONGsize; # min interval default |
} |
else { |
$self->{"_N_RINT"} = 0; |
} |
$self->{"_N_RTOT"} = 0; |
$self->{"_N_RCONST"} = 0; |
if ($self->{"_C_TOT_TIME"}) { |
$self->{"_N_WCONST"} = 201; # startup overhead + 1 |
$self->{"_N_WTOT"} = 11; # per char out + 1 |
} |
else { |
$self->{"_N_WTOT"} = 0; |
$self->{"_N_WCONST"} = 0; |
} |
$hr = \%{$self->{"_L_HSHAKE"}}; |
if ($self->{"_C_HSHAKE"}) { |
${$hr}{"xoff"} = "xoff" if ($fmask & PCF_XONXOFF); |
${$hr}{"rts"} = "rts" if ($fmask & PCF_RTSCTS); |
${$hr}{"dtr"} = "dtr" if ($fmask & PCF_DTRDSR); |
${$hr}{"none"} = "none"; |
} |
else { $self->{"_N_HSHAKE"} = undef; } |
#### really just using the keys here, so value = Win32_definition |
#### in case we ever need it for something else |
# first check for programmable baud |
$hr = \%{$self->{"_L_BAUD"}}; |
if ($CP_MaxBaud & BAUD_USER) { |
$fmask = $CP_SettableBaud; |
${$hr}{110} = CBR_110 if ($fmask & BAUD_110); |
${$hr}{300} = CBR_300 if ($fmask & BAUD_300); |
${$hr}{600} = CBR_600 if ($fmask & BAUD_600); |
${$hr}{1200} = CBR_1200 if ($fmask & BAUD_1200); |
${$hr}{2400} = CBR_2400 if ($fmask & BAUD_2400); |
${$hr}{4800} = CBR_4800 if ($fmask & BAUD_4800); |
${$hr}{9600} = CBR_9600 if ($fmask & BAUD_9600); |
${$hr}{14400} = CBR_14400 if ($fmask & BAUD_14400); |
${$hr}{19200} = CBR_19200 if ($fmask & BAUD_19200); |
${$hr}{38400} = CBR_38400 if ($fmask & BAUD_38400); |
${$hr}{56000} = CBR_56000 if ($fmask & BAUD_56K); |
${$hr}{57600} = CBR_57600 if ($fmask & BAUD_57600); |
${$hr}{115200} = CBR_115200 if ($fmask & BAUD_115200); |
${$hr}{128000} = CBR_128000 if ($fmask & BAUD_128K); |
${$hr}{256000} = CBR_256000 if (0); # reserved ?? |
} |
else { |
# get fixed baud from CP_MaxBaud |
$fmask = $CP_MaxBaud; |
$fix_baud = 75 if ($fmask & BAUD_075); |
$fix_baud = 110 if ($fmask & BAUD_110); |
$fix_baud = 134.5 if ($fmask & BAUD_134_5); |
$fix_baud = 150 if ($fmask & BAUD_150); |
$fix_baud = 300 if ($fmask & BAUD_300); |
$fix_baud = 600 if ($fmask & BAUD_600); |
$fix_baud = 1200 if ($fmask & BAUD_1200); |
$fix_baud = 1800 if ($fmask & BAUD_1800); |
$fix_baud = 2400 if ($fmask & BAUD_2400); |
$fix_baud = 4800 if ($fmask & BAUD_4800); |
$fix_baud = 7200 if ($fmask & BAUD_7200); |
$fix_baud = 9600 if ($fmask & BAUD_9600); |
$fix_baud = 14400 if ($fmask & BAUD_14400); |
$fix_baud = 19200 if ($fmask & BAUD_19200); |
$fix_baud = 34800 if ($fmask & BAUD_38400); |
$fix_baud = 56000 if ($fmask & BAUD_56K); |
$fix_baud = 57600 if ($fmask & BAUD_57600); |
$fix_baud = 115200 if ($fmask & BAUD_115200); |
$fix_baud = 128000 if ($fmask & BAUD_128K); |
${$hr}{$fix_baud} = $fix_baud; |
$self->{"_N_BAUD"} = undef; |
} |
#### data bits |
$fmask = $CP_SettableData; |
if ($self->{"_C_DATA"}) { |
$hr = \%{$self->{"_L_DATA"}}; |
${$hr}{5} = 5 if ($fmask & DATABITS_5); |
${$hr}{6} = 6 if ($fmask & DATABITS_6); |
${$hr}{7} = 7 if ($fmask & DATABITS_7); |
${$hr}{8} = 8 if ($fmask & DATABITS_8); |
${$hr}{16} = 16 if ($fmask & DATABITS_16); |
## ${$hr}{16X} = 16 if ($fmask & DATABITS_16X); |
} |
else { $self->{"_N_DATA"} = undef; } |
#### value = (DCB Win32_definition + 1) so 0 means unchanged |
$fmask = $CP_SettableStopParity; |
if ($self->{"_C_STOP"}) { |
$hr = \%{$self->{"_L_STOP"}}; |
${$hr}{1} = 1 + ONESTOPBIT if ($fmask & STOPBITS_10); |
${$hr}{1.5} = 1 + ONE5STOPBITS if ($fmask & STOPBITS_15); |
${$hr}{2} = 1 + TWOSTOPBITS if ($fmask & STOPBITS_20); |
} |
else { $self->{"_N_STOP"} = undef; } |
if ($self->{"_C_PARITY_CFG"}) { |
$hr = \%{$self->{"_L_PARITY"}}; |
${$hr}{"none"} = 1 + NOPARITY if ($fmask & PARITY_NONE); |
${$hr}{"even"} = 1 + EVENPARITY if ($fmask & PARITY_EVEN); |
${$hr}{"odd"} = 1 + ODDPARITY if ($fmask & PARITY_ODD); |
${$hr}{"mark"} = 1 + MARKPARITY if ($fmask & PARITY_MARK); |
${$hr}{"space"} = 1 + SPACEPARITY if ($fmask & PARITY_SPACE); |
} |
else { $self->{"_N_PARITY"} = undef; } |
$hr = 0; # no loops |
# changable dcb parameters |
# 0 = no change requested |
# mask_on: requested value for OR |
# mask_off: complement of requested value for AND |
$self->{"_N_FM_ON"} = 0; |
$self->{"_N_FM_OFF"} = 0; |
$self->{"_N_AUX_ON"} = 0; |
$self->{"_N_AUX_OFF"} = 0; |
### "VALUE" is initialized from DCB by default (but also in %validate) |
# 0 = no change requested |
# integer: requested value or (value+1 if 0 is a legal value) |
# binary: 1=false requested, 2=true requested |
$self->{"_N_XONLIM"} = 0; |
$self->{"_N_XOFFLIM"} = 0; |
$self->{"_N_XOFFCHAR"} = 0; |
$self->{"_N_XONCHAR"} = 0; |
$self->{"_N_ERRCHAR"} = 0; |
$self->{"_N_EOFCHAR"} = 0; |
$self->{"_N_EVTCHAR"} = 0; |
$self->{"_N_BINARY"} = 0; |
$self->{"_N_PARITY_EN"} = 0; |
### "_N_items" for save/start |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
$self->{"_N_HSHAKE"} = 0; |
### The "required" DCB values are deliberately NOT defined. That way, |
### write_settings can verify they "exist" to assure they got set. |
### $self->{"_N_BAUD"} |
### $self->{"_N_DATA"} |
### $self->{"_N_STOP"} |
### $self->{"_N_PARITY"} |
$self->{"_R_EVENT"} = CreateEvent($null, # no security |
1, # explicit reset req |
0, # initial event reset |
$null); # no name |
unless ($self->{"_R_EVENT"}) { |
OS_Error; |
carp "could not create required read event"; |
undef $self; |
return; |
} |
$self->{"_W_EVENT"} = CreateEvent($null, # no security |
1, # explicit reset req |
0, # initial event reset |
$null); # no name |
unless ($self->{"_W_EVENT"}) { |
OS_Error; |
carp "could not create required write event"; |
undef $self; |
return; |
} |
$self->{"_R_OVERLAP"} = pack($OVERLAPPEDformat, |
$zero, # osRead_Internal, |
$zero, # osRead_InternalHigh, |
$zero, # osRead_Offset, |
$zero, # osRead_OffsetHigh, |
$self->{"_R_EVENT"}); |
$self->{"_W_OVERLAP"} = pack($OVERLAPPEDformat, |
$zero, # osWrite_Internal, |
$zero, # osWrite_InternalHigh, |
$zero, # osWrite_Offset, |
$zero, # osWrite_OffsetHigh, |
$self->{"_W_EVENT"}); |
# Device Control Block (DCB) |
unless ( fetch_DCB ($self) ) { |
carp "can't read Device Control Block for $self->{NAME}\n"; |
undef $self; |
return; |
} |
$self->{"_L_BAUD"}{$self->{BAUD}} = $self->{BAUD}; # actual must be ok |
# Read Timeouts |
unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
carp "Error in GetCommTimeouts"; |
undef $self; |
return; |
} |
($self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
bless ($self, $class); |
return $self; |
} |
sub fetch_DCB { |
my $self = shift; |
my $ok; |
my $hr; |
my $fmask; |
my $key; |
my $value; |
my $dcb = " "x32; |
GetCommState($self->{"_HANDLE"}, $dcb) or return; |
($self->{"_DCBLength"}, |
$self->{BAUD}, |
$self->{"_BitMask"}, |
$self->{"_ResvWORD"}, |
$self->{XONLIM}, |
$self->{XOFFLIM}, |
$self->{DATA}, |
$self->{"_Parity"}, |
$self->{"_StopBits"}, |
$self->{XONCHAR}, |
$self->{XOFFCHAR}, |
$self->{ERRCHAR}, |
$self->{EOFCHAR}, |
$self->{EVTCHAR}, |
$self->{"_PackWORD"})= unpack($DCBformat, $dcb); |
if ($self->{"_DCBLength"} > 32) { |
carp "invalid DCB block length"; |
return; |
} |
if ($Babble) { |
printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
printf "BaudRate= %d\n", $self->{BAUD}; |
printf "BitMask= %lx\n", $self->{"_BitMask"}; |
printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
printf "XonLim= %x\n", $self->{XONLIM}; |
printf "XoffLim= %x\n", $self->{XOFFLIM}; |
printf "ByteSize= %d\n", $self->{DATA}; |
printf "Parity= %d\n", $self->{"_Parity"}; |
printf "StopBits= %d\n", $self->{"_StopBits"}; |
printf "XonChar= %x\n", $self->{XONCHAR}; |
printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
printf "EofChar= %x\n", $self->{EOFCHAR}; |
printf "EvtChar= %x\n", $self->{EVTCHAR}; |
printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
printf "handle= %d\n\n", $self->{"_HANDLE"}; |
} |
$fmask = 1 + $self->{"_StopBits"}; |
while (($key, $value) = each %{ $self->{"_L_STOP"} }) { |
if ($value == $fmask) { |
$self->{STOP} = $key; |
} |
} |
$fmask = 1 + $self->{"_Parity"}; |
while (($key, $value) = each %{ $self->{"_L_PARITY"} }) { |
if ($value == $fmask) { |
$self->{PARITY} = $key; |
} |
} |
$fmask = $self->{"_BitMask"}; |
$hr = DTR_CONTROL_HANDSHAKE; |
$ok = RTS_CONTROL_HANDSHAKE; |
if ($fmask & ( $hr << 4) ) { |
$self->{HSHAKE} = "dtr"; |
} |
elsif ($fmask & ( $ok << 12) ) { |
$self->{HSHAKE} = "rts"; |
} |
elsif ($fmask & ( FM_fOutX | FM_fInX ) ) { |
$self->{HSHAKE} = "xoff"; |
} |
else { |
$self->{HSHAKE} = "none"; |
} |
$self->{BINARY} = ($fmask & FM_fBinary); |
$self->{PARITY_EN} = ($fmask & FM_fParity); |
if ($fmask & FM_fDummy2) { |
carp "Unknown DCB Flow Mask Bit in $self->{NAME}"; |
} |
1; |
} |
sub init_done { |
my $self = shift; |
return 0 unless (defined $self->{"_INIT"}); |
return $self->{"_INIT"}; |
} |
sub update_DCB { |
my $self = shift; |
my $ok = 0; |
return unless (defined $self->{"_INIT"}); |
fetch_DCB ($self); |
if ($self->{"_N_HSHAKE"}) { |
$self->{HSHAKE} = $self->{"_N_HSHAKE"}; |
if ($self->{HSHAKE} eq "dtr" ) { |
$self->{"_N_FM_ON"} = 0x1028; |
$self->{"_N_FM_OFF"} = 0xffffdceb; |
} |
elsif ($self->{HSHAKE} eq "rts" ) { |
$self->{"_N_FM_ON"} = 0x2014; |
$self->{"_N_FM_OFF"} = 0xffffecd7; |
} |
elsif ($self->{HSHAKE} eq "xoff" ) { |
$self->{"_N_FM_ON"} = 0x1310; |
$self->{"_N_FM_OFF"} = 0xffffdfd3; |
} |
else { |
$self->{"_N_FM_ON"} = 0x1010; |
$self->{"_N_FM_OFF"} = 0xffffdcd3; |
} |
$self->{"_N_HSHAKE"} = 0; |
} |
if ($self->{"_N_PARITY_EN"}) { |
if (2 == $self->{"_N_PARITY_EN"}) { |
$self->{"_N_FM_ON"} |= FM_fParity; # enable |
if ($self->{"_N_FM_OFF"}) { |
$self->{"_N_FM_OFF"} |= FM_fParity; |
} |
else { $self->{"_N_FM_OFF"} = LONGsize; } |
} |
else { |
if ($self->{"_N_FM_ON"}) { |
$self->{"_N_FM_ON"} &= ~FM_fParity; # disable |
} |
if ($self->{"_N_FM_OFF"}) { |
$self->{"_N_FM_OFF"} &= ~FM_fParity; |
} |
else { $self->{"_N_FM_OFF"} = ~FM_fParity; } |
} |
## DEBUG ## |
## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
## DEBUG ## |
$self->{"_N_PARITY_EN"} = 0; |
} |
## DEBUG ## |
## printf "_N_AUX_ON=%lx\n", $self->{"_N_AUX_ON"}; ## DEBUG ## |
## printf "_N_AUX_OFF=%lx\n", $self->{"_N_AUX_OFF"}; ## DEBUG ## |
## DEBUG ## |
if ( $self->{"_N_AUX_ON"} or $self->{"_N_AUX_OFF"} ) { |
if ( $self->{"_N_FM_OFF"} ) { |
$self->{"_N_FM_OFF"} &= $self->{"_N_AUX_OFF"}; |
} |
else { |
$self->{"_N_FM_OFF"} = $self->{"_N_AUX_OFF"}; |
} |
$self->{"_N_FM_ON"} |= $self->{"_N_AUX_ON"}; |
$self->{"_N_AUX_ON"} = 0; |
$self->{"_N_AUX_OFF"} = 0; |
} |
## DEBUG ## |
## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
## DEBUG ## |
if ( $self->{"_N_FM_ON"} or $self->{"_N_FM_OFF"} ) { |
$self->{"_BitMask"} &= $self->{"_N_FM_OFF"}; |
$self->{"_BitMask"} |= $self->{"_N_FM_ON"}; |
$self->{"_N_FM_ON"} = 0; |
$self->{"_N_FM_OFF"} = 0; |
} |
if ($self->{"_N_XONLIM"}) { |
$self->{XONLIM} = $self->{"_N_XONLIM"} - 1; |
$self->{"_N_XONLIM"} = 0; |
} |
if ($self->{"_N_XOFFLIM"}) { |
$self->{XOFFLIM} = $self->{"_N_XOFFLIM"} - 1; |
$self->{"_N_XOFFLIM"} = 0; |
} |
if ($self->{"_N_BAUD"}) { |
$self->{BAUD} = $self->{"_N_BAUD"}; |
$self->{"_N_BAUD"} = 0; |
} |
if ($self->{"_N_DATA"}) { |
$self->{DATA} = $self->{"_N_DATA"}; |
$self->{"_N_DATA"} = 0; |
} |
if ($self->{"_N_STOP"}) { |
$self->{"_StopBits"} = $self->{"_N_STOP"} - 1; |
$self->{"_N_STOP"} = 0; |
} |
if ($self->{"_N_PARITY"}) { |
$self->{"_Parity"} = $self->{"_N_PARITY"} - 1; |
$self->{"_N_PARITY"} = 0; |
} |
if ($self->{"_N_XONCHAR"}) { |
$self->{XONCHAR} = $self->{"_N_XONCHAR"} - 1; |
$self->{"_N_XONCHAR"} = 0; |
} |
if ($self->{"_N_XOFFCHAR"}) { |
$self->{XOFFCHAR} = $self->{"_N_XOFFCHAR"} - 1; |
$self->{"_N_XOFFCHAR"} = 0; |
} |
if ($self->{"_N_ERRCHAR"}) { |
$self->{ERRCHAR} = $self->{"_N_ERRCHAR"} - 1; |
$self->{"_N_ERRCHAR"} = 0; |
} |
if ($self->{"_N_EOFCHAR"}) { |
$self->{EOFCHAR} = $self->{"_N_EOFCHAR"} - 1; |
$self->{"_N_EOFCHAR"} = 0; |
} |
if ($self->{"_N_EVTCHAR"}) { |
$self->{EVTCHAR} = $self->{"_N_EVTCHAR"} - 1; |
$self->{"_N_EVTCHAR"} = 0; |
} |
my $dcb = pack($DCBformat, |
$self->{"_DCBLength"}, |
$self->{BAUD}, |
$self->{"_BitMask"}, |
$self->{"_ResvWORD"}, |
$self->{XONLIM}, |
$self->{XOFFLIM}, |
$self->{DATA}, |
$self->{"_Parity"}, |
$self->{"_StopBits"}, |
$self->{XONCHAR}, |
$self->{XOFFCHAR}, |
$self->{ERRCHAR}, |
$self->{EOFCHAR}, |
$self->{EVTCHAR}, |
$self->{"_PackWORD"}); |
if ( SetCommState($self->{"_HANDLE"}, $dcb) ) { |
print "updated DCB for $self->{NAME}\n" if ($Babble); |
## DEBUG ## |
## printf "DEBUG BitMask= %lx\n", $self->{"_BitMask"}; ## DEBUG ## |
## DEBUG ## |
} |
else { |
carp "SetCommState failed"; |
OS_Error; |
if ($Babble) { |
printf "\ntried to write:\n"; |
printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
printf "BaudRate= %d\n", $self->{BAUD}; |
printf "BitMask= %lx\n", $self->{"_BitMask"}; |
printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
printf "XonLim= %x\n", $self->{XONLIM}; |
printf "XoffLim= %x\n", $self->{XOFFLIM}; |
printf "ByteSize= %d\n", $self->{DATA}; |
printf "Parity= %d\n", $self->{"_Parity"}; |
printf "StopBits= %d\n", $self->{"_StopBits"}; |
printf "XonChar= %x\n", $self->{XONCHAR}; |
printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
printf "EofChar= %x\n", $self->{EOFCHAR}; |
printf "EvtChar= %x\n", $self->{EVTCHAR}; |
printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
printf "handle= %d\n", $self->{"_HANDLE"}; |
} |
} |
} |
sub initialize { |
my $self = shift; |
my $item; |
my $fault = 0; |
foreach $item (@_) { |
unless (exists $self->{"_N_$item"}) { |
# must be "exists" so undef=not_settable |
$fault++; |
nocarp or carp "Missing REQUIRED setting for $item"; |
} |
} |
unless ($self->{"_INIT"}) { |
$self->{"_INIT"} = 1 unless ($fault); |
$self->{"_BitMask"} = 0x1011; |
$self->{XONLIM} = 100 unless ($self->{"_N_XONLIM"}); |
$self->{XOFFLIM} = 100 unless ($self->{"_N_XOFFLIM"}); |
$self->{XONCHAR} = 0x11 unless ($self->{"_N_XONCHAR"}); |
$self->{XOFFCHAR} = 0x13 unless ($self->{"_N_XOFFCHAR"}); |
$self->{ERRCHAR} = 0 unless ($self->{"_N_ERRCHAR"}); |
$self->{EOFCHAR} = 0 unless ($self->{"_N_EOFCHAR"}); |
$self->{EVTCHAR} = 0 unless ($self->{"_N_EVTCHAR"}); |
update_timeouts($self); |
} |
if ($self->{"_N_READBUF"} or $self->{"_N_WRITEBUF"}) { |
if ($self->{"_N_READBUF"}) { |
$self->{READBUF} = $self->{"_N_READBUF"}; |
} |
if ($self->{"_N_WRITEBUF"}) { |
$self->{WRITEBUF} = $self->{"_N_WRITEBUF"}; |
} |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
SetupComm($self->{"_HANDLE"}, $self->{READBUF}, $self->{WRITEBUF}); |
} |
purge_all($self); |
return $fault; |
} |
sub is_status { |
my $self = shift; |
my $ok = 0; |
my $error_p = " "x4; |
my $CommStatus = " "x12; |
if (@_ and $testactive) { |
$self->{"_LATCH"} |= shift; |
} |
$ok=ClearCommError($self->{"_HANDLE"}, $error_p, $CommStatus); |
my $Error_BitMask = unpack("L", $error_p); |
$self->{"_LATCH"} |= $Error_BitMask; |
my @stat = unpack($COMSTATformat, $CommStatus); |
push @stat, $self->{"_LATCH"}; |
$stat[ST_BLOCK] &= BM_AllBits; |
if ( $Babble or $self->{"_DEBUG_C"} ) { |
printf "Blocking Bits= %d\n", $stat[ST_BLOCK]; |
printf "Input Queue= %d\n", $stat[ST_INPUT]; |
printf "Output Queue= %d\n", $stat[ST_OUTPUT]; |
printf "Latched Errors= %d\n", $stat[ST_ERROR]; |
printf "ok= %d\n", $ok; |
} |
return ($ok ? @stat : undef); |
} |
sub reset_error { |
my $self = shift; |
my $was = $self->{"_LATCH"}; |
$self->{"_LATCH"} = 0; |
return $was; |
} |
sub can_baud { |
my $self = shift; |
return $self->{"_C_BAUD"}; |
} |
sub can_databits { |
my $self = shift; |
return $self->{"_C_DATA"}; |
} |
sub can_stopbits { |
my $self = shift; |
return $self->{"_C_STOP"}; |
} |
sub can_dtrdsr { |
my $self = shift; |
return $self->{"_C_DTRDSR"}; |
} |
sub can_handshake { |
my $self = shift; |
return $self->{"_C_HSHAKE"}; |
} |
sub can_parity_check { |
my $self = shift; |
return $self->{"_C_PARITY_CK"}; |
} |
sub can_parity_config { |
my $self = shift; |
return $self->{"_C_PARITY_CFG"}; |
} |
sub can_parity_enable { |
my $self = shift; |
return $self->{"_C_PARITY_EN"}; |
} |
sub can_rlsd_config { |
my $self = shift; |
return $self->{"_C_RLSD_CFG"}; |
} |
sub can_rlsd { |
my $self = shift; |
return $self->{"_C_RLSD"}; |
} |
sub can_16bitmode { |
my $self = shift; |
return $self->{"_C_16BITMODE"}; |
} |
sub is_rs232 { |
my $self = shift; |
return ($self->{"_TYPE"} == PST_RS232); |
} |
sub is_modem { |
my $self = shift; |
return ($self->{"_TYPE"} == PST_MODEM); |
} |
sub can_rtscts { |
my $self = shift; |
return $self->{"_C_RTSCTS"}; |
} |
sub can_xonxoff { |
my $self = shift; |
return $self->{"_C_XONXOFF"}; |
} |
sub can_xon_char { |
my $self = shift; |
return $self->{"_C_XON_CHAR"}; |
} |
sub can_spec_char { |
my $self = shift; |
return $self->{"_C_SPECHAR"}; |
} |
sub can_interval_timeout { |
my $self = shift; |
return $self->{"_C_INT_TIME"}; |
} |
sub can_total_timeout { |
my $self = shift; |
return $self->{"_C_TOT_TIME"}; |
} |
sub is_handshake { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_HSHAKE"}; |
return unless (defined $self->{"_L_HSHAKE"}{$_[0]}); |
$self->{"_N_HSHAKE"} = $self->{"_L_HSHAKE"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{HSHAKE}; |
} |
sub are_handshake { |
my $self = shift; |
return unless $self->{"_C_HSHAKE"}; |
return if (@_); |
return keys(%{$self->{"_L_HSHAKE"}}); |
} |
sub is_baudrate { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_BAUD"}; |
return unless (defined $self->{"_L_BAUD"}{$_[0]}); |
$self->{"_N_BAUD"} = int shift; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{BAUD}; |
} |
sub are_baudrate { |
my $self = shift; |
return unless $self->{"_C_BAUD"}; |
return if (@_); |
return keys(%{$self->{"_L_BAUD"}}); |
} |
sub is_parity { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_PARITY_CFG"}; |
return unless (defined $self->{"_L_PARITY"}{$_[0]}); |
$self->{"_N_PARITY"} = $self->{"_L_PARITY"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{PARITY}; |
} |
sub are_parity { |
my $self = shift; |
return unless $self->{"_C_PARITY_CFG"}; |
return if (@_); |
return keys(%{$self->{"_L_PARITY"}}); |
} |
sub is_databits { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_DATA"}; |
return unless (defined $self->{"_L_DATA"}{$_[0]}); |
$self->{"_N_DATA"} = $self->{"_L_DATA"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{DATA}; |
} |
sub are_databits { |
my $self = shift; |
return unless $self->{"_C_DATA"}; |
return if (@_); |
return keys(%{$self->{"_L_DATA"}}); |
} |
sub is_stopbits { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_STOP"}; |
return unless (defined $self->{"_L_STOP"}{$_[0]}); |
$self->{"_N_STOP"} = $self->{"_L_STOP"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{STOP}; |
} |
sub are_stopbits { |
my $self = shift; |
return unless $self->{"_C_STOP"}; |
return if (@_); |
return keys(%{$self->{"_L_STOP"}}); |
} |
# single value for save/start |
sub is_read_buf { |
my $self = shift; |
if (@_) { $self->{"_N_READBUF"} = int shift; } |
return $self->{READBUF}; |
} |
# single value for save/start |
sub is_write_buf { |
my $self = shift; |
if (@_) { $self->{"_N_WRITEBUF"} = int shift; } |
return $self->{WRITEBUF}; |
} |
sub is_buffers { |
my $self = shift; |
return unless (@_ == 2); |
my $rbuf = shift; |
my $wbuf = shift; |
SetupComm($self->{"_HANDLE"}, $rbuf, $wbuf) or return; |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
$self->{READBUF} = $rbuf; |
$self->{WRITEBUF} = $wbuf; |
1; |
} |
sub read_bg { |
return unless (@_ == 2); |
my $self = shift; |
my $wanted = shift; |
return unless ($wanted > 0); |
if ($self->{"_R_BUSY"}) { |
nocarp or carp "Second Read attempted before First is done"; |
return; |
} |
my $got_p = " "x4; |
my $ok; |
my $got = 0; |
if ($wanted > $RBUF_Size) { |
$wanted = $RBUF_Size; |
warn "read buffer limited to $RBUF_Size bytes at the moment"; |
} |
$self->{"_R_BUSY"} = 1; |
$ok=ReadFile( $self->{"_HANDLE"}, |
$self->{"_RBUF"}, |
$wanted, |
$got_p, |
$self->{"_R_OVERLAP"}); |
if ($ok) { |
$got = unpack("L", $got_p); |
$self->{"_R_BUSY"} = 0; |
} |
return $got; |
} |
sub write_bg { |
return unless (@_ == 2); |
my $self = shift; |
my $wbuf = shift; |
if ($self->{"_W_BUSY"}) { |
nocarp or carp "Second Write attempted before First is done"; |
return; |
} |
my $ok; |
my $got_p = " "x4; |
return 0 if ($wbuf eq ""); |
my $lbuf = length ($wbuf); |
my $written = 0; |
$self->{"_W_BUSY"} = 1; |
$ok=WriteFile( $self->{"_HANDLE"}, |
$wbuf, |
$lbuf, |
$got_p, |
$self->{"_W_OVERLAP"}); |
if ($ok) { |
$written = unpack("L", $got_p); |
$self->{"_W_BUSY"} = 0; |
} |
if ($Babble) { |
print "error=$ok\n"; |
print "wbuf=$wbuf\n"; |
print "lbuf=$lbuf\n"; |
print "write_bg=$written\n"; |
} |
return $written; |
} |
sub read_done { |
return unless (@_ == 2); |
my $self = shift; |
my $wait = yes_true ( shift ); |
my $ov; |
my $got_p = " "x4; |
my $wanted = 0; |
$self->{"_R_BUSY"} = 1; |
$ov=GetOverlappedResult( $self->{"_HANDLE"}, |
$self->{"_R_OVERLAP"}, |
$got_p, |
$wait); |
if ($ov) { |
$wanted = unpack("L", $got_p); |
$self->{"_R_BUSY"} = 0; |
print "read_done=$wanted\n" if ($Babble); |
return (1, $wanted, substr($self->{"_RBUF"}, 0, $wanted)); |
} |
return (0, 0, ""); |
} |
sub write_done { |
return unless (@_ == 2); |
my $self = shift; |
my $wait = yes_true ( shift ); |
my $ov; |
my $got_p = " "x4; |
my $written = 0; |
$self->{"_W_BUSY"} = 1; |
$ov=GetOverlappedResult( $self->{"_HANDLE"}, |
$self->{"_W_OVERLAP"}, |
$got_p, |
$wait); |
if ($ov) { |
$written = unpack("L", $got_p); |
$self->{"_W_BUSY"} = 0; |
print "write_done=$written\n" if ($Babble); |
return (1, $written); |
} |
return (0, $written); |
} |
sub purge_all { |
my $self = shift; |
return if (@_); |
# PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000f) ) { |
carp "Error in PurgeComm"; |
OS_Error; |
return; |
} |
$self->{"_R_BUSY"} = 0; |
$self->{"_W_BUSY"} = 0; |
return 1; |
} |
sub purge_rx { |
my $self = shift; |
return if (@_); |
# PURGE_RXABORT | PURGE_RXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000a) ) { |
OS_Error; |
carp "Error in PurgeComm"; |
return; |
} |
$self->{"_R_BUSY"} = 0; |
return 1; |
} |
sub purge_tx { |
my $self = shift; |
return if (@_); |
# PURGE_TXABORT | PURGE_TXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x00000005) ) { |
OS_Error; |
carp "Error in PurgeComm"; |
return; |
} |
$self->{"_W_BUSY"} = 0; |
return 1; |
} |
sub are_buffers { |
my $self = shift; |
return if (@_); |
return ($self->{READBUF}, $self->{WRITEBUF}); |
} |
sub buffer_max { |
my $self = shift; |
return if (@_); |
return ($self->{"_RBUFMAX"}, $self->{"_TBUFMAX"}); |
} |
sub suspend_tx { |
my $self = shift; |
return if (@_); |
return SetCommBreak($self->{"_HANDLE"}); |
} |
sub resume_tx { |
my $self = shift; |
return if (@_); |
return ClearCommBreak($self->{"_HANDLE"}); |
} |
sub xmit_imm_char { |
my $self = shift; |
return unless (@_ == 1); |
my $v = int shift; |
unless ( TransmitCommChar($self->{"_HANDLE"}, $v) ) { |
carp "Can't transmit char: $v"; |
return; |
} |
1; |
} |
sub is_xon_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
$self->{"_N_XONCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XONCHAR}; |
} |
sub is_xoff_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
$self->{"_N_XOFFCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XOFFCHAR}; |
} |
sub is_eof_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_EOFCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{EOFCHAR}; |
} |
sub is_event_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_EVTCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{EVTCHAR}; |
} |
sub is_error_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_ERRCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{ERRCHAR}; |
} |
sub is_xon_limit { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_XONXOFF"}); |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->{"_N_XONLIM"} = ++$v; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XONLIM}; |
} |
sub is_xoff_limit { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_XONXOFF"}); |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->{"_N_XOFFLIM"} = ++$v; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XOFFLIM}; |
} |
sub is_read_interval { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_INT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v > LONGsize)); |
if ($v == LONGsize) { |
$self->{"_N_RINT"} = $v; # Win32 uses as flag |
} |
else { |
$self->{"_N_RINT"} = ++$v; |
} |
return unless update_timeouts ($self); |
} |
return $self->{RINT}; |
} |
sub is_read_char_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_RTOT"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{RTOT}; |
} |
sub is_read_const_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_RCONST"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{RCONST}; |
} |
sub is_write_const_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_WCONST"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{WCONST}; |
} |
sub is_write_char_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_WTOT"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{WTOT}; |
} |
sub update_timeouts { |
return unless (@_ == 1); |
my $self = shift; |
unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
carp "Error in GetCommTimeouts"; |
return; |
} |
($self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
if ($self->{"_N_RINT"}) { |
if ($self->{"_N_RINT"} == LONGsize) { |
$self->{RINT} = $self->{"_N_RINT"}; # Win32 uses as flag |
} |
else { |
$self->{RINT} = $self->{"_N_RINT"} -1; |
} |
$self->{"_N_RINT"} = 0; |
} |
if ($self->{"_N_RTOT"}) { |
$self->{RTOT} = $self->{"_N_RTOT"} -1; |
$self->{"_N_RTOT"} = 0; |
} |
if ($self->{"_N_RCONST"}) { |
$self->{RCONST} = $self->{"_N_RCONST"} -1; |
$self->{"_N_RCONST"} = 0; |
} |
if ($self->{"_N_WTOT"}) { |
$self->{WTOT} = $self->{"_N_WTOT"} -1; |
$self->{"_N_WTOT"} = 0; |
} |
if ($self->{"_N_WCONST"}) { |
$self->{WCONST} = $self->{"_N_WCONST"} -1; |
$self->{"_N_WCONST"} = 0; |
} |
$self->{"_TIMEOUT"} = pack($TIMEOUTformat, |
$self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST}); |
if ( SetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
return 1; |
} |
else { |
carp "Error in SetCommTimeouts"; |
return; |
} |
} |
# true/false parameters |
sub is_binary { |
my $self = shift; |
if (@_) { |
$self->{"_N_BINARY"} = 1 + yes_true ( shift ); |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
### printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fBinary); |
} |
sub is_parity_enable { |
my $self = shift; |
if (@_) { |
$self->{"_N_PARITY_EN"} = 1 + yes_true ( shift ); |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ## DEBUG ## |
return ($self->{"_BitMask"} & FM_fParity); |
} |
sub ignore_null { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fNull; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fNull; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fNull; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fNull); |
} |
sub ignore_no_dsr { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fDsrSensitivity; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fDsrSensitivity; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fDsrSensitivity; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fDsrSensitivity); |
} |
sub subst_pe_char { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fErrorChar; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fErrorChar; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fErrorChar; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fErrorChar); |
} |
sub abort_on_error { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fAbortOnError; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fAbortOnError; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fAbortOnError; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fAbortOnError); |
} |
sub output_dsr { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutxDsrFlow; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutxDsrFlow; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutxDsrFlow; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutxDsrFlow); |
} |
sub output_cts { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutxCtsFlow; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutxCtsFlow; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutxCtsFlow; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutxCtsFlow); |
} |
sub input_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fInX; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fInX; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fInX; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fInX); |
} |
sub output_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutX; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutX; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutX; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutX); |
} |
sub tx_on_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fTXContinueOnXoff; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fTXContinueOnXoff; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fTXContinueOnXoff; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fTXContinueOnXoff); |
} |
sub dtr_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETDTR : CLRDTR ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
sub rts_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETRTS : CLRRTS ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
# pulse parameters |
sub pulse_dtr_off { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_dtr_off not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->dtr_active(0) or carp "Did not pulse DTR off"; |
Win32::Sleep($delay); |
$self->dtr_active(1) or carp "Did not restore DTR on"; |
Win32::Sleep($delay); |
} |
sub pulse_rts_off { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_rts_off not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->rts_active(0) or carp "Did not pulse RTS off"; |
Win32::Sleep($delay); |
$self->rts_active(1) or carp "Did not restore RTS on"; |
Win32::Sleep($delay); |
} |
sub pulse_break_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_break_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->break_active(1) or carp "Did not pulse BREAK on"; |
Win32::Sleep($delay); |
$self->break_active(0) or carp "Did not restore BREAK off"; |
Win32::Sleep($delay); |
} |
sub pulse_dtr_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_dtr_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->dtr_active(1) or carp "Did not pulse DTR on"; |
Win32::Sleep($delay); |
$self->dtr_active(0) or carp "Did not restore DTR off"; |
Win32::Sleep($delay); |
} |
sub pulse_rts_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_rts_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->rts_active(1) or carp "Did not pulse RTS on"; |
Win32::Sleep($delay); |
$self->rts_active(0) or carp "Did not restore RTS off"; |
Win32::Sleep($delay); |
} |
sub break_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETBREAK : CLRBREAK ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
sub xon_active { |
return unless (@_ == 1); |
my $self = shift; |
return EscapeCommFunction($self->{"_HANDLE"}, SETXON); |
} |
sub xoff_active { |
return unless (@_ == 1); |
my $self = shift; |
return EscapeCommFunction($self->{"_HANDLE"}, SETXOFF); |
} |
sub is_modemlines { |
return unless (@_ == 1); |
my $self = shift; |
my $mstat = " " x4; |
unless ( GetCommModemStatus($self->{"_HANDLE"}, $mstat) ) { |
carp "Error in GetCommModemStatus"; |
return; |
} |
my $result = unpack ("L", $mstat); |
return $result; |
} |
sub debug_comm { |
my $self = shift; |
if (ref($self)) { |
if (@_) { $self->{"_DEBUG_C"} = yes_true ( shift ); } |
else { |
nocarp or carp "Debug level: $self->{NAME} = $self->{\"_DEBUG_C\"}"; |
return $self->{"_DEBUG_C"}; |
} |
} else { |
$Babble = yes_true ($self); |
nocarp or carp "CommPort Debug Class = $Babble"; |
return $Babble; |
} |
} |
sub close { |
my $self = shift; |
my $ok; |
my $success = 1; |
return unless (defined $self->{NAME}); |
if ($Babble) { |
carp "Closing $self " . $self->{NAME}; |
} |
if ($self->{"_HANDLE"}) { |
purge_all ($self); |
update_timeouts ($self); # if any running ?? |
$ok=CloseHandle($self->{"_HANDLE"}); |
if (! $ok) { |
print "Error Closing handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
elsif ($Babble) { |
print "Closing Device handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
} |
$self->{"_HANDLE"} = undef; |
} |
if ($self->{"_R_EVENT"}) { |
$ok=CloseHandle($self->{"_R_EVENT"}); |
if (! $ok) { |
print "Error closing Read Event handle $self->{\"_R_EVENT\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
$self->{"_R_EVENT"} = undef; |
} |
if ($self->{"_W_EVENT"}) { |
$ok=CloseHandle($self->{"_W_EVENT"}); |
if (! $ok) { |
print "Error closing Write Event handle $self->{\"_W_EVENT\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
$self->{"_W_EVENT"} = undef; |
} |
$self->{NAME} = undef; |
if ($Babble) { |
printf "CommPort close result:%d\n", $success; |
} |
return $success; |
} |
sub DESTROY { |
my $self = shift; |
return unless (defined $self->{NAME}); |
if ($Babble or $self->{"_DEBUG_C"}) { |
print "Destroying $self->{NAME}\n" if (defined $self->{NAME}); |
} |
$self->close; |
} |
1; # so the require or use succeeds |
# Autoload methods go after =cut, and are processed by the autosplit program. |
__END__ |
=pod |
=head1 NAME |
Win32API::CommPort - Raw Win32 system API calls for serial communications. |
=head1 SYNOPSIS |
use Win32; ## not required under all circumstances |
require 5.003; |
use Win32API::CommPort qw( :PARAM :STAT 0.19 ); |
## when available ## use Win32API::File 0.07 qw( :ALL ); |
=head2 Constructors |
$PortObj = new Win32API::CommPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
@required = qw( BAUD DATA STOP ); |
$faults = $PortObj->initialize(@required); |
if ($faults) { die "Required parameters not set before initialize\n"; } |
=head2 Configuration Utility Methods |
set_no_messages(1); # test suite use |
# exported by :PARAM |
nocarp || carp "Something fishy"; |
$a = SHORTsize; # 0xffff |
$a = LONGsize; # 0xffffffff |
$answer = yes_true("choice"); # 1 or 0 |
OS_Error unless ($API_Call_OK); # prints error |
$PortObj->init_done || die "Not done"; |
$PortObj->fetch_DCB || die "Not done"; |
$PortObj->update_DCB || die "Not done"; |
$milliseconds = $PortObj->get_tick_count; |
=head2 Capability Methods (read only) |
# true/false capabilities |
$a = $PortObj->can_baud; # else fixed |
$a = $PortObj->can_databits; |
$a = $PortObj->can_stopbits; |
$a = $PortObj->can_dtrdsr; |
$a = $PortObj->can_handshake; |
$a = $PortObj->can_parity_check; |
$a = $PortObj->can_parity_config; |
$a = $PortObj->can_parity_enable; |
$a = $PortObj->can_rlsd; # receive line signal detect (carrier) |
$a = $PortObj->can_rlsd_config; |
$a = $PortObj->can_16bitmode; |
$a = $PortObj->is_rs232; |
$a = $PortObj->is_modem; |
$a = $PortObj->can_rtscts; |
$a = $PortObj->can_xonxoff; |
$a = $PortObj->can_xon_char; |
$a = $PortObj->can_spec_char; |
$a = $PortObj->can_interval_timeout; |
$a = $PortObj->can_total_timeout; |
# list output capabilities |
($rmax, $wmax) = $PortObj->buffer_max; |
($rbuf, $wbuf) = $PortObj->are_buffers; # current |
@choices = $PortObj->are_baudrate; # legal values |
@choices = $PortObj->are_handshake; |
@choices = $PortObj->are_parity; |
@choices = $PortObj->are_databits; |
@choices = $PortObj->are_stopbits; |
=head2 Configuration Methods |
# most methods can be called two ways: |
$PortObj->is_handshake("xoff"); # set parameter |
$flowcontrol = $PortObj->is_handshake; # current value (scalar) |
# similar |
$PortObj->is_baudrate(9600); |
$PortObj->is_parity("odd"); |
$PortObj->is_databits(8); |
$PortObj->is_stopbits(1); |
$PortObj->debug_comm(0); |
$PortObj->is_xon_limit(100); # bytes left in buffer |
$PortObj->is_xoff_limit(100); # space left in buffer |
$PortObj->is_xon_char(0x11); |
$PortObj->is_xoff_char(0x13); |
$PortObj->is_eof_char(0x0); |
$PortObj->is_event_char(0x0); |
$PortObj->is_error_char(0); # for parity errors |
$rbuf = $PortObj->is_read_buf; # read_only except internal use |
$wbuf = $PortObj->is_write_buf; |
$size = $PortObj->internal_buffer; |
$PortObj->is_buffers(4096, 4096); # read, write |
# returns current in list context |
$PortObj->is_read_interval(100); # max time between read char (millisec) |
$PortObj->is_read_char_time(5); # avg time between read char |
$PortObj->is_read_const_time(100); # total = (avg * bytes) + const |
$PortObj->is_write_char_time(5); |
$PortObj->is_write_const_time(100); |
$PortObj->is_binary(T); # just say Yes (Win 3.x option) |
$PortObj->is_parity_enable(F); # faults during input |
=head2 Operating Methods |
($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->is_status |
|| warn "could not get port status\n"; |
$ClearedErrorFlags = $PortObj->reset_error; |
# The API resets errors when reading status, $LatchErrorFlags |
# is all $ErrorFlags since they were last explicitly cleared |
if ($BlockingFlags) { warn "Port is blocked"; } |
if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
Additional useful constants may be exported eventually. |
$count_in = $PortObj->read_bg($InBytes); |
($done, $count_in, $string_in) = $PortObj->read_done(1); |
# background read with wait until done |
$count_out = $PortObj->write_bg($output_string); # background write |
($done, $count_out) = $PortObj->write_done(0); |
$PortObj->suspend_tx; # output from write buffer |
$PortObj->resume_tx; |
$PortObj->xmit_imm_char(0x03); # bypass buffer (and suspend) |
$PortObj->xoff_active; # simulate received xoff |
$PortObj->xon_active; # simulate received xon |
$PortObj->purge_all; |
$PortObj->purge_rx; |
$PortObj->purge_tx; |
# controlling outputs from the port |
$PortObj->dtr_active(T); # sends outputs direct to hardware |
$PortObj->rts_active(Yes); # returns status of API call |
$PortObj->break_active(N); # NOT state of bit |
$PortObj->pulse_break_on($milliseconds); # off version is implausible |
$PortObj->pulse_rts_on($milliseconds); |
$PortObj->pulse_rts_off($milliseconds); |
$PortObj->pulse_dtr_on($milliseconds); |
$PortObj->pulse_dtr_off($milliseconds); |
# sets_bit, delays, resets_bit, delays |
# pulse_xxx methods not supported on Perl 5.004 |
$ModemStatus = $PortObj->is_modemlines; |
if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
$PortObj->close || die; |
# "undef $PortObj" preferred unless reopening port |
# "close" should precede "undef" if both used |
=head1 DESCRIPTION |
This provides fairly low-level access to the Win32 System API calls |
dealing with serial ports. |
Uses features of the Win32 API to implement non-blocking I/O, serial |
parameter setting, event-loop operation, and enhanced error handling. |
To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
This is expected to change to an empty list reference, C<[]>, when Perl |
supports that form in this usage. |
Beyond raw access to the API calls and related constants, this module |
will eventually handle smart buffer allocation and translation of return |
codes. |
=head2 Initialization |
The constructor is B<new> with a F<PortName> (as the Registry |
knows it) specified. This will do a B<CreateFile>, get the available |
options and capabilities via the Win32 API, and create the object. |
The port is not yet ready for read/write access. First, the desired |
I<parameter settings> must be established. Since these are tuning |
constants for an underlying hardware driver in the Operating System, |
they should all checked for validity by the method calls that set them. |
The B<initialize> method takes a list of required parameters and confirms |
they have been set. For others, it will attempt to deduce defaults from |
the hardware or from other parameters. The B<initialize> method returns |
the number of faults (zero if the port is setup ok). The B<update_DCB> |
method writes a new I<Device Control Block> to complete the startup and |
allow the port to be used. Ports are opened for binary transfers. A |
separate C<binmode> is not needed. The USER must release the object |
if B<initialize> or B<update_DCB> does not succeed. |
Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
to open a port prints a error message to STDOUT by default. Since only |
one application at a time can "own" the port, one source of failure was |
"port in use". There was previously no way to check this without getting |
a "fail message". Setting C<$quiet> disables this built-in message. It |
also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
used for testing this condition - other faults may still return C<undef>). |
Use of C<$quiet> only applies to B<new>. |
The fault checking in B<initialize> consists in verifying an I<_N_$item> |
internal variable exists for each I<$item> in the input list. The |
I<_N_$item> is created for each parameter that is set either directly |
or by default. A derived class must create the I<_N_$items> for any |
varibles it adds to the base class if it wants B<initialize> to check |
them. Win32API::CommPort supports the following: |
$item _N_$item setting method |
------ --------- -------------- |
BAUD "_N_BAUD" is_baudrate |
BINARY "_N_BINARY" is_binary |
DATA "_N_DATA" is_databits |
EOFCHAR "_N_EOFCHAR" is_eof_char |
ERRCHAR "_N_ERRCHAR" is_error_char |
EVTCHAR "_N_EVTCHAR" is_event_char |
HSHAKE "_N_HSHAKE" is_handshake |
PARITY "_N_PARITY" is_parity |
PARITY_EN "_N_PARITY_EN" is_parity_enable |
RCONST "_N_RCONST" is_read_const_time |
READBUF "_N_READBUF" is_read_buf |
RINT "_N_RINT" is_read_interval |
RTOT "_N_RTOT" is_read_char_time |
STOP "_N_STOP" is_stopbits |
WCONST "_N_WCONST" is_write_const_time |
WRITEBUF "_N_WRITEBUF" is_write_buf |
WTOT "_N_WTOT" is_write_char_time |
XOFFCHAR "_N_XOFFCHAR" is_xoff_char |
XOFFLIM "_N_XOFFLIM" is_xoff_limit |
XONCHAR "_N_XONCHAR" is_xon_char |
XONLIM "_N_XONLIM" is_xon_limit |
Some individual parameters (eg. baudrate) can be changed after the |
initialization is completed. These will automatically update the |
I<Device Control Block> as required. The I<init_done> method indicates |
when I<initialize> has completed successfully. |
$PortObj = new Win32API::CommPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
if $PortObj->can_databits { $PortObj->is_databits(8) }; |
$PortObj->is_baudrate(9600); |
$PortObj->is_parity("none"); |
$PortObj->is_stopbits(1); |
$PortObj->is_handshake("rts"); |
$PortObj->is_buffers(4096, 4096); |
$PortObj->dtr_active(T); |
@required = qw( BAUD DATA STOP PARITY ); |
$PortObj->initialize(@required) || undef $PortObj; |
$PortObj->dtr_active(f); |
$PortObj->is_baudrate(300); |
$PortObj->close || die; |
# "undef $PortObj" preferred unless reopening port |
# "close" should precede "undef" if both used |
undef $PortObj; # closes port AND frees memory in perl |
The F<PortName> maps to both the Registry I<Device Name> and the |
I<Properties> associated with that device. A single I<Physical> port |
can be accessed using two or more I<Device Names>. But the options |
and setup data will differ significantly in the two cases. A typical |
example is a Modem on port "COM2". Both of these F<PortNames> open |
the same I<Physical> hardware: |
$P1 = new Win32API::CommPort ("COM2"); |
$P2 = new Win32API::CommPort ("\\\\.\\Nanohertz Modem model K-9"); |
$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
of modem-specific added options and features. The "raw" API calls return |
different size configuration structures in the two cases. Win32 uses the |
"\\.\" prefix to identify "named" devices. Since both names use the same |
I<Physical> hardware, they can not both be used at the same time. The OS |
will complain. Consider this A Good Thing. |
Version 0.16 adds B<pulse> methods for the I<RTS, BREAK, and DTR> bits. The |
B<pulse> methods assume the bit is in the opposite state when the method |
is called. They set the requested state, delay the specified number of |
milliseconds, set the opposite state, and again delay the specified time. |
These methods are designed to support devices, such as the X10 "FireCracker" |
control and some modems, which require pulses on these lines to signal |
specific events or data. Since the 5.00402 Perl distribution from CPAN does |
not support sub-second time delays readily, these methods are not supported |
on that version of Perl. |
$PortObj->pulse_break_on($milliseconds); |
$PortObj->pulse_rts_on($milliseconds); |
$PortObj->pulse_rts_off($milliseconds); |
$PortObj->pulse_dtr_on($milliseconds); |
$PortObj->pulse_dtr_off($milliseconds); |
Version 0.16 also adds I<experimental> support for the rest of the option bits |
available through the I<Device Control Block>. They have not been extensively |
tested and these settings are NOT saved in the B<configuration file> by |
I<Win32::SerialPort>. Please let me know if one does not work as advertised. |
[Win32 API bit designation] |
$PortObj->ignore_null(0); # discard \000 bytes on input [fNull] |
$PortObj->ignore_no_dsr(0); # discard input bytes unless DSR |
# [fDsrSensitivity] |
$PortObj->subst_pe_char(0); # replace parity errors with B<is_error_char> |
# when B<is_parity_enable> [fErrorChar] |
$PortObj->abort_on_error(0); # cancel read/write [fAbortOnError] |
# next one set by $PortObj->is_handshake("dtr"); |
$PortObj->output_dsr(0); # use DSR handshake on output [fOutxDsrFlow] |
# next one set by $PortObj->is_handshake("rts"); |
$PortObj->output_cts(0); # use CTS handshake on output [fOutxCtsFlow] |
# next two set by $PortObj->is_handshake("xoff"); |
$PortObj->input_xoff(0); # use Xon/Xoff handshake on input [fInX] |
$PortObj->output_xoff(0); # use Xon/Xoff handshake on output [fOutX] |
$PortObj->tx_on_xoff(0); # continue output even after input xoff sent |
# [fTXContinueOnXoff] |
The B<get_tick_count> method is a wrapper around the I<Win32::GetTickCount()> |
function. It matches a corresponding method in I<Device::SerialPort> which |
does not have access to the I<Win32::> namespace. It still returns time |
in milliseconds - but can be used in cross-platform scripts. |
=head2 Configuration and Capability Methods |
The Win32 Serial Comm API provides extensive information concerning |
the capabilities and options available for a specific port (and |
instance). "Modem" ports have different capabilties than "RS-232" |
ports - even if they share the same Hardware. Many traditional modem |
actions are handled via TAPI. "Fax" ports have another set of options - |
and are accessed via MAPI. Yet many of the same low-level API commands |
and data structures are "common" to each type ("Modem" is implemented |
as an "RS-232" superset). In addition, Win95 supports a variety of |
legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
16-data-bit paths, and 256Kbaud. |
=over 8 |
Binary selections will accept as I<true> any of the following: |
C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
Anything else is I<false>. |
There are a large number of possible configuration and option parameters. |
To facilitate checking option validity in scripts, most configuration |
methods can be used in two different ways: |
=item method called with an argument |
The parameter is set to the argument, if valid. An invalid argument |
returns I<false> (undef) and the parameter is unchanged. After B<init_done>, |
the port will be updated immediately if allowed. Otherwise, the value |
will be applied when B<update_DCB> is called. |
=item method called with no argument in scalar context |
The current value is returned. If the value is not initialized either |
directly or by default, return "undef" which will parse to I<false>. |
For binary selections (true/false), return the current value. All |
current values from "multivalue" selections will parse to I<true>. |
Current values may differ from requested values until B<init_done>. |
There is no way to see requests which have not yet been applied. |
Setting the same parameter again overwrites the first request. Test |
the return value of the setting method to check "success". |
=item Asynchronous (Background) I/O |
This version now handles Polling (do if Ready), Synchronous (block until |
Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
choices provided by the API. No effort has yet been made to interact with |
Windows events. But background I/O has been used successfully with the |
Perl Tk modules and callbacks from the event loop. |
=item Timeouts |
The API provides two timing models. The first applies only to reading and |
essentially determines I<Read Not Ready> by checking the time between |
consecutive characters. The B<ReadFile> operation returns if that time |
exceeds the value set by B<is_read_interval>. It does this by timestamping |
each character. It appears that at least one character must by received in |
I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
is then reset by each succeeding character. If no characters are received, |
the read will block indefinitely. |
Setting B<is_read_interval> to C<0xffffffff> will do a non-blocking read. |
The B<ReadFile> returns immediately whether or not any characters are |
actually read. This replicates the behavior of the API. |
The other model defines the total time allowed to complete the operation. |
A fixed overhead time is added to the product of bytes and per_byte_time. |
A wide variety of timeout options can be defined by selecting the three |
parameters: fixed, each, and size. |
Read_Total = B<is_read_const_time> + (B<is_read_char_time> * bytes_to_read) |
Write_Total = B<is_write_const_time> + (B<is_write_char_time> * bytes_to_write) |
When reading a known number of characters, the I<Read_Total> mechanism is |
recommended. This mechanism I<MUST> be used with |
I<Win32::SerialPort tied FileHandles> because the tie methods can make |
multiple internal API calls. The I<Read_Interval> mechanism is suitable for |
a B<read_bg> method that expects a response of variable or unknown size. You |
should then also set a long I<Read_Total> timeout as a "backup" in case |
no bytes are received. |
=back |
=head2 Exports |
Nothing is exported by default. The following tags can be used to have |
large sets of symbols exported: |
=over 4 |
=item :PARAM |
Utility subroutines and constants for parameter setting and test: |
LONGsize SHORTsize nocarp yes_true |
OS_Error internal_buffer |
=item :STAT |
Serial communications status constants. Included are the constants for |
ascertaining why a transmission is blocked: |
BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
Which incoming bits are active: |
MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
What hardware errors have been detected: |
CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL CE_MODE |
Offsets into the array returned by B<status:> |
ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
=item :RAW |
The constants and wrapper methods for low-level API calls. Details of |
these methods may change with testing. Some may be inherited from |
Win32API::File when that becomes available. |
$result=ClearCommError($handle, $Error_BitMask_p, $CommStatus); |
$result=ClearCommBreak($handle); |
$result=SetCommBreak($handle); |
$result=GetCommModemStatus($handle, $ModemStatus); |
$result=GetCommProperties($handle, $CommProperties); |
$result=GetCommState($handle, $DCB_Buffer); |
$result=SetCommState($handle, $DCB_Buffer); |
$result=SetupComm($handle, $in_buf_size, $out_buf_size); |
$result=ReadFile($handle, $buffer, $wanted, $got, $template); |
$result=WriteFile($handle, $buffer, $size, $count, $template); |
$result=GetCommTimeouts($handle, $CommTimeOuts); |
$result=SetCommTimeouts($handle, $CommTimeOuts); |
$result=EscapeCommFunction($handle, $Func_ID); |
$result=GetCommConfig($handle, $CommConfig, $Size); |
$result=SetCommConfig($handle, $CommConfig, $Size); |
$result=PurgeComm($handle, $flags); |
$result=GetCommMask($handle, $Event_Bitmask); |
$result=SetCommMask($handle, $Event_Bitmask); |
$hEvent=CreateEvent($security, $reset_req, $initial, $name); |
$handle=CreateFile($file, $access, $share, $security, |
$creation, $flags, $template); |
$result=CloseHandle($handle); |
$result=ResetEvent($hEvent); |
$result=TransmitCommChar($handle, $char); |
$result=WaitCommEvent($handle, $Event_Bitmask, $lpOverlapped); |
$result=GetOverlappedResult($handle, $lpOverlapped, $count, $bool); |
Flags used by B<PurgeComm:> |
PURGE_TXABORT PURGE_RXABORT PURGE_TXCLEAR PURGE_RXCLEAR |
Function IDs used by EscapeCommFunction: |
SETXOFF SETXON SETRTS CLRRTS |
SETDTR CLRDTR SETBREAK CLRBREAK |
Events used by B<WaitCommEvent:> |
EV_RXCHAR EV_RXFLAG EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD EV_BREAK EV_ERR |
EV_RING EV_PERR EV_RX80FULL EV_EVENT1 |
EV_EVENT2 |
Errors specific to B<GetOverlappedResult:> |
ERROR_IO_INCOMPLETE ERROR_IO_PENDING |
=item :COMMPROP |
The constants for the I<CommProperties structure> returned by |
B<GetCommProperties>. Included mostly for completeness. |
BAUD_USER BAUD_075 BAUD_110 BAUD_134_5 |
BAUD_150 BAUD_300 BAUD_600 BAUD_1200 |
BAUD_1800 BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 BAUD_38400 |
BAUD_56K BAUD_57600 BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM PST_PARALLELPORT |
PST_RS232 PST_RS422 PST_X25 PST_NETWORK_BRIDGE |
PST_RS423 PST_RS449 PST_SCANNER PST_TCPIP_TELNET |
PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK PCF_16BITMODE |
PCF_DTRDSR PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR PCF_TOTALTIMEOUTS |
PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING SP_PARITY |
SP_RLSD SP_STOPBITS SP_SERIALCOMM SP_PARITY_CHECK |
DATABITS_5 DATABITS_6 DATABITS_7 DATABITS_8 |
DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD PARITY_EVEN |
PARITY_MARK |
COMMPROP_INITIALIZED |
=item :DCB |
The constants for the I<Device Control Block> returned by B<GetCommState> |
and updated by B<SetCommState>. Again, included mostly for completeness. |
But there are some combinations of "FM_f" settings which are not currently |
supported by high-level commands. If you need one of those, please report |
the lack as a bug. |
CBR_110 CBR_300 CBR_600 CBR_1200 |
CBR_2400 CBR_4800 CBR_9600 CBR_14400 |
CBR_19200 CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE DTR_CONTROL_HANDSHAKE |
RTS_CONTROL_DISABLE RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY ODDPARITY |
SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity FM_fOutxCtsFlow |
FM_fOutxDsrFlow FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX FM_fInX |
FM_fErrorChar FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 |
=item :ALL |
All of the above. Except for the I<test suite>, there is not really a good |
reason to do this. |
=back |
=head1 NOTES |
The object returned by B<new> is NOT a I<Filehandle>. You |
will be disappointed if you try to use it as one. |
e.g. the following is WRONG!!____C<print $PortObj "some text";> |
I<Win32::SerialPort> supports accessing ports via I<Tied Filehandles>. |
An important note about Win32 filenames. The reserved device names such |
as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
This module uses Win32::API extensively. The raw API calls are B<very> |
unforgiving. You will certainly want to start perl with the B<-w> switch. |
If you can, B<use strict> as well. Try to ferret out all the syntax and |
usage problems BEFORE issuing the API calls (many of which modify tuning |
constants in hardware device drivers....not where you want to look for bugs). |
Thanks to Ken White for testing on NT. |
=head1 KNOWN LIMITATIONS |
The current version of the module has been designed for testing using |
the ActiveState and Core (GS 5.004_02) ports of Perl for Win32 without |
requiring a compiler or using XS. In every case, compatibility has been |
selected over performance. Since everything is (sometimes convoluted but |
still pure) Perl, you can fix flaws and change limits if required. But |
please file a bug report if you do. This module has been tested with |
each of the binary perl versions for which Win32::API is supported: AS |
builds 315, 316, and 500-509 and GS 5.004_02. It has only been tested on |
Intel hardware. |
=over 4 |
=item Tutorial |
With all the options, this module needs a good tutorial. It doesn't |
have a complete one yet. A I<"How to get started"> tutorial appeared |
B<The Perl Journal #13> (March 1999). The demo programs are a good |
starting point for additional examples. |
=item Buffers |
The size of the Win32 buffers are selectable with B<is_buffers>. But each read |
method currently uses a fixed internal buffer of 4096 bytes. This can be |
changed in the module source. The read-only B<internal_buffer> method will |
give the current size. There are other fixed internal buffers as well. But |
no one has needed to change those. The XS version will support dynamic buffer |
sizing. |
=item Modems |
Lots of modem-specific options are not supported. The same is true of |
TAPI, MAPI. I<API Wizards> are welcome to contribute. |
=item API Options |
Lots of options are just "passed through from the API". Some probably |
shouldn't be used together. The module validates the obvious choices when |
possible. For something really fancy, you may need additional API |
documentation. Available from I<Micro$oft Pre$$>. |
=back |
=head1 BUGS |
ActiveState ports of Perl for Win32 before build 500 do not support the |
tools for building extensions and so will not support later versions of |
this extension. In particular, the automated install and test scripts in |
this distribution work differently with ActiveState builds 3xx. |
There is no parameter checking on the "raw" API calls. You probably should |
be familiar with using the calls in "C" before doing much experimenting. |
On Win32, a port must B<close> before it can be reopened again by the same |
process. If a physical port can be accessed using more than one name (see |
above), all names are treated as one. The perl script can also be run |
multiple times within a single batch file or shell script. The I<Makefile.PL> |
spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
but it works. |
On NT, a B<read_done> or B<write_done> returns I<False> if a background |
operation is aborted by a purge. Win95 returns I<True>. |
EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
A few NT systems seem to set B<can_parity_enable> true, but do not actually |
support setting B<is_parity_enable>. This may be a characteristic of certain |
third-party serial drivers. Or a Microsoft bug. I have not been able to |
reproduce it on my system. |
__Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
=head1 AUTHORS |
Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
=head1 SEE ALSO |
Wi32::SerialPort - High-level user interface/front-end for this module |
Win32API::File I<when available> |
Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
=head1 COPYRIGHT |
Copyright (C) 1999, Bill Birthisel. All rights reserved. |
This module is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head2 COMPATIBILITY |
Most of the code in this module has been stable since version 0.12. |
Except for items indicated as I<Experimental>, I do not expect functional |
changes which are not fully backwards compatible. However, Version 0.16 |
removes the "dummy (0, 1) list" which was returned by many binary methods |
in case they were called in list context. I do not know of any use outside |
the test suite for that feature. |
Version 0.12 added an I<Install.PL> script to put modules into the documented |
Namespaces. The script uses I<MakeMaker> tools not available in |
ActiveState 3xx builds. Users of those builds will need to install |
differently (see README). Programs in the test suite are modified for |
the current version. Additions to the configurtion files generated by |
B<save> prevent those created by Version 0.15 from being used by earlier |
Versions. 4 November 1999. |
=cut |