/MissionCockpit/tags/V0.2.5/perl/site/lib/Geo/Ellipsoid.pm |
---|
0,0 → 1,950 |
# Geo::Ellipsoid |
# |
# This package implements an Ellipsoid class to perform latitude |
# and longitude calculations on the surface of an ellipsoid. |
# |
# This is a Perl conversion of existing Fortran code (see |
# ACKNOWLEDGEMENTS) and the author of this class makes no |
# claims of originality. Nor can he even vouch for the |
# results of the calculations, although they do seem to |
# work for him and have been tested against other methods. |
package Geo::Ellipsoid; |
use warnings; |
use strict; |
use 5.006_00; |
use Scalar::Util 'looks_like_number'; |
use Math::Trig; |
use Carp; |
=head1 NAME |
Geo::Ellipsoid - Longitude and latitude calculations using an ellipsoid model. |
=head1 VERSION |
Version 1.12, released July 4, 2008. |
=cut |
our $VERSION = '1.12'; |
our $DEBUG = 0; |
=head1 SYNOPSIS |
use Geo::Ellipsoid; |
$geo = Geo::Ellipsoid->new(ellipsoid=>'NAD27', units=>'degrees'); |
@origin = ( 37.619002, -122.374843 ); # SFO |
@dest = ( 33.942536, -118.408074 ); # LAX |
( $range, $bearing ) = $geo->to( @origin, @dest ); |
($lat,$lon) = $geo->at( @origin, 2000, 45.0 ); |
( $x, $y ) = $geo->displacement( @origin, $lat, $lon ); |
@pos = $geo->location( $lat, $lon, $x, $y ); |
=head1 DESCRIPTION |
Geo::Ellipsoid performs geometrical calculations on the surface of |
an ellipsoid. An ellipsoid is a three-dimension object formed from |
the rotation of an ellipse about one of its axes. The approximate |
shape of the earth is an ellipsoid, so Geo::Ellipsoid can accurately |
calculate distance and bearing between two widely-separated locations |
on the earth's surface. |
The shape of an ellipsoid is defined by the lengths of its |
semi-major and semi-minor axes. The shape may also be specifed by |
the flattening ratio C<f> as: |
f = ( semi-major - semi-minor ) / semi-major |
which, since f is a small number, is normally given as the reciprocal |
of the flattening C<1/f>. |
The shape of the earth has been surveyed and estimated differently |
at different times over the years. The two most common sets of values |
used to describe the size and shape of the earth in the United States |
are 'NAD27', dating from 1927, and 'WGS84', from 1984. United States |
Geological Survey topographical maps, for example, use one or the |
other of these values, and commonly-available Global Positioning |
System (GPS) units can be set to use one or the other. |
See L<"DEFINED ELLIPSOIDS"> below for the ellipsoid survey values |
that may be selected for use by Geo::Ellipsoid. |
=cut |
# class data and constants |
our $degrees_per_radian = 180/pi; |
our $eps = 1.0e-23; |
our $max_loop_count = 20; |
our $twopi = 2 * pi; |
our $halfpi = pi/2; |
our %defaults = ( |
ellipsoid => 'WGS84', |
units => 'radians', |
distance_units => 'meter', |
longitude => 0, |
latitude => 1, # allows use of _normalize_output |
bearing => 0, |
); |
our %distance = ( |
'foot' => 0.3048, |
'kilometer' => 1_000, |
'meter' => 1.0, |
'mile' => 1_609.344, |
'nm' => 1_852, |
); |
# set of ellipsoids that can be used. |
# values are |
# 1) a = semi-major (equatorial) radius of Ellipsoid |
# 2) 1/f = reciprocal of flattening (f), the ratio of the semi-minor |
# (polar) radius to the semi-major (equatorial) axis, or |
# polar radius = equatorial radius * ( 1 - f ) |
our %ellipsoids = ( |
'AIRY' => [ 6377563.396, 299.3249646 ], |
'AIRY-MODIFIED' => [ 6377340.189, 299.3249646 ], |
'AUSTRALIAN' => [ 6378160.0, 298.25 ], |
'BESSEL-1841' => [ 6377397.155, 299.1528128 ], |
'CLARKE-1880' => [ 6378249.145, 293.465 ], |
'EVEREST-1830' => [ 6377276.345, 300.8017 ], |
'EVEREST-MODIFIED' => [ 6377304.063, 300.8017 ], |
'FISHER-1960' => [ 6378166.0, 298.3 ], |
'FISHER-1968' => [ 6378150.0, 298.3 ], |
'GRS80' => [ 6378137.0, 298.25722210088 ], |
'HOUGH-1956' => [ 6378270.0, 297.0 ], |
'HAYFORD' => [ 6378388.0, 297.0 ], |
'IAU76' => [ 6378140.0, 298.257 ], |
'KRASSOVSKY-1938' => [ 6378245.0, 298.3 ], |
'NAD27' => [ 6378206.4, 294.9786982138 ], |
'NWL-9D' => [ 6378145.0, 298.25 ], |
'SOUTHAMERICAN-1969' => [ 6378160.0, 298.25 ], |
'SOVIET-1985' => [ 6378136.0, 298.257 ], |
'WGS72' => [ 6378135.0, 298.26 ], |
'WGS84' => [ 6378137.0, 298.257223563 ], |
); |
=head1 CONSTRUCTOR |
=head2 new |
The new() constructor may be called with a hash list to set the value of the |
ellipsoid to be used, the value of the units to be used for angles and |
distances, and whether or not the output range of longitudes and bearing |
angles should be symmetric around zero or always greater than zero. |
The initial default constructor is equivalent to the following: |
my $geo = Geo::Ellipsoid->new( |
ellipsoid => 'WGS84', |
units => 'radians' , |
distance_units => 'meter', |
longitude => 0, |
bearing => 0, |
); |
The constructor arguments may be of any case and, with the exception of |
the ellipsoid value, abbreviated to their first three characters. |
Thus, ( UNI => 'DEG', DIS => 'FEE', Lon => 1, ell => 'NAD27', bEA => 0 ) |
is valid. |
=cut |
sub new |
{ |
my( $class, %args ) = @_; |
my $self = {%defaults}; |
print "new: @_\n" if $DEBUG; |
foreach my $key ( keys %args ) { |
my $val = $args{$key}; |
if( $key =~ /^ell/i ) { |
$self->{ellipsoid} = uc $args{$key}; |
}elsif( $key =~ /^uni/i ) { |
$self->{units} = $args{$key}; |
}elsif( $key =~ /^dis/i ) { |
$self->{distance_units} = $args{$key}; |
}elsif( $key =~ /^lon/i ) { |
$self->{longitude} = $args{$key}; |
}elsif( $key =~ /^bea/i ) { |
$self->{bearing} = $args{$key}; |
}else{ |
carp("Unknown argument: $key => $args{$key}"); |
} |
} |
set_units($self,$self->{units}); |
set_ellipsoid($self,$self->{ellipsoid}); |
set_distance_unit($self,$self->{distance_units}); |
set_longitude_symmetric($self,$self->{longitude}); |
set_bearing_symmetric($self,$self->{bearing}); |
"Ellipsoid(units=>$self->{units},distance_units=>" . |
"$self->{distance_units},ellipsoid=>$self->{ellipsoid}," . |
"longitude=>$self->{longitude},bearing=>$self->{bearing})\n" if $DEBUG; |
bless $self,$class; |
return $self; |
} |
=head1 METHODS |
=head2 set_units |
Set the angle units used by the Geo::Ellipsoid object. The units may |
also be set in the constructor of the object. The allowable values are |
'degrees' or 'radians'. The default is 'radians'. The units value is |
not case sensitive and may be abbreviated to 3 letters. The units of |
angle apply to both input and output latitude, longitude, and bearing |
values. |
$geo->set_units('degrees'); |
=cut |
sub set_units |
{ |
my $self = shift; |
my $units = shift; |
if( $units =~ /deg/i ) { |
$units = 'degrees'; |
}elsif( $units =~ /rad/i ) { |
$units = 'radians'; |
}else{ |
croak("Invalid units specifier '$units' - please use either " . |
"degrees or radians (the default)") unless $units =~ /rad/i; |
} |
$self->{units} = $units; |
} |
=head2 set_distance_unit |
Set the distance unit used by the Geo::Ellipsoid object. The unit of |
distance may also be set in the constructor of the object. The recognized |
values are 'meter', 'kilometer', 'mile', 'nm' (nautical mile), or 'foot'. |
The default is 'meter'. The value is not case sensitive and may be |
abbreviated to 3 letters. |
$geo->set_distance_unit('kilometer'); |
For any other unit of distance not recogized by this method, pass a |
numerical argument representing the length of the distance unit in |
meters. For example, to use units of furlongs, call |
$geo->set_distance_unit(201.168); |
The distance conversion factors used by this module are as follows: |
Unit Units per meter |
-------- --------------- |
foot 0.3048 |
kilometer 1000.0 |
mile 1609.344 |
nm 1852.0 |
=cut |
sub set_distance_unit |
{ |
my $self = shift; |
my $unit = shift; |
print "distance unit = $unit\n" if $DEBUG; |
my $conversion = 0; |
if( defined $unit ) { |
my( $key, $val ); |
while( ($key,$val) = each %distance ) { |
my $re = substr($key,0,3); |
print "trying ($key,$re,$val)\n" if $DEBUG; |
if( $unit =~ /^$re/i ) { |
$self->{distance_units} = $unit; |
$conversion = $val; |
# finish iterating to reset 'each' function call |
while( each %distance ) {} |
last; |
} |
} |
if( $conversion == 0 ) { |
if( looks_like_number($unit) ) { |
$conversion = $unit; |
}else{ |
carp("Unknown argument to set_distance_unit: $unit\nAssuming meters"); |
$conversion = 1.0; |
} |
} |
}else{ |
carp("Missing or undefined argument to set_distance_unit: ". |
"$unit\nAssuming meters"); |
$conversion = 1.0; |
} |
$self->{conversion} = $conversion; |
} |
=head2 set_ellipsoid |
Set the ellipsoid to be used by the Geo::Ellipsoid object. See |
L<"DEFINED ELLIPSOIDS"> below for the allowable values. The value |
may also be set by the constructor. The default value is 'WGS84'. |
$geo->set_ellipsoid('NAD27'); |
=cut |
sub set_ellipsoid |
{ |
my $self = shift; |
my $ellipsoid = uc shift || $defaults{ellipsoid}; |
print " set ellipsoid to $ellipsoid\n" if $DEBUG; |
unless( exists $ellipsoids{$ellipsoid} ) { |
croak("Ellipsoid $ellipsoid does not exist - please use " . |
"set_custom_ellipsoid to use an ellipsoid not in valid set"); |
} |
$self->{ellipsoid} = $ellipsoid; |
my( $major, $recip ) = @{$ellipsoids{$ellipsoid}}; |
$self->{equatorial} = $major; |
if( $recip == 0 ) { |
carp("Infinite flattening specified by ellipsoid -- assuming a sphere"); |
$self->{polar} = $self->{equatorial}; |
$self->{flattening} = 0; |
$self->{eccentricity} = 0; |
}else{ |
$self->{flattening} = ( 1.0 / $ellipsoids{$ellipsoid}[1]); |
$self->{polar} = $self->{equatorial} * ( 1.0 - $self->{flattening} ); |
$self->{eccentricity} = sqrt( 2.0 * $self->{flattening} - |
( $self->{flattening} * $self->{flattening} ) ); |
} |
} |
=head2 set_custom_ellipsoid |
Sets the ellipsoid parameters to the specified ( major semiaxis and |
reciprocal flattening. A zero value for the reciprocal flattening |
will result in a sphere for the ellipsoid, and a warning message |
will be issued. |
$geo->set_custom_ellipsoid( 'sphere', 6378137, 0 ); |
=cut |
sub set_custom_ellipsoid |
{ |
my $self = shift; |
my( $name, $major, $recip ) = @_; |
$name = uc $name; |
$recip = 0 unless defined $recip; |
if( $major ) { |
$ellipsoids{$name} = [ $major, $recip ]; |
}else{ |
croak("set_custom_ellipsoid called without semi-major radius parameter"); |
} |
set_ellipsoid($self,$name); |
} |
=head2 set_longitude_symmetric |
If called with no argument or a true argument, sets the range of output |
values for longitude to be in the range [-pi,+pi) radians. If called with |
a false or undefined argument, sets the output angle range to be |
[0,2*pi) radians. |
$geo->set_longitude_symmetric(1); |
=cut |
sub set_longitude_symmetric |
{ |
my( $self, $sym ) = @_; |
# see if argument passed |
if( $#_ > 0 ) { |
# yes -- use value passed |
$self->{longitude} = $sym; |
}else{ |
# no -- set to true |
$self->{longitude} = 1; |
} |
} |
=head2 set_bearing_symmetric |
If called with no argument or a true argument, sets the range of output |
values for bearing to be in the range [-pi,+pi) radians. If called with |
a false or undefined argument, sets the output angle range to be |
[0,2*pi) radians. |
$geo->set_bearing_symmetric(1); |
=cut |
sub set_bearing_symmetric |
{ |
my( $self, $sym ) = @_; |
# see if argument passed |
if( $#_ > 0 ) { |
# yes -- use value passed |
$self->{bearing} = $sym; |
}else{ |
# no -- set to true |
$self->{bearing} = 1; |
} |
} |
=head2 set_defaults |
Sets the defaults for the new method. Call with key, value pairs similar to |
new. |
$Geo::Ellipsoid->set_defaults( |
units => 'degrees', |
ellipsoid => 'GRS80', |
distance_units => 'kilometer', |
longitude => 1, |
bearing => 0 |
); |
Keys and string values (except for the ellipsoid identifier) may be shortened |
to their first three letters and are case-insensitive: |
$Geo::Ellipsoid->set_defaults( |
uni => 'deg', |
ell => 'GRS80', |
dis => 'kil', |
lon => 1, |
bea => 0 |
); |
=cut |
sub set_defaults |
{ |
my $self = shift; |
my %args = @_; |
foreach my $key ( keys %args ) { |
if( $key =~ /^ell/i ) { |
$defaults{ellipsoid} = uc $args{$key}; |
}elsif( $key =~ /^uni/i ) { |
$defaults{units} = $args{$key}; |
}elsif( $key =~ /^dis/i ) { |
$defaults{distance_units} = $args{$key}; |
}elsif( $key =~ /^lon/i ) { |
$defaults{longitude} = $args{$key}; |
}elsif( $key =~ /^bea/i ) { |
$defaults{bearing} = $args{$key}; |
}else{ |
croak("Geo::Ellipsoid::set_defaults called with invalid key: $key"); |
} |
} |
print "Defaults set to ($defaults{ellipsoid},$defaults{units}\n" |
if $DEBUG; |
} |
=head2 scales |
Returns a list consisting of the distance unit per angle of latitude |
and longitude (degrees or radians) at the specified latitude. |
These values may be used for fast approximations of distance |
calculations in the vicinity of some location. |
( $lat_scale, $lon_scale ) = $geo->scales($lat0); |
$x = $lon_scale * ($lon - $lon0); |
$y = $lat_scale * ($lat - $lat0); |
=cut |
sub scales |
{ |
my $self = shift; |
my $units = $self->{units}; |
my $lat = $_[0]; |
if( defined $lat ) { |
$lat /= $degrees_per_radian if( $units eq 'degrees' ); |
}else{ |
carp("scales() method requires latitude argument; assuming 0"); |
$lat = 0; |
} |
my $aa = $self->{equatorial}; |
my $bb = $self->{polar}; |
my $a2 = $aa*$aa; |
my $b2 = $bb*$bb; |
my $d1 = $aa * cos($lat); |
my $d2 = $bb * sin($lat); |
my $d3 = $d1*$d1 + $d2*$d2; |
my $d4 = sqrt($d3); |
my $n1 = $aa * $bb; |
my $latscl = ( $n1 * $n1 ) / ( $d3 * $d4 * $self->{conversion} ); |
my $lonscl = ( $aa * $d1 ) / ( $d4 * $self->{conversion} ); |
if( $DEBUG ) { |
print "lat=$lat, aa=$aa, bb=$bb\nd1=$d1, d2=$d2, d3=$d3, d4=$d4\n"; |
print "latscl=$latscl, lonscl=$lonscl\n"; |
} |
if( $self->{units} eq 'degrees' ) { |
$latscl /= $degrees_per_radian; |
$lonscl /= $degrees_per_radian; |
} |
return ( $latscl, $lonscl ); |
} |
=head2 range |
Returns the range in distance units between two specified locations given |
as latitude, longitude pairs. |
my $dist = $geo->range( $lat1, $lon1, $lat2, $lon2 ); |
my $dist = $geo->range( @origin, @destination ); |
=cut |
sub range |
{ |
my $self = shift; |
my @args = _normalize_input($self->{units},@_); |
my($range,$bearing) = _inverse($self,@args); |
print "inverse(@_[1..4]) returns($range,$bearing)\n" if $DEBUG; |
return $range; |
} |
=head2 bearing |
Returns the bearing in degrees or radians from the first location to |
the second. Zero bearing is true north. |
my $bearing = $geo->bearing( $lat1, $lon1, $lat2, $lon2 ); |
=cut |
sub bearing |
{ |
my $self = shift; |
my $units = $self->{units}; |
my @args = _normalize_input($units,@_); |
my($range,$bearing) = _inverse($self,@args); |
print "inverse(@args) returns($range,$bearing)\n" if $DEBUG; |
my $t = $bearing; |
$self->_normalize_output('bearing',$bearing); |
print "_normalize_output($t) returns($bearing)\n" if $DEBUG; |
return $bearing; |
} |
=head2 at |
Returns the list (latitude,longitude) in degrees or radians that is a |
specified range and bearing from a given location. |
my( $lat2, $lon2 ) = $geo->at( $lat1, $lon1, $range, $bearing ); |
=cut |
sub at |
{ |
my $self = shift; |
my $units = $self->{units}; |
my( $lat, $lon, $az ) = _normalize_input($units,@_[0,1,3]); |
my $r = $_[2]; |
print "at($lat,$lon,$r,$az)\n" if $DEBUG; |
my( $lat2, $lon2 ) = _forward($self,$lat,$lon,$r,$az); |
print "_forward returns ($lat2,$lon2)\n" if $DEBUG; |
$self->_normalize_output('longitude',$lon2); |
$self->_normalize_output('latitude',$lat2); |
return ( $lat2, $lon2 ); |
} |
=head2 to |
In list context, returns (range, bearing) between two specified locations. |
In scalar context, returns just the range. |
my( $dist, $theta ) = $geo->to( $lat1, $lon1, $lat2, $lon2 ); |
my $dist = $geo->to( $lat1, $lon1, $lat2, $lon2 ); |
=cut |
sub to |
{ |
my $self = shift; |
my $units = $self->{units}; |
my @args = _normalize_input($units,@_); |
print "to($units,@args)\n" if $DEBUG; |
my($range,$bearing) = _inverse($self,@args); |
print "to: inverse(@args) returns($range,$bearing)\n" if $DEBUG; |
#$bearing *= $degrees_per_radian if $units eq 'degrees'; |
$self->_normalize_output('bearing',$bearing); |
if( wantarray() ) { |
return ( $range, $bearing ); |
}else{ |
return $range; |
} |
} |
=head2 displacement |
Returns the (x,y) displacement in distance units between the two specified |
locations. |
my( $x, $y ) = $geo->displacement( $lat1, $lon1, $lat2, $lon2 ); |
NOTE: The x and y displacements are only approximations and only valid |
between two locations that are fairly near to each other. Beyond 10 kilometers |
or more, the concept of X and Y on a curved surface loses its meaning. |
=cut |
sub displacement |
{ |
my $self = shift; |
print "displacement(",join(',',@_),"\n" if $DEBUG; |
my @args = _normalize_input($self->{units},@_); |
print "call _inverse(@args)\n" if $DEBUG; |
my( $range, $bearing ) = _inverse($self,@args); |
print "disp: _inverse(@args) returns ($range,$bearing)\n" if $DEBUG; |
my $x = $range * sin($bearing); |
my $y = $range * cos($bearing); |
return ($x,$y); |
} |
=head2 location |
Returns the list (latitude,longitude) of a location at a given (x,y) |
displacement from a given location. |
my @loc = $geo->location( $lat, $lon, $x, $y ); |
=cut |
sub location |
{ |
my $self = shift; |
my $units = $self->{units}; |
my($lat,$lon,$x,$y) = @_; |
my $range = sqrt( $x*$x+ $y*$y ); |
my $bearing = atan2($x,$y); |
$bearing *= $degrees_per_radian if $units eq 'degrees'; |
print "location($lat,$lon,$x,$y,$range,$bearing)\n" if $DEBUG; |
return $self->at($lat,$lon,$range,$bearing); |
} |
######################################################################## |
# |
# internal functions |
# |
# inverse |
# |
# Calculate the displacement from origin to destination. |
# The input to this subroutine is |
# ( latitude-1, longitude-1, latitude-2, longitude-2 ) in radians. |
# |
# Return the results as the list (range,bearing) with range in the |
# current specified distance unit and bearing in radians. |
sub _inverse() |
{ |
my $self = shift; |
my( $lat1, $lon1, $lat2, $lon2 ) = (@_); |
print "_inverse($lat1,$lon1,$lat2,$lon2)\n" if $DEBUG; |
my $a = $self->{equatorial}; |
my $f = $self->{flattening}; |
my $r = 1.0 - $f; |
my $tu1 = $r * sin($lat1) / cos($lat1); |
my $tu2 = $r * sin($lat2) / cos($lat2); |
my $cu1 = 1.0 / ( sqrt(($tu1*$tu1) + 1.0) ); |
my $su1 = $cu1 * $tu1; |
my $cu2 = 1.0 / ( sqrt( ($tu2*$tu2) + 1.0 )); |
my $s = $cu1 * $cu2; |
my $baz = $s * $tu2; |
my $faz = $baz * $tu1; |
my $dlon = $lon2 - $lon1; |
if( $DEBUG ) { |
printf "lat1=%.8f, lon1=%.8f\n", $lat1, $lon1; |
printf "lat2=%.8f, lon2=%.8f\n", $lat2, $lon2; |
printf "r=%.8f, tu1=%.8f, tu2=%.8f\n", $r, $tu1, $tu2; |
printf "faz=%.8f, dlon=%.8f\n", $faz, $dlon; |
} |
my $x = $dlon; |
my $cnt = 0; |
print "enter loop:\n" if $DEBUG; |
my( $c2a, $c, $cx, $cy, $cz, $d, $del, $e, $sx, $sy, $y ); |
do { |
printf " x=%.8f\n", $x if $DEBUG; |
$sx = sin($x); |
$cx = cos($x); |
$tu1 = $cu2*$sx; |
$tu2 = $baz - ($su1*$cu2*$cx); |
printf " sx=%.8f, cx=%.8f, tu1=%.8f, tu2=%.8f\n", |
$sx, $cx, $tu1, $tu2 if $DEBUG; |
$sy = sqrt( $tu1*$tu1 + $tu2*$tu2 ); |
$cy = $s*$cx + $faz; |
$y = atan2($sy,$cy); |
my $sa; |
if( $sy == 0.0 ) { |
$sa = 1.0; |
}else{ |
$sa = ($s*$sx) / $sy; |
} |
printf " sy=%.8f, cy=%.8f, y=%.8f, sa=%.8f\n", $sy, $cy, $y, $sa |
if $DEBUG; |
$c2a = 1.0 - ($sa*$sa); |
$cz = $faz + $faz; |
if( $c2a > 0.0 ) { |
$cz = ((-$cz)/$c2a) + $cy; |
} |
$e = ( 2.0 * $cz * $cz ) - 1.0; |
$c = ( ((( (-3.0 * $c2a) + 4.0)*$f) + 4.0) * $c2a * $f )/16.0; |
$d = $x; |
$x = ( ($e * $cy * $c + $cz) * $sy * $c + $y) * $sa; |
$x = ( 1.0 - $c ) * $x * $f + $dlon; |
$del = $d - $x; |
if( $DEBUG ) { |
printf " c2a=%.8f, cz=%.8f\n", $c2a, $cz; |
printf " e=%.8f, d=%.8f\n", $e, $d; |
printf " (d-x)=%.8g\n", $del; |
} |
}while( (abs($del) > $eps) && ( ++$cnt <= $max_loop_count ) ); |
$faz = atan2($tu1,$tu2); |
$baz = atan2($cu1*$sx,($baz*$cx - $su1*$cu2)) + pi; |
$x = sqrt( ((1.0/($r*$r)) -1.0 ) * $c2a+1.0 ) + 1.0; |
$x = ($x-2.0)/$x; |
$c = 1.0 - $x; |
$c = (($x*$x)/4.0 + 1.0)/$c; |
$d = ((0.375*$x*$x) - 1.0)*$x; |
$x = $e*$cy; |
if( $DEBUG ) { |
printf "e=%.8f, cy=%.8f, x=%.8f\n", $e, $cy, $x; |
printf "sy=%.8f, c=%.8f, d=%.8f\n", $sy, $c, $d; |
printf "cz=%.8f, a=%.8f, r=%.8f\n", $cz, $a, $r; |
} |
$s = 1.0 - $e - $e; |
$s = (((((((( $sy * $sy * 4.0 ) - 3.0) * $s * $cz * $d/6.0) - $x) * |
$d /4.0) + $cz) * $sy * $d) + $y ) * $c * $a * $r; |
printf "s=%.8f\n", $s if $DEBUG; |
# adjust azimuth to (0,360) or (-180,180) as specified |
if( $self->{symmetric} ) { |
$faz += $twopi if $faz < -(pi); |
$faz -= $twopi if $faz >= pi; |
}else{ |
$faz += $twopi if $faz < 0; |
$faz -= $twopi if $faz >= $twopi; |
} |
# return result |
my @disp = ( ($s/$self->{conversion}), $faz ); |
print "disp = (@disp)\n" if $DEBUG; |
return @disp; |
} |
# _forward |
# |
# Calculate the location (latitue,longitude) of a point |
# given a starting point and a displacement from that |
# point as (range,bearing) |
# |
sub _forward |
{ |
my $self = shift; |
my( $lat1, $lon1, $range, $bearing ) = @_; |
if( $DEBUG ) { |
printf "_forward(lat1=%.8f,lon1=%.8f,range=%.8f,bearing=%.8f)\n", |
$lat1, $lon1, $range, $bearing; |
} |
my $eps = 0.5e-13; |
my $a = $self->{equatorial}; |
my $f = $self->{flattening}; |
my $r = 1.0 - $f; |
my $tu = $r * sin($lat1) / cos($lat1); |
my $faz = $bearing; |
my $s = $self->{conversion} * $range; |
my $sf = sin($faz); |
my $cf = cos($faz); |
my $baz = 0.0; |
$baz = 2.0 * atan2($tu,$cf) if( $cf != 0.0 ); |
my $cu = 1.0 / sqrt(1.0 + $tu*$tu); |
my $su = $tu * $cu; |
my $sa = $cu * $sf; |
my $c2a = 1.0 - ($sa*$sa); |
my $x = 1.0 + sqrt( (((1.0/($r*$r)) - 1.0 )*$c2a) +1.0); |
$x = ($x-2.0)/$x; |
my $c = 1.0 - $x; |
$c = ((($x*$x)/4.0) + 1.0)/$c; |
my $d = $x * ((0.375*$x*$x)-1.0); |
$tu = (($s/$r)/$a)/$c; |
my $y = $tu; |
if( $DEBUG ) { |
printf "r=%.8f, tu=%.8f, faz=%.8f\n", $r, $tu, $faz; |
printf "baz=%.8f, sf=%.8f, cf=%.8f\n", $baz, $sf, $cf; |
printf "cu=%.8f, su=%.8f, sa=%.8f\n", $cu, $su, $sa; |
printf "x=%.8f, c=%.8f, y=%.8f\n", $x, $c, $y; |
} |
my( $cy, $cz, $e, $sy ); |
do { |
$sy = sin($y); |
$cy = cos($y); |
$cz = cos($baz+$y); |
$e = (2.0*$cz*$cz)-1.0; |
$c = $y; |
$x = $e * $cy; |
$y = (2.0 * $e) - 1.0; |
$y = ((((((((($sy*$sy*4.0)-3.0)*$y*$cz*$d)/6.0)+$x)*$d)/4.0)-$cz)*$sy*$d) + |
$tu; |
} while( abs($y-$c) > $eps ); |
$baz = ($cu*$cy*$cf) - ($su*$sy); |
$c = $r*sqrt(($sa*$sa) + ($baz*$baz)); |
$d = $su*$cy + $cu*$sy*$cf; |
my $lat2 = atan2($d,$c); |
$c = $cu*$cy - $su*$sy*$cf; |
$x = atan2($sy*$sf,$c); |
$c = (((((-3.0*$c2a)+4.0)*$f)+4.0)*$c2a*$f)/16.0; |
$d = (((($e*$cy*$c) + $cz)*$sy*$c)+$y)*$sa; |
my $lon2 = $lon1 + $x - (1.0-$c)*$d*$f; |
#$baz = atan2($sa,$baz) + pi; |
# return result |
return ($lat2,$lon2); |
} |
# _normalize_input |
# |
# Normalize a set of input angle values by converting to |
# radians if given in degrees and by converting to the |
# range [0,2pi), i.e. greater than or equal to zero and |
# less than two pi. |
# |
sub _normalize_input |
{ |
my $units = shift; |
my @args = @_; |
return map { |
$_ = deg2rad($_) if $units eq 'degrees'; |
while( $_ < 0 ) { $_ += $twopi } |
while( $_ >= $twopi ) { $_ -= $twopi } |
$_ |
} @args; |
} |
# _normalize_output |
# |
# Normalize a set of output angle values by converting to |
# degrees if needed and by converting to the range [-pi,+pi) or |
# [0,2pi) as needed. |
# |
sub _normalize_output |
{ |
my $self = shift; |
my $elem = shift; # 'bearing' or 'longitude' |
# adjust remaining input values by reference |
for ( @_ ) { |
if( $self->{$elem} ) { |
# normalize to range [-pi,pi) |
while( $_ < -(pi) ) { $_ += $twopi } |
while( $_ >= pi ) { $_ -= $twopi } |
}else{ |
# normalize to range [0,2*pi) |
while( $_ < 0 ) { $_ += $twopi } |
while( $_ >= $twopi ) { $_ -= $twopi } |
} |
$_ = rad2deg($_) if $self->{units} eq 'degrees'; |
} |
} |
=head1 DEFINED ELLIPSOIDS |
The following ellipsoids are defined in Geo::Ellipsoid, with the |
semi-major axis in meters and the reciprocal flattening as shown. |
The default ellipsoid is WGS84. |
Ellipsoid Semi-Major Axis (m.) 1/Flattening |
--------- ------------------- --------------- |
AIRY 6377563.396 299.3249646 |
AIRY-MODIFIED 6377340.189 299.3249646 |
AUSTRALIAN 6378160.0 298.25 |
BESSEL-1841 6377397.155 299.1528128 |
CLARKE-1880 6378249.145 293.465 |
EVEREST-1830 6377276.345 290.8017 |
EVEREST-MODIFIED 6377304.063 290.8017 |
FISHER-1960 6378166.0 298.3 |
FISHER-1968 6378150.0 298.3 |
GRS80 6378137.0 298.25722210088 |
HOUGH-1956 6378270.0 297.0 |
HAYFORD 6378388.0 297.0 |
IAU76 6378140.0 298.257 |
KRASSOVSKY-1938 6378245.0 298.3 |
NAD27 6378206.4 294.9786982138 |
NWL-9D 6378145.0 298.25 |
SOUTHAMERICAN-1969 6378160.0 298.25 |
SOVIET-1985 6378136.0 298.257 |
WGS72 6378135.0 298.26 |
WGS84 6378137.0 298.257223563 |
=head1 LIMITATIONS |
The methods should not be used on points which are too near the poles |
(above or below 89 degrees), and should not be used on points which |
are antipodal, i.e., exactly on opposite sides of the ellipsoid. The |
methods will not return valid results in these cases. |
=head1 ACKNOWLEDGEMENTS |
The conversion algorithms used here are Perl translations of Fortran |
routines written by LCDR S<L. Pfeifer> NGS Rockville MD that implement |
S<T. Vincenty's> Modified Rainsford's method with Helmert's elliptical |
terms as published in "Direct and Inverse Solutions of Ellipsoid on |
the Ellipsoid with Application of Nested Equations", S<T. Vincenty,> |
Survey Review, April 1975. |
The Fortran source code files inverse.for and forward.for |
may be obtained from |
ftp://ftp.ngs.noaa.gov/pub/pcsoft/for_inv.3d/source/ |
=head1 AUTHOR |
Jim Gibson, C<< <Jim@Gibson.org> >> |
=head1 BUGS |
See LIMITATIONS, above. |
Please report any bugs or feature requests to |
C<bug-geo-ellipsoid@rt.cpan.org>, or through the web interface at |
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Geo-Ellipsoid>. |
=head1 COPYRIGHT & LICENSE |
Copyright 2005-2008 Jim Gibson, all rights reserved. |
This program is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head1 SEE ALSO |
Geo::Distance, Geo::Ellipsoids |
=cut |
1; # End of Geo::Ellipsoid |
/MissionCockpit/tags/V0.2.5/perl/site/lib/Time/HiRes.pm |
---|
0,0 → 1,591 |
package Time::HiRes; |
use strict; |
use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); |
require Exporter; |
require DynaLoader; |
@ISA = qw(Exporter DynaLoader); |
@EXPORT = qw( ); |
@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval |
getitimer setitimer nanosleep clock_gettime clock_getres |
clock clock_nanosleep |
CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID |
CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID |
CLOCK_TIMEOFDAY CLOCKS_PER_SEC |
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF |
TIMER_ABSTIME |
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer |
d_nanosleep d_clock_gettime d_clock_getres |
d_clock d_clock_nanosleep |
stat |
); |
$VERSION = '1.9719'; |
$XS_VERSION = $VERSION; |
$VERSION = eval $VERSION; |
sub AUTOLOAD { |
my $constname; |
($constname = $AUTOLOAD) =~ s/.*:://; |
# print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n"; |
die "&Time::HiRes::constant not defined" if $constname eq 'constant'; |
my ($error, $val) = constant($constname); |
# print "AUTOLOAD: error = $error, val = $val\n"; |
if ($error) { |
my (undef,$file,$line) = caller; |
die "$error at $file line $line.\n"; |
} |
{ |
no strict 'refs'; |
*$AUTOLOAD = sub { $val }; |
} |
goto &$AUTOLOAD; |
} |
sub import { |
my $this = shift; |
for my $i (@_) { |
if (($i eq 'clock_getres' && !&d_clock_getres) || |
($i eq 'clock_gettime' && !&d_clock_gettime) || |
($i eq 'clock_nanosleep' && !&d_clock_nanosleep) || |
($i eq 'clock' && !&d_clock) || |
($i eq 'nanosleep' && !&d_nanosleep) || |
($i eq 'usleep' && !&d_usleep) || |
($i eq 'ualarm' && !&d_ualarm)) { |
require Carp; |
Carp::croak("Time::HiRes::$i(): unimplemented in this platform"); |
} |
} |
Time::HiRes->export_to_level(1, $this, @_); |
} |
bootstrap Time::HiRes; |
# Preloaded methods go here. |
sub tv_interval { |
# probably could have been done in C |
my ($a, $b) = @_; |
$b = [gettimeofday()] unless defined($b); |
(${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000); |
} |
# Autoload methods go after =cut, and are processed by the autosplit program. |
1; |
__END__ |
=head1 NAME |
Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers |
=head1 SYNOPSIS |
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep |
clock_gettime clock_getres clock_nanosleep clock |
stat ); |
usleep ($microseconds); |
nanosleep ($nanoseconds); |
ualarm ($microseconds); |
ualarm ($microseconds, $interval_microseconds); |
$t0 = [gettimeofday]; |
($seconds, $microseconds) = gettimeofday; |
$elapsed = tv_interval ( $t0, [$seconds, $microseconds]); |
$elapsed = tv_interval ( $t0, [gettimeofday]); |
$elapsed = tv_interval ( $t0 ); |
use Time::HiRes qw ( time alarm sleep ); |
$now_fractions = time; |
sleep ($floating_seconds); |
alarm ($floating_seconds); |
alarm ($floating_seconds, $floating_interval); |
use Time::HiRes qw( setitimer getitimer ); |
setitimer ($which, $floating_seconds, $floating_interval ); |
getitimer ($which); |
use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep |
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF ); |
$realtime = clock_gettime(CLOCK_REALTIME); |
$resolution = clock_getres(CLOCK_REALTIME); |
clock_nanosleep(CLOCK_REALTIME, 1.5e9); |
clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME); |
my $ticktock = clock(); |
use Time::HiRes qw( stat ); |
my @stat = stat("file"); |
my @stat = stat(FH); |
=head1 DESCRIPTION |
The C<Time::HiRes> module implements a Perl interface to the |
C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and |
C<setitimer>/C<getitimer> system calls, in other words, high |
resolution time and timers. See the L</EXAMPLES> section below and the |
test scripts for usage; see your system documentation for the |
description of the underlying C<nanosleep> or C<usleep>, C<ualarm>, |
C<gettimeofday>, and C<setitimer>/C<getitimer> calls. |
If your system lacks C<gettimeofday()> or an emulation of it you don't |
get C<gettimeofday()> or the one-argument form of C<tv_interval()>. |
If your system lacks all of C<nanosleep()>, C<usleep()>, |
C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>, |
C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>. |
If your system lacks both C<ualarm()> and C<setitimer()> you don't get |
C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>. |
If you try to import an unimplemented function in the C<use> statement |
it will fail at compile time. |
If your subsecond sleeping is implemented with C<nanosleep()> instead |
of C<usleep()>, you can mix subsecond sleeping with signals since |
C<nanosleep()> does not use signals. This, however, is not portable, |
and you should first check for the truth value of |
C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and |
then carefully read your C<nanosleep()> C API documentation for any |
peculiarities. |
If you are using C<nanosleep> for something else than mixing sleeping |
with signals, give some thought to whether Perl is the tool you should |
be using for work requiring nanosecond accuracies. |
Remember that unless you are working on a I<hard realtime> system, |
any clocks and timers will be imprecise, especially so if you are working |
in a pre-emptive multiuser system. Understand the difference between |
I<wallclock time> and process time (in UNIX-like systems the sum of |
I<user> and I<system> times). Any attempt to sleep for X seconds will |
most probably end up sleeping B<more> than that, but don't be surpised |
if you end up sleeping slightly B<less>. |
The following functions can be imported from this module. |
No functions are exported by default. |
=over 4 |
=item gettimeofday () |
In array context returns a two-element array with the seconds and |
microseconds since the epoch. In scalar context returns floating |
seconds like C<Time::HiRes::time()> (see below). |
=item usleep ( $useconds ) |
Sleeps for the number of microseconds (millionths of a second) |
specified. Returns the number of microseconds actually slept. |
Can sleep for more than one second, unlike the C<usleep> system call. |
Can also sleep for zero seconds, which often works like a I<thread yield>. |
See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and |
C<Time::HiRes::clock_nanosleep()>. |
Do not expect usleep() to be exact down to one microsecond. |
=item nanosleep ( $nanoseconds ) |
Sleeps for the number of nanoseconds (1e9ths of a second) specified. |
Returns the number of nanoseconds actually slept (accurate only to |
microseconds, the nearest thousand of them). Can sleep for more than |
one second. Can also sleep for zero seconds, which often works like |
a I<thread yield>. See also C<Time::HiRes::sleep()>, |
C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>. |
Do not expect nanosleep() to be exact down to one nanosecond. |
Getting even accuracy of one thousand nanoseconds is good. |
=item ualarm ( $useconds [, $interval_useconds ] ) |
Issues a C<ualarm> call; the C<$interval_useconds> is optional and |
will be zero if unspecified, resulting in C<alarm>-like behaviour. |
Returns the remaining time in the alarm in microseconds, or C<undef> |
if an error occurred. |
ualarm(0) will cancel an outstanding ualarm(). |
Note that the interaction between alarms and sleeps is unspecified. |
=item tv_interval |
tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] ) |
Returns the floating seconds between the two times, which should have |
been returned by C<gettimeofday()>. If the second argument is omitted, |
then the current time is used. |
=item time () |
Returns a floating seconds since the epoch. This function can be |
imported, resulting in a nice drop-in replacement for the C<time> |
provided with core Perl; see the L</EXAMPLES> below. |
B<NOTE 1>: This higher resolution timer can return values either less |
or more than the core C<time()>, depending on whether your platform |
rounds the higher resolution timer values up, down, or to the nearest second |
to get the core C<time()>, but naturally the difference should be never |
more than half a second. See also L</clock_getres>, if available |
in your system. |
B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when |
the C<time()> seconds since epoch rolled over to 1_000_000_000, the |
default floating point format of Perl and the seconds since epoch have |
conspired to produce an apparent bug: if you print the value of |
C<Time::HiRes::time()> you seem to be getting only five decimals, not |
six as promised (microseconds). Not to worry, the microseconds are |
there (assuming your platform supports such granularity in the first |
place). What is going on is that the default floating point format of |
Perl only outputs 15 digits. In this case that means ten digits |
before the decimal separator and five after. To see the microseconds |
you can use either C<printf>/C<sprintf> with C<"%.6f">, or the |
C<gettimeofday()> function in list context, which will give you the |
seconds and microseconds as two separate values. |
=item sleep ( $floating_seconds ) |
Sleeps for the specified amount of seconds. Returns the number of |
seconds actually slept (a floating point value). This function can |
be imported, resulting in a nice drop-in replacement for the C<sleep> |
provided with perl, see the L</EXAMPLES> below. |
Note that the interaction between alarms and sleeps is unspecified. |
=item alarm ( $floating_seconds [, $interval_floating_seconds ] ) |
The C<SIGALRM> signal is sent after the specified number of seconds. |
Implemented using C<setitimer()> if available, C<ualarm()> if not. |
The C<$interval_floating_seconds> argument is optional and will be |
zero if unspecified, resulting in C<alarm()>-like behaviour. This |
function can be imported, resulting in a nice drop-in replacement for |
the C<alarm> provided with perl, see the L</EXAMPLES> below. |
Returns the remaining time in the alarm in seconds, or C<undef> |
if an error occurred. |
B<NOTE 1>: With some combinations of operating systems and Perl |
releases C<SIGALRM> restarts C<select()>, instead of interrupting it. |
This means that an C<alarm()> followed by a C<select()> may together |
take the sum of the times specified for the the C<alarm()> and the |
C<select()>, not just the time of the C<alarm()>. |
Note that the interaction between alarms and sleeps is unspecified. |
=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] ) |
Start up an interval timer: after a certain time, a signal ($which) arrives, |
and more signals may keep arriving at certain intervals. To disable |
an "itimer", use C<$floating_seconds> of zero. If the |
C<$interval_floating_seconds> is set to zero (or unspecified), the |
timer is disabled B<after> the next delivered signal. |
Use of interval timers may interfere with C<alarm()>, C<sleep()>, |
and C<usleep()>. In standard-speak the "interaction is unspecified", |
which means that I<anything> may happen: it may work, it may not. |
In scalar context, the remaining time in the timer is returned. |
In list context, both the remaining time and the interval are returned. |
There are usually three or four interval timers (signals) available: the |
C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or |
C<ITIMER_REALPROF>. Note that which ones are available depends: true |
UNIX platforms usually have the first three, but only Solaris seems to |
have C<ITIMER_REALPROF> (which is used to profile multithreaded programs). |
Win32 unfortunately does not haveinterval timers. |
C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in |
I<real time>; that is, wallclock time. C<SIGALRM> is delivered when |
the timer expires. |
C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is, |
only when the process is running. In multiprocessor/user/CPU systems |
this may be more or less than real or wallclock time. (This time is |
also known as the I<user time>.) C<SIGVTALRM> is delivered when the |
timer expires. |
C<ITIMER_PROF> counts time when either the process virtual time or when |
the operating system is running on behalf of the process (such as I/O). |
(This time is also known as the I<system time>.) (The sum of user |
time and system time is known as the I<CPU time>.) C<SIGPROF> is |
delivered when the timer expires. C<SIGPROF> can interrupt system calls. |
The semantics of interval timers for multithreaded programs are |
system-specific, and some systems may support additional interval |
timers. For example, it is unspecified which thread gets the signals. |
See your C<setitimer()> documentation. |
=item getitimer ( $which ) |
Return the remaining time in the interval timer specified by C<$which>. |
In scalar context, the remaining time is returned. |
In list context, both the remaining time and the interval are returned. |
The interval is always what you put in using C<setitimer()>. |
=item clock_gettime ( $which ) |
Return as seconds the current value of the POSIX high resolution timer |
specified by C<$which>. All implementations that support POSIX high |
resolution timers are supposed to support at least the C<$which> value |
of C<CLOCK_REALTIME>, which is supposed to return results close to the |
results of C<gettimeofday>, or the number of seconds since 00:00:00:00 |
January 1, 1970 Greenwich Mean Time (GMT). Do not assume that |
CLOCK_REALTIME is zero, it might be one, or something else. |
Another potentially useful (but not available everywhere) value is |
C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time |
value (unlike time() or gettimeofday(), which can be adjusted). |
See your system documentation for other possibly supported values. |
=item clock_getres ( $which ) |
Return as seconds the resolution of the POSIX high resolution timer |
specified by C<$which>. All implementations that support POSIX high |
resolution timers are supposed to support at least the C<$which> value |
of C<CLOCK_REALTIME>, see L</clock_gettime>. |
=item clock_nanosleep ( $which, $nanoseconds, $flags = 0) |
Sleeps for the number of nanoseconds (1e9ths of a second) specified. |
Returns the number of nanoseconds actually slept. The $which is the |
"clock id", as with clock_gettime() and clock_getres(). The flags |
default to zero but C<TIMER_ABSTIME> can specified (must be exported |
explicitly) which means that C<$nanoseconds> is not a time interval |
(as is the default) but instead an absolute time. Can sleep for more |
than one second. Can also sleep for zero seconds, which often works |
like a I<thread yield>. See also C<Time::HiRes::sleep()>, |
C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>. |
Do not expect clock_nanosleep() to be exact down to one nanosecond. |
Getting even accuracy of one thousand nanoseconds is good. |
=item clock() |
Return as seconds the I<process time> (user + system time) spent by |
the process since the first call to clock() (the definition is B<not> |
"since the start of the process", though if you are lucky these times |
may be quite close to each other, depending on the system). What this |
means is that you probably need to store the result of your first call |
to clock(), and subtract that value from the following results of clock(). |
The time returned also includes the process times of the terminated |
child processes for which wait() has been executed. This value is |
somewhat like the second value returned by the times() of core Perl, |
but not necessarily identical. Note that due to backward |
compatibility limitations the returned value may wrap around at about |
2147 seconds or at about 36 minutes. |
=item stat |
=item stat FH |
=item stat EXPR |
As L<perlfunc/stat> but with the access/modify/change file timestamps |
in subsecond resolution, if the operating system and the filesystem |
both support such timestamps. To override the standard stat(): |
use Time::HiRes qw(stat); |
Test for the value of &Time::HiRes::d_hires_stat to find out whether |
the operating system supports subsecond file timestamps: a value |
larger than zero means yes. There are unfortunately no easy |
ways to find out whether the filesystem supports such timestamps. |
UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp |
granularity is B<two> seconds). |
A zero return value of &Time::HiRes::d_hires_stat means that |
Time::HiRes::stat is a no-op passthrough for CORE::stat(), |
and therefore the timestamps will stay integers. The same |
thing will happen if the filesystem does not do subsecond timestamps, |
even if the &Time::HiRes::d_hires_stat is non-zero. |
In any case do not expect nanosecond resolution, or even a microsecond |
resolution. Also note that the modify/access timestamps might have |
different resolutions, and that they need not be synchronized, e.g. |
if the operations are |
write |
stat # t1 |
read |
stat # t2 |
the access time stamp from t2 need not be greater-than the modify |
time stamp from t1: it may be equal or I<less>. |
=back |
=head1 EXAMPLES |
use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); |
$microseconds = 750_000; |
usleep($microseconds); |
# signal alarm in 2.5s & every .1s thereafter |
ualarm(2_500_000, 100_000); |
# cancel that ualarm |
ualarm(0); |
# get seconds and microseconds since the epoch |
($s, $usec) = gettimeofday(); |
# measure elapsed time |
# (could also do by subtracting 2 gettimeofday return values) |
$t0 = [gettimeofday]; |
# do bunch of stuff here |
$t1 = [gettimeofday]; |
# do more stuff here |
$t0_t1 = tv_interval $t0, $t1; |
$elapsed = tv_interval ($t0, [gettimeofday]); |
$elapsed = tv_interval ($t0); # equivalent code |
# |
# replacements for time, alarm and sleep that know about |
# floating seconds |
# |
use Time::HiRes; |
$now_fractions = Time::HiRes::time; |
Time::HiRes::sleep (2.5); |
Time::HiRes::alarm (10.6666666); |
use Time::HiRes qw ( time alarm sleep ); |
$now_fractions = time; |
sleep (2.5); |
alarm (10.6666666); |
# Arm an interval timer to go off first at 10 seconds and |
# after that every 2.5 seconds, in process virtual time |
use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time ); |
$SIG{VTALRM} = sub { print time, "\n" }; |
setitimer(ITIMER_VIRTUAL, 10, 2.5); |
use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME ); |
# Read the POSIX high resolution timer. |
my $high = clock_getres(CLOCK_REALTIME); |
# But how accurate we can be, really? |
my $reso = clock_getres(CLOCK_REALTIME); |
use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME ); |
clock_nanosleep(CLOCK_REALTIME, 1e6); |
clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME); |
use Time::HiRes qw( clock ); |
my $clock0 = clock(); |
... # Do something. |
my $clock1 = clock(); |
my $clockd = $clock1 - $clock0; |
use Time::HiRes qw( stat ); |
my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10]; |
=head1 C API |
In addition to the perl API described above, a C API is available for |
extension writers. The following C functions are available in the |
modglobal hash: |
name C prototype |
--------------- ---------------------- |
Time::NVtime double (*)() |
Time::U2time void (*)(pTHX_ UV ret[2]) |
Both functions return equivalent information (like C<gettimeofday>) |
but with different representations. The names C<NVtime> and C<U2time> |
were selected mainly because they are operating system independent. |
(C<gettimeofday> is Unix-centric, though some platforms like Win32 and |
VMS have emulations for it.) |
Here is an example of using C<NVtime> from C: |
double (*myNVtime)(); /* Returns -1 on failure. */ |
SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0); |
if (!svp) croak("Time::HiRes is required"); |
if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer"); |
myNVtime = INT2PTR(double(*)(), SvIV(*svp)); |
printf("The current time is: %f\n", (*myNVtime)()); |
=head1 DIAGNOSTICS |
=head2 useconds or interval more than ... |
In ualarm() you tried to use number of microseconds or interval (also |
in microseconds) more than 1_000_000 and setitimer() is not available |
in your system to emulate that case. |
=head2 negative time not invented yet |
You tried to use a negative time argument. |
=head2 internal error: useconds < 0 (unsigned ... signed ...) |
Something went horribly wrong-- the number of microseconds that cannot |
become negative just became negative. Maybe your compiler is broken? |
=head2 useconds or uinterval equal to or more than 1000000 |
In some platforms it is not possible to get an alarm with subsecond |
resolution and later than one second. |
=head2 unimplemented in this platform |
Some calls simply aren't available, real or emulated, on every platform. |
=head1 CAVEATS |
Notice that the core C<time()> maybe rounding rather than truncating. |
What this means is that the core C<time()> may be reporting the time |
as one second later than C<gettimeofday()> and C<Time::HiRes::time()>. |
Adjusting the system clock (either manually or by services like ntp) |
may cause problems, especially for long running programs that assume |
a monotonously increasing time (note that all platforms do not adjust |
time as gracefully as UNIX ntp does). For example in Win32 (and derived |
platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily |
drift off from the system clock (and the original time()) by up to 0.5 |
seconds. Time::HiRes will notice this eventually and recalibrate. |
Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC) |
might help in this (in case your system supports CLOCK_MONOTONIC). |
Some systems have APIs but not implementations: for example QNX and Haiku |
have the interval timer APIs but not the functionality. |
=head1 SEE ALSO |
Perl modules L<BSD::Resource>, L<Time::TAI64>. |
Your system documentation for C<clock>, C<clock_gettime>, |
C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>, |
C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>. |
=head1 AUTHORS |
D. Wegscheid <wegscd@whirlpool.com> |
R. Schertler <roderick@argon.org> |
J. Hietaniemi <jhi@iki.fi> |
G. Aas <gisle@aas.no> |
=head1 COPYRIGHT AND LICENSE |
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. |
Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi. |
All rights reserved. |
This program is free software; you can redistribute it and/or modify |
it under the same terms as Perl itself. |
=cut |
/MissionCockpit/tags/V0.2.5/perl/site/lib/Win32/Locale.pm |
---|
0,0 → 1,371 |
package Win32::Locale; |
# Time-stamp: "2004-01-11 18:56:06 AST" |
use strict; |
use vars qw($VERSION %MSLocale2LangTag); |
$VERSION = '0.04'; |
%MSLocale2LangTag = ( |
0x0436 => 'af' , # <AFK> <Afrikaans> <Afrikaans> |
0x041c => 'sq' , # <SQI> <Albanian> <Albanian> |
0x0401 => 'ar-sa', # <ARA> <Arabic> <Arabic (Saudi Arabia)> |
0x0801 => 'ar-iq', # <ARI> <Arabic> <Arabic (Iraq)> |
0x0C01 => 'ar-eg', # <ARE> <Arabic> <Arabic (Egypt)> |
0x1001 => 'ar-ly', # <ARL> <Arabic> <Arabic (Libya)> |
0x1401 => 'ar-dz', # <ARG> <Arabic> <Arabic (Algeria)> |
0x1801 => 'ar-ma', # <ARM> <Arabic> <Arabic (Morocco)> |
0x1C01 => 'ar-tn', # <ART> <Arabic> <Arabic (Tunisia)> |
0x2001 => 'ar-om', # <ARO> <Arabic> <Arabic (Oman)> |
0x2401 => 'ar-ye', # <ARY> <Arabic> <Arabic (Yemen)> |
0x2801 => 'ar-sy', # <ARS> <Arabic> <Arabic (Syria)> |
0x2C01 => 'ar-jo', # <ARJ> <Arabic> <Arabic (Jordan)> |
0x3001 => 'ar-lb', # <ARB> <Arabic> <Arabic (Lebanon)> |
0x3401 => 'ar-kw', # <ARK> <Arabic> <Arabic (Kuwait)> |
0x3801 => 'ar-ae', # <ARU> <Arabic> <Arabic (U.A.E.)> |
0x3C01 => 'ar-bh', # <ARH> <Arabic> <Arabic (Bahrain)> |
0x4001 => 'ar-qa', # <ARQ> <Arabic> <Arabic (Qatar)> |
0x042b => 'hy' , # <HYE> <Armenian> <Armenian> |
0x044d => 'as' , # <ASM> <Assamese> <Assamese> |
0x042c => 'az-latn', # <AZE> <Azeri> <Azeri (Latin)> |
0x082c => 'az-cyrl', # <AZC> <Azeri> <Azeri (Cyrillic)> |
0x042D => 'eu' , # <EUQ> <Basque> <Basque> |
0x0423 => 'be' , # <BEL> <Belarussian> <Belarussian> |
0x0445 => 'bn' , # <BEN> <Bengali> <Bengali> |
0x0402 => 'bg' , # <BGR> <Bulgarian> <Bulgarian> |
0x0403 => 'ca' , # <CAT> <Catalan> <Catalan> |
# Chinese is zh, not cn! |
0x0404 => 'zh-tw', # <CHT> <Chinese> <Chinese (Taiwan)> |
0x0804 => 'zh-cn', # <CHS> <Chinese> <Chinese (PRC)> |
0x0C04 => 'zh-hk', # <ZHH> <Chinese> <Chinese (Hong Kong)> |
0x1004 => 'zh-sg', # <ZHI> <Chinese> <Chinese (Singapore)> |
0x1404 => 'zh-mo', # <ZHM> <Chinese> <Chinese (Macau SAR)> |
0x041a => 'hr' , # <HRV> <Croatian> <Croatian> |
0x0405 => 'cs' , # <CSY> <Czech> <Czech> |
0x0406 => 'da' , # <DAN> <Danish> <Danish> |
0x0413 => 'nl-nl', # <NLD> <Dutch> <Dutch (Netherlands)> |
0x0813 => 'nl-be', # <NLB> <Dutch> <Dutch (Belgium)> |
0x0409 => 'en-us', # <ENU> <English> <English (United States)> |
0x0809 => 'en-gb', # <ENG> <English> <English (United Kingdom)> |
0x0c09 => 'en-au', # <ENA> <English> <English (Australia)> |
0x1009 => 'en-ca', # <ENC> <English> <English (Canada)> |
0x1409 => 'en-nz', # <ENZ> <English> <English (New Zealand)> |
0x1809 => 'en-ie', # <ENI> <English> <English (Ireland)> |
0x1c09 => 'en-za', # <ENS> <English> <English (South Africa)> |
0x2009 => 'en-jm', # <ENJ> <English> <English (Jamaica)> |
0x2409 => 'en-jm', # <ENB> <English> <English (Caribbean)> # a hack |
0x2809 => 'en-bz', # <ENL> <English> <English (Belize)> |
0x2c09 => 'en-tt', # <ENT> <English> <English (Trinidad)> |
0x3009 => 'en-zw', # <ENW> <English> <English (Zimbabwe)> |
0x3409 => 'en-ph', # <ENP> <English> <English (Philippines)> |
0x0425 => 'et' , # <ETI> <Estonian> <Estonian> |
0x0438 => 'fo' , # <FOS> <Faeroese> <Faeroese> |
0x0429 => 'pa' , # <FAR> <Farsi> <Farsi> # =Persian |
0x040b => 'fi' , # <FIN> <Finnish> <Finnish> |
0x040c => 'fr-fr', # <FRA> <French> <French (France)> |
0x080c => 'fr-be', # <FRB> <French> <French (Belgium)> |
0x0c0c => 'fr-ca', # <FRC> <French> <French (Canada)> |
0x100c => 'fr-ch', # <FRS> <French> <French (Switzerland)> |
0x140c => 'fr-lu', # <FRL> <French> <French (Luxembourg)> |
0x180c => 'fr-mc', # <FRM> <French> <French (Monaco)> |
0x0437 => 'ka' , # <KAT> <Georgian> <Georgian> |
0x0407 => 'de-de', # <DEU> <German> <German (Germany)> |
0x0807 => 'de-ch', # <DES> <German> <German (Switzerland)> |
0x0c07 => 'de-at', # <DEA> <German> <German (Austria)> |
0x1007 => 'de-lu', # <DEL> <German> <German (Luxembourg)> |
0x1407 => 'de-li', # <DEC> <German> <German (Liechtenstein)> |
0x0408 => 'el' , # <ELL> <Greek> <Greek> |
0x0447 => 'gu' , # <GUJ> <Gujarati> <Gujarati> |
0x040D => 'he' , # <HEB> <Hebrew> <Hebrew> # formerly 'iw' |
0x0439 => 'hi' , # <HIN> <Hindi> <Hindi> |
0x040e => 'hu' , # <HUN> <Hungarian> <Hungarian> |
0x040F => 'is' , # <ISL> <Icelandic> <Icelandic> |
0x0421 => 'id' , # <IND> <Indonesian> <Indonesian> # formerly 'in' |
0x0410 => 'it-it', # <ITA> <Italian> <Italian (Italy)> |
0x0810 => 'it-ch', # <ITS> <Italian> <Italian (Switzerland)> |
0x0411 => 'ja' , # <JPN> <Japanese> <Japanese> # not "jp"! |
0x044b => 'kn' , # <KAN> <Kannada> <Kannada> |
0x0860 => 'ks' , # <KAI> <Kashmiri> <Kashmiri (India)> |
0x043f => 'kk' , # <KAZ> <Kazakh> <Kazakh> |
0x0457 => 'kok' , # <KOK> <Konkani> <Konkani> 3-letters! |
0x0412 => 'ko' , # <KOR> <Korean> <Korean> |
0x0812 => 'ko' , # <KOJ> <Korean> <Korean (Johab)> ? |
0x0426 => 'lv' , # <LVI> <Latvian> <Latvian> # = lettish |
0x0427 => 'lt' , # <LTH> <Lithuanian> <Lithuanian> |
0x0827 => 'lt' , # <LTH> <Lithuanian> <Lithuanian (Classic)> ? |
0x042f => 'mk' , # <MKD> <FYOR Macedonian> <FYOR Macedonian> |
0x043e => 'ms' , # <MSL> <Malay> <Malaysian> |
0x083e => 'ms-bn', # <MSB> <Malay> <Malay Brunei Darussalam> |
0x044c => 'ml' , # <MAL> <Malayalam> <Malayalam> |
0x044e => 'mr' , # <MAR> <Marathi> <Marathi> |
0x0461 => 'ne-np', # <NEP> <Nepali> <Nepali (Nepal)> |
0x0861 => 'ne-in', # <NEI> <Nepali> <Nepali (India)> |
0x0414 => 'nb' , # <NOR> <Norwegian> <Norwegian (Bokmal)> #was no-bok |
0x0814 => 'nn' , # <NON> <Norwegian> <Norwegian (Nynorsk)> #was no-nyn |
# note that this leaves nothing using "no" ("Norwegian") |
0x0448 => 'or' , # <ORI> <Oriya> <Oriya> |
0x0415 => 'pl' , # <PLK> <Polish> <Polish> |
0x0416 => 'pt-br', # <PTB> <Portuguese> <Portuguese (Brazil)> |
0x0816 => 'pt-pt', # <PTG> <Portuguese> <Portuguese (Portugal)> |
0x0446 => 'pa' , # <PAN> <Punjabi> <Punjabi> |
0x0417 => 'rm' , # <RMS> <Rhaeto-Romanic> <Rhaeto-Romanic> |
0x0418 => 'ro' , # <ROM> <Romanian> <Romanian> |
0x0818 => 'ro-md', # <ROV> <Romanian> <Romanian (Moldova)> |
0x0419 => 'ru' , # <RUS> <Russian> <Russian> |
0x0819 => 'ru-md', # <RUM> <Russian> <Russian (Moldova)> |
0x043b => 'se' , # <SZI> <Sami> <Sami (Lappish)> assuming == "Northern Sami" |
0x044f => 'sa' , # <SAN> <Sanskrit> <Sanskrit> |
0x0c1a => 'sr-cyrl', # <SRB> <Serbian> <Serbian (Cyrillic)> |
0x081a => 'sr-latn', # <SRL> <Serbian> <Serbian (Latin)> |
0x0459 => 'sd' , # <SND> <Sindhi> <Sindhi> |
0x041b => 'sk' , # <SKY> <Slovak> <Slovak> |
0x0424 => 'sl' , # <SLV> <Slovenian> <Slovenian> |
0x042e => 'wen' , # <SBN> <Sorbian> <Sorbian> # !!! 3 letters |
0x040a => 'es-es', # <ESP> <Spanish> <Spanish (Spain - Traditional Sort)> |
0x080a => 'es-mx', # <ESM> <Spanish> <Spanish (Mexico)> |
0x0c0a => 'es-es', # <ESN> <Spanish> <Spanish (Spain - Modern Sort)> |
0x100a => 'es-gt', # <ESG> <Spanish> <Spanish (Guatemala)> |
0x140a => 'es-cr', # <ESC> <Spanish> <Spanish (Costa Rica)> |
0x180a => 'es-pa', # <ESA> <Spanish> <Spanish (Panama)> |
0x1c0a => 'es-do', # <ESD> <Spanish> <Spanish (Dominican Republic)> |
0x200a => 'es-ve', # <ESV> <Spanish> <Spanish (Venezuela)> |
0x240a => 'es-co', # <ESO> <Spanish> <Spanish (Colombia)> |
0x280a => 'es-pe', # <ESR> <Spanish> <Spanish (Peru)> |
0x2c0a => 'es-ar', # <ESS> <Spanish> <Spanish (Argentina)> |
0x300a => 'es-ec', # <ESF> <Spanish> <Spanish (Ecuador)> |
0x340a => 'es-cl', # <ESL> <Spanish> <Spanish (Chile)> |
0x380a => 'es-uy', # <ESY> <Spanish> <Spanish (Uruguay)> |
0x3c0a => 'es-py', # <ESZ> <Spanish> <Spanish (Paraguay)> |
0x400a => 'es-bo', # <ESB> <Spanish> <Spanish (Bolivia)> |
0x440a => 'es-sv', # <ESE> <Spanish> <Spanish (El Salvador)> |
0x480a => 'es-hn', # <ESH> <Spanish> <Spanish (Honduras)> |
0x4c0a => 'es-ni', # <ESI> <Spanish> <Spanish (Nicaragua)> |
0x500a => 'es-pr', # <ESU> <Spanish> <Spanish (Puerto Rico)> |
0x0430 => 'st' , # <SXT> <Sutu> <Sutu> == soto, sesotho |
0x0441 => 'sw-ke', # <SWK> <Swahili> <Swahili (Kenya)> |
0x041D => 'sv' , # <SVE> <Swedish> <Swedish> |
0x081d => 'sv-fi', # <SVF> <Swedish> <Swedish (Finland)> |
0x0449 => 'ta' , # <TAM> <Tamil> <Tamil> |
0x0444 => 'tt' , # <TAT> <Tatar> <Tatar (Tatarstan)> |
0x044a => 'te' , # <TEL> <Telugu> <Telugu> |
0x041E => 'th' , # <THA> <Thai> <Thai> |
0x0431 => 'ts' , # <TSG> <Tsonga> <Tsonga> (not Tonga!) |
0x0432 => 'tn' , # <TNA> <Tswana> <Tswana> == Setswana |
0x041f => 'tr' , # <TRK> <Turkish> <Turkish> |
0x0422 => 'uk' , # <UKR> <Ukrainian> <Ukrainian> |
0x0420 => 'ur-pk', # <URD> <Urdu> <Urdu (Pakistan)> |
0x0820 => 'ur-in', # <URI> <Urdu> <Urdu (India)> |
0x0443 => 'uz-latn', # <UZB> <Uzbek> <Uzbek (Latin)> |
0x0843 => 'uz-cyrl', # <UZC> <Uzbek> <Uzbek (Cyrillic)> |
0x0433 => 'ven' , # <VEN> <Venda> <Venda> |
0x042a => 'vi' , # <VIT> <Vietnamese> <Vietnamese> |
0x0434 => 'xh' , # <XHS> <Xhosa> <Xhosa> |
0x043d => 'yi' , # <JII> <Yiddish> <Yiddish> # formetly ji |
0x0435 => 'zu' , # <ZUL> <Zulu> <Zulu> |
); |
#----------------------------------------------------------------------------- |
sub get_ms_locale { |
my $locale; |
return unless defined do { |
# see if there's a W32 registry on this machine, and if so, look in it |
local $SIG{"__DIE__"} = ""; |
eval ' |
use Win32::TieRegistry (); |
my $i18n = Win32::TieRegistry->new( |
"HKEY_CURRENT_USER/Control Panel/International", |
{ Delimiter => "/" } |
); |
#print "no key!" unless $i18n; |
$locale = $i18n->GetValue("Locale") if $i18n; |
undef $i18n; |
'; |
#print "<$@>\n" if $@; |
$locale; |
}; |
return unless $locale =~ m/^[0-9a-fA-F]+$/s; |
return hex($locale); |
} |
sub get_language { |
my $lang = $MSLocale2LangTag{ $_[0] || get_ms_locale() || '' }; |
return unless $lang; |
return $lang; |
} |
sub get_locale { |
# I guess this is right. |
my $lang = get_language(@_); |
return unless $lang and $lang =~ m/^[a-z]{2}(?:-[a-z]{2})?$/s; |
# should we try to turn "fi" into "fi_FI"? |
$lang =~ tr/-/_/; |
return $lang; |
} |
#----------------------------------------------------------------------------- |
# If we're just executed... |
unless(caller) { |
my $locale = get_ms_locale(); |
if($locale) { |
printf "Locale 0x%08x (%s => %s) => Lang %s\n", |
$locale, $locale, |
get_locale($locale) || '?', |
get_language($locale) || '?', |
} else { |
print "Can't get ms-locale\n"; |
} |
} |
#----------------------------------------------------------------------------- |
1; |
__END__ |
=head1 NAME |
Win32::Locale - get the current MSWin locale or language |
=head1 SYNOPSIS |
use Win32::Locale; |
my $language = Win32::Locale::get_language(); |
if($language eq 'en-us') { |
print "Wasaaap homeslice!\n"; |
} else { |
print "You $language people ain't FROM around here, are ya?\n"; |
} |
=head1 DESCRIPTION |
This library provides some simple functions allowing Perl under MSWin |
to ask what the current locale/language setting is. (Yes, MSWin |
conflates locales and languages, it seems; and the way it's |
conflated is even stranger after MSWin98.) |
Note that you should be able to safely use this module under any |
OS; the functions just won't be able to access any current |
locale value. |
=head1 FUNCTIONS |
Note that these functions are not exported, |
nor are they exportable: |
=over |
=item Win32::Locale::get_language() |
Returns the (all-lowercase) RFC3066 language tag corresponding |
to the currently currently selected MS locale. |
Returns nothing if the MS locale value isn't accessible |
(notably, if you're not running under MSWin!), or if it |
corresponds to no known language tag. Example: "en-us". |
In list context, this may in the future be made to return |
multiple values. |
=item Win32::Locale::get_locale() |
Returns the (all-lowercase) Unixish locale tag corresponding |
to the currently currently selected MS locale. Example: "en_us". |
Returns nothing if the MS locale value isn't accessible |
(notably, if you're not running under MSWin!), or if it |
corresponds to no locale. |
In list context, this may in the future be made to return |
multiple values. |
Note that this function is B<experimental>, and I greatly welcome |
suggestions. |
=item Win32::Locale::get_ms_locale() |
Returns the MS locale ID code for the currently selected MSWindows |
locale. For example, returns the number 1033 for "US |
English". (You may know the number 1033 better as 0x00000409, |
as these numbers are usually given in hex in MS documents). |
Returns nothing if the value isn't accessible (notably, if you're |
not running under MSWin!). |
=item Win32::Locale::get_language($msid) |
Returns the (all-lowercase) RFC3066 language tag corresponding |
to the given MS locale code, or nothing if none. |
In list context, this may in the future be made to return |
multiple values. |
=item Win32::Locale::get_locale($msid) |
Returns the (all-lowercase) Unixish locale tag corresponding |
to the given MS locale code, or nothing if none. |
In list context, this may in the future be made to return |
multiple values. |
=back |
("Nothing", above, means "in scalar context, undef; in list |
context, empty-list".) |
=head1 AND MORE |
This module provides an (unexported) public hash, |
%Win32::Locale::MSLocale2LangTag, that maps |
from the MS locale ID code to my idea of the single best corresponding |
RFC3066 language tag. |
The hash's contents are relatively certain for well-known |
languages (US English is "en-us"), but are still experimental |
in its finer details (like Konkani being "kok"). |
=head1 SEE ALSO |
L<I18N::LangTags|I18N::LangTags>, |
L<I18N::LangTags::List|I18N::LangTags::List>, |
L<Locale::Maketext|Locale::Maketext>. |
=head1 COPYRIGHT AND DISCLAIMER |
Copyright (c) 2001,2003 Sean M. Burke. All rights reserved. |
This library is free software; you can redistribute it and/or modify |
it under the same terms as Perl itself. |
This program is distributed in the hope that it will be useful, but |
without any warranty; without even the implied warranty of |
merchantability or fitness for a particular purpose. |
I am not affiliated with the Microsoft corporation, nor the ActiveState |
corporation. |
Product and company names mentioned in this document may be the |
trademarks or service marks of their respective owners. Trademarks |
and service marks might not be identified as such, although |
this must not be construed as anyone's expression of validity |
or invalidity of each trademark or service mark. |
=head1 AUTHOR |
Sean M. Burke C<sburke@cpan.org> |
=cut |
# No big whoop. |
/MissionCockpit/tags/V0.2.5/perl/site/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.2.5/perl/site/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 > 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.2.5/perl/site/lib/threads/shared.pm |
---|
0,0 → 1,616 |
package threads::shared; |
use 5.008; |
use strict; |
use warnings; |
use Scalar::Util qw(reftype refaddr blessed); |
our $VERSION = '1.28'; |
my $XS_VERSION = $VERSION; |
$VERSION = eval $VERSION; |
# Declare that we have been loaded |
$threads::shared::threads_shared = 1; |
# Load the XS code, if applicable |
if ($threads::threads) { |
require XSLoader; |
XSLoader::load('threads::shared', $XS_VERSION); |
*is_shared = \&_id; |
} else { |
# String eval is generally evil, but we don't want these subs to |
# exist at all if 'threads' is not loaded successfully. |
# Vivifying them conditionally this way saves on average about 4K |
# of memory per thread. |
eval <<'_MARKER_'; |
sub share (\[$@%]) { return $_[0] } |
sub is_shared (\[$@%]) { undef } |
sub cond_wait (\[$@%];\[$@%]) { undef } |
sub cond_timedwait (\[$@%]$;\[$@%]) { undef } |
sub cond_signal (\[$@%]) { undef } |
sub cond_broadcast (\[$@%]) { undef } |
_MARKER_ |
} |
### Export ### |
sub import |
{ |
# Exported subroutines |
my @EXPORT = qw(share is_shared cond_wait cond_timedwait |
cond_signal cond_broadcast shared_clone); |
if ($threads::threads) { |
push(@EXPORT, 'bless'); |
} |
# Export subroutine names |
my $caller = caller(); |
foreach my $sym (@EXPORT) { |
no strict 'refs'; |
*{$caller.'::'.$sym} = \&{$sym}; |
} |
} |
# Predeclarations for internal functions |
my ($make_shared); |
### Methods, etc. ### |
sub threads::shared::tie::SPLICE |
{ |
require Carp; |
Carp::croak('Splice not implemented for shared arrays'); |
} |
# Create a thread-shared clone of a complex data structure or object |
sub shared_clone |
{ |
if (@_ != 1) { |
require Carp; |
Carp::croak('Usage: shared_clone(REF)'); |
} |
return $make_shared->(shift, {}); |
} |
### Internal Functions ### |
# Used by shared_clone() to recursively clone |
# a complex data structure or object |
$make_shared = sub { |
my ($item, $cloned) = @_; |
# Just return the item if: |
# 1. Not a ref; |
# 2. Already shared; or |
# 3. Not running 'threads'. |
return $item if (! ref($item) || is_shared($item) || ! $threads::threads); |
# Check for previously cloned references |
# (this takes care of circular refs as well) |
my $addr = refaddr($item); |
if (exists($cloned->{$addr})) { |
# Return the already existing clone |
return $cloned->{$addr}; |
} |
# Make copies of array, hash and scalar refs and refs of refs |
my $copy; |
my $ref_type = reftype($item); |
# Copy an array ref |
if ($ref_type eq 'ARRAY') { |
# Make empty shared array ref |
$copy = &share([]); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
push(@$copy, map { $make_shared->($_, $cloned) } @$item); |
} |
# Copy a hash ref |
elsif ($ref_type eq 'HASH') { |
# Make empty shared hash ref |
$copy = &share({}); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
foreach my $key (keys(%{$item})) { |
$copy->{$key} = $make_shared->($item->{$key}, $cloned); |
} |
} |
# Copy a scalar ref |
elsif ($ref_type eq 'SCALAR') { |
$copy = \do{ my $scalar = $$item; }; |
share($copy); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
} |
# Copy of a ref of a ref |
elsif ($ref_type eq 'REF') { |
# Special handling for $x = \$x |
if ($addr == refaddr($$item)) { |
$copy = \$copy; |
share($copy); |
$cloned->{$addr} = $copy; |
} else { |
my $tmp; |
$copy = \$tmp; |
share($copy); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
$tmp = $make_shared->($$item, $cloned); |
} |
} else { |
require Carp; |
Carp::croak("Unsupported ref type: ", $ref_type); |
} |
# If input item is an object, then bless the copy into the same class |
if (my $class = blessed($item)) { |
bless($copy, $class); |
} |
# Clone READONLY flag |
if ($ref_type eq 'SCALAR') { |
if (Internals::SvREADONLY($$item)) { |
Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003); |
} |
} |
if (Internals::SvREADONLY($item)) { |
Internals::SvREADONLY($copy, 1) if ($] >= 5.008003); |
} |
return $copy; |
}; |
1; |
__END__ |
=head1 NAME |
threads::shared - Perl extension for sharing data structures between threads |
=head1 VERSION |
This document describes threads::shared version 1.28 |
=head1 SYNOPSIS |
use threads; |
use threads::shared; |
my $var :shared; |
my %hsh :shared; |
my @ary :shared; |
my ($scalar, @array, %hash); |
share($scalar); |
share(@array); |
share(%hash); |
$var = $scalar_value; |
$var = $shared_ref_value; |
$var = shared_clone($non_shared_ref_value); |
$var = shared_clone({'foo' => [qw/foo bar baz/]}); |
$hsh{'foo'} = $scalar_value; |
$hsh{'bar'} = $shared_ref_value; |
$hsh{'baz'} = shared_clone($non_shared_ref_value); |
$hsh{'quz'} = shared_clone([1..3]); |
$ary[0] = $scalar_value; |
$ary[1] = $shared_ref_value; |
$ary[2] = shared_clone($non_shared_ref_value); |
$ary[3] = shared_clone([ {}, [] ]); |
{ lock(%hash); ... } |
cond_wait($scalar); |
cond_timedwait($scalar, time() + 30); |
cond_broadcast(@array); |
cond_signal(%hash); |
my $lockvar :shared; |
# condition var != lock var |
cond_wait($var, $lockvar); |
cond_timedwait($var, time()+30, $lockvar); |
=head1 DESCRIPTION |
By default, variables are private to each thread, and each newly created |
thread gets a private copy of each existing variable. This module allows you |
to share variables across different threads (and pseudo-forks on Win32). It |
is used together with the L<threads> module. |
This module supports the sharing of the following data types only: scalars |
and scalar refs, arrays and array refs, and hashes and hash refs. |
=head1 EXPORT |
The following functions are exported by this module: C<share>, |
C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal> |
and C<cond_broadcast> |
Note that if this module is imported when L<threads> has not yet been loaded, |
then these functions all become no-ops. This makes it possible to write |
modules that will work in both threaded and non-threaded environments. |
=head1 FUNCTIONS |
=over 4 |
=item share VARIABLE |
C<share> takes a variable and marks it as shared: |
my ($scalar, @array, %hash); |
share($scalar); |
share(@array); |
share(%hash); |
C<share> will return the shared rvalue, but always as a reference. |
Variables can also be marked as shared at compile time by using the |
C<:shared> attribute: |
my ($var, %hash, @array) :shared; |
Shared variables can only store scalars, refs of shared variables, or |
refs of shared data (discussed in next section): |
my ($var, %hash, @array) :shared; |
my $bork; |
# Storing scalars |
$var = 1; |
$hash{'foo'} = 'bar'; |
$array[0] = 1.5; |
# Storing shared refs |
$var = \%hash; |
$hash{'ary'} = \@array; |
$array[1] = \$var; |
# The following are errors: |
# $var = \$bork; # ref of non-shared variable |
# $hash{'bork'} = []; # non-shared array ref |
# push(@array, { 'x' => 1 }); # non-shared hash ref |
=item shared_clone REF |
C<shared_clone> takes a reference, and returns a shared version of its |
argument, performing a deep copy on any non-shared elements. Any shared |
elements in the argument are used as is (i.e., they are not cloned). |
my $cpy = shared_clone({'foo' => [qw/foo bar baz/]}); |
Object status (i.e., the class an object is blessed into) is also cloned. |
my $obj = {'foo' => [qw/foo bar baz/]}; |
bless($obj, 'Foo'); |
my $cpy = shared_clone($obj); |
print(ref($cpy), "\n"); # Outputs 'Foo' |
For cloning empty array or hash refs, the following may also be used: |
$var = &share([]); # Same as $var = shared_clone([]); |
$var = &share({}); # Same as $var = shared_clone({}); |
=item is_shared VARIABLE |
C<is_shared> checks if the specified variable is shared or not. If shared, |
returns the variable's internal ID (similar to |
L<refaddr()|Scalar::Util/"refaddr EXPR">). Otherwise, returns C<undef>. |
if (is_shared($var)) { |
print("\$var is shared\n"); |
} else { |
print("\$var is not shared\n"); |
} |
When used on an element of an array or hash, C<is_shared> checks if the |
specified element belongs to a shared array or hash. (It does not check |
the contents of that element.) |
my %hash :shared; |
if (is_shared(%hash)) { |
print("\%hash is shared\n"); |
} |
$hash{'elem'} = 1; |
if (is_shared($hash{'elem'})) { |
print("\$hash{'elem'} is in a shared hash\n"); |
} |
=item lock VARIABLE |
C<lock> places a B<advisory> lock on a variable until the lock goes out of |
scope. If the variable is locked by another thread, the C<lock> call will |
block until it's available. Multiple calls to C<lock> by the same thread from |
within dynamically nested scopes are safe -- the variable will remain locked |
until the outermost lock on the variable goes out of scope. |
C<lock> follows references exactly I<one> level: |
my %hash :shared; |
my $ref = \%hash; |
lock($ref); # This is equivalent to lock(%hash) |
Note that you cannot explicitly unlock a variable; you can only wait for the |
lock to go out of scope. This is most easily accomplished by locking the |
variable inside a block. |
my $var :shared; |
{ |
lock($var); |
# $var is locked from here to the end of the block |
... |
} |
# $var is now unlocked |
As locks are advisory, they do not prevent data access or modification by |
another thread that does not itself attempt to obtain a lock on the variable. |
You cannot lock the individual elements of a container variable: |
my %hash :shared; |
$hash{'foo'} = 'bar'; |
#lock($hash{'foo'}); # Error |
lock(%hash); # Works |
If you need more fine-grained control over shared variable access, see |
L<Thread::Semaphore>. |
=item cond_wait VARIABLE |
=item cond_wait CONDVAR, LOCKVAR |
The C<cond_wait> function takes a B<locked> variable as a parameter, unlocks |
the variable, and blocks until another thread does a C<cond_signal> or |
C<cond_broadcast> for that same locked variable. The variable that |
C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied. If |
there are multiple threads C<cond_wait>ing on the same variable, all but one |
will re-block waiting to reacquire the lock on the variable. (So if you're only |
using C<cond_wait> for synchronisation, give up the lock as soon as possible). |
The two actions of unlocking the variable and entering the blocked wait state |
are atomic, the two actions of exiting from the blocked wait state and |
re-locking the variable are not. |
In its second form, C<cond_wait> takes a shared, B<unlocked> variable followed |
by a shared, B<locked> variable. The second variable is unlocked and thread |
execution suspended until another thread signals the first variable. |
It is important to note that the variable can be notified even if no thread |
C<cond_signal> or C<cond_broadcast> on the variable. It is therefore |
important to check the value of the variable and go back to waiting if the |
requirement is not fulfilled. For example, to pause until a shared counter |
drops to zero: |
{ lock($counter); cond_wait($count) until $counter == 0; } |
=item cond_timedwait VARIABLE, ABS_TIMEOUT |
=item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR |
In its two-argument form, C<cond_timedwait> takes a B<locked> variable and an |
absolute timeout as parameters, unlocks the variable, and blocks until the |
timeout is reached or another thread signals the variable. A false value is |
returned if the timeout is reached, and a true value otherwise. In either |
case, the variable is re-locked upon return. |
Like C<cond_wait>, this function may take a shared, B<locked> variable as an |
additional parameter; in this case the first parameter is an B<unlocked> |
condition variable protected by a distinct lock variable. |
Again like C<cond_wait>, waking up and reacquiring the lock are not atomic, |
and you should always check your desired condition after this function |
returns. Since the timeout is an absolute value, however, it does not have to |
be recalculated with each pass: |
lock($var); |
my $abs = time() + 15; |
until ($ok = desired_condition($var)) { |
last if !cond_timedwait($var, $abs); |
} |
# we got it if $ok, otherwise we timed out! |
=item cond_signal VARIABLE |
The C<cond_signal> function takes a B<locked> variable as a parameter and |
unblocks one thread that's C<cond_wait>ing on that variable. If more than one |
thread is blocked in a C<cond_wait> on that variable, only one (and which one |
is indeterminate) will be unblocked. |
If there are no threads blocked in a C<cond_wait> on the variable, the signal |
is discarded. By always locking before signaling, you can (with care), avoid |
signaling before another thread has entered cond_wait(). |
C<cond_signal> will normally generate a warning if you attempt to use it on an |
unlocked variable. On the rare occasions where doing this may be sensible, you |
can suppress the warning with: |
{ no warnings 'threads'; cond_signal($foo); } |
=item cond_broadcast VARIABLE |
The C<cond_broadcast> function works similarly to C<cond_signal>. |
C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in |
a C<cond_wait> on the locked variable, rather than only one. |
=back |
=head1 OBJECTS |
L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that |
works on shared objects such that I<blessings> propagate across threads. |
# Create a shared 'Foo' object |
my $foo :shared = shared_clone({}); |
bless($foo, 'Foo'); |
# Create a shared 'Bar' object |
my $bar :shared = shared_clone({}); |
bless($bar, 'Bar'); |
# Put 'bar' inside 'foo' |
$foo->{'bar'} = $bar; |
# Rebless the objects via a thread |
threads->create(sub { |
# Rebless the outer object |
bless($foo, 'Yin'); |
# Cannot directly rebless the inner object |
#bless($foo->{'bar'}, 'Yang'); |
# Retrieve and rebless the inner object |
my $obj = $foo->{'bar'}; |
bless($obj, 'Yang'); |
$foo->{'bar'} = $obj; |
})->join(); |
print(ref($foo), "\n"); # Prints 'Yin' |
print(ref($foo->{'bar'}), "\n"); # Prints 'Yang' |
print(ref($bar), "\n"); # Also prints 'Yang' |
=head1 NOTES |
L<threads::shared> is designed to disable itself silently if threads are not |
available. This allows you to write modules and packages that can be used |
in both threaded and non-threaded applications. |
If you want access to threads, you must C<use threads> before you |
C<use threads::shared>. L<threads> will emit a warning if you use it after |
L<threads::shared>. |
=head1 BUGS AND LIMITATIONS |
When C<share> is used on arrays, hashes, array refs or hash refs, any data |
they contain will be lost. |
my @arr = qw(foo bar baz); |
share(@arr); |
# @arr is now empty (i.e., == ()); |
# Create a 'foo' object |
my $foo = { 'data' => 99 }; |
bless($foo, 'foo'); |
# Share the object |
share($foo); # Contents are now wiped out |
print("ERROR: \$foo is empty\n") |
if (! exists($foo->{'data'})); |
Therefore, populate such variables B<after> declaring them as shared. (Scalar |
and scalar refs are not affected by this problem.) |
It is often not wise to share an object unless the class itself has been |
written to support sharing. For example, an object's destructor may get |
called multiple times, once for each thread's scope exit. Another danger is |
that the contents of hash-based objects will be lost due to the above |
mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of |
this module) for how to create a class that supports object sharing. |
Does not support C<splice> on arrays! |
Taking references to the elements of shared arrays and hashes does not |
autovivify the elements, and neither does slicing a shared array/hash over |
non-existent indices/keys autovivify the elements. |
C<share()> allows you to C<< share($hashref->{key}) >> and |
C<< share($arrayref->[idx]) >> without giving any error message. But the |
C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing |
the error "lock can only be used on shared values" to occur when you attempt |
to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another |
thread. |
Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing |
whether or not two shared references are equivalent (e.g., when testing for |
circular references). Use L<is_shared()/"is_shared VARIABLE">, instead: |
use threads; |
use threads::shared; |
use Scalar::Util qw(refaddr); |
# If ref is shared, use threads::shared's internal ID. |
# Otherwise, use refaddr(). |
my $addr1 = is_shared($ref1) || refaddr($ref1); |
my $addr2 = is_shared($ref2) || refaddr($ref2); |
if ($addr1 == $addr2) { |
# The refs are equivalent |
} |
L<each()|perlfunc/"each HASH"> does not work properly on shared references |
embedded in shared structures. For example: |
my %foo :shared; |
$foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'}); |
while (my ($key, $val) = each(%{$foo{'bar'}})) { |
... |
} |
Either of the following will work instead: |
my $ref = $foo{'bar'}; |
while (my ($key, $val) = each(%{$ref})) { |
... |
} |
foreach my $key (keys(%{$foo{'bar'}})) { |
my $val = $foo{'bar'}{$key}; |
... |
} |
View existing bug reports at, and submit any new bugs, problems, patches, etc. |
to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared> |
=head1 SEE ALSO |
L<threads::shared> Discussion Forum on CPAN: |
L<http://www.cpanforum.com/dist/threads-shared> |
Annotated POD for L<threads::shared>: |
L<http://annocpan.org/~JDHEDDEN/threads-shared-1.28/shared.pm> |
Source repository: |
L<http://code.google.com/p/threads-shared/> |
L<threads>, L<perlthrtut> |
L<http://www.perl.com/pub/a/2002/06/11/threads.html> and |
L<http://www.perl.com/pub/a/2002/09/04/threads.html> |
Perl threads mailing list: |
L<http://lists.cpan.org/showlist.cgi?name=iThreads> |
=head1 AUTHOR |
Artur Bergman E<lt>sky AT crucially DOT netE<gt> |
Documentation borrowed from the old Thread.pm. |
CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>. |
=head1 LICENSE |
threads::shared is released under the same license as Perl. |
=cut |