/MissionCockpit/tags/V0.2.7/Handbuch.pdf |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/LICENSE.TXT |
---|
0,0 → 1,36 |
Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
====================================================== |
Es ist Ihnen gestattet: |
* das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
* Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
Zu den folgenden Bedingungen: |
* Namensnennung. |
Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
* Keine kommerzielle Nutzung. |
Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
* Weitergabe unter gleichen Bedingungen. |
Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
verändern oder als Grundlage für einen anderen Inhalt verwenden, |
dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
des Rechteinhabers dazu erhalten. |
Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
Weitere Details zur Lizenzbestimmung gibt es hier: |
Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
/MissionCockpit/tags/V0.2.7/geserver.pl |
---|
0,0 → 1,208 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# geserver.pl - Google Earth Server for MK Mission Cockpit |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 20090317 0.0.1 rw created |
# 20090401 0.1.0 rw RC1 |
# |
############################################################################### |
$Version{'geserver.pl'} = "0.1.0 - 2009-04-01"; |
# |
# Parameter |
# |
$port_listen = $Cfg->{'geserver'}->{'HttpPort'}; |
use Socket; |
use IO::Select; |
use threads; |
use threads::shared; |
$| = 1; |
# "Lon, Lat, Alt" |
share (@GeCoords); |
sub GeServer() |
{ |
local *S; |
socket (S, PF_INET , SOCK_STREAM , getprotobyname('tcp')) or die "couldn't open socket: $!"; |
setsockopt (S, SOL_SOCKET, SO_REUSEADDR, 1); |
bind (S, sockaddr_in($port_listen, INADDR_ANY)); |
listen (S, 5) or die "don't hear anything: $!"; |
my $ss = IO::Select->new(); |
$ss -> add (*S); |
while(1) |
{ |
my @connections_pending = $ss->can_read(); |
foreach (@connections_pending) |
{ |
my $fh; |
my $remote = accept($fh, $_); |
my($port,$iaddr) = sockaddr_in($remote); |
my $peeraddress = inet_ntoa($iaddr); |
# memory-leak in threads!!! Process only one request in parallel |
# my $t = threads->create(\&new_connection, $fh); |
&new_connection ($fh); |
} |
} |
} |
sub new_connection |
{ |
my $fh = shift; |
binmode $fh; |
my %req; |
$req{HEADER}={}; |
my $request_line = <$fh>; |
my $first_line = ""; |
while ($request_line ne "\r\n") |
{ |
unless ($request_line) |
{ |
close $fh; |
} |
chomp $request_line; |
unless ($first_line) |
{ |
$first_line = $request_line; |
my @parts = split(" ", $first_line); |
if (@parts != 3) |
{ |
close $fh; |
} |
$req{METHOD} = $parts[0]; |
$req{OBJECT} = $parts[1]; |
} |
else |
{ |
my ($name, $value) = split(": ", $request_line); |
$name = lc $name; |
$req{HEADER}{$name} = $value; |
} |
$request_line = <$fh>; |
} |
&http_request_handler($fh, \%req); |
close $fh; |
} |
sub http_request_handler |
{ |
my $fh = shift; |
my $req_ = shift; |
my %req = %$req_; |
my %header = %{$req{HEADER}}; |
print $fh "HTTP/1.0 200 OK\n"; |
print $fh "Content-Type: application/vnd.google-earth.kml+xml; charset=iso-8859-1\n"; |
print $fh "Connection: close\n\n"; |
# KML Header |
print $fh <<EOF; |
<?xml version="1.0" encoding="UTF-8"?> |
<kml xmlns="http://earth.google.com/kml/2.2"> |
<Document> |
<name>Mikrokopter GPS logging</name> |
<Style id="MK_gps-style"> |
<LineStyle> |
<color>ff0000ff</color> |
<width>2</width> |
</LineStyle> |
</Style> |
<Placemark> |
<name>Flight live</name> |
<styleUrl>MK_gps-style</styleUrl> |
<LineString> |
<tessellate>1</tessellate> |
<altitudeMode>relativeToGround</altitudeMode> |
<coordinates> |
EOF |
# send all KML Coords for each request |
for $i (0 .. $#GeCoords) |
{ |
print $fh "$GeCoords[$i]\n"; |
} |
# KML Trailler |
print $fh <<EOF; |
</coordinates> |
</LineString> |
</Placemark> |
</Document> |
</kml> |
EOF |
# Debug: |
# print "Method: $req{METHOD}\n"; |
# print "Object: $req{OBJECT}\n>"; |
# foreach my $r (keys %header) |
# { |
# print $r, " = ", $header{$r} , "\n"; |
# } |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/icon/Antenna_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/ModeKml_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/ModeWpt_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/RandomMap_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/RandomOff_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/RandomOn_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/RandomWpt_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/Record_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpFirst.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpHome.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpLast.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpNext.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpPause.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpPlay.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpPrev.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/WpStop.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/bear_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/heart_32.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/heart_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/satellite_64.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/target_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/waypoint_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/icon/webcam_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/libmap.pl |
---|
0,0 → 1,207 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmap.pl - Conversion GPS and Map-X/Y Coordinates |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-03-06 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-05-13 0.1.1 rw MapGpsAt() added |
# 2009-05-22 0.1.2 rw add default Map dir |
# 2009-07-22 0.1.3 rw Map Offset_x, Offset_y added |
# 2009-08-08 0.1.4 rw atan -> atan2 |
# |
############################################################################### |
$Version{'libmap.pl'} = "0.1.4 - 2009-08-08"; |
use Geo::Ellipsoid; # http://search.cpan.org/dist/Geo-Ellipsoid-1.12/lib/Geo/Ellipsoid.pm |
use Math::Trig; |
if ( ! defined Cfg->{'map'}->{'MapDir'} ) |
{ |
# set default map directory |
$Cfg->{'map'}->{'MapDir'} = "map"; |
} |
require "$Cfg->{'map'}->{'MapDir'}/map.pl"; # Landkarte |
# |
# Convert GPS (Lat,Lon) to pixel coordinates in map |
# |
sub MapGps2XY () |
{ |
my ($Lat, $Lon, $Bearing) = @_; |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
# P1 -> P2: Entfernung und Richtung |
my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} ); |
my $dx_p = $Map{'P2_x'} - $Map{'P1_x'}; |
my $dy_p = $Map{'P2_y'} - $Map{'P1_y'}; |
my $P1P2_Dist_p = sqrt($dx_p*$dx_p + $dy_p*$dy_p); |
my $PixRes = $P1P2_Dist_m / $P1P2_Dist_p ; # 1 Pixel = $PixRes Meter |
my $Phi = rad2deg atan2 ($dy_p, $dx_p); |
my $PhiRef = $P1P2_Bearing - $Phi; # Winkel zwischen N und Bild-Horizont |
# P1 -> Target: Entfernung und Richtung |
my ($T_Dist_m, $T_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Lat, $Lon ); |
my $Alpha = deg2rad($T_Bearing - $PhiRef); # Winkel zw. Bild-Horizont und Target |
my $T_dx_p = cos($Alpha) * $T_Dist_m / $PixRes; |
my $T_dy_p = sin($Alpha) * $T_Dist_m / $PixRes; |
my $X_p = $Map{'P1_x'} + $T_dx_p + $Map{'Offset_x'}; |
my $Y_p = $Map{'P1_y'} + $T_dy_p - $Map{'Offset_y'}; |
# map calibration adjustment |
$X_p += $Map{'Offset_x'}; |
$Y_p -= $Map{'Offset_y'}; |
$Angel = $Bearing - $PhiRef; |
return ($X_p, $Y_p, $Angel); |
} |
# |
# Convert pixel coordinates in map to GPS (Lat,Lon) |
# |
sub MapXY2Gps () |
{ |
my ($X, $Y) = @_; |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
# map calibration adjustment |
$X -= $Map{'Offset_x'}; |
$Y += $Map{'Offset_y'}; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
# P1 -> P2: Entfernung und Richtung |
my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} ); |
my $dx_p = $Map{'P2_x'} - $Map{'P1_x'}; |
my $dy_p = $Map{'P2_y'} - $Map{'P1_y'}; |
my $P1P2_Dist_p = sqrt($dx_p*$dx_p + $dy_p*$dy_p); |
my $PixRes = $P1P2_Dist_m / $P1P2_Dist_p ; # 1 Pixel = $PixRes Meter |
my $Phi = rad2deg atan2 ($dy_p, $dx_p); |
my $PhiRef = $P1P2_Bearing - $Phi; # Winkel zwischen N und Bild-Horizont |
my $dx = $X - $Map{'P1_x'}; |
my $dy = $Y - $Map{'P1_y'}; |
my $Phi = rad2deg atan2 ($dy, $dx); |
my $Bearing = $PhiRef + $Phi; |
my $Dist = $PixRes * sqrt($dx*$dx + $dy*$dy); |
my ($Lat, $Lon) = $Map_Geo->at( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Dist, $Bearing ); |
return ($Lat, $Lon); |
} |
# |
# Get Bearing, Distance from 2 GPS Points |
# |
sub MapGpsTo() |
{ |
my ($Lat1, $Lon1, $Lat2, $Lon2) = @_; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
my ($Dist, $Bearing) = $Map_Geo->to( $Lat1, $Lon1, $Lat2, $Lon2); |
return ($Dist, $Bearing); |
} |
# |
# Get Target from GPS-Point, Bearing, Distance |
# |
sub MapGpsAt() |
{ |
my ($Lat, $Lon, $Dist, $Bearing) = @_; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
my ($Target_Lat, $Target_Lon) = $Map_Geo->at( $Lat, $Lon, $Dist, $Bearing); |
return ($Target_Lat, $Target_Lon); |
} |
# Angel geographic North to Map Horizont |
sub MapAngel() |
{ |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
# P1 -> P2: Entfernung und Richtung |
my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} ); |
my $dx_p = $Map{'P2_x'} - $Map{'P1_x'}; |
my $dy_p = $Map{'P2_y'} - $Map{'P1_y'}; |
my $Phi = rad2deg atan2 ($dy_p, $dx_p); |
my $PhiRef = $P1P2_Bearing - $Phi; # Winkel zwischen N und Bild-Horizont |
return ($PhiRef); |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/libmkcockpit.pl |
---|
0,0 → 1,1638 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmkcockpit.pl - MK Mission Cockpit - Subroutined for GUI Frontend |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-08-09 0.2.5 rw subroutines moved from mkcockpit.pl |
# 2009-09-05 0.2.6 rw POI heading control added |
# 2009-10-10 0.2.7 rw Layout Config-dialog |
# Fix Message-Balloon in KML-Mode |
# |
############################################################################### |
$Version{'libmkcockpit.pl'} = "0.2.7 - 2009-10-10"; |
# check, if %MkOsd is valid |
sub MkOsdIsValid() |
{ |
return ( $MkOsd{'_Timestamp'} >= time-2 ); |
} |
# check, if current GPS position is valid |
sub CurPosIsValid() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'CurPos_Stat'} == 1 ); |
} |
# check, if home GPS position is valid |
sub HomePosIsValid() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'HomePos_Stat'} == 1 ); |
} |
# check, if target GPS position is valid |
sub TargetIsValid() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'TargetPos_Stat'} == 1 ); |
} |
# check, if motor are on |
sub MkIsMotorOn() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x01 ); |
} |
# check, if MK is flying |
sub MkIsFlying() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x02 ); |
} |
# check, if MK is calibrating |
sub MkIsCalibrating() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x04 ); |
} |
# check, if Motor is starting |
sub MkIsMotorStarting() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x08 ); |
} |
# check, Emergency Landing |
sub MkEmergencyLanding() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x10 ); |
} |
# check, if MK is FREE Mode |
sub MkIsFreeMode() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x01 ); |
} |
# check, if MK is in PH Mode |
sub MkIsPhMode() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x02 ); |
} |
# check, if MK is in WPT Mode |
sub MkIsWptMode() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x04 ); |
} |
# check, Range Limit |
sub MkRangeLimit() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x08 ); |
} |
# check, Serial Link |
sub MkSerialLink() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x10 ); |
} |
# check, Target reached |
sub MkTargetReached() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x20 ); |
} |
# check, Manual Control |
sub MkManualControl() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x40 ); |
} |
# get battery capacity in % |
sub BatCapacity() |
{ |
my ($UBat) = @_; |
my $CfgVal = $Cfg->{'mkcockpit'}->{'BatCharacteristics'}; |
my @Voltage = split ' ', $CfgVal; |
my $Capacity = 0; |
if ( $UBat >= $Voltage[0] ) |
{ |
$Capacity = 100; |
} |
$Cnt = $#Voltage; |
for ($i=0; $i < $Cnt; $i++) |
{ |
my $V1 = $Voltage[$i]; |
my $V2 = $Voltage[$i+1]; |
if ( $UBat >= $V1 and $UBat < $V2 or |
$UBat <= $V1 and $UBat > $V2 ) |
{ |
# linear interpolation |
my $x = $i + ($UBat - $V1 ) / ($V2 - $V1); |
$Capacity = 100 - $x * 100 / $Cnt; |
last; |
} |
} |
return $Capacity; |
} |
# |
# Waypoint handling |
# |
# Add a Waypoint to @Waypoints List |
sub WpAdd() |
{ |
my ($Wp_x, $Wp_y) = @_; |
# save Wp-Hash in Waypoint-Array |
my $Wp = {}; |
my $Tag = sprintf "Waypoint-%d.%d", time, int (rand(9)) ; # kind of unique Tag for this Wp |
($Lat, $Lon) = &MapXY2Gps($Wp_x, $Wp_y); |
$Wp->{'Tag'} = $Tag; |
$Wp->{'MapX'} = $Wp_x; |
$Wp->{'MapY'} = $Wp_y; |
$Wp->{'Pos_Lat'} = $Lat; |
$Wp->{'Pos_Lon'} = $Lon; |
$Wp->{'Pos_Alt'} = $MkOsd{'CurPos_Alt'}; |
$Wp->{'Heading'} = $Cfg->{'waypoint'}->{'DefaultHeading'}; |
$Wp->{'ToleranceRadius'} = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; |
$Wp->{'Holdtime'} = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; |
$Wp->{'Event_Flag'} = $Cfg->{'waypoint'}->{'DefaultEventFlag'}; |
push @Waypoints, $Wp; |
} |
# Delete Waypoint from @Waypoints List |
sub WpDelete () |
{ |
my ($WpIndex) = @_; |
# delete Wp in Waypoint-Array |
splice @Waypoints, $WpIndex, 1; |
} |
# Load @Waypoints from file |
sub WpLoadFile () |
{ |
my ($WpFile) = @_; |
# XML in Hash-Ref lesen |
my $Wp = XMLin($WpFile, ForceArray => 1); |
# XML Hash-Ref in Wp-Array umkopieren |
undef @Waypoints; |
foreach $key (sort keys %$Wp) |
{ |
my $Point = $Wp->{$key}->[0]; |
# relative Pixelkoordinaten auf Bildgroesse umrechnen |
if ( $Point->{'MapX'} <= 1 and $Point->{'MapY'} <= 1 ) |
{ |
$Point->{'MapX'} = int ( $Point->{'MapX'} * $MapSizeX + 0.5 ); |
$Point->{'MapY'} = int ( $Point->{'MapY'} * $MapSizeY + 0.5 ); |
} |
# GPS Koordinaten für die aktuelle Karte neu aus Map x/y berechnen |
my ($Lat, $Lon) = &MapXY2Gps($Point->{'MapX'}, $Point->{'MapY'}); |
$Point->{'Pos_Lat'} = $Lat; |
$Point->{'Pos_Lon'} = $Lon; |
push @Waypoints, $Point; |
} |
} |
# Safe @Waypoints to file |
sub WpSaveFile() |
{ |
my ($WpFile) = @_; |
# Waypoint-Array in Hash umkopieren |
for $i ( 0 .. $#Waypoints ) |
{ |
my $key = sprintf ("WP-%04d", $i); |
my $Wp = {%{$Waypoints[$i]}}; # copy of Hash-content |
$WpOut{$key} = $Wp; |
# Pixelkoordinaten relativ zur Bildgroesse speichern |
$WpOut{$key}{'MapX_Pixel'} = $WpOut{$key}{'MapX'}; |
$WpOut{$key}{'MapY_Pixel'} = $WpOut{$key}{'MapY'}; |
$WpOut{$key}{'MapX'} /= $MapSizeX; |
$WpOut{$key}{'MapY'} /= $MapSizeY; |
} |
# WP-Hash als XML speichern |
&XMLout (\%WpOut, |
'OutputFile' => $WpFile, |
'AttrIndent' => '1', |
'RootName' => 'Waypoints', |
); |
} |
# Get Wp Index from Canvas Id |
sub WpGetIndexFromId() |
{ |
my ($id) = @_; |
my @Tags = $map_canvas->gettags($id); |
my $WpTag = $Tags[1]; |
for $i (0 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
if ( $Wp->{'Tag'} eq $WpTag ) |
{ |
# got it |
return $i; |
} |
} |
return -1; |
} |
# Resend all Waypoints to MK |
sub WpSendAll() |
{ |
# OSD/Debug Abfragefrequenz verringern, sonst kommen nicht alle Wp im MK an |
# Sicherheitshalber doppelt senden |
$MkSendWp = 1; # verhindert ueberschreiben im Timer |
$MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 1000) ); # Frequenz OSD Datensatz, * 10ms |
$MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 1000) ); # Frequenz MK Debug Datensatz, * 10ms |
usleep (200000); |
$MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 1000) ); # Frequenz OSD Datensatz, * 10ms |
$MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 1000) ); # Frequenz MK Debug Datensatz, * 10ms |
usleep (200000); |
# Alte WP-Liste im MK löschen |
my $Wp = $Waypoints[0]; |
&MkFlyTo ( '-lat' => $Wp->{'Pos_Lat'}, |
'-lon' => $Wp->{'Pos_Lon'}, |
'-mode' => "Waypoint Delete" |
); |
for $i (0 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
&MkFlyTo ( '-lat' => $Wp->{'Pos_Lat'}, |
'-lon' => $Wp->{'Pos_Lon'}, |
'-alt' => $Wp->{'Pos_Alt'}, |
'-heading' => $Wp->{'Heading'}, |
'-toleranceradius' => $Wp->{'ToleranceRadius'}, |
'-holdtime' => $Wp->{'Holdtime'}, |
'-eventflag' => $Wp->{'Event_Flag'}, |
'-mode' => "Waypoint" |
); |
usleep (150000) # NC Zeit zum Verarbeiten geben |
} |
$MkSendWp = 0; # normale OSD/Debug Abfragefrequenz wird automatisch im 5s Timer wieder eingestellt |
# gray connectors: Wp are sent to MK |
$map_canvas->itemconfigure('Waypoint-Connector', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorWpConnector'}, |
); |
# MK ist nun synchron mit @Waypoints |
$WaypointsModified = 0; |
} |
# Redraw Waypoint Icons |
sub WpRedrawIcons() |
{ |
if ( $PlayerWptKmlMode =~ /WPT/i ) |
{ |
# delete old icons and Wp-Number from canvas |
$map_canvas->delete('Waypoint'); |
$map_canvas->delete('WaypointNumber'); |
# create new icons |
for $i (0 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
my $x = $Wp->{'MapX'}; |
my $y = $Wp->{'MapY'}; |
my $Tag = $Wp->{'Tag'}; |
# Waypoint Icon |
my $IconHeight = 48; |
my $IconWidth = 48; |
$map_canvas->createImage($x-$IconWidth/2, $y-$IconHeight, |
'-tags' => ['Waypoint', $Tag], |
'-anchor' => 'nw', |
'-image' => 'Waypoint-Photo', |
); |
# Waypoint Number |
my $WpNumber = $i + 1; |
$map_canvas->createText ( $x+3, $y-$IconHeight/2+12, |
'-tags' => ['WaypointNumber', $Tag], |
'-text' => $WpNumber, |
'-font' => '-*-Arial-Bold-R-Normal--*-100-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorWpNumber'}, |
'-anchor' => 'w', |
); |
} |
$map_canvas->lower('Waypoint', 'Target'); # waypoint below Target |
$map_canvas->lower('WaypointNumber', 'Waypoint'); # waypoint-number below waypoint |
} |
} |
# Redraw Waypoint connectors |
sub WpRedrawLines() |
{ |
if ( $PlayerWptKmlMode eq 'WPT' and $PlayerRandomMode eq 'STD' ) |
{ |
# delete old connectors from canvas |
$map_canvas->delete('Waypoint-Connector'); |
my $Color = $Cfg->{'mkcockpit'}->{'ColorWpConnector'}; |
if ( $WaypointsModified ) |
{ |
$Color = $Cfg->{'mkcockpit'}->{'ColorWpResend'}; |
} |
my $Wp = $Waypoints[0]; |
my $x_last = $Wp->{'MapX'}; |
my $y_last = $Wp->{'MapY'}; |
for $i (1 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
my $x = $Wp->{'MapX'}; |
my $y = $Wp->{'MapY'}; |
$map_canvas->createLine ( $x_last, $y_last, $x, $y, |
'-tags' => 'Waypoint-Connector', |
'-arrow' => 'last', |
'-arrowshape' => [10, 10, 3 ], |
'-fill' => $Color, |
'-width' => 1, |
); |
$x_last = $x; |
$y_last = $y; |
} |
$map_canvas->lower('Waypoint-Connector', 'Waypoint'); # connector below waypoint |
} |
} |
# Hide Waypoints and connectors on Canvas |
sub WpHide() |
{ |
$map_canvas->delete('Waypoint'); |
$map_canvas->delete('WaypointNumber'); |
$map_canvas->delete('Waypoint-Connector'); |
} |
# Hide Kml-Track on Canvas |
sub KmlHide() |
{ |
$map_canvas->delete('KML-Track'); |
} |
# Load @KmlTargets from file |
sub KmlLoadFile() |
{ |
my ($File) = @_; |
# XML in Hash-Ref lesen |
my $Kml = XMLin($File); |
# init state maschine |
undef @KmlTargets; |
$KmlPlayerIndex = 0; |
my $Coordinates = $Kml->{Document}->{Placemark}->{LineString}->{coordinates}; |
foreach $Line (split "\n", $Coordinates) |
{ |
chomp $Line; |
$Line =~ s/\s//g; # remove white space |
if ( $Line ne "" ) |
{ |
my ($Lon, $Lat, $Alt) = split ",", $Line; |
$Lon = sprintf ("%f", $Lon); |
$Lat = sprintf ("%f", $Lat); |
$Alt = sprintf ("%f", $Alt); |
push @KmlTargets, {'Lat' => $Lat, |
'Lon' => $Lon, |
'Alt' => $Alt, |
}; |
} |
} |
} |
# Redraw KML track |
sub KmlRedraw() |
{ |
# delete old Track from canvas |
$map_canvas->delete('KML-Track'); |
my @Track; |
foreach $Target ( @KmlTargets ) |
{ |
my $Lat = $Target->{'Lat'}; |
my $Lon = $Target->{'Lon'}; |
my $Alt = $Target->{'Alt'}; |
my ($x, $y) = &MapGps2XY($Lat, $Lon); |
push @Track, $x, $y; |
} |
if ( scalar @Track >= 4 ) # at least 2 Koordinaten-Paare |
{ |
$map_canvas->createLine ( @Track, |
'-tags' => 'KML-Track', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorKmlTrack'}, |
'-width' => 1, |
); |
$map_canvas->lower('KML-Track', 'Target'); # Track below Target |
} |
} |
# Redraw Footprint |
sub FootprintRedraw() |
{ |
# delete old Footprint from canvas |
$map_canvas->delete('Footprint'); |
if ( scalar @Footprint >= 4 ) # at least 2 Koordinaten-Paare |
{ |
$map_canvas->createLine ( @Footprint, |
'-tags' => 'Footprint', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorFootprint'}, |
'-width' => 1, |
); |
} |
$map_canvas->lower('Footprint', 'Target'); |
} |
# Waypoint Player: Set Waypoint - sequence or random |
sub WpTargetSet() |
{ |
my ($Index) = @_; |
my $WpCnt = scalar @Waypoints; |
if ( $Index < 0 or $Index >= $WpCnt ) |
{ |
# invalid WP number |
return 1; |
} |
my $Wp = $Waypoints[$Index]; |
my $Wp_x = $Wp->{'MapX'}; |
my $Wp_y = $Wp->{'MapY'}; |
# is Wp reachable? |
if ( ! &IsTargetReachable($Wp_x, $Wp_y) ) |
{ |
# new Wp-Target is not reachable |
return 1; |
} |
# set new Wp-Target |
$WpPlayerIndex = $Index; |
$WpPlayerHoldtime = -1; |
return 0; |
} |
# Waypoint Player: Goto next Waypoint - sequence or random |
sub WpTargetNext() |
{ |
my ($ParIndex) = @_; |
my $WpCnt = scalar @Waypoints; |
# Std- or Random Waypoint sequence |
if ( $PlayerRandomMode =~ /STD/i or |
$PlayerRandomMode =~ /RND/i ) |
{ |
$NewIndex = $WpPlayerIndex; |
# get next Wp |
for ( $i=0; $i<5; $i++) # avoid deadlock, if no WP reachable |
{ |
for ( $j=0; $j<5; $j++ ) # avoid deadlock, if only 1 WP |
{ |
if ( $PlayerRandomMode =~ /STD/i ) |
{ |
$NewIndex ++; |
if ( $NewIndex >= $WpCnt ) |
{ |
# Restart with 1st Wp |
$NewIndex = 0; |
} |
} |
if ( $PlayerRandomMode =~ /RND/i ) |
{ |
$NewIndex = int (rand($WpCnt)); |
} |
# want to have different Wp |
if ( $NewIndex ne $WpPlayerIndex ) |
{ |
last; |
} |
} |
# Set new Target |
if ( &WpTargetSet ($NewIndex) == 0 ) |
{ |
# new Wp-Target set |
last; |
} |
} |
} |
# Random Map sequence |
if ( $PlayerRandomMode =~ /MAP/i ) |
{ |
$RandomTarget_x = $MkPos_x; |
$RandomTarget_y = $MkPos_y; |
for ( $i=0; $i<50; $i++) # avoid deadlock, if target not reachable |
{ |
# don't use 10% around the map |
my $New_x = int (rand($MapSizeX - 2 * $MapSizeX/10)); |
my $New_y = int (rand($MapSizeY - 2 * $MapSizeY/10)); |
$New_x += $MapSizeX/10; |
$New_y += $MapSizeY/10; |
# is Target reachable? |
if ( &IsTargetReachable($New_x, $New_y) ) |
{ |
# new Target found |
$RandomTarget_x = $New_x; |
$RandomTarget_y = $New_y; |
last; |
} |
} |
} |
&TtsSpeak ('MEDIUM', $Translate{'TtsNextTarget'}); |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Goto previous Waypoint |
sub WpTargetPrev() |
{ |
if ( $PlayerRandomMode =~ /STD/i ) |
{ |
$WpPlayerIndex --; |
if ( $WpPlayerIndex < 0 ) |
{ |
# Restart with last Wp |
$WpPlayerIndex = $#Waypoints; |
} |
} |
else |
{ |
# Next Random Target |
&WpTargetNext(); |
} |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Goto first Waypoint |
sub WpTargetFirst() |
{ |
$WpPlayerIndex = 0; |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Goto last Waypoint |
sub WpTargetLast() |
{ |
$WpPlayerIndex = $#Waypoints; |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Waypoint Target reached? |
sub WpCheckTargetReached() |
{ |
if ( $WpPlayerHoldtime == -1 ) |
{ |
lock (%MkOsd); # until end of block |
if ( &CurPosIsValid() and &HomePosIsValid() and &MkIsWptMode() ) |
{ |
# Gueltige SAT Daten |
# for Wp mode |
my $Wp = $Waypoints[$WpPlayerIndex]; |
my $WpTarget_Lat = $Wp->{'Pos_Lat'}; |
my $WpTarget_Lon = $Wp->{'Pos_Lon'}; |
my $WpTolerance = $Wp->{'ToleranceRadius'}; |
my $WpHoldtime = $Wp->{'Holdtime'}; |
# Random-Map Mode |
if ( $PlayerRandomMode =~ /MAP/i ) |
{ |
($WpTarget_Lat, $WpTarget_Lon) = &MapXY2Gps ($RandomTarget_x, $RandomTarget_y); |
$WpTolerance = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; |
$WpHoldtime = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; |
} |
# Operation Radius pruefen |
my ($HomeDist, $HomeBearing) = &MapGpsTo($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, $WpTarget_Lat, $WpTarget_Lon ); |
if ( $HomeDist > $MkOsd{'OperatingRadius'} ) |
{ |
# Target entsprechend Operation Radius neu berechnen |
$HomeDist = $MkOsd{'OperatingRadius'}; |
($WpTarget_Lat, $WpTarget_Lon) = &MapGpsAt($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, $HomeDist, $HomeBearing); |
} |
# Abstand zum Ziel pruefen |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, $WpTarget_Lat, $WpTarget_Lon ); |
$Dist = int ($Dist + 0.5); |
if ( $Dist <= $WpTolerance ) |
{ |
# Target reached - count down Holdtime |
$WpPlayerHoldtime = 2 * $WpHoldtime; # 0..2n - decrement im 0.5s timer |
&TtsSpeak ('MEDIUM', $Translate{'TtsTargetReached'}); |
} |
} |
} |
if ( $WpPlayerHoldtime == 0 ) # wird im 0.5s timer runtergezaehlt |
{ |
# Target reached - Holdtime is over |
$WpPlayerHoldtime = -1; |
return 1; |
} |
# Target NOT reached |
return 0; |
} |
# KML Player: 10s forward |
sub KmlTargetNext() |
{ |
$KmlPlayerIndex += int (10 / $Cfg->{waypoint}->{'KmlTimeBase'} + 0.5); |
if ( $KmlPlayerIndex > $#KmlTargets ) |
{ |
# Next loop |
$KmlPlayerIndex -= $#KmlTargets; |
} |
} |
# KML Player: 10s backward |
sub KmlTargetPrev() |
{ |
$KmlPlayerIndex -= int (10 / $Cfg->{waypoint}->{'KmlTimeBase'} + 0.5); |
if ( $KmlPlayerIndex < 0 ) |
{ |
# Next loop |
$KmlPlayerIndex += $#KmlTargets; |
} |
} |
# KML Player: Goto first Target |
sub KmlTargetFirst() |
{ |
$KmlPlayerIndex = 0; |
} |
# KML Player: Goto last Target |
sub KmlTargetLast() |
{ |
$KmlPlayerIndex = $#KmlTargets; |
} |
# |
# Set Player modes |
# |
# set player to "Play" mode |
sub PlayerPlay() |
{ |
$PlayerMode = 'Play'; |
$WpPlayerHoldtime = -1; |
# Play/Pause-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPause-Foto', |
); |
&FoxHide(); |
} |
# set player to "Pause" mode |
sub PlayerPause() |
{ |
$PlayerMode = 'Pause'; |
$WpPlayerHoldtime = -1; |
# Play/Pause-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPlay-Foto', |
); |
# momentane Position merken und im Player-Timer senden |
$PlayerPause_Lon = ""; |
$PlayerPause_Lat = ""; |
lock (%MkOsd); # until end of block |
if ( &CurPosIsValid() ) |
{ |
$PlayerPause_Lon = $MkOsd{'CurPos_Lon'}; |
$PlayerPause_Lat = $MkOsd{'CurPos_Lat'}; |
} |
&FoxShow(); |
} |
# set player to "Home" mode |
sub PlayerHome() |
{ |
$PlayerMode = 'Home'; |
&WpTargetFirst(); |
# Play/Pause-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPlay-Foto', |
); |
&FoxHide(); |
} |
# set player to "Stop" mode |
sub PlayerStop() |
{ |
$PlayerMode = 'Stop'; |
&WpTargetFirst(); |
# set Play/Pause Icon to "Play |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPlay-Foto', |
); |
# switch player to Wp Mode |
&PlayerWpt(); |
&FoxHide(); |
} |
# set player Random Mode to "STD" |
sub PlayerRandomStd() |
{ |
$PlayerRandomMode = "STD"; |
# Set Icon |
$map_canvas->delete('Wp-WptRandom'); |
$map_canvas->createImage($MapSizeX/2-200, $MapSizeY-48, |
'-tags' => 'Wp-WptRandom', |
'-anchor' => 'nw', |
'-image' => 'WpRandomOn-Foto', |
); |
# redraw connectors and Icons on canvas |
&WpRedrawLines(); |
&WpRedrawIcons(); |
} |
# set player Random Mode to "RND" |
sub PlayerRandomRnd() |
{ |
$PlayerRandomMode = "RND"; |
# Set Icon |
$map_canvas->delete('Wp-WptRandom'); |
$map_canvas->createImage($MapSizeX/2-200, $MapSizeY-48, |
'-tags' => 'Wp-WptRandom', |
'-anchor' => 'nw', |
'-image' => 'WpRandomMap-Foto', |
); |
# delete Wp-connectors from canvas |
$map_canvas->delete('Waypoint-Connector'); |
} |
# set player Random Mode to "MAP" |
sub PlayerRandomMap() |
{ |
$PlayerRandomMode = "MAP"; |
# Set Icon |
$map_canvas->delete('Wp-WptRandom'); |
$map_canvas->createImage($MapSizeX/2-200, $MapSizeY-48, |
'-tags' => 'Wp-WptRandom', |
'-anchor' => 'nw', |
'-image' => 'WpRandomOff-Foto', |
); |
# Get 1st Target |
&WpTargetNext(); |
# hide WP and connectors on canvas |
&WpHide(); |
} |
# set player to KML mode |
sub PlayerKml() |
{ |
$PlayerWptKmlMode = 'KML'; |
# Wpt/Kml-Player-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-WptKml'); |
$map_canvas->createImage($MapSizeX/2-250, $MapSizeY-48, |
'-tags' => 'Wp-WptKml', |
'-anchor' => 'nw', |
'-image' => 'WpKml-Foto', |
); |
# delete Waypoints from canvas |
&WpHide(); |
# show KML Track |
&KmlRedraw(); |
} |
# set player to WPT mode |
sub PlayerWpt() |
{ |
$PlayerWptKmlMode = 'WPT'; |
# Wpt/Kml-Player-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-WptKml'); |
$map_canvas->createImage($MapSizeX/2-250, $MapSizeY-48, |
'-tags' => 'Wp-WptKml', |
'-anchor' => 'nw', |
'-image' => 'WpWpt-Foto', |
); |
# delete Kml-Track from canvas |
&KmlHide(); |
# Show waypoints, WP resend required |
$WaypointsModified = 1; |
if ( $PlayerRandomMode ne 'MAP' ) |
{ |
&WpRedrawIcons() |
} |
if ( $PlayerRandomMode eq 'STD' ) |
{ |
&WpRedrawLines() |
} |
} |
# Activate Recording mode |
sub PlayerRecordOn |
{ |
$PlayerRecordMode = "REC"; |
$map_canvas->itemconfigure ('MK-OSD-Rec-Value', '-text' => "Recording" ); |
# Record new KML-Track |
undef @KmlTargets; |
$KmlPlayerIndex = 0; |
# delete Kml-Track from canvas |
&KmlHide(); |
} |
# Deactivate Recording mode |
sub PlayerRecordOff |
{ |
$PlayerRecordMode = ""; |
$map_canvas->itemconfigure ('MK-OSD-Rec-Value', '-text' => "" ); |
} |
# Hide Fox icon on canvas |
sub FoxHide() |
{ |
$map_canvas->lower('Fox', 'Map'); |
} |
# Show Fox icon on canvas |
sub FoxShow() |
{ |
$map_canvas->raise('Fox', 'Target'); |
} |
# Hide POI icon on canvas |
sub PoiHide() |
{ |
$map_canvas->lower('POI', 'Map'); |
} |
# Show POI icon on canvas |
sub PoiShow() |
{ |
$map_canvas->raise('POI', 'Track-Antenna'); |
} |
# |
# System Messages |
# |
# Init Messages for a Subsystem/timer |
sub MkMessageInit () |
{ |
my ($Id) = @_; |
$MkMessages{$Id} = []; |
} |
# Register message |
sub MkMessage () |
{ |
my ($Message, $Id) = @_; |
push @{$MkMessages{$Id}}, $Message; |
} |
# show registered messages |
sub MkMessageShow() |
{ |
my @Messages; |
my $MsgLines = 0; |
my $MaxMsgLen = 0; |
# Collect Messages of each category |
foreach my $Id (keys %MkMessages) |
{ |
foreach $i ( 0 .. $#{$MkMessages{$Id}} ) |
{ |
my $Msg = $MkMessages{$Id}[$i]; |
push @Messages, $Msg; |
$MsgLines ++; |
my $Len = length $Msg; |
if ( $Len > $MaxMsgLen ) |
{ |
$MaxMsgLen = $Len; |
} |
} |
} |
$map_canvas->delete('Message-Balloon'); # delete old Balloon |
if ( $MsgLines > 0 ) |
{ |
# draw Balloon |
my @MsgBalloon = ( $MkPos_x , $MkPos_y, |
$MkPos_x + 30 , $MkPos_y + 40, |
$MkPos_x + 30 + $MaxMsgLen * 11, $MkPos_y + 40, |
$MkPos_x + 30 + $MaxMsgLen * 11, $MkPos_y + 44 + $MsgLines * 20, |
$MkPos_x + 20, $MkPos_y + 44 + $MsgLines * 20, |
$MkPos_x + 20, $MkPos_y + 40, |
$MkPos_x, $MkPos_y, |
); |
$map_canvas->createPolygon( @MsgBalloon, |
'-tags' => ['Message-Balloon', 'Message-BalloonBubble'], |
'-fill' => 'yellow', |
'-outline' => 'yellow', |
'-width' => 1, |
); |
# draw Messages |
my $MsgLine = 1; |
foreach my $Msg (@Messages) |
{ |
$map_canvas->createText ( $MkPos_x + 25, $MkPos_y + 32 + $MsgLine * 20 , |
'-tags' => ['Message-Balloon', 'Message-BalloonText'], |
'-text' => $Msg, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => 'blue', |
'-anchor' => 'w', |
); |
$MsgLine ++; |
} |
$map_canvas->lower('Message-Balloon', 'MK-Arrow'); |
} |
} |
# Show Balloon, when arproaching Target |
sub TargetMessageShow () |
{ |
$map_canvas->delete('Target-Balloon'); # delete old Balloon |
if ( $OperationMode ne "Free" and $MkOsd{'TargetPos_Stat'} == 1 and $MkOsd{'TargetPosDev_Dist'} /10 < 25 ) |
{ |
my $BalloonLines = 0; |
$ColorBalloon = "blue"; |
my ($T_x, $T_y) = &MapGps2XY($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}); |
my $Wp = $Waypoints[$MkOsd{'WaypointIndex'}]; |
# Holdtime Wp-Player Mode |
if ( $WpPlayerHoldtime >= 0 and $PlayerWptKmlMode eq "WPT" ) |
{ |
# Holdtime |
$ColorBalloon = 'red'; |
my $HoldTime = sprintf ("%5s %3d s", "HLD:", int ($WpPlayerHoldtime / 2 + 0.5) ); |
$map_canvas->createText ( $T_x + 25, $T_y - 40, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $HoldTime, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Holdtime WPT-Mode |
if ( &MkTargetReached() and $OperationMode eq "WPT" ) |
{ |
# Holdtime from MK |
$ColorBalloon = 'red'; |
my $HoldTime = sprintf ("%5s %3d s", "HLD:", int ($MkOsd{'TargetHoldTime'} + 0.5) ); |
$map_canvas->createText ( $T_x + 25, $T_y - 40, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $HoldTime, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Tolerance Radius Player Mode |
if ( &MkIsWptMode() and $OperationMode eq "Play" and $PlayerWptKmlMode eq "WPT" ) |
{ |
my $WpTolerance = sprintf ("%5s %3d m", "TOL:", $Wp->{'ToleranceRadius'}); |
$map_canvas->createText ( $T_x + 25, $T_y - 60, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $WpTolerance, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Tolerance WPT-Mode |
if ( &MkIsWptMode and $OperationMode eq "WPT" ) |
{ |
my $WpTolerance = sprintf ("%5s %3d m", "TOL:", $Wp->{'ToleranceRadius'} ); |
$map_canvas->createText ( $T_x + 25, $T_y - 60, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $WpTolerance, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Distance to Target |
my $Dist = int ($MkOsd{'TargetPosDev_Dist'} /10 + 0.5); |
$map_canvas->createText ( $T_x + 25, $T_y - 80, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => sprintf ("%5s %3d m", "DST:", $Dist) , |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
if ( $BalloonLines >= 1 ) |
{ |
# draw Balloon |
my @TargetBalloon = ( $T_x , $T_y, |
$T_x + 30, $T_y - (3 - $BalloonLines) * 20 -27, |
$T_x + 150, $T_y - (3 - $BalloonLines) * 20 -27 , |
$T_x + 150, $T_y - 93, |
$T_x + 20, $T_y - 93, |
$T_x + 20, $T_y - (3 - $BalloonLines) * 20 -27, |
$T_x, $T_y, |
); |
$map_canvas->createPolygon( @TargetBalloon, |
'-tags' => ['Target-Balloon', 'Target-BalloonBubble'], |
'-fill' => 'lightgray', |
'-outline' => 'yellow', |
'-width' => 1, |
); |
} |
$map_canvas->lower('Target-Balloon', 'MK-Home-Line'); |
$map_canvas->lower('Target-BalloonBubble', 'Target-BalloonText'); |
} |
} |
# |
# Airfield border |
# |
# Are two segments A(a1/a2), B(b1/b2) and C(c1/c2), D(d1/d2) crossing ? |
sub SegmentCross() |
{ |
my ( $a1, $a2, $b1, $b2, $c1, $c2, $d1, $d2) = @_; |
# segment C/D ist vertical, avoid div/0 |
if ( $c1 == $d1 ) |
{ |
$d1 += 0.00001; |
} |
my $n = ($b1 - $a1) * ($d2 - $c2) - ($b2 - $a2) * ($d1 - $c1); |
if ( $n == 0.0 ) |
{ |
# AB und CD sind parallel |
return 0; |
} |
my $s = ( ($c1 - $a1) * ($d2 - $c2) - ($c2 - $a2) * ($d1 - $c1) ) / $n; |
my $t = ( $a1 - $c1 + $s * ($b1 - $a1) ) / ( $d1 - $c1 ); |
if ( $s >= 0.0 and $s <= 1.0 and $t >= 0.0 and $t <= 1.0 ) |
{ |
# beide Strecken kreuzen sich |
# Schnittpunkt: s_x, s_y |
my $s_x = $a1 + $s * ( $b1 - $a1 ); |
my $s_y = $a2 + $s * ( $b2 - $a2 ); |
return 1; |
} |
# beide Strecken kreuzen sich nicht |
return 0; |
} |
# How often does a segment A(a1,a2), B(b1,b2) cross the polygon? |
sub SegmentPolygonCross() |
{ |
my ( $a1, $a2, $b1, $b2, $Polygon) = @_; |
my $Cross = 0; |
my $PolyCnt = scalar @{$Polygon}; |
my $PolyPointCnt = $PolyCnt / 2; |
my $i = 0; |
for ( $p=0; $p < $PolyPointCnt; $p++ ) |
{ |
my $c1 = ${$Polygon}[$i++]; |
my $c2 = ${$Polygon}[$i++]; |
if ( $i >= $PolyCnt ) { $i = 0; } |
my $d1 = ${$Polygon}[$i]; |
my $d2 = ${$Polygon}[$i+1]; |
# map calibration offsets |
$c1 -= $Map{'Offset_x'}; |
$c2 += $Map{'Offset_y'}; |
$d1 -= $Map{'Offset_x'}; |
$d2 += $Map{'Offset_y'}; |
if ( &SegmentCross($a1, $a2, $b1, $b2, $c1, $c2, $d1, $d2) ) |
{ |
$Cross ++; |
} |
} |
return $Cross; |
} |
# Is point A inside airfield border? |
sub IsInsideBorder() |
{ |
my ($a1, $a2) = @_; |
if ( scalar @Map{'Border'} == 0 ) |
{ |
# no border defined, always inside |
return 1; |
} |
my $Cross = &SegmentPolygonCross (-10, -10, $a1, $a2, @Map{'Border'} ); |
# Ungerade Anzahl Kreuzungen: Inside |
return ( $Cross % 2 ); |
} |
# Is segment A, B crossing the airfield border? |
sub IsCrossingBorder() |
{ |
my ($a1, $a2, $b1, $b2) = @_; |
if ( scalar @Map{'Border'} == 0 ) |
{ |
# no border defined, always not crossing |
return 0; |
} |
my $Cross = &SegmentPolygonCross ($a1, $a2, $b1, $b2, @Map{'Border'} ); |
return ( $Cross > 0 ); |
} |
# How often is segment A, B crossing the airfield border? |
sub CrossingBorderCount() |
{ |
my ($a1, $a2, $b1, $b2) = @_; |
if ( scalar @Map{'Border'} == 0 ) |
{ |
# no border defined, not crossing |
return 0; |
} |
my $Cross = &SegmentPolygonCross ($a1, $a2, $b1, $b2, @Map{'Border'} ); |
return ( $Cross ); |
} |
# check, if Target is reachable my MK |
sub IsTargetReachable() |
{ |
my ($T_x, $T_y) = @_; |
my $MkIsInside = &IsInsideBorder($MkPos_x, $MkPos_y); |
my $TargetIsInside = &IsInsideBorder($T_x, $T_y); |
my $MkTargetCrossingCount = &CrossingBorderCount($MkPos_x, $MkPos_y, $T_x, $T_y); |
if ( ($MkIsInside and $MkTargetCrossingCount == 0 ) or |
(! $MkIsInside and $TargetIsInside and $MkTargetCrossingCount == 1) ) |
{ |
# Target is reachable |
return 1; |
} |
# Target is not reachable |
return 0; |
} |
# |
# Configuration and data-visualisation |
# |
# Display or Modify Hash |
sub DisplayHash() |
{ |
my ($hrefData, $Titel, $Mode) = @_; |
# $Mode: Display, Edit, Waypoint, Refresh |
my %Id; |
my $Label; |
my $Value; |
# Neues Fenster aufmachen |
my $popup = $main->Toplevel(); |
$popup->title($Titel); |
# Buttons |
my $popup_button = $popup->Frame() -> pack('-side' => 'bottom', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$popup_button->Button('-text' => 'Schließen', |
'-command' => sub |
{ |
if ( $Mode =~ /edit/i and $Mode =~ /waypoint/i ) |
{ |
$WaypointsModified = 1; |
&WpRedrawLines(); |
&WpRedrawIcons(); |
} |
$popup->destroy() |
})->pack; |
# Frame mit den Labels |
my $popup_label = $popup->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Labels anzeigen |
foreach $Label ( sort keys %{$hrefData}) |
{ |
if ( $Translate{$Label} ne "" ) |
{ |
$Label = $Translate{$Label}; |
} |
$popup_label->Label ('-text' => $Label, |
'-width' => 25, |
'-anchor' => 'w', |
) -> pack(); |
} |
# Frame mit den Daten |
my $popup_values = $popup->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Daten anzeigen |
foreach $Value ( sort keys %{$hrefData}) |
{ |
if ( $Mode =~ /display/i ) |
{ |
# Display |
$Id{$Value} = $popup_values->Label ('-text' => ${$hrefData}{$Value}, |
'-width' => 20, |
'-anchor' => 'e', |
'-relief' => 'sunken', |
) -> pack(); |
} |
if ( $Mode =~ /edit/i ) |
{ |
# Edit |
$Id{$Value} = $popup_values->Entry ('-textvariable' => \${$hrefData}{$Value}, |
'-exportselection' => '1', |
'-width' => 20, |
'-relief' => 'sunken', |
) -> pack(); |
if ( $Mode =~ /waypoint/i ) |
{ |
# einige Waypoint-Felder nicht aenderbar einstellen |
if ( "MapX MapY Pos_Lat Pos_Lon Tag" =~ /$Value/i ) |
{ |
$Id{$Value}->configure('-state' => 'disabled', ); |
} |
} |
} |
} |
if ( $Mode =~ /refresh/i ) |
{ |
# Timer: 0.1s |
$popup_values->repeat (100, sub |
{ |
# Datenfelder alle 100ms aktualisieren |
my $BgColor = 'white'; |
if ( $Mode =~ /heartbeat/i ) |
{ |
$BgColor = 'red'; |
if ( &MkOsdIsValid() ) |
{ |
# gültige daten vom MK |
$BgColor = 'white'; |
} |
} |
foreach $Value ( sort keys %{$hrefData} ) |
{ |
# Eingebbare Waypoint-Felder nicht aktualisieren |
if ( ! ($Mode =~ /waypoint/i and |
"Event_Flag Heading ToleranceRadius HoldTime Pos_Alt" =~ /$Value/i) ) |
{ |
$Id{$Value}->configure('-text' => ${$hrefData}{$Value}, |
'-background' => "$BgColor", |
); |
} |
} |
}); |
} |
return 0; |
} |
# Konfigurationsdatei mkcockpit.xml im Popup-Fenster editieren |
sub Configure() |
{ |
# Copy Cfg-Hash for editing |
my $CfgEdit = {%{$Cfg}}; |
foreach $key (keys %{$Cfg}) |
{ |
if ( ref $Cfg->{$key} ) |
{ |
$CfgEdit->{$key} = {%{$Cfg->{$key}}}; |
} |
} |
# Neues Fenster aufmachen |
my $popup = $main->Toplevel(); |
$popup->title("Einstellungen - $XmlConfigFile"); |
# jede Sektion in einem Tab anzeigen |
my $book = $popup->NoteBook()->pack( -fill=>'both', -expand=>1 ); |
foreach $key (sort keys %{$CfgEdit}) |
{ |
if ( ! ref $CfgEdit->{$key} ) |
{ |
next; |
} |
my $TabLabel = "$key"; |
if ( $Translate{$key} ne "" ) |
{ |
$TabLabel = $Translate{$key}; |
} |
my $Tab = $book->add( "$key", -label=>"$TabLabel", ); |
# Frame fuer Buttons |
my $book_button = $Tab->Frame() -> pack('-side' => 'bottom', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$book_button->Button('-text' => 'OK', |
'-width' => '10', |
'-command' => sub |
{ |
# Copy back CfgEdit-Hash |
$Cfg = {%{$CfgEdit}}; |
foreach $key (keys %{$CfgEdit}) |
{ |
if ( ref $CfgEdit->{$key} ) |
{ |
$Cfg->{$key} = {%{$CfgEdit->{$key}}}; |
} |
} |
# set new timestamp |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
$Cfg->{'CreationDate'} = $TimeStamp; |
# Cfg in mkcockpit.xml speichern |
&XMLout ($Cfg, |
'OutputFile' => $XmlConfigFile, |
'AttrIndent' => '1', |
'RootName' => 'mkcockpit-Config', |
); |
$popup->destroy(); |
} )->pack ('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$book_button->Button('-text' => $Translate{'Abort'}, |
'-width' => '10', |
'-command' => sub { $popup->destroy() }, |
)->pack ('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$book_button->Label ('-text' => $Translate{'RestartRequired'}, |
'-anchor' => 'w', |
'-foreground' => 'red', |
) ->pack ('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 10, |
'-pady' => 5, |
); |
# Frame mit den Labels |
my $popup_label = $Tab->Frame() -> pack('-side' => 'left', |
# '-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Labels anzeigen |
foreach $Label ( sort keys %{$CfgEdit->{$key}}) |
{ |
if ( $Translate{$Label} ne "" ) |
{ |
$Label = $Translate{$Label}; |
} |
$popup_label->Label ('-text' => $Label, |
'-width' => 35, |
'-anchor' => 'w', |
) -> pack(); |
} |
# Frame mit den Daten |
my $popup_values = $Tab->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Eingabefelder mit Daten anzeigen |
foreach $Value ( sort keys %{$CfgEdit->{$key}}) |
{ |
$popup_values->Entry ('-textvariable' => \$CfgEdit->{$key}->{$Value}, |
'-exportselection' => '1', |
'-width' => 30, |
'-relief' => 'sunken', |
) -> pack(); |
} |
} |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/libmksim.pl |
---|
0,0 → 1,1067 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmap.pl - Conversion GPS and Map-X/Y Coordinates |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-10-10 0.0.1 rw created |
# |
############################################################################### |
$Version{'libmksim.pl'} = "0.0.1 - 2009-10-10"; |
my $Simulator = "OFF"; |
sub MkSim() |
{ |
my $popup = $main->Toplevel(); |
$popup->title("MikroKopter Simulator"); |
my $menu_bar = $popup->Menu; |
$popup->optionAdd("*tearOff", "false"); |
$popup->configure ('-menu' => $menu_bar); |
my $menu_action = $menu_bar->cascade('-label' => "Action"); |
$menu_action->command('-label' => "3D Fix", |
'-command' => [\&CbSim3DFix ], |
); |
$menu_action->command('-label' => "Make MK Fly", |
'-command' => [\&CbSimMkFly ], |
); |
$menu_action->separator; |
$menu_action->command('-label' => "Start Simulator", |
'-command' => [\&CbSimStart ], |
); |
$menu_action->command('-label' => "Stop Simulator", |
'-command' => [\&CbSimStop ], |
); |
my $frame = $popup->Frame() -> pack('-side' => 'top', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
my $button = $popup->Frame() -> pack('-side' => 'bottom', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
# Exit Button |
$button->Button('-text' => 'Exit', |
'-width' => 10, |
'-command' => sub |
{ |
$popup->destroy(); |
}) -> pack( '-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
# Tabs erstellen |
my $book = $frame->NoteBook()->pack( -fill=>'both', -expand=>1 ); |
# |
# Tab: GPS |
# |
my $GpsTab = $book->add( "GPS", -label=>"GPS" ); |
# canvas grid position |
my $GpsRow = 0; |
my $GpsCol = 0; |
my $GpsRowMap = $GpsRow + 1; |
my $GpsColMap = $GpsCol; |
my $GpsRowAlt = $GpsRow + 2; |
my $GpsColAlt = $GpsCol; |
my $GpsRowStat = $GpsRow + 4; |
my $GpsColStat = $GpsCol; |
my $GpsRowSats = $GpsRow + 5; |
my $GpsColSats = $GpsCol; |
# Create and scale Photo |
my $ImgWidth = "$Cfg->{'mksim'}->{'ImageSize'}"; |
my $Factor = $MapSizeX / $ImgWidth; |
my $Img1 = $popup->Photo( 'SimFoto', |
'-file' => "$Cfg->{'map'}->{'MapDir'}/$Map{'File'}", |
); |
my $Img2 = $popup->Photo ('SimFoto-Resized'); |
$Img2->copy ( $Img1, |
'-shrink', |
'-subsample' => $Factor, $Factor, |
); |
my $ImgWidth = $Img2->width; |
my $ImgHeight = $Img2->height; |
my $ImgScaleX = $MapSizeX / $ImgWidth; |
my $ImgScaleY = $MapSizeY / $ImgHeight; |
# display scaled Photo on canvas |
my $canvas = $GpsTab->Canvas( '-width' => $ImgWidth, |
'-height' => $ImgHeight, |
) -> grid (-row => $GpsRowMap, |
-column => $GpsColMap, |
-columnspan => 4, |
); |
$canvas->createImage( 0, 0, |
'-tags' => 'SimMap', |
'-anchor' => 'nw', |
'-image' => $Img2, |
); |
# Circle-Icon for MK, Target, Home |
my $Dia = 14; |
my $ImgSplit = $ImgWidth / 4; |
my $MkX = $ImgSplit - $Dia/2; |
my $MkY = $ImgHeight / 2 + $Dia/2; |
my $TargetX = $ImgSplit * 2 - $Dia/2; |
my $TargetY = $ImgHeight / 2 + $Dia/2; |
my $HomeX = $ImgSplit * 3 - $Dia/2; |
my $HomeY = $ImgHeight / 2 + $Dia/2; |
($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}) = &MapXY2Gps ($MkX * $ImgScaleX, $MkY * $ImgScaleY); |
($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}) = &MapXY2Gps ($TargetX * $ImgScaleX, $TargetY * $ImgScaleY); |
($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}) = &MapXY2Gps ($HomeX * $ImgScaleX, $HomeY * $ImgScaleY); |
$canvas->createOval ( $HomeX, $HomeY, $HomeX + $Dia, $HomeY + $Dia, |
'-tags' => "SimHome", |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeLine'}, |
'-outline' => "white", |
); |
$canvas->createOval ( $TargetX, $TargetY, $TargetX + $Dia, $TargetY + $Dia, |
'-tags' => "SimTarget", |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetLine'}, |
'-outline' => "white", |
); |
$canvas->createOval ( $MkX, $MkY, $MkX + $Dia, $MkY + $Dia, |
'-tags' => "SimMk", |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorMkSatGood'}, |
'-outline' => "white", |
); |
# GPS Alt MK |
$GpsTab->Label(-text => , $Translate{'CurPos_Alt'}, |
)->grid ('-row' => $GpsRowAlt, |
'-column' => $GpsColAlt, |
'-sticky' => 'w', |
); |
$MkOsd{'CurPos_Alt'} = 0; |
$scCurPos_Alt = $GpsTab->Scale( |
'-orient' => 'vertical', |
'-from' => 400, |
'-to' => 0, |
'-tickinterval' => 50, |
'-resolution' => 1, |
'-label' => "", |
'-font' => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
'-length' => 150, |
'-width' => 15, |
'-variable' => \$MkOsd{'CurPos_Alt'}, |
)->grid ('-row' => $GpsRowAlt+1, |
'-column' => $GpsColAlt, |
); |
$MkOsd{'CurPos_Stat'} = 0; |
$cbCurPos_Stat = $GpsTab->Checkbutton( |
-text => $Translate{'CurPos_Stat'}, |
-offvalue => 0x00, |
-onvalue => 0x01, |
-variable => \$MkOsd{'CurPos_Stat'}, |
)->grid (-row => $GpsRowStat, |
-column => $GpsColStat, |
-columnspan => 2, |
-sticky => 'w', |
); |
# Altimeter |
$GpsTab->Label(-text => , $Translate{'Altimeter'}, |
)->grid ('-row' => $GpsRowAlt, |
'-column' => $GpsColAlt +1, |
); |
$MkOsd{'Altimeter'} = 0; |
$scAltimeter = $GpsTab->Scale( |
-orient => 'vertical', |
-from => 8000, |
-to => 0, |
-tickinterval => 2000, |
-resolution => 1, |
-label => "", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 150, |
-width => 15, |
-variable => \$MkOsd{'Altimeter'}, |
)->grid (-row => $GpsRowAlt +1, |
-column => $GpsColAlt +1, |
); |
# GPS Alt Target |
$GpsTab->Label(-text => , $Translate{'TargetPos_Alt'}, |
)->grid ('-row' => $GpsRowAlt, |
'-column' => $GpsColAlt +2, |
); |
$MkOsd{'TargetPos_Alt'} = 0; |
$scTargetPos_Alt = $GpsTab->Scale( |
'-orient' => 'vertical', |
'-from' => 400, |
'-to' => 0, |
'-tickinterval' => 50, |
'-resolution' => 1, |
'-label' => "", |
'-font' => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
'-length' => 150, |
'-width' => 15, |
'-variable' => \$MkOsd{'TargetPos_Alt'}, |
)->grid ('-row' => $GpsRowAlt +1, |
'-column' => $GpsColAlt +2, |
); |
$MkOsd{'TargetPos_Stat'} = 0; |
$cbTargetPos_Stat = $GpsTab->Checkbutton(-text => $Translate{'TargetPos_Stat'}, |
-offvalue => 0x00, |
-onvalue => 0x01, |
-variable => \$MkOsd{'TargetPos_Stat'}, |
)->grid (-row => $GpsRowStat, |
-column => $GpsColStat +2, |
); |
# GPS Alt Home |
$GpsTab->Label(-text => , $Translate{'HomePos_Alt'}, |
)->grid ('-row' => $GpsRowAlt, |
'-column' => $GpsColAlt +3, |
); |
$MkOsd{'HomePos_Alt'} = 0; |
$scHomePos_Alt = $GpsTab->Scale( |
'-orient' => 'vertical', |
'-from' => 400, |
'-to' => 0, |
'-tickinterval' => 50, |
'-resolution' => 1, |
'-label' => "", |
'-font' => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
'-length' => 150, |
'-width' => 15, |
'-variable' => \$MkOsd{'HomePos_Alt'}, |
)->grid ('-row' => $GpsRowAlt +1, |
'-column' => $GpsColAlt +3, |
); |
$MkOsd{'HomePos_Stat'} = 0; |
$cbHomePos_Stat = $GpsTab->Checkbutton( |
-text => "Home Status", # $Translate{'HomePos_Stat'}, |
-offvalue => 0x00, |
-onvalue => 0x01, |
-variable => \$MkOsd{'HomePos_Stat'}, |
)->grid (-row => $GpsRowStat, |
-column => $GpsColStat +3, |
); |
# Sats in Use |
$MkOsd{'SatsInUse'} = 0; |
$scSatsInUse = $GpsTab->Scale( |
'-orient' => 'horizontal', |
'-from' => 0, |
'-to' => 12, |
'-resolution' => 1, |
'-tickinterval' => 1, |
'-label' => $Translate{'SatsInUse'}, |
'-font' => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
'-length' => 300, |
'-width' => 15, |
'-variable' => \$MkOsd{'SatsInUse'}, |
)->grid (-row => $GpsRowSats, |
-column => $GpsColSats, |
-columnspan => 4, |
); |
# Balloon |
my $simballoon = $popup->Balloon(); |
$simballoon->attach($canvas, |
'-balloonposition' => 'mouse', |
'-state' => 'balloon', |
'-msg' => { 'SimMk' => 'MikroKopter', |
'SimTarget' => 'Target', |
'SimHome' => 'Home', |
}, |
); |
# Mouse button 1 for MK |
my $MkOldx = 0; |
my $MkOldy = 0; |
# Pick MK |
$canvas->bind('SimMk' => '<Button-1>' => sub |
{ |
# prepare to move |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$MkOldx = $x; |
$MkOldy = $y; |
}); |
# Move Mk |
$canvas->bind('SimMk' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $canvas->find('withtag', 'current'); |
my $Dia2 = $Dia/2; |
if ( $x < $Dia2 ) { $x = $Dia2 }; |
if ( $y < $Dia2 ) { $y = $Dia2 }; |
if ( $x > $ImgWidth - $Dia2 ) { $x = $ImgWidth - $Dia2 }; |
if ( $y > $ImgHeight - $Dia2) { $y = $ImgHeight - $Dia2 }; |
$canvas->move($id => $x - $MkOldx, $y - $MkOldy); |
$MkOldx = $x; |
$MkOldy = $y; |
($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}) = &MapXY2Gps ($x * $ImgScaleX, $y * $ImgScaleY); |
}); |
# Mouse button 1 for Target |
my $TargetOldx = 0; |
my $TargetOldy = 0; |
# Pick Target |
$canvas->bind('SimTarget' => '<Button-1>' => sub |
{ |
# prepare to move |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$TargetOldx = $x; |
$TargetOldy = $y; |
}); |
# Move Target |
$canvas->bind('SimTarget' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $canvas->find('withtag', 'current'); |
my $Dia2 = $Dia/2; |
if ( $x < $Dia2 ) { $x = $Dia2 }; |
if ( $y < $Dia2 ) { $y = $Dia2 }; |
if ( $x > $ImgWidth - $Dia2 ) { $x = $ImgWidth - $Dia2 }; |
if ( $y > $ImgHeight - $Dia2) { $y = $ImgHeight - $Dia2 }; |
$canvas->move($id => $x - $TargetOldx, $y - $TargetOldy); |
$TargetOldx = $x; |
$TargetOldy = $y; |
($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}) = &MapXY2Gps ($x * $ImgScaleX, $y * $ImgScaleY); |
}); |
# Mouse button 1 for Home |
my $HomeOldx = 0; |
my $HomeOldy = 0; |
# Pick Home |
$canvas->bind('SimHome' => '<Button-1>' => sub |
{ |
# prepare to move |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$HomeOldx = $x; |
$HomeOldy = $y; |
}); |
# Move Home |
$canvas->bind('SimHome' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $canvas->find('withtag', 'current'); |
my $Dia2 = $Dia/2; |
if ( $x < $Dia2 ) { $x = $Dia2 }; |
if ( $y < $Dia2 ) { $y = $Dia2 }; |
if ( $x > $ImgWidth - $Dia2 ) { $x = $ImgWidth - $Dia2 }; |
if ( $y > $ImgHeight - $Dia2) { $y = $ImgHeight - $Dia2 }; |
$canvas->move($id => $x - $HomeOldx, $y - $HomeOldy); |
$HomeOldx = $x; |
$HomeOldy = $y; |
($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}) = &MapXY2Gps ($x * $ImgScaleX, $y * $ImgScaleY); |
}); |
# |
# Tab: Navigation |
# |
my $NavTab = $book->add( "Navigation", -label=>"Navigation", ); |
my $Row = 0; |
my $Col = 0; |
# Waypoint Index |
$MkOsd{'WaypointIndex'} = 0; |
$scWaypointIndex = $NavTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 20, |
-tickinterval => 5, |
-resolution => 1, |
-label => $Translate{'WaypointIndex'}, |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 300, |
-width => 15, |
-variable => \$MkOsd{'WaypointIndex'}, |
)->grid (-row => $Row + 1, |
-column => $Col, |
); |
# Waypoint Number |
$MkOsd{'WaypointNumber'} = 0; |
$scWaypointNumber = $NavTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 20, |
-tickinterval => 5, |
-resolution => 1, |
-label => $Translate{'WaypointNumber'}, |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 300, |
-width => 15, |
-variable => \$MkOsd{'WaypointNumber'}, |
)->grid (-row => $Row + 2, |
-column => $Col, |
); |
# Operating Radius |
$MkOsd{'OperatingRadius'} = 250; |
$scOperatingRadius = $NavTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 250, |
-tickinterval => 50, |
-resolution => 1, |
-label => "$Translate{'OperatingRadius'} (m)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 300, |
-width => 15, |
-variable => \$MkOsd{'OperatingRadius'}, |
)->grid (-row => $Row + 3, |
-column => $Col, |
); |
# TargetPosDev_Dist |
$MkOsd{'TargetPosDev_Dist'} = 250; |
$scTargetPosDev_Dist = $NavTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 500, |
-tickinterval => 100, |
-resolution => 1, |
-label => "$Translate{'TargetPosDev_Dist'} (dm)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 300, |
-width => 15, |
-variable => \$MkOsd{'TargetPosDev_Dist'}, |
)->grid (-row => $Row + 4, |
-column => $Col, |
); |
# |
# Tab: MK |
# |
my $MkTab = $book->add( "MikroKopter", -label=>"MikroKopter", ); |
my $Row = 0; |
my $Col = 0; |
# Battery |
$MkOsd{'UBat'} = 12.6; |
$scUBat = $MkTab->Scale( |
-orient => 'horizontal', |
-from => 6.0, |
-to => 18.0, |
-tickinterval => 2, |
-resolution => 0.1, |
-label => "$Translate{'UBat'} (V)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 200, |
-width => 15, |
-variable => \$MkOsd{'UBat'}, |
)->grid (-row => $Row, |
-column => $Col, |
); |
# RC Quality |
$MkOsd{'RC_Quality'} = 190; |
$scRC_Quality = $MkTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 200, |
-tickinterval => 50, |
-resolution => 1, |
-label => $Translate{'RC_Quality'}, |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 200, |
-width => 15, |
-variable => \$MkOsd{'RC_Quality'}, |
)->grid (-row => $Row +1, |
-column => $Col, |
); |
# CompassHeading |
$MkOsd{'CompassHeading'} = 0; |
$scCompassHeading = $MkTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 360, |
-tickinterval => 45, |
-resolution => 1, |
-label => $Translate{'CompassHeading'}, |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 200, |
-width => 15, |
-variable => \$MkOsd{'CompassHeading'}, |
)->grid (-row => $Row +2, |
-rowspan => 4, |
-column => $Col, |
); |
# GPS Groundspeed |
$MkOsd{'GroundSpeed'} = 0; |
$scGroundSpeed = $MkTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 1000, |
-tickinterval => 200, |
-resolution => 1, |
-label => "$Translate{'GroundSpeed'} (dm/s)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 200, |
-width => 15, |
-variable => \$MkOsd{'GroundSpeed'}, |
)->grid (-row => $Row + 6, |
-rowspan => 4, |
-column => $Col, |
); |
# GPS Speed North |
$MkNcDebug{'Analog_21'} = 0; |
$scAnalog_21 = $MkTab->Scale( |
-orient => 'horizontal', |
-from => -1000, |
-to => 1000, |
-tickinterval => 400, |
-resolution => 1, |
-label => "$Translate{'Analog_21'} (dm/s)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 200, |
-width => 15, |
-variable => \$MkNcDebug{'Analog_21'}, |
)->grid (-row => $Row + 10, |
-rowspan => 4, |
-column => $Col, |
); |
# GPS Speed East |
$MkNcDebug{'Analog_22'} = 0; |
$scAnalog_22 = $MkTab->Scale( |
-orient => 'horizontal', |
-from => -1000, |
-to => 1000, |
-tickinterval => 400, |
-resolution => 1, |
-label => "$Translate{'Analog_22'} (dm/s)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 200, |
-width => 15, |
-variable => \$MkNcDebug{'Analog_22'}, |
)->grid (-row => $Row + 14, |
-rowspan => 4, |
-column => $Col, |
); |
# Variometer |
$MkOsd{'Variometer'} = 0; |
$scVariometer = $MkTab->Scale( |
-orient => 'vertical', |
-from => 30, |
-to => -30, |
-tickinterval => 10, |
-resolution => 1, |
-label => $Translate{'Variometer'}, |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 100, |
-width => 15, |
-variable => \$MkOsd{'Variometer'}, |
)->grid (-row => $Row, |
-rowspan => 2, |
-column => $Col + 1, |
); |
my $DataLink = 1; |
$cbDataLink = $MkTab->Checkbutton( |
-text => $Translate{'DataLink'}, |
-offvalue => 0x00, |
-onvalue => 0x01, |
-variable => \$DataLink, |
)->grid (-row => $Row + 2, |
-column => $Col +1, |
-sticky=>'w', |
-ipadx => 10, |
); |
$MkTab->Label(-text => "", # space |
)->grid (-row => $Row +3, |
-column => $Col +1, |
-sticky=>'w', |
-ipadx => 10, |
); |
$MkTab->Label(-text => "$Translate{'MKFlags'}: --------", |
)->grid (-row => $Row +4, |
-column => $Col +1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $MkMotorRun = 0; |
$cbMkMotorRun = $MkTab->Checkbutton( |
-text => $Translate{'MkMotorRun'}, |
-offvalue => 0x00, |
-onvalue => 0x01, |
-variable => \$MkMotorRun, |
)->grid (-row => $Row + 5, |
-column => $Col +1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $MkFly = 0; |
$cbMkFly = $MkTab->Checkbutton( |
-text => $Translate{'MkFly'}, |
-variable => \$MkFly, |
-offvalue => 0x00, |
-onvalue => 0x02, |
)->grid (-row => $Row + 6, |
-column => $Col +1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $MkCalibrate = 0; |
$cbMkCalibrate = $MkTab->Checkbutton( |
-text => $Translate{'MkCalibrate'}, |
-variable => \$MkCalibrate, |
-offvalue => 0x00, |
-onvalue => 0x04, |
)->grid (-row => $Row + 7, |
-column => $Col +1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $MkStart = 0; |
$cbMkStart = $MkTab->Checkbutton( |
-text => $Translate{'MkStart'}, |
-variable => \$MkStart, |
-offvalue => 0x00, |
-onvalue => 0x08, |
)->grid (-row => $Row + 8, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $MkEmergency = 0; |
$cbMkEmergency = $MkTab->Checkbutton( |
-text => $Translate{'MkEmergency'}, |
-variable => \$MkEmergency, |
-offvalue => 0x00, |
-onvalue => 0x10, |
)->grid (-row => $Row + 9, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
$MkTab->Label(-text => "$Translate{'NCFlags'}: --------", |
)->grid (-row => $Row + 10, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagFree = 0; |
$cbNcFlagFree = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagFree'}, |
-offvalue => 0x00, |
-onvalue => 0x01, |
-variable => \$NcFlagFree, |
)->grid (-row => $Row + 11, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagPH = 0; |
$cbNcFlagPH = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagPH'}, |
-offvalue => 0x00, |
-onvalue => 0x02, |
-variable => \$NcFlagPH, |
)->grid (-row => $Row + 12, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagCH = 0; |
$cbNcFlagCH = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagCH'}, |
-offvalue => 0x00, |
-onvalue => 0x04, |
-variable => \$NcFlagCH, |
)->grid (-row => $Row + 13, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagRangeLimit = 0; |
$cbNcFlagRangeLimit = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagRangeLimit'}, |
-offvalue => 0x00, |
-onvalue => 0x08, |
-variable => \$NcFlagRangeLimit, |
)->grid (-row => $Row + 14, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagNoSerialLink = 0; |
$cbNcFlagNoSerialLink = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagNoSerialLink'}, |
-offvalue => 0x00, |
-onvalue => 0x10, |
-variable => \$NcFlagNoSerialLink, |
)->grid (-row => $Row + 15, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagTargetReached = 0; |
$cbNcFlagTargetReached = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagTargetReached'}, |
-offvalue => 0x00, |
-onvalue => 0x20, |
-variable => \$NcFlagTargetReached, |
)->grid (-row => $Row + 16, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
my $NcFlagManualControl = 0; |
$cbNcFlagManualControl = $MkTab->Checkbutton( |
-text => $Translate{'NcFlagManualControl'}, |
-offvalue => 0x00, |
-onvalue => 0x40, |
-variable => \$NcFlagManualControl |
)->grid (-row => $Row + 17, |
-column => $Col + 1, |
-sticky=>'w', |
-ipadx => 10, |
); |
# |
# Tab: Simulator |
# |
my $MkTab = $book->add( "Simulator", -label=>"Simulator", ); |
my $Row = 0; |
my $Col = 0; |
# Speed |
my $SimSpeed = 20; # km/h |
$scSimSpeed = $MkTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 50, |
-tickinterval => 5, |
-resolution => 1, |
-label => "Speed (km/h)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 300, |
-width => 15, |
-variable => \$SimSpeed, |
)->grid (-row => $Row, |
-column => $Col, |
); |
# Acceleration |
my $SimAcc = 10; # m/s**2 |
$scSimAcc = $MkTab->Scale( |
-orient => 'horizontal', |
-from => 0, |
-to => 30, |
-tickinterval => 5, |
-resolution => 0.5, |
-label => "Acceleration (m/s**2)", |
-font => '-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1', |
-length => 300, |
-width => 15, |
-variable => \$SimAcc, |
)->grid (-row => $Row +1, |
-column => $Col, |
); |
my $Speed = 0; # Current Mk Speed |
my $SpeedN = 0; # Speed North |
my $SpeedE = 0; # Speed East |
# |
# Timer |
# |
my $SimTimebase = 100; # Simulator Timebase in ms |
$popup->repeat ($SimTimebase, sub |
{ |
lock (%MkOsd); # until end of block |
$MkOsd{'MKFlags'} = $MkMotorRun | $MkFly | $MkCalibrate | $MkStart | $MkEmergency; |
$MkOsd{'NCFlags'} = $NcFlagFree | $NcFlagPH | $NcFlagCH | $NcFlagRangeLimit | |
$NcFlagNoSerialLink | $NcFlagTargetReached | $NcFlagManualControl; |
# Calibration sequence |
if ( $CalibCount > 0 ) |
{ |
$CalibCount ++; |
} |
if ( $CalibCount > 2 * 1000 / $SimTimebase ) # 2s |
{ |
$cbMkCalibrate-> deselect(); |
$cbMkStart->deselect(); |
$cbMkMotorRun->select(); |
$cbMkFly->select(); |
$CalibCount = 0; |
} |
# |
# Simulator |
# |
if ( $Simulator =~ /ON/i ) |
{ |
# Set Target-Pos |
$MkOsd{'TargetPos_Lat'} = $MkSim{'Target_Lat'}; |
$MkOsd{'TargetPos_Lon'} = $MkSim{'Target_Lon'}; |
$MkOsd{'TargetPos_Alt'} = $MkSim{'Target_Alt'}; |
$MkOsd{'TargetPos_Status'} = 1; |
my ($HomeDist, $HomeBearing) = &MapGpsTo($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, |
$MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'} ); |
if ( $HomeDist > $MkOsd{'OperatingRadius'} ) |
{ |
# Target entsprechend Operation Radius neu berechnen |
$HomeDist = $MkOsd{'OperatingRadius'}; |
($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}) = &MapGpsAt($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, |
$HomeDist, $HomeBearing); |
$cbNcFlagRangeLimit->select; |
} |
else |
{ |
$cbNcFlagRangeLimit->deselect; |
} |
# |
# Mk physics |
# Move MK to Target with constant acceleration |
# |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'} ); |
$MkOsd{'TargetPosDev_Dist'} = $Dist * 10; # in dm |
$MkOsd{'TargetPosDev_Bearing'} = $Bearing; |
my $AccN = $SimAcc * cos (deg2rad $Bearing); # Acceleration North |
my $AccE = $SimAcc * sin (deg2rad $Bearing); # Acceleration East |
my $t = $SimTimebase / 1000; |
$SpeedN = $SpeedN + $AccN * $t; # Speed North |
$SpeedE = $SpeedE + $AccE * $t; # Speed East |
$Speed = sqrt ($SpeedN * $SpeedN + $SpeedE * $SpeedE); |
if ( $Speed >= $SimSpeed/3.6 ) |
{ |
# Limit maximum Speed |
my $SpeedBearing = rad2deg atan2 ($SpeedE, $SpeedN); |
$SpeedN = $SimSpeed/3.6 * cos (deg2rad $SpeedBearing); |
$SpeedE = $SimSpeed/3.6 * sin (deg2rad $SpeedBearing); |
$Speed = $SimSpeed/3.6; |
} |
my $BreakDist = 5; |
if ( $Dist <= $BreakDist ) |
{ |
$Speed = $SimSpeed/3.6 - $SimSpeed/3.6 * (1 - $Dist/$BreakDist); |
my $SpeedBearing = rad2deg atan2 ($SpeedE, $SpeedN); |
$SpeedN = $Speed * cos (deg2rad $SpeedBearing); |
$SpeedE = $Speed * sin (deg2rad $SpeedBearing); |
$AccN = 0; |
$AccE = 0; |
} |
# Distance to go in this loop |
my $GoDistN = $SpeedN * $t + 0.5 * $AccN * $t * $t; |
my $GoDistE = $SpeedE * $t + 0.5 * $AccE * $t * $t; |
my $GoDist = sqrt ( $GoDistN * $GoDistN + $GoDistE * $GoDistE); |
my $GoBearing = rad2deg atan2 ($GoDistE, $GoDistN); |
if ($GoDist > 0 ) |
{ |
($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}) = &MapGpsAt($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$GoDist, $GoBearing); |
} |
if ( $Dist < $MkSim{'Target_ToleranceRadius'} ) |
{ |
$cbNcFlagTargetReached -> select(); |
} |
else |
{ |
$cbNcFlagTargetReached -> deselect(); |
} |
# GPS Groundspeed, North, East |
$MkOsd{'GroundSpeed'} = $Speed * 100; # dm/s |
$MkNcDebug{'Analog_21'} = $SpeedN * 100; |
$MkNcDebug{'Analog_22'} = $SpeedE * 100; |
# Heading |
if ( $MkSim{'Target_Heading'} != 0 ) |
{ |
$scCompassHeading -> set($MkSim{'Target_Heading'}); |
} |
} |
# update display |
$scAnalog_21 -> set($MkNcDebug{'Analog_21'}); |
$scAnalog_22 -> set($MkNcDebug{'Analog_22'}); |
$scTargetPos_Alt -> set($MkOsd{'TargetPos_Alt'}); |
$scTargetPosDev_Dist -> set ($MkOsd{'TargetPosDev_Dist'}); |
$scGroundSpeed -> set($MkOsd{'GroundSpeed'}); |
$scWaypointNumber -> set ($MkOsd{'WaypointNumber'}); |
$scWaypointIndex -> set ($MkOsd{'WaypointIndex'}); |
# move MK symbol on canvas |
my ($x, $y) = &MapGps2XY ($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}); |
$x = $x / $ImgScaleX; |
$y = $y / $ImgScaleY; |
$canvas->coords ('SimMk', $x, $y, $x + $Dia, $y + $Dia); |
# move Home symbol on canvas |
my ($x, $y) = &MapGps2XY ($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}); |
$x = $x / $ImgScaleX; |
$y = $y / $ImgScaleY; |
$canvas->coords ('SimHome', $x, $y, $x + $Dia, $y + $Dia); |
# move Target symbol on canvas |
my ($x, $y) = &MapGps2XY ($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}); |
$x = $x / $ImgScaleX; |
$y = $y / $ImgScaleY; |
$canvas->coords ('SimTarget', $x, $y, $x + $Dia, $y + $Dia); |
if ( $DataLink) |
{ |
# Timestamp, wann der Datensatz geschrieben wurde |
$MkOsd{'_Timestamp'} = time; |
} |
}); |
} |
# Make MK Fly |
sub CbSimMkFly |
{ |
$scWaypointIndex->set(5); |
$scWaypointNumber->set(10); |
$cbNcFlagCH->select(); |
# start calibration sequence |
$cbMkCalibrate-> select(); |
$cbMkStart->select(); |
$CalibCount = 1; |
} |
# 3D Fix |
sub CbSim3DFix |
{ |
my $Alt = 50; |
$scCurPos_Alt->set($Alt); |
$scAltimeter->set($Alt * $Cfg->{'mkcockpit'}->{'AltFactor'}); |
$scSatsInUse->set(10); |
$cbCurPos_Stat->select(); |
$cbTargetPos_Stat->select(); |
$cbHomePos_Stat->select(); |
# Set Home-Pos to Cur-Pos |
$MkOsd{'HomePos_Lat'} = $MkOsd{'CurPos_Lat'}; |
$MkOsd{'HomePos_Lon'} = $MkOsd{'CurPos_Lon'}; |
$scGroundSpeed->set(400); |
$scAnalog_21->set(10); |
$scAnalog_22->set(10); |
} |
# Switch Simulator ON |
sub CbSimStart |
{ |
$Simulator = "ON"; |
# Only one Target from Player |
$MkOsd{'WaypointNumber'} = 1; |
$MkOsd{'WaypointIndex'} = 0; |
} |
# Switch Simulator OFF |
sub CbSimStop |
{ |
$Simulator = "OFF"; |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/libmktimer.pl |
---|
0,0 → 1,871 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmktime.pl - MK Mission Cockpit - Timer for GUI Frontend |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-08-09 0.2.5 rw Timer moved from mkcockpit.pl |
# Optional Player home-pos in map configuration |
# 2009-08-23 0.2.6 rw Tracking-Antenna Icon |
# POI heading control |
# 2009-10-11 0.2.7 rw Tracker control changed |
# |
############################################################################### |
$Version{'libmktimer.pl'} = "0.2.7 - 2009-10-11"; |
use Math::Trig; |
# |
# Timer: 5s |
# |
$main->repeat (5000, sub |
{ |
if ( ! $MkSendWp ) |
{ |
# Abfragefrequenz OSD und Debug regelmäßig neu einstellen, falls Übertragungsfehler |
$MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 10) ); # Frequenz OSD Datensatz, * 10ms |
$MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 10) ); # Frequenz MK Debug Datensatz, * 10ms |
$MkSendQueue->enqueue( "v", "$AddrNC", ""); # Version |
$MkSendQueue->enqueue( "e", "$AddrNC", ""); # Error Text Request |
} |
lock (%MkOsd); # until end of block |
# Draw Operation Radius Border |
$map_canvas->delete('Map-Border-OperatingRadius'); |
if ( &HomePosIsValid() ) |
{ |
my $Radius = $MkOsd{'OperatingRadius'}; |
my $H_Lat = $MkOsd{'HomePos_Lat'}; |
my $H_Lon = $MkOsd{'HomePos_Lon'}; |
my $Angel = &MapAngel(); |
my ($T_Lat, $T_Lon) = &MapGpsAt ($H_Lat, $H_Lon, $Radius, $Angel -90); |
my ($R_Lat, $R_Lon) = &MapGpsAt ($H_Lat, $H_Lon, $Radius, $Angel); |
my ($B_Lat, $B_Lon) = &MapGpsAt ($H_Lat, $H_Lon, $Radius, $Angel + 90); |
my ($L_Lat, $L_Lon) = &MapGpsAt ($H_Lat, $H_Lon, $Radius, $Angel + 180); |
my ($T_x, $T_y) = &MapGps2XY ($T_Lat, $T_Lon); |
my ($R_x, $R_y) = &MapGps2XY ($R_Lat, $R_Lon); |
my ($B_x, $B_y) = &MapGps2XY ($B_Lat, $B_Lon); |
my ($L_x, $L_y) = &MapGps2XY ($L_Lat, $L_Lon); |
$map_canvas->createArc ( $L_x, $B_y, $R_x, $T_y, |
'-tags' => 'Map-Border-OperatingRadius', |
'-extent' => '359', |
'-start' => '0', |
'-style' => 'chord', |
'-outline' => $Cfg->{'mkcockpit'}->{'ColorAirfield'}, |
'-width' => '1', |
); |
$map_canvas->raise('Map-Border-OperatingRadius', 'Map'); # Border above Map |
} |
}); |
# |
# Timer: 0.1s - Map Overlay aktualisieren |
# |
$frame_map_top->repeat (100, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-MapOverlay"); |
lock (%MkOsd); # until end of block |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
if ( &MkOsdIsValid() ) |
{ |
# Gueltige OSD Daten |
# Operation Mode |
$OperationMode = ""; |
if ( &MkIsWptMode() ) { $OperationMode = "WPT"; } |
if ( $PlayerMode eq "Play" ) { $OperationMode = "Play"; } |
if ( $PlayerMode eq "Pause" ) { $OperationMode = "Paus"; } |
if ( $PlayerMode eq "Home" ) { $OperationMode = "Home"; } |
if ( &MkIsPhMode() ) { $OperationMode = "PH"; } |
if ( &MkIsFreeMode() ) { $OperationMode = "Free"; } |
my $SatsInUse = $MkOsd{'SatsInUse'}; |
if ( &CurPosIsValid() and &HomePosIsValid() ) |
{ |
# ausreichender GPS Empfang |
# get x,y map coords of current position |
my ($C_x, $C_y, $C_Angel) = &MapGps2XY($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, $MkOsd{'CompassHeading'}); |
$MkPos_x = $C_x; |
$MkPos_y = $C_y; |
# rotate MK arrow |
my $dy = sin (deg2rad $C_Angel) * ($MapMkLen/2); |
my $dx = cos (deg2rad $C_Angel) * ($MapMkLen/2); |
my $x0 = $C_x - $dx; |
my $y0 = $C_y - $dy; |
my $x1 = $C_x + $dx; |
my $y1 = $C_y + $dy; |
$map_canvas->coords ('MK-Arrow', $x0, $y0, $x1, $y1); |
# Update speed vector |
my $MapAngel = &MapAngel(); # North to Map-Horizont |
my $GpsSpeedNorth = $MkNcDebug{'Analog_21'}; |
my $GpsSpeedEast = $MkNcDebug{'Analog_22'}; |
my $PhiGpsSpeed = rad2deg atan2 ( $GpsSpeedEast, $GpsSpeedNorth ); |
$PhiMapSpeed = $PhiGpsSpeed - $MapAngel; |
# 555 cm/s ~ 20 km/h -> Zeigerlänge = $MkSpeedLen bei 20 km/h |
my $dy = sin (deg2rad $PhiMapSpeed) * $MapMkSpeedLen * $MkOsd{'GroundSpeed'} / 555; |
my $dx = cos (deg2rad $PhiMapSpeed) * $MapMkSpeedLen * $MkOsd{'GroundSpeed'} / 555; |
my $x0 = $C_x; |
my $y0 = $C_y; |
my $x1 = $C_x + $dx; |
my $y1 = $C_y + $dy; |
$map_canvas->coords ('MK-Speed', $x0, $y0, $x1, $y1); |
# Update Line between Home and MK |
my ($H_x, $H_y) = &MapGps2XY($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}); |
$map_canvas->coords ('MK-Home-Line', $H_x, $H_y, $C_x, $C_y); |
# Update Distance between Home and MK |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'} ); |
my $x = ($C_x - $H_x) / 2 + $H_x + 8; |
my $y = ($C_y - $H_y) / 2 + $H_y + 8; |
$map_canvas->coords ('MK-Home-Dist', $x, $y); |
$map_canvas->itemconfigure ('MK-Home-Dist', |
'-text' => sprintf ("%4d m", int ($Dist + 0.5) ), |
); |
# Update OSD - Sat dependent values |
$map_canvas->itemconfigure ('MK-OSD-Spd-Value', '-text' => sprintf ("%3d km/h", $MkOsd{'GroundSpeed'} * 0.036) ); |
# Alt = average Luftdruck und Sat |
my $Alt = int ( ($MkOsd{'Altimeter'} / $Cfg->{'mkcockpit'}->{'AltFactor'} + |
$MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'} ) / 2 + 0.5 ); |
$System{'Alt'} = $Alt; |
$map_canvas->itemconfigure ('MK-OSD-Alt-Value', '-text' => sprintf ("%3d m", $Alt) ); |
if ( &TargetIsValid() ) |
{ |
# Valid Target |
# Update Line between Target and MK |
my ($T_x, $T_y) = &MapGps2XY($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}); |
$map_canvas->coords ('MK-Target-Line', $C_x, $C_y, $T_x, $T_y); |
# Update Distance between Target and MK |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'} ); |
if ( $Dist >= 25 ) |
{ |
my $x = ($C_x - $T_x) / 2 + $T_x - 8; |
my $y = ($C_y - $T_y) / 2 + $T_y + 8; |
$map_canvas->coords ('MK-Target-Dist', $x, $y); |
$map_canvas->itemconfigure ('MK-Target-Dist', |
'-text' => sprintf ("%4d m", int ($Dist + 0.5) ), |
); |
} |
else |
{ |
# Don't show distance < 25m |
$map_canvas->coords ('MK-Target-Dist', 0, -100); |
} |
# show target icon |
my $IconHeight = 48; |
my $IconWidth = 48; |
$map_canvas->coords('Target', $T_x - $IconWidth/2, $T_y - $IconHeight ); |
$System{'CrossingBorder'} = 0; |
if ( &MkIsFlying() and &IsCrossingBorder($MkPos_x, $MkPos_y, $T_x, $T_y) ) |
{ |
# only, if MK is flying |
$System{'CrossingBorder'} = 1; |
&MkMessage ($Translate{'MsgCrossingBorder'}, "Timer-MapOverlay"); |
} |
} |
else |
{ |
# No valid Target, move target line out of sight/canvas |
$map_canvas->coords ('MK-Target-Line', 0, -100, 0, -100); |
$map_canvas->coords ('MK-Target-Dist', 0, -100); |
# hide target icon |
$map_canvas->coords('Target', 0, -100, ); |
} |
# Update Line between MK and POI |
if ( $PoiMode ) |
{ |
my ($P_x, $P_y) = &MapGps2XY($Poi_Lat, $Poi_Lon); |
$map_canvas->coords ('MK-POI-Line', $P_x, $P_y, $C_x, $C_y); |
} |
else |
{ |
$map_canvas->coords ('MK-POI-Line', 0, -200, 0, -200); |
} |
} |
else |
{ |
# kein ausreichender Sat-Empfang |
$map_canvas->itemconfigure ('MK-OSD-Spd-Value', '-text' => sprintf ("%3d km/h", 0 ) ); |
} |
# Update OSD - non Sat dependent values |
$map_canvas->itemconfigure ('MK-OSD-Odo-Value', '-text' => sprintf ("%3.3f km", $OdoMeter / 1000) ); |
$map_canvas->itemconfigure ('MK-OSD-Tim-Value', '-text' => sprintf ("%02d:%02d", $MkFlyingTime / 60, $MkFlyingTime % 60) ); |
$map_canvas->itemconfigure ('MK-OSD-Sat-Value', '-text' => $MkOsd{'SatsInUse'} ); |
# battery - OSD and warning |
my $UBat = sprintf ("%3.1f", $MkOsd{'UBat'}); |
$System{'UBat'} = $UBat; |
$map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-text' => "$UBat V" ); |
$System{'BatWarning'} = 0; |
$map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'}); |
if ( $MkOsd{'UBat'} < $Cfg->{'mkcockpit'}->{'UBatWarning'} ) |
{ |
if ( time %2 ) |
{ |
$map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-fill' => 'red'); |
} |
&MkMessage ($Translate{'MsgBatWarning'}, "Timer-MapOverlay"); |
$System{'BatWarning'} = 1; |
} |
# Display Operation Mode |
my $DisplayMode = $OperationMode; |
if ( &MkIsWptMode() and $OperationMode eq "Play" ) |
{ |
my %ModeMatrix = |
( |
"KML-STD" => "Play KML", |
"KML-RND" => "Play KML", |
"KML-MAP" => "Play KML", |
"WPT-STD" => "Play WPT", |
"WPT-RND" => "Rand WPT", |
"WPT-MAP" => "Rand MAP", |
); |
my $Key = "${PlayerWptKmlMode}-${PlayerRandomMode}"; |
$DisplayMode = $ModeMatrix{$Key}; |
} |
$System{'RangeWarning'} = 0; |
if ( &MkRangeLimit() ) |
{ |
$DisplayMode = "$DisplayMode" . " !!"; # Range Warning |
$System{'RangeWarning'} = 1; |
} |
$map_canvas->itemconfigure ('MK-OSD-Mode-Value', '-text' => $DisplayMode ); |
# Waypoints abhaengig vom Modus NC/Player |
my $WpValue = "-- / --"; |
if ( $MkOsd{'WaypointNumber'} > 0) |
{ |
$WpValue = sprintf ("%d / %d", $MkOsd{'WaypointIndex'} + 1, $MkOsd{'WaypointNumber'}); |
} |
if ($PlayerMode ne "Stop" and $PlayerWptKmlMode eq "WPT") |
{ |
$WpValue = sprintf ("%d / %d", $WpPlayerIndex +1, scalar @Waypoints); |
} |
if ($PlayerMode ne "Stop" and $PlayerWptKmlMode eq "KML" ) |
{ |
my $KmlTimeBase = $Cfg->{'waypoint'}->{'KmlTimeBase'} || 1.0; |
my $CurrTime = int ($KmlPlayerIndex * $KmlTimeBase + 0.5); |
my $TotTime = int (scalar @KmlTargets * $KmlTimeBase + 0.5); |
$WpValue = sprintf ("%02d:%02d / %02d:%02d", $CurrTime / 60, $CurrTime % 60, $TotTime / 60, $TotTime % 60); |
} |
$map_canvas->itemconfigure ('MK-OSD-Wp-Value', '-text' => "$WpValue"); |
# Recording Mode |
my $RecordText = ""; |
if ( $PlayerRecordMode =~ /REC/i ) |
{ |
my $KmlTimeBase = $Cfg->{'waypoint'}->{'KmlTimeBase'} || 1.0; |
my $TotTime = int (scalar @KmlTargets * $KmlTimeBase + 0.5); |
$RecordText = sprintf ("Recording %02d:%02d", $TotTime / 60, $TotTime % 60); |
} |
$map_canvas->itemconfigure ('MK-OSD-Rec-Value', '-text' => $RecordText ); |
# Farbe MK-Zeiger abhängig vom GPS Empfang |
my $MkCol= $Cfg->{'mkcockpit'}->{'ColorMkSatNo'}; |
if ( $SatsInUse >= 1 ) { $MkCol = $Cfg->{'mkcockpit'}->{'ColorMkSatLow'} ; } |
if ( $SatsInUse >= 6 ) { $MkCol = $Cfg->{'mkcockpit'}->{'ColorMkSatGood'}; } |
$map_canvas->itemconfigure ('MK-Arrow', '-fill' => $MkCol); |
# Show/Hide SatFix Icon |
if ($SatsInUse >= 6 ) |
{ |
$map_canvas->coords('Satellite', $MapSizeX-300, 10, ); |
} |
else |
{ |
# move icon out of sight |
$map_canvas->coords('Satellite', 0, -100, ); |
} |
# Variometer Pointer |
my $dy = -$MkOsd{'Variometer'} * 10; |
$map_canvas->coords('Map-Variometer-Pointer', 5, $MapSizeY/2+$dy, 20, $MapSizeY/2+10+$dy, 20, $MapSizeY/2-10+$dy); |
# |
# System checks |
# |
if ( ! &MkIsMotorOn() ) { &MkMessage ($Translate{'MsgMotorOff'}, "Timer-MapOverlay"); } |
if ( ! &MkIsFlying() ) { &MkMessage ($Translate{'MsgNotFlying'}, "Timer-MapOverlay"); } |
if ( &MkIsCalibrating() ) { &MkMessage ($Translate{'MsgCalibrate'}, "Timer-MapOverlay"); } |
if ( &MkIsMotorStarting() ) { &MkMessage ($Translate{'MsgStart'}, "Timer-MapOverlay") } |
if ( &MkEmergencyLanding() ) { &MkMessage ($Translate{'MsgEmergencyLanding'}, "Timer-MapOverlay"); } |
if ( &MkRangeLimit() ) { &MkMessage ($Translate{'MsgRangeLimit'}, "Timer-MapOverlay"); } |
# RC range check |
my $RcQuality = $MkOsd{'RC_Quality'}; |
$System{'RCQuality'} = ""; |
if ( $RcQuality < 100 ) |
{ |
$System{'RCQuality'} = "NO"; |
&MkMessage ($Translate{'MsgRcError'}, "Timer-MapOverlay"); |
} |
elsif ( $RcQuality < 150 ) |
{ |
$System{'RCQuality'} = "WEAK"; |
&MkMessage ($Translate{'MsgRcWarning'}, "Timer-MapOverlay"); |
} |
# Sat reception quality |
if ( $SatsInUse == 0 ) |
{ |
&MkMessage ($Translate{'MsgNoSatReception'}, "Timer-MapOverlay"); |
} |
elsif ( $SatsInUse > 0 and $SatsInUse < 6 ) |
{ |
&MkMessage ($Translate{'MsgWeakSatReception'}, "Timer-MapOverlay"); |
} |
# MK Border check |
$System{'OutsideBorder'} = "0"; |
if ( &MkIsFlying() and ! &IsInsideBorder($MkPos_x, $MkPos_y) ) |
{ |
# only, if MK is flying |
$System{'OutsideBorder'} = "1"; |
&MkMessage ($Translate{'MsgOutsideBorder'}, "Timer-MapOverlay"); |
} |
# Show Balloon, when aproaching Target |
&TargetMessageShow(); |
} |
else |
{ |
# keine aktuellen OSD Daten vom MK verfügbar |
&MkMessage ($Translate{'MsgNoData'}, "Timer-MapOverlay"); |
} |
# Wp-Number input from keyboard |
$KbTimer++; |
if ( $CbPlayerKey ne "" ) |
{ |
# Key pressed |
$KbNum = "$KbNum" . "$CbPlayerKey"; |
$CbPlayerKey = ""; |
$KbTimer = 0; |
} |
if ( $KbTimer > 7 and $KbNum ne "" ) |
{ |
# number complete, set target |
my $WpIndex = sprintf ("%d", $KbNum); |
&WpTargetSet ($WpIndex - 1); |
# prepare for next number |
$KbNum = ""; |
} |
# Show System Messages |
&MkMessageShow(); |
}); |
# |
# Timer: 0.1s - Tracking Anzeige aktualisieren |
# |
if ( $Cfg->{'track'}->{'Active'} =~ /y/i ) |
{ |
$TrackMkCalibrateEdge = 0; # calibrate edge detection |
$frame_map_top->repeat (100, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-Tracking"); |
lock (%MkOsd); # until end of block |
lock (%MkTrack); # until end of block |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
# Zeiger neu zeichnen |
my $ServoPan = @ServoPos[$MkTrack{'ServoPan'}]; |
if ( $ServoPan ne "" ) |
{ |
my $x0 = $TrackSizeX/2; |
my $y0 = $TrackSizeY - 0 - $TrackOffY; |
my $x1 = $TrackSizeX/2 - ($TrackPtrLen-22) * cos( deg2rad $ServoPan); |
my $y1 = $TrackSizeY - ($TrackPtrLen-22) * sin (deg2rad $ServoPan) - $TrackOffY; |
$track_canvas->coords ('Track-Ptr', $x0, $y0, $x1, $y1); |
} |
# Farbe Zeiger abhängig vom GPS Empfang |
my $SatsInUse = $MkOsd{'SatsInUse'}; |
my $TrackPtrCol= 'red'; |
if ( $SatsInUse >= 1 ) { $TrackPtrCol = 'orange'; } |
if ( $SatsInUse >= 6 ) { $TrackPtrCol = 'green'; } |
$track_canvas->itemconfigure ('Track-Ptr', '-fill' => $TrackPtrCol); |
# tracker coldstart condition at MK calibration, rising edge of signal |
if ( &MkIsCalibrating() ) |
{ |
if ( $TrackMkCalibrateEdge == 0 ) |
{ |
$TrackMkCalibrateEdge = 1; |
# send coldstart command to tracker |
$TrackQueue->enqueue("COLDSTART"); |
} |
} |
else |
{ |
$TrackMkCalibrateEdge = 0; |
} |
}); |
} |
# |
# Timer: 0.5s - Waypoint Player |
# |
$frame_map_top->repeat (500, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-Player"); |
lock (%MkOsd); # until end of block |
if ( &MkIsWptMode() ) |
{ |
# NC is in WPT Mode |
my $PoiHeading = $Cfg->{'waypoint'}->{'DefaultHeading'}; |
if ( &CurPosIsValid() and $PoiMode ) |
{ |
$PoiHeading = &MapGpsTo ( $MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$Poi_Lat, $Poi_Lon ); |
} |
if ( $PlayerMode eq "Pause" ) |
{ |
if ( $PlayerPause_Lat ne "" and $PlayerPause_Lon ne "" ) |
{ |
# Gespeicherte Pausen-Pos senden |
&MkFlyTo ( '-lat' => $PlayerPause_Lat, |
'-lon' => $PlayerPause_Lon, |
'-holdtime' => "60", |
'-heading' => $PoiHeading, |
'-mode' => "Target", |
); |
} |
} |
if ( $PlayerMode eq "Home" and &HomePosIsValid() ) |
{ |
# Gespeicherte oder eingestellte Home-Pos senden |
my $Home_Lat = $Map{'Home_Lat'} || $MkOsd{'HomePos_Lat'}; |
my $Home_Lon = $Map{'Home_Lon'} || $MkOsd{'HomePos_Lon'}; |
&MkFlyTo ( '-lat' => $Home_Lat, |
'-lon' => $Home_Lon, |
'-holdtime' => "60", |
'-heading' => $PoiHeading, |
'-mode' => "Target", |
); |
} |
if ( $PlayerWptKmlMode ne 'WPT' ) |
{ |
# not in Wp mode |
return; |
} |
if ( $PlayerMode eq "Play" ) |
{ |
if ( $PlayerRandomMode =~ /RND/i or $PlayerRandomMode =~ /STD/i ) |
{ |
my $WpCnt = scalar @Waypoints; |
if ( $WpCnt > 0 and $WpPlayerIndex < $WpCnt ) |
{ |
# Target WP-Pos senden |
my $Wp = $Waypoints[$WpPlayerIndex]; |
my $Wp_Lon = $Wp->{'Pos_Lon'}; |
my $Wp_Lat = $Wp->{'Pos_Lat'}; |
if ( $Wp_Lat ne "" and $Wp_Lon ne "" ) |
{ |
&MkFlyTo ( '-lat' => $Wp_Lat, |
'-lon' => $Wp_Lon, |
'-holdtime' => "60", |
'-heading' => $PoiHeading, |
'-mode' => "Target", |
); |
} |
} |
} |
if ( $PlayerRandomMode =~ /MAP/i ) |
{ |
# Target Map-Pos senden |
&MkFlyTo ( '-x' => $RandomTarget_x , |
'-y' => $RandomTarget_y , |
'-holdtime' => "60", |
'-heading' => $PoiHeading, |
'-mode' => "Target", |
); |
} |
# Ziel erreicht? |
if ( &WpCheckTargetReached() ) |
{ |
&WpTargetNext(); |
} |
} |
} |
# WP Player Holdtime count down |
if ( $WpPlayerHoldtime > 0 ) |
{ |
$WpPlayerHoldtime --; |
} |
}); |
# |
# Timer: variabel - KML Player |
# |
my $KmlTimeBase = $Cfg->{'waypoint'}->{'KmlTimeBase'} || 1.0; |
$KmlTimeBase *= 1000; |
$frame_map_top->repeat ($KmlTimeBase, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-KMLPlayer"); |
lock (%MkOsd); # until end of block |
if ( &CurPosIsValid() and $PlayerRecordMode =~ /REC/i ) |
{ |
# record current position |
push @KmlTargets, { |
'Lat' => $MkOsd{'CurPos_Lat'}, |
'Lon' => $MkOsd{'CurPos_Lon'}, |
'Alt' => $MkOsd{'CurPos_Alt'}, |
}; |
} |
if ( &MkIsWptMode() and $PlayerMode eq "Play" and $PlayerWptKmlMode eq 'KML') |
{ |
# Play KML |
# Pause, Home is handled in WPT-Timer |
my $KmlCnt = scalar @KmlTargets; |
if ( $KmlCnt > 0 and $KmlPlayerIndex < $KmlCnt ) |
{ |
my $Lat = $KmlTargets[$KmlPlayerIndex]->{'Lat'}; |
my $Lon = $KmlTargets[$KmlPlayerIndex]->{'Lon'}; |
my $Alt = $KmlTargets[$KmlPlayerIndex]->{'Alt'}; |
&MkFlyTo ( '-lat' => $Lat, |
'-lon' => $Lon, |
'-alt' => $Alt, |
'-holdtime' => "60", |
'-mode' => "Target", |
); |
# proceed to next Target |
$KmlPlayerIndex ++; |
if ( $KmlPlayerIndex >= $KmlCnt ) |
{ |
$KmlPlayerIndex = 0; |
} |
} |
} |
}); |
# |
# Timer: 1s |
# |
$frame_map_top->repeat (1000, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-Misc-1s"); |
lock (%MkOsd); # until end of block |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
if ( &MkOsdIsValid() ) |
{ |
# Heartbeat MK Datenübertragung |
if ( time %2 ) |
{ |
$map_canvas->itemconfigure('Heartbeat', '-image' => 'HeartbeatLarge', ); |
} |
else |
{ |
$map_canvas->itemconfigure('Heartbeat', '-image' => 'HeartbeatSmall', ); |
} |
# Flugzeit aktualisieren |
# Flugzeit selber mitzählen, da $MkOsd{'FlyingTime'} immer 0 (0.14b) |
if ( &MkIsFlying() ) |
{ |
$MkFlyingTime += 1; |
} |
# Update ODO-Meter |
if ( &CurPosIsValid() ) |
{ |
my $C_Lat = $MkOsd{'CurPos_Lat'}; |
my $C_Lon = $MkOsd{'CurPos_Lon'}; |
if ( $OdoFirst ne "" ) |
{ |
my ($Dist, $Bearing) = &MapGpsTo($C_Lat, $C_Lon, $OdoPos_Lat, $OdoPos_Lon ); |
$OdoMeter += $Dist; |
} |
$OdoPos_Lat = $C_Lat; |
$OdoPos_Lon = $C_Lon; |
$OdoFirst = "1"; |
} |
# # Bat capacity |
# my $Capacity = 100.0; |
# my $CapacityText = ""; |
# if ( &MkIsFlying() ) |
# { |
# if ( $UBatAverage eq "" ) |
# { |
# $UBatAverage = $MkOsd{'UBat'}; |
# } |
# $UBatAverage = (9.0 * $UBatAverage + $MkOsd{'UBat'}) / 10.0; |
# $Capacity = &BatCapacity($UBatAverage); |
# $CapacityText = sprintf ("(%d %)", int ($Capacity + 0.5) ); |
# } |
# $map_canvas->itemconfigure ('MK-OSD-Bat-Level', '-text' => $CapacityText ); |
# # Estimate remaining flight time |
# my $TextTimeLeft = ""; |
# if ( &MkIsFlying() and $Capacity <= 90 ) |
# { |
# my $MaxTime = 100.0 / (100.0 - $Capacity) * $MkFlyingTime; |
# my $TimeLeft = $MaxTime - $MkFlyingTime; |
# $TextTimeLeft = sprintf ("(%d min)", int ($TimeLeft / 60.0 + 0.8) ); |
# } |
# $map_canvas->itemconfigure ('MK-OSD-Tim-Left', '-text' => $TextTimeLeft ); |
# Footprint |
if ( $Cfg->{'mkcockpit'}->{'FootprintLength'} > 0 ) |
{ |
if ( &CurPosIsValid() ) |
{ |
# neuen Footprint hinten anhaengen |
my ($x, $y) = &MapGps2XY($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}); |
push @Footprint, $x, $y; |
} |
while ( $#Footprint / 2 > $Cfg->{'mkcockpit'}->{'FootprintLength'} ) |
{ |
# alte Footprints entfernen |
splice @Footprint, 0, 2; |
} |
&FootprintRedraw(); |
} |
# show tracking antenna icon |
if ( $MkTrack{'HomePos_Lat'} ne "" and $MkTrack{'HomePos_Lon'} ne "" ) |
{ |
# show antenna icon |
my ($x, $y) = &MapGps2XY($MkTrack{'HomePos_Lat'}, $MkTrack{'HomePos_Lon'}); |
my $IconHeight = 48; |
my $IconWidth = 48; |
$map_canvas->coords('Track-Antenna', $x - $IconWidth/2, $y - $IconHeight ); |
} |
else |
{ |
# move icon out of sight |
$map_canvas->coords('Track-Antenna', 0, -50 ); |
} |
# fun :-) |
if ( int rand (100) == 43 ) |
{ |
&TtsSpeak ('LOW', $Translate{'TtsFun'}); |
} |
} |
}); |
# |
# Timer: 1s - TTS Sprachausgabe |
# |
$frame_map_top->repeat (1000, sub |
{ |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
lock (%MkOsd); # until end of block |
my $StatusInterval = $Cfg->{'tts'}->{'StatusInterval'} || "30"; |
$SpeechTimer ++; |
my @TtsMsg; |
if ( &MkOsdIsValid() ) |
{ |
# Gueltige OSD Daten |
if ( $SpeechTimer % $StatusInterval == 0 ) |
{ |
# |
# give system status, low prio messages |
# |
# clear old low prio messages |
&TtsClear('LOW'); |
# Flight time |
my $Min = int ( ($MkFlyingTime +1) / 60); |
my $Sec = int ( ($MkFlyingTime +1) % 60); |
my $Text = sprintf ("$Translate{'TtsFlightTimeMinSec'}", $Min, $Sec); |
if ( $Min == 0 ) |
{ |
$Text = sprintf ("$Translate{'TtsFlightTimeSec'}", $Sec); |
} |
&TtsSpeak ('LOW', "$Text"); |
# Battery |
my ($Volt, $Tenth) = split '\.', $System{'UBat'}; |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsBattery'}", $Volt, $Tenth)); |
# Altitude |
if ( $System{'Alt'} < 0 ) |
{ |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsAltitudeNegative'}", abs($System{'Alt'}) ) ); |
} |
else |
{ |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsAltitude'}", $System{'Alt'} ) ); |
} |
# Satellites |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsSatellite'}", $MkOsd{'SatsInUse'}) ); |
} |
# high prio messages |
if ( $SpeechTimer % 5 == 0 ) |
{ |
if ( $System{'BatWarning'} ) { push @TtsMsg, $Translate{'TtsBatteryWarning'}; } |
if ( $System{'RCQuality'} eq "WEAK" ) { push @TtsMsg, $Translate{'TtsRcWeak'}; } |
if ( $System{'RCQuality'} eq "NO" ) { push @TtsMsg, $Translate{'TtsRcNo'}; } |
if ( $System{'CrossingBorder'} ) { push @TtsMsg, $Translate{'TtsCrossingBorder'}; } |
if ( $System{'OutsideBorder'} ) { push @TtsMsg, $Translate{'TtsOutsideAirfield'}; } |
if ( $System{'RangeWarning'} ) { push @TtsMsg, $Translate{'TtsRange'}; } |
} |
} |
else |
{ |
# no data link |
if ( $SpeechTimer % 5 == 0 ) |
{ |
push @TtsMsg, $Translate{'TtsNoDataLink'}; |
} |
} |
# speak high prio messages |
if ( scalar @TtsMsg > 0 ) |
{ |
# Clear pending messsages |
&TtsClear('HIGH'); |
# Speak collected messages |
foreach $Msg (@TtsMsg) |
{ |
&TtsSpeak ('HIGH', $Msg); |
} |
} |
}); |
__END__ |
/MissionCockpit/tags/V0.2.7/logging.pl |
---|
0,0 → 1,407 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# logging.pl - CSV, KLM, GPS Logging |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-02-23 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-05-01 0.1.1 rw configurable logging interval |
# 2009-05-17 0.1.7 rw _Timestamp timeout von 2s auf 10s erhoeht |
# 2009-09-30 0.1.8 rw SignalHandler removed |
# |
############################################################################### |
$Version{'logging.pl'} = "0.1.8 - 2009-09-30"; |
# |
# Parameter |
# |
my $LoopTime = $Cfg->{'logging'}->{'Intervall'} || 1; # in s |
$LoopTime *= 1000000; # in us |
# Packages |
use threads; |
use threads::shared; |
use Time::HiRes qw(usleep); |
require "mkcomm.pl"; # MK communication |
require "geserver.pl"; # Google Earth Server |
require "translate.pl"; # Übersetzungstable |
my $LogCsvIsOpen = 0; |
my $LogKmlIsOpen = 0; |
my $LogGpxIsOpen = 0; |
my $GeServerIsRunning = 0; |
# |
# CSV |
# |
# Open CSV logfile |
sub LogCsvOpen() |
{ |
if ( ! $LogCsvIsOpen ) |
{ |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $Filename = sprintf ("mk-%04d%02d%02d-%02d%02d%02d.csv", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
open LOGCSV, ">$Cfg->{'logging'}->{'CsvLogDir'}/$Filename"; |
$LogCsvIsOpen = 1; |
# print labes at first line |
# NC OSD |
my $Sep = ""; |
foreach $Label (sort keys %MkOsd) |
{ |
if ( $Translate{$Label} ne "" ) |
{ |
$Label = $Translate{$Label}; |
} |
print LOGCSV "$Sep" . "$Label"; |
$Sep = ","; |
} |
# NC Debug |
foreach $Label (sort keys %MkNcDebug) |
{ |
if ( $Translate{$Label} ne "" ) |
{ |
$Label = $Translate{$Label}; |
} |
print LOGCSV "$Sep" . "$Label"; |
} |
print LOGCSV "\n"; |
} |
return 0; |
} |
# Close CSV |
sub LogCsvClose() |
{ |
if ( $LogCsvIsOpen ) |
{ |
close LOGCSV; |
$LogCsvIsOpen = 0; |
} |
return 0; |
} |
# Log CSV |
sub LogCsv() |
{ |
lock %MkOsd; # until end of Block |
lock %MkNcDebug; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 ) |
{ |
# active connection to MK |
&LogCsvOpen(); |
# NC OSD |
my $Sep = ""; |
foreach $Label (sort keys %MkOsd) |
{ |
print LOGCSV "$Sep" . "$MkOsd{$Label}"; |
$Sep = ","; |
} |
# NC Debug |
foreach $Label (sort keys %MkNcDebug) |
{ |
print LOGCSV "$Sep" . "$MkNcDebug{$Label}"; |
} |
print LOGCSV "\n"; |
} |
else |
{ |
# connection to MK lost, close Logfile |
&LogCsvClose(); |
} |
return 0; |
} |
# |
# GPX |
# http://www.topografix.com/gpx_manual.asp |
# |
# Open GPX logfile |
sub LogGpxOpen() |
{ |
if ( ! $LogGpxIsOpen ) |
{ |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
my $Filename = "mk-" . $TimeStamp . ".gpx"; |
open LOGGPX, ">$Cfg->{'logging'}->{'GpxLogDir'}/$Filename"; |
$LogGpxIsOpen = 1; |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); |
my $UtcTimeStamp = sprintf ("%04d-%02d-%02dT%02d:%02d:%02dZ", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
# print GPX-Header |
print LOGGPX <<EOF; |
<?xml version="1.0" encoding="UTF-8"?> |
<gpx |
version="1.0" |
creator="MK Mission Cockpit" |
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" |
xmlns="http://www.topografix.com/GPX/1/0" |
xsi:schemaLocation="http://www.topografix.com/GPX/1/0 http://www.topografix.com/GPX/1/0/gpx.xsd"> |
<time>${UtcTimeStamp}</time> |
<trk> |
<name>Mikrokopter GPS logging</name> |
<desc>Flight ${TimeStamp}</desc> |
<trkseg> |
EOF |
} |
return 0; |
} |
# Close GPX |
sub LogGpxClose() |
{ |
if ( $LogGpxIsOpen ) |
{ |
# print GPX-Trailer |
print LOGGPX <<EOF; |
</trkseg> |
</trk> |
</gpx> |
EOF |
close LOGGPX; |
$LogGpxIsOpen = 0; |
} |
return 0; |
} |
# Log GPX |
sub LogGpx() |
{ |
lock %MkOsd; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 and |
$MkOsd{'MKFlags'} & 0x02 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
# active connection to MK, MK is flying, valid GPS |
&LogGpxOpen(); |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); |
my $UtcTimeStamp = sprintf ("%04d-%02d-%02dT%02d:%02d:%02dZ", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
my $Speed = $MkOsd{'GroundSpeed'} / 100; # m/s |
printf LOGGPX <<EOF; |
<trkpt lat="$MkOsd{'CurPos_Lat'}" lon="$MkOsd{'CurPos_Lon'}"> |
<ele>$MkOsd{'CurPos_Alt'}</ele> |
<time>${UtcTimeStamp}</time> |
<sat>$MkOsd{'SatsInUse'}</sat> |
<course>$MkOsd{'CompassHeading'}</course> |
<speed>$Speed</speed> |
<extensions> |
<Target-Lat>$MkOsd{'TargetPos_Lat'}</Target-Lat> |
<Target-Lon>$MkOsd{'TargetPos_Lon'}</Target-Lon> |
<Target-Alt>$MkOsd{'TargetPos_Alt'}</Target-Alt> |
<Target-Bearing>$MkOsd{'TargetPosDev_Bearing'}</Target-Bearing> |
<Target-Dist>$MkOsd{'TargetPosDev_Dist'}</Target-Dist> |
<Waypoint>$MkOsd{'WaypointIndex'} / $MkOsd{'WaypointNumber'}</Waypoint> |
<Altimeter>$MkOsd{'Altimeter'}</Altimeter> |
<Variometer>$MkOsd{'Variometer'}</Variometer> |
<UBat>$MkOsd{'UBat'}</UBat> |
<AngleNick>$MkOsd{'AngleNick'}</AngleNick> |
<AngleRoll>$MkOsd{'AngleRoll'}</AngleRoll> |
<MKFlags>$MkOsd{'MKFlags'}</MKFlags> |
<NCFlags>$MkOsd{'NCFlags'}</NCFlags> |
</extensions> |
</trkpt> |
EOF |
} |
else |
{ |
&LogGpxClose(); |
} |
} |
# |
# KML |
# http://code.google.com/intl/de-DE/apis/kml/documentation/kml_tut.html |
# |
# Open KML logfile |
sub LogKmlOpen() |
{ |
if ( ! $LogKmlIsOpen ) |
{ |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
my $Filename = "mk-" . $TimeStamp . ".kml"; |
open LOGKML, ">$Cfg->{'logging'}->{'KmlLogDir'}/$Filename"; |
$LogKmlIsOpen = 1; |
# print KML-Header |
print LOGKML <<EOF; |
<?xml version="1.0" encoding="UTF-8"?> |
<kml xmlns="http://earth.google.com/kml/2.2"> |
<Document> |
<name>Mikrokopter GPS logging</name> |
<Style id="MK_gps-style"> |
<LineStyle> |
<color>ff0000ff</color> |
<width>2</width> |
</LineStyle> |
</Style> |
<Placemark> |
<name>Flight ${TimeStamp}</name> |
<styleUrl>MK_gps-style</styleUrl> |
<LineString> |
<tessellate>1</tessellate> |
<altitudeMode>relativeToGround</altitudeMode> |
<coordinates> |
EOF |
} |
return 0; |
} |
# Close KML |
sub LogKmlClose() |
{ |
if ( $LogKmlIsOpen ) |
{ |
# print KML-Trailer |
print LOGKML <<EOF; |
</coordinates> |
</LineString> |
</Placemark> |
</Document> |
</kml> |
EOF |
close LOGKML; |
$LogKmlIsOpen = 0; |
} |
return 0; |
} |
# Log KML |
sub LogKml() |
{ |
lock %MkOsd; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 and |
$MkOsd{'MKFlags'} & 0x02 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
# active connection to MK, MK is flying, valid GPS |
&LogKmlOpen(); |
my $AltRel = $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'}; |
if ( $AltRel < 0 ) { $AltRel = 0; } |
printf LOGKML " %f, %f, %f\n", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $AltRel; |
} |
else |
{ |
&LogKmlClose(); |
} |
} |
# Send Coords to GoogleEarth server |
sub Send2GeServer() |
{ |
lock %MkOsd; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 and |
$MkOsd{'MKFlags'} & 0x02 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
# active connection to MK, MK is flying, valid GPS |
my $AltRel = $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'}; |
if ( $AltRel < 0 ) { $AltRel = 0; } |
push @GeCoords, sprintf "%f, %f, %f", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $AltRel; |
} |
} |
sub MkLogLoop() |
{ |
while (1) |
{ |
&LogCsv(); |
&LogKml(); |
&LogGpx(); |
&Send2GeServer(); # Google Earth |
# kurz schlafen legen |
usleep $LoopTime; |
} |
} |
# |
# Hauptprgramm |
# |
if ( $0 =~ /logging.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
# Kommunikation zum MK herstellen |
$mk_thr = threads->create (\&MkCommLoop) -> detach(); |
&MkLogLoop(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/map/default-800.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/map/hemhofen-800.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.7/map/hemhofen-example.xml |
---|
0,0 → 1,30 |
<mkcockpit-Maps> |
<Hemhofen |
Name="Hemhofen" |
File="hemhofen-800.gif" |
P1_x="66" |
P1_y="62" |
P2_x="778" |
P2_y="488" |
P1_Lat="49.685333" |
P1_Lon="10.950134" |
P2_Lat="49.682949" |
P2_Lon="10.944580" |
Border="555, 430, |
516, 555, |
258, 555, |
100, 300, |
580, 260, |
530, 94, |
627, 130, |
735, 300, |
680, 400, |
757, 470, |
720, 515, |
575, 420," |
/> |
</mkcockpit-Maps> |
/MissionCockpit/tags/V0.2.7/map/map.pl |
---|
0,0 → 1,275 |
############################################################################### |
# |
# map.pl - Map definition |
# |
## Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
## |
# 2009-03-06 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-04-18 0.1.1 rw Select default map, if configured map does not exist |
# 2009-07-22 0.1.2 rw Offset_x and Offset_y for adjustment of map calibration |
# 2009-08-15 0.1.3 rw Tracking Antenne Home position added |
# Player home position added |
# Read map definition from XML file |
# 2009-09-29 0.1.4 rw Read map definition from KML file (GE import) |
# Allow Config lines in map definition file (like mkcockpit.xml) |
# |
############################################################################### |
$Version{'map/map.pl'} = "0.1.4 - 2009-09-29"; |
use XML::Simple; # http://search.cpan.org/dist/XML-Simple-2.18/lib/XML/Simple.pm |
%Maps = |
( |
Default => { |
'Name' => "Default", |
'File' => 'default-800.gif', |
'P1_x' => '71', # calibration P1, P2 |
'P1_y' => '472', |
'P2_x' => '500', |
'P2_y' => '103', |
'P1_Lat' => '48.856253', |
'P1_Lon' => '2.3500000', |
'P2_Lat' => '54.090153', |
'P2_Lon' => '12.133249', |
# 'Offset_x' => 5, # Optional Pixel offset MK to right |
# 'Offset_y' => 5, # Optional pixel offset MK to top |
# 'Home_Lat' => '54.090153', # Optional home position for player |
# 'Home_Lon' => '12.133249', # Optional home position for player |
# 'Poi_Lat' => '54.090153', # Optional POI position for player |
# 'Poi_Lon' => '12.133249', # Optional POI position for player |
# 'Track_Lat' => '49.685333', # Optional Tracking Antenna pos |
# 'Track_Lon' => '10.950134', # Optional Tracking Antenna pos |
# 'Track_Alt' => '500', # Optional Tracking Antenna altitude |
# 'Track_Bearing' => 10, # Optional Tracking antenne direction |
# 'Border' => [ 555, 430, # airfield border |
# 516, 555, |
# 258, 555, |
# 100, 300, |
# 580, 260, |
# 530, 94, |
# 627, 130, |
# 735, 300, |
# 680, 400, |
# 757, 470, |
# 720, 515, |
# 575, 420, |
# ], |
}, |
); |
# |
# load additional Maps from XML files |
# |
my $MapDir = $Cfg->{'map'}->{'MapDir'} || "map"; |
if ( -d $MapDir ) |
{ |
opendir DIR, $MapDir; |
my @Files = readdir DIR; |
@Files = grep /\.xml$/, @Files; |
closedir DIR; |
foreach $Xml (@Files) |
{ |
my $MapConfigFile = "$MapDir/$Xml"; |
if ( -f $MapConfigFile ) |
{ |
my $XmlMap = XMLin($MapConfigFile); |
foreach $Location (keys %{$XmlMap}) |
{ |
foreach $Key (keys %{$XmlMap->{$Location}} ) |
{ |
my $Value = $XmlMap->{$Location}->{$Key}; |
if ( $Key =~ /Border/i ) |
{ |
$Value =~ s/\s//g; |
my @Border = split ',', $Value; |
@{$Maps{$Location}->{$Key}} = @Border; |
} |
else |
{ |
$Maps{$Location}->{$Key} = $Value; |
} |
} |
} |
} |
} |
} |
# |
# load additional Maps from KML files |
# |
my $MapDir = $Cfg->{'map'}->{'MapDir'} || "map"; |
if ( -d $MapDir ) |
{ |
opendir DIR, $MapDir; |
my @Files = readdir DIR; |
@Files = grep /\.kml$/, @Files; |
closedir DIR; |
foreach $Kml (@Files) |
{ |
my $MapConfigFile = "$MapDir/$Kml"; |
if ( -f $MapConfigFile ) |
{ |
my $KmlMap = XMLin($MapConfigFile); |
my $Name = $KmlMap->{'Document'}->{'Folder'}->{'name'}; |
my $Desc = $KmlMap->{'Document'}->{'Folder'}->{'description'}; |
$Maps{$Name}->{'Name'} = $Name; |
# Airfield Border |
my $Border = ""; |
my $bBorder = 0; |
# parse config lines |
@DescLines = split '\n', $Desc; |
foreach $Line (@DescLines) |
{ |
if ( $bBorder ) |
{ |
# collect border lines |
if ( $Line =~ /=/i ) |
{ |
# New keyword found. End of multi-line border config |
$bBorder = 0; |
} |
else |
{ |
$Border = "$Border" . "$Line"; |
} |
} |
if ( $Line =~ /\s*(\S*)\s*=\s*(.*)/i) |
{ |
my $Key = $1; |
my $Value = $2; |
chomp $Value; |
# search for border keyword |
if ($Key =~ /border/i ) |
{ |
$Border = $Value; |
$bBorder = 1; |
} |
else |
{ |
$Maps{$Name}->{$Key} = $Value; |
} |
} |
} |
if ( $Border ne "" ) |
{ |
$Border =~ s/\s//g; |
my @Border = split ',', $Border; |
@{$Maps{$Name}->{'Border'}} = @Border; |
} |
# P1 calibration point |
my $P1 = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'P1'}->{'Point'}->{'coordinates'}; |
my $P1Desc = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'P1'}->{'description'}; |
($Maps{$Name}->{'P1_Lon'}, $Maps{$Name}->{'P1_Lat'}) = split ',', $P1; |
if ( $P1Desc =~ /\s*x\s*=\s*(\d*)/i) { $Maps{$Name}->{'P1_x'} = $1; } # x=nnn |
if ( $P1Desc =~ /\s*y\s*=\s*(\d*)/i) { $Maps{$Name}->{'P1_y'} = $1; } # y=nnn |
# P2 calibration point |
my $P2 = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'P2'}->{'Point'}->{'coordinates'}; |
my $P2Desc = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'P2'}->{'description'}; |
($Maps{$Name}->{'P2_Lon'}, $Maps{$Name}->{'P2_Lat'}) = split ',', $P2; |
if ( $P2Desc =~ /\s*x\s*=\s*(\d*)/i) { $Maps{$Name}->{'P2_x'} = $1; } # x=nnn |
if ( $P2Desc =~ /\s*y\s*=\s*(\d*)/i) { $Maps{$Name}->{'P2_y'} = $1; } # y=nnn |
# Home position |
if ( $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'Home'}->{'visibility'} ne "0" ) |
{ |
my $Home = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'Home'}->{'Point'}->{'coordinates'}; |
my $HomeDesc = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'Home'}->{'description'}; |
($Maps{$Name}->{'Home_Lon'}, $Maps{$Name}->{'Home_Lat'}) = split ',', $Home; |
} |
# POI position |
if ( $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'POI'}->{'visibility'} ne "0" ) |
{ |
my $Poi = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'POI'}->{'Point'}->{'coordinates'}; |
my $PoiDesc = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'POI'}->{'description'}; |
($Maps{$Name}->{'Poi_Lon'}, $Maps{$Name}->{'Poi_Lat'}) = split ',', $Poi; |
} |
# Antenna tracker position |
if ( $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'Antenna'}->{'visibility'} ne "0" ) |
{ |
my $Track = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'Antenna'}->{'Point'}->{'coordinates'}; |
my $TrackDesc = $KmlMap->{'Document'}->{'Folder'}->{'Placemark'}->{'Antenna'}->{'description'}; |
($Maps{$Name}->{'Track_Lon'}, $Maps{$Name}->{'Track_Lat'}) = split ',', $Track; |
if ( $TrackDesc =~ /\s*Track_Alt\s*=\s*(\d*)/i) { $Maps{$Name}->{'Track_Alt'} = $1; } # Track_Alt=nnn |
if ( $TrackDesc =~ /\s*Track_Bearing\s*=\s*(\d*)/i) { $Maps{$Name}->{'Track_Bearing'} = $1; } # Track_Bearing=nnn |
} |
} |
} |
} |
# |
# Die verwendete Karte |
# |
my $MapDefault = $Cfg->{'map'}->{'MapDefault'}; |
if ( defined $Maps{$MapDefault} ) |
{ |
$Maps{'Current'} = $Maps{$MapDefault}; |
} |
else |
{ |
$Maps{'Current'} = $Maps{'Default'}; |
print "Map \"$MapDefault\" not found in map.pl. Using \"Default\" map\n"; |
} |
# |
# Todo: Karte automatisch anhand der aktuellen GPS Position auswählen |
# |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/mkcockpit.pl |
---|
0,0 → 1,1528 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# mkcockpit.pl - MK Mission Cockpit - GUI |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-02-20 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-04-16 0.1.1 rw Bugfix, ALT= average of airsensor and Sat |
# 2009-05-14 0.2.0 rw Waypoint Player |
# 2009-05-17 0.2.1 rw Cursor-Steuerung fuer WP-Player. Cmdline-Parameter "-geometry" |
# 2009-07-18 0.2.2 rw DE/EN multinational |
# Target-Balloon with Distance, Tolerance and Holdtime |
# Fix footprint "Ausreiser" |
# JPEG and PNG maps supported |
# Player for KML Files |
# 2009-07-26 0.2.3 rw System Messages Balloon |
# 2009-07-31 0.2.4 rw ODO Kilometerzähler |
# Enter WP-Number from Keyboard |
# Random WP-Player (Waypoint and Map) |
# Check Airfield Border |
# Draw Calibration points on map |
# 2009-08-08 0.2.5 rw KML Recorder |
# Text to speech |
# Subroutines moved to libmkcockpit.pl |
# Timer moved to libmktimer.pl |
# Start Scenarion configuration |
# Battery capacity estimation |
# Read map definition from maps/map.xml |
# 2009-08-23 0.2.6 rw Tracking-Antenna Icon |
# Show Fox only in Player-Pause mode |
# POI heading control |
# Display scale |
# Measuring-tool on left mouse button |
# Display Operation Radius Border |
# Read map definition from KML file (GE import) |
# Include of local *.pm changed |
# Copy x/y/Lat/Lon to Clipboard when pressing left mouse button |
# Calculate size of map image |
# track.pl - Commandline parameter added for COM ports |
# don't use local perl libs any more |
# 2009-10-18 0.2.7 rw Mk-Simulator |
# Start tracker at program start. Coldstart at MK-calibration |
# COM Port >9; PortSetSkip config |
# Reset Flight-Time and ODO when clicking on OSD-value |
# |
############################################################################### |
$Version = "0.2.7 - 2009-10-18"; |
# change working directory to program path |
my $Cwd = substr ($0, 0, rindex ($0, "mkcockpit.pl")); |
chdir $Cwd; |
# set path for local Perl libs |
push @INC, $Cwd . "perl/lib"; |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Tk; |
use Tk::Balloon; |
use Tk::Dialog; |
use Tk::Notebook; |
use Tk::JPEG; # http://search.cpan.org/~srezic/Tk-804.028/JPEG/JPEG.pm |
use Tk::PNG; # http://search.cpan.org/~srezic/Tk-804.028/PNG/PNG.pm |
use Math::Trig; |
use Time::HiRes qw(usleep); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
use XML::Simple; # http://search.cpan.org/dist/XML-Simple-2.18/lib/XML/Simple.pm |
use Clipboard; # http://search.cpan.org/~king/Clipboard-0.09/lib/Clipboard.pm |
use Image::Size; # http://search.cpan.org/~rjray/Image-Size-3.2/lib/Image/Size.pm |
# Version setting |
share (%Version); |
$Version{'mkcockpit.pl'} = $Version; |
# Read configuration |
$XmlConfigFile = "mkcockpit.xml"; |
$Cfg = XMLin($XmlConfigFile); |
require "track.pl"; # Tracking antenna |
require "mkcomm.pl"; # MK communication |
require "logging.pl"; # CSV and GPX Logging |
require "geserver.pl"; # Google Earth Server |
require "$Cfg->{'map'}->{'MapDir'}/map.pl"; # Landkarte |
require "libmap.pl"; # map subs |
require "translate.pl"; # Übersetzungstable |
require "tts.pl"; # Text to Speech |
require "libmkcockpit.pl"; # Subroutines |
require "libmksim.pl"; # MK Simulator |
# Commandline parameter |
my %CmdLine = @ARGV; |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
# optional map specific Cfg setup from map definition |
foreach $Key (keys %Map) |
{ |
# Cfg:Section:Keyword |
if ( $Key =~ /^Cfg:(\S*):(\S*)/i ) |
{ |
$Section = $1; |
$Keyword = $2; |
$Cfg->{$Section}->{$Keyword} = $Map{$Key}; |
} |
} |
# Canvas size - get image size |
my $ImgFile = "$Cfg->{'map'}->{'MapDir'}/$Map{'File'}"; |
($MapSizeX, $MapSizeY, my $ImgError) = imgsize ($ImgFile); |
if ( $MapSizeX eq "" ) |
{ |
print "$ImgFile: $ImgError\n"; |
# Try size information from map definition |
$MapSizeX = $Map{'Size_X'}; |
$MapSizeY = $Map{'Size_Y'}; |
} |
# Thread fuer Kommunikation mit MK starten |
# Output: %MkOsd, %MkTarget, %MkNcDebug, %Mk |
# Input: Thread-Queue: $MkSendQueue |
$mk_thr = threads->create (\&MkCommLoop) -> detach(); |
# Start Logging Thread |
$log_thr = threads->create (\&MkLogLoop) -> detach(); |
# Start GoogleEarth Thread |
$ge_thr = threads->create (\&GeServer) -> detach(); |
# Start TTS Thread |
$tts_thr = threads->create (\&TtsLoop) -> detach(); |
# Start Antenna tracker |
if ( $Cfg->{'track'}->{'Active'} =~ /y/i ) |
{ |
$track_thr = threads->create (\&TrackAntennaGps)->detach(); |
} |
# |
# Player: |
# Waypoint-List: @Waypoints |
# KML-Target-List: @KmlTargets |
# |
# Player state machine |
$PlayerMode = 'Stop'; # Play, Stop, Pause, Home ... |
$PlayerWptKmlMode = 'WPT'; # WPT, KML |
$PlayerRandomMode = 'STD'; # STD, RND, MAP |
$PlayerRecordMode = ""; # "", REC |
$WpPlayerIndex = 0; |
$WpPlayerHoldtime = -1; |
$KmlPlayerIndex = 0; |
$PlayerPause_Lat = ""; |
$PlayerPause_Lon = ""; |
# Point Of Interest (POI) |
my $Poi_x = $MapSizeX/2-100; |
my $Poi_y = $MapSizeY/2 ; |
($Poi_Lat, $Poi_Lon) = &MapXY2Gps($Poi_x + 24, $Poi_y + 48); |
# POI from Map configuration |
if ( $Map{'Poi_Lat'} ne "" and $Map{'Poi_Lon'} ne "" ) |
{ |
$Poi_Lat = $Map{'Poi_Lat'}; |
$Poi_Lon = $Map{'Poi_Lon'}; |
($Poi_x, $Poi_y) = &MapGps2XY($Poi_Lat, $Poi_Lon); |
$Poi_x = $Poi_x - 24; |
$Poi_y = $Poi_y - 48; |
} |
$Poi_Mode = 0; # POI Mode off |
# Hauptfenster |
$main = new MainWindow; |
$main->title ("MK Mission Cockpit - Version $Version"); |
if ( $CmdLine{'-geometry'} ne "" ) |
{ |
$main->geometry( "$CmdLine{'-geometry'}" ); |
} |
# pattern for dashed lines |
my $stipple_bits = []; |
foreach my $b (1..8) |
{ |
push @$stipple_bits, pack ('b8', '1' x $b . '.' x (8 - $b)); |
$main->DefineBitmap("stipple$b" => 8, 1, $stipple_bits->[$b-1]); |
} |
#----------------------------------------------------------------- |
# Menu |
#----------------------------------------------------------------- |
# Menu bar |
my $menu_bar = $main->Menu; |
$main->optionAdd("*tearOff", "false"); |
$main->configure ('-menu' => $menu_bar); |
my $menu_file = $menu_bar->cascade('-label' => $Translate{'File'}); |
$menu_file->command('-label' => $Translate{'Preferences'}, |
'-command' => [\&Configure], |
); |
$menu_file->separator; |
$menu_file->command('-label' => $Translate{'Exit'}, |
'-command' => [\&CbExit ], |
); |
my $menu_debug = $menu_bar->cascade(-label => $Translate{'Debug'}); |
$menu_debug->command('-label' => $Translate{'NcOsdDataset'}, |
'-command' => [\&DisplayHash, \%MkOsd, $Translate{'NcOsdDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->command('-label' => $Translate{'NcTargetDataset'}, |
'-command' => [\&DisplayHash, \%MkTarget, $Translate{'NcTargetDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->command('-label' => $Translate{'NcDebugDataset'}, |
'-command' => [\&DisplayHash, \%MkNcDebug, $Translate{'NcDebugDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->command('-label' => $Translate{'NcOther'}, |
'-command' => [\&DisplayHash, \%Mk, $Translate{'NcOther'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->separator; |
$menu_debug->command('-label' => $Translate{'TrackingDebugDataset'}, |
'-command' => [\&DisplayHash, \%MkTrack, $Translate{'TrackingDebugDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->separator; |
$menu_debug->command('-label' => $Translate{'MkDebugSim'}, |
'-command' => \&MkSim, |
); |
#$menu_debug->command('-label' => $Translate{'MapDebugDataset'}, |
# '-command' => [\&DisplayHash, \%Map, $Translate{'MapDebugDataset'}, "Display"], |
# ); |
my $menu_help = $menu_bar->cascade(-label => $Translate{'Help'}); |
$menu_help->command('-label' => 'Version', |
'-command' => [\&DisplayHash, \%Version, $Translate{'Version'}, "Display"], |
); |
$menu_help->separator; |
$menu_help->command('-label' => $Translate{'About'}, |
'-command' => sub |
{ |
my $License = <<EOF; |
Copyright (C) 2009 Rainer Walther (rainerwalther-mail\@web.de) |
Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
See LICENSE.TXT |
EOF |
my $DlgAbout = $frame_map->Dialog('-title' => $Translate{'AboutMissionCockpit'}, |
'-text' => "$License", |
'-buttons' => ['OK'], |
'-bitmap' => 'info', |
); |
$DlgAbout->Show; |
}); |
# Hauptfenster Statuszeile |
$frame_status = $main->Frame( '-background' => 'lightgray', |
) -> pack('-side' => 'bottom', |
'-anchor' => 'w', |
'-fill' => 'none', |
'-expand' => 'y', |
); |
$status_line = $frame_status->Label ('-text' => $Translate{'StatusLine'}, |
) -> pack ('-side' => 'bottom', |
); |
#----------------------------------------------------------------- |
# Frames |
#----------------------------------------------------------------- |
# |
# Frame: Map |
# |
$frame_map = $main->Frame( '-background' => 'lightgray', |
'-relief' => 'sunken', |
'-borderwidth' => 5, |
) -> pack('-side' => 'top', |
'-fill' => 'x', |
); |
# Map Überschrift |
$frame_map_top = $frame_map->Frame() -> pack( '-side' => 'top', |
'-expand' => 'x', |
'-anchor' => 'w', |
); |
$frame_map_top->Label ('-text' => "$Translate{'Map'}: $Map{'Name'} ($Map{'File'})", |
'-background' => 'lightgray', |
'-relief' => 'flat', |
) -> pack( '-side' => 'left' ); |
# Map Statuszeile |
$map_status = $frame_map->Frame( '-background' => 'lightgray', |
) -> pack('-side' => 'bottom', |
'-anchor' => 'w', |
'-fill' => 'none', |
'-expand' => 'y', |
); |
$map_status_line = $map_status->Label ( '-text' => $Translate{'StatusLine'}, |
'-background' => 'lightgray', |
) -> pack ('-side' => 'bottom',); |
# |
# Map Canvas |
# |
$map_canvas = $frame_map->Canvas( '-width' => $MapSizeX, |
'-height' => $MapSizeY, |
'-cursor' => 'cross', |
) -> pack(); |
# Images and Icons on canvas |
my @Icons = ( |
# Image Tag File Pos_x Pos_y |
'Map', 'Map', "$Cfg->{'map'}->{'MapDir'}/$Map{'File'}", 0, 0, |
'HeartbeatSmall', 'Heartbeat', "$Cfg->{'mkcockpit'}->{'IconHeartSmall'}", $MapSizeX/4, 10, |
'HeartbeatLarge', 'Heartbeat', "$Cfg->{'mkcockpit'}->{'IconHeartLarge'}", $MapSizeX/4, -100, |
'Satellite-Photo', 'Satellite', "$Cfg->{'mkcockpit'}->{'IconSatellite'}", $MapSizeX-300, -100, |
'Antenna-Photo', 'Track-Antenna',"$Cfg->{'track'}->{'IconAntenna'}", 0, -50, |
'POI-Photo', 'POI' ,"$Cfg->{'mkcockpit'}->{'IconPoi'}", $Poi_x, $Poi_y, |
'Waypoint-Photo', 'Waypoint', "$Cfg->{'mkcockpit'}->{'IconWaypoint'}", 0, -150, |
'Target-Photo', 'Target', "$Cfg->{'mkcockpit'}->{'IconTarget'}", 0, -100, |
'Fox-Photo', 'Fox', "$Cfg->{'mkcockpit'}->{'IconFox'}", $MapSizeX/2-100, $MapSizeY/2, |
'WpPlay-Foto', 'Wp-PlayPause', "$Cfg->{'waypoint'}->{'IconPlay'}", $MapSizeX/2+150, $MapSizeY-48, |
'WpPause-Foto', 'Wp-PlayPause', "$Cfg->{'waypoint'}->{'IconPause'}", $MapSizeX/2+150, -100, |
'WpStop-Foto', 'Wp-Stop', "$Cfg->{'waypoint'}->{'IconStop'}", $MapSizeX/2+200, $MapSizeY-48, |
'WpNext-Foto', 'Wp-Next', "$Cfg->{'waypoint'}->{'IconNext'}", $MapSizeX/2+50, $MapSizeY-48, |
'WpPrev-Foto', 'Wp-Prev', "$Cfg->{'waypoint'}->{'IconPrev'}", $MapSizeX/2, $MapSizeY-48, |
'WpFirst-Foto', 'Wp-First', "$Cfg->{'waypoint'}->{'IconFirst'}", $MapSizeX/2-50, $MapSizeY-48, |
'WpLast-Foto', 'Wp-Last', "$Cfg->{'waypoint'}->{'IconLast'}", $MapSizeX/2+100, $MapSizeY-48, |
'WpHome-Foto', 'Wp-Home', "$Cfg->{'waypoint'}->{'IconHome'}", $MapSizeX/2-100, $MapSizeY-48, |
'WpRecord-Foto', 'Wp-Record', "$Cfg->{'waypoint'}->{'IconRecord'}", $MapSizeX/2-150, $MapSizeY-48, |
'WpRandomOff-Foto', 'Wp-WptRandom', "$Cfg->{'waypoint'}->{'IconRandomOff'}", $MapSizeX/2-200, -100, |
'WpRandomOn-Foto', 'Wp-WptRandom', "$Cfg->{'waypoint'}->{'IconRandomOn'}", $MapSizeX/2-200, $MapSizeY-48, |
'WpRandomMap-Foto', 'Wp-WptRandom', "$Cfg->{'waypoint'}->{'IconRandomMap'}", $MapSizeX/2-200, -100, |
'WpWpt-Foto', 'Wp-WptKml', "$Cfg->{'waypoint'}->{'IconWpt'}", $MapSizeX/2-250, $MapSizeY-48, |
'WpKml-Foto', 'Wp-WptKml', "$Cfg->{'waypoint'}->{'IconKml'}", $MapSizeX/2-250, -100 , |
); |
my $i = 0; |
for $Icon (0 .. $#Icons/5) |
{ |
my $Image = $Icons[$i++]; |
my $Tag = $Icons[$i++]; |
my $File = $Icons[$i++]; |
my $Pos_x = $Icons[$i++]; |
my $Pos_y = $Icons[$i++]; |
$map_canvas->Photo( $Image, |
'-file' => $File, |
); |
$map_canvas->createImage( $Pos_x, $Pos_y, |
'-tags' => $Tag, |
'-anchor' => 'nw', |
'-image' => $Image, |
); |
} |
# Calibration Points |
$map_canvas->createLine ( $Map{'P1_x'}-8, $Map{'P1_y'}, |
$Map{'P1_x'}+8, $Map{'P1_y'}, |
$Map{'P1_x'}, $Map{'P1_y'}, |
$Map{'P1_x'}, $Map{'P1_y'}-8, |
$Map{'P1_x'}, $Map{'P1_y'}+8, |
'-tags' => 'Calibration', |
'-arrow' => 'none', |
'-fill' => 'red', |
'-width' => 1, |
); |
$map_canvas->createLine ( $Map{'P2_x'}-8, $Map{'P2_y'}, |
$Map{'P2_x'}+8, $Map{'P2_y'}, |
$Map{'P2_x'}, $Map{'P2_y'}, |
$Map{'P2_x'}, $Map{'P2_y'}-8, |
$Map{'P2_x'}, $Map{'P2_y'}+8, |
'-tags' => 'Calibration', |
'-arrow' => 'none', |
'-fill' => 'red', |
'-width' => 1, |
); |
# scale |
my $x1 = $MapSizeX/2 +280; |
my $x2 = $MapSizeX -30; |
my $y1 = $MapSizeY - 20; |
my $y2 = $MapSizeY - 15; |
if ( $x2 - $x1 > 150 ) |
{ |
$x1 = $x2 - 150; |
} |
$map_canvas->createLine ( $x1, $y1, |
$x1, $y2, |
$x2, $y2, |
$x2, $y1, |
'-tags' => 'Scale', |
'-arrow' => 'none', |
'-fill' => 'red', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorScale'} || 'white', |
'-width' => 1, |
); |
my ($Lat1, $Lon1) = &MapXY2Gps($x1, $y1); |
my ($Lat2, $Lon2) = &MapXY2Gps($x2, $y2); |
my ($Dist, $Bearing) = &MapGpsTo($Lat1, $Lon1, $Lat2, $Lon2 ); |
$Dist = sprintf ("%.2f m", $Dist); |
$map_canvas->createText ( $x1 + ($x2 - $x1)/2 - 20, $y1 - ($y2 - $y1)/2, |
'-tags' => 'Scale-Text', |
'-text' => $Dist, |
'-anchor' => 'w', |
'-font' => '-*-Arial-Bold-R-Normal--*-120-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorScale'} || 'white', |
); |
# border polygon |
$map_canvas->createPolygon( @Map{'Border'}, |
'-tags' => 'Map-Border', |
'-fill' => '', |
'-outline' => $Cfg->{'mkcockpit'}->{'ColorAirfield'}, '-width' => 2, |
); |
$map_canvas->raise('Map-Border', 'Map'); # Border above Map |
# Balloon attached to Canvas |
$map_balloon = $frame_map->Balloon('-statusbar' => $status_line, ); |
$map_balloon->attach($map_canvas, |
'-balloonposition' => 'mouse', |
'-state' => 'balloon', |
'-msg' => { 'MK-Arrow' => $Translate{'Balloon-MK-Arrow'}, |
'MK-Home-Line' => $Translate{'Balloon-MK-Home-Line'}, |
'MK-Home-Dist' => $Translate{'Balloon-MK-Home-Dist'}, |
'MK-Target-Line' => $Translate{'Balloon-MK-Target-Line' }, |
'MK-Target-Dist' => $Translate{'Balloon-MK-Target-Dist'}, |
'MK-Speed' => $Translate{'Balloon-MK-Speed'}, |
'Map-Variometer' => $Translate{'Balloon-Map-Variometer' }, |
'Map-Variometer-Pointer' => $Translate{'Balloon-Map-Variometer-Pointer'}, |
'Map-Variometer-Skala' => $Translate{'Balloon-Map-Variometer-Pointer'}, |
'Fox' => $Translate{'Balloon-Fox'}, |
'Heartbeat' => $Translate{'Balloon-Heartbeat'}, |
'Satellite' => $Translate{'Balloon-Satellite'}, |
'Waypoint' => $Translate{'Balloon-Waypoint'}, |
'Map-Border' => $Translate{'Balloon-Map-Border'}, |
'Waypoint-Connector' => $Translate{'Balloon-Waypoint-Connector'}, |
'Wp-PlayPause' => $Translate{'Balloon-Wp-PlayPause'}, |
'Wp-Stop' => $Translate{'Balloon-Wp-Stop'}, |
'Wp-First' => $Translate{'Balloon-Wp-First'}, |
'Wp-Last' => $Translate{'Balloon-Wp-Last'}, |
'Wp-Next' => $Translate{'Balloon-Wp-Next'}, |
'Wp-Prev' => $Translate{'Balloon-Wp-Prev'}, |
'Wp-Home' => $Translate{'Balloon-Wp-Home'}, |
'Wp-WptKml' => $Translate{'Balloon-Wp-WptKml'}, |
'Wp-WptRandom' => $Translate{'Balloon-Wp-WptRandom'}, |
'Wp-Record' => $Translate{'Balloon-Wp-Record'}, |
'Track-Antenna' => $Translate{'Balloon-TrackAntenna'}, |
'POI' => $Translate{'Balloon-Poi'}, |
}, |
); |
# |
# Mouse button 1 |
# |
# Button 1 Press |
$map_canvas->CanvasBind("<Button-1>", sub |
{ |
# print coords in status line |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my ($Lat, $Lon) = &MapXY2Gps($x, $y); |
$map_status_line->configure ('-text' => "Lat: $Lat Lon: $Lon x: $x y: $y"); |
# save Coords and GPS-Pos for Button-Motion and Release |
$Button1_x = $x; |
$Button1_y = $y; |
$Button1_Lat = $Lat; |
$Button1_Lon = $Lon; |
# copy Pixel-Coordinates to Clipboard |
Clipboard->copy ("x=$x\r\n" . "y=$y\r\n" . "Lat=$Lat\r\n" . "Lon=$Lon\r\n"); |
}); |
# Button 1 Motion |
$map_canvas->CanvasBind("<Button1-Motion>", sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
# delete old measuring line |
$map_canvas->delete('Map-Measure'); |
my @Tags = $map_canvas->gettags($id); |
if ( ( $Tags[0] eq "Map" or $Tags[0] eq "Map-Border") and |
$x ne $Button1_x and $y ne $Button1_y ) |
{ |
# button moved on Map |
# draw new measuring line |
$map_canvas->createLine ( $Button1_x, $Button1_y, $x, $y, |
'-tags' => 'Map-Measure', |
'-arrow' => 'none', |
'-fill' => 'white', |
'-width' => 1, |
); |
# update status line |
my ($Lat, $Lon) = &MapXY2Gps($x, $y); |
my ($Dist, $Bearing) = &MapGpsTo($Button1_Lat, $Button1_Lon, $Lat, $Lon); |
$Dist = sprintf ("%.2f m", $Dist); |
$Bearing = sprintf ("%.2f degree", $Bearing); |
$map_status_line->configure ('-text' => "Dist: $Dist Bearing: $Bearing"); |
} |
}); |
# Button 1 Release |
$map_canvas->CanvasBind("<Button1-ButtonRelease>", sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
# delete measuring line |
$map_canvas->delete('Map-Measure'); |
my @Tags = $map_canvas->gettags($id); |
if ( ( $Tags[0] eq "Map" or $Tags[0] eq "Map-Border") and |
$x ne $Button1_x and $y ne $Button1_y ) |
{ |
# button released on Map |
# update status line |
my ($Lat, $Lon) = &MapXY2Gps($x, $y); |
my ($Dist, $Bearing) = &MapGpsTo($Button1_Lat, $Button1_Lon, $Lat, $Lon); |
$Dist = sprintf ("%.2f m", $Dist); |
$Bearing = sprintf ("%.2f degree", $Bearing); |
$map_status_line->configure ('-text' => "Dist: $Dist Bearing: $Bearing"); |
} |
}); |
# Mouse button 1 for Fox |
my $FoxOldx = 0; |
my $FoxOldy = 0; |
my $FoxTime = time; |
&FoxHide(); # Show only in Player-Pause Mode |
# Pick Fox |
$map_canvas->bind('Fox' => '<Button-1>' => sub |
{ |
# prepare to move Fox |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$FoxOldx = $x; |
$FoxOldy = $y; |
$FoxTime = time; |
}); |
# Move Fox |
$map_canvas->bind('Fox' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
$map_canvas->move($id => $x - $FoxOldx, $y - $FoxOldy); |
$FoxOldx = $x; |
$FoxOldy = $y; |
if ( time > $FoxTime ) |
{ |
# wenn in Bewegung Koordinaten nur 1/s senden |
my ($x0, $y0, $x1, $y1) = $map_canvas->bbox ($id); |
$x = $x0 + ($x1 - $x0)/2; |
$y = $y1; |
($PlayerPause_Lat, $PlayerPause_Lon) = &MapXY2Gps($x, $y); |
$FoxTime = time; |
$map_status_line->configure ('-text' => "$Translate{'TargetCoordSent'} -> Lat: $PlayerPause_Lat Lon: $PlayerPause_Lon x: $x y: $y"); |
} |
}); |
# Release Fox |
$map_canvas->bind('Fox' => '<Button1-ButtonRelease>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
my ($x0, $y0, $x1, $y1) = $map_canvas->bbox ($id); |
$x = $x0 + ($x1 - $x0)/2; |
$y = $y1; |
($PlayerPause_Lat, $PlayerPause_Lon) = &MapXY2Gps($x, $y); |
# Show user that Waypoints in MK are cleared |
$WaypointsModified = 1; |
&WpRedrawLines(); |
$map_status_line->configure ('-text' => "$Translate{'TargetCoordSent'} -> Lat: $PlayerPause_Lat Lon: $PlayerPause_Lon x: $x y: $y"); |
}); |
# Pick Waypoint |
my $WpOldx; |
my $WpOldy; |
$map_canvas->bind('Waypoint' => '<Button-1>' => sub |
{ |
# prepare to move |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$WpOldx = $x; |
$WpOldy = $y; |
}); |
# Move Waypoint |
$map_canvas->bind('Waypoint' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
# move icon and Wp-Number |
my $WpIndex = &WpGetIndexFromId($id); |
if ( $WpIndex >= 0 ) |
{ |
my $Tag = $Waypoints[$WpIndex]{'Tag'}; |
$map_canvas->move($Tag => $x - $WpOldx, $y - $WpOldy); |
} |
$WpOldx = $x; |
$WpOldy = $y; |
}); |
# Release Wp |
$map_canvas->bind('Waypoint' => '<Button1-ButtonRelease>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
# take coords from lower/middle icon position |
my ($x0, $y0, $x1, $y1) = $map_canvas->bbox ($id); |
$x = $x0 + ($x1 - $x0)/2; |
$y = $y1; |
# update Waypoint-Array |
my $WpIndex = &WpGetIndexFromId($id); |
if ( $WpIndex >= 0 ) |
{ |
# got it: set new coords |
my ($Lat, $Lon) = &MapXY2Gps($x, $y); |
my $Wp = $Waypoints[$WpIndex]; |
$Wp->{'MapX'} = $x; |
$Wp->{'MapY'} = $y; |
$Wp->{'Pos_Lat'} = $Lat; |
$Wp->{'Pos_Lon'} = $Lon; |
# redraw connector-lines |
&WpRedrawLines(); |
# red connectors: Wp still have to be sent to MK |
$map_canvas->itemconfigure('Waypoint-Connector', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorWpResend'}, |
); |
$WaypointsModified = 1; |
my $WpNum = $WpIndex + 1; |
$map_status_line->configure ('-text' => "$Translate{'WpMoved'}: $WpNum -> Lat: $Lat Lon: $Lon x: $x y: $y"); |
} |
}); |
# Mouse button 1 for POI |
my $PoiOldx = 0; |
my $PoiOldy = 0; |
&PoiHide(); |
# Pick Poi |
$map_canvas->bind('POI' => '<Button-1>' => sub |
{ |
# prepare to move Icon |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$PoiOldx = $x; |
$PoiOldy = $y; |
}); |
# Move POI |
$map_canvas->bind('POI' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
$map_canvas->move($id => $x - $PoiOldx, $y - $PoiOldy); |
$PoiOldx = $x; |
$PoiOldy = $y; |
}); |
# Release POI |
$map_canvas->bind('POI' => '<Button1-ButtonRelease>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
my ($x0, $y0, $x1, $y1) = $map_canvas->bbox ($id); |
$x = $x0 + ($x1 - $x0)/2; |
$y = $y1; |
($Poi_Lat, $Poi_Lon) = &MapXY2Gps($x, $y); |
$map_status_line->configure ('-text' => "$Translate{'PoiMoved'}: -> Lat: $Poi_Lat Lon: $Poi_Lon x: $x y: $y"); |
}); |
# Reset Flight time |
$map_canvas->bind('MK-OSD-Tim-Value' => '<Button-1>' => sub |
{ |
$MkFlyingTime = 0; |
}); |
# Reset ODO |
$map_canvas->bind('MK-OSD-Odo-Value' => '<Button-1>' => sub |
{ |
$OdoMeter = 0; |
}); |
# |
# Mouse button 3 context menu |
# |
my $map_menu = $map_canvas->Menu('-tearoff' => 0, |
'-title' =>'None', |
'-menuitems' => |
[ |
[Button => $Translate{'WpAddAndSend'}, -command => sub |
{ |
# send Wp to MK |
($Lat, $Lon) = &MapXY2Gps($Wp_x, $Wp_y); |
&MkFlyTo ( '-lat' => $Lat, |
'-lon' => $Lon, |
'-mode' => "Waypoint" |
); |
# Add Wp to Waypoints list |
&WpAdd ($MapCanvasX, $MapCanvasY); |
# switch player to Wp mode and redraw waypoints |
&PlayerWpt(); |
$map_status_line->configure ('-text' => "$Translate{'WpSavedAndSent'} -> Lat: $Lat Lon: $Lon"); |
}], |
[Button => $Translate{'WpProperties'}, -command => sub |
{ |
# find Wp-Hash for selected icon/tag |
my $WpIndex = &WpGetIndexFromId($MapCanvasId); |
if ( $WpIndex >= 0 ) |
{ |
my $Wp = $Waypoints[$WpIndex]; |
my $WpNum = $WpIndex + 1; |
&DisplayHash ($Wp, "$Translate{'WpProperties'} $WpNum", "Edit Waypoint Refresh"); |
$map_status_line->configure ('-text' => "$Translate{'WpProperties'} $WpNum"); |
} |
}], |
[Button => $Translate{'WpResendAll'}, -command => sub |
{ |
&WpSendAll(); |
$map_status_line->configure ('-text' => $Translate{'WpAllSent'}); |
}], |
'', # Separator |
[Button => $Translate{'WpLoadAndSend'}, -command => sub |
{ |
my $WpFile = $main->getOpenFile('-defaultextension' => ".xml", |
'-filetypes' => |
[['Waypoints', '.xml' ], |
['All Files', '*', ], |
], |
'-initialdir' => $Cfg->{'waypoint'}->{'WpDir'}, |
'-title' => $Translate{'WpLoad'}, |
); |
if ( -f $WpFile ) |
{ |
&WpLoadFile ($WpFile); |
# send all Wp to MK |
&WpSendAll(); |
# switch player to Wp mode and redraw waypoints |
$PlayerRandomMode = 'STD'; |
&PlayerWpt(); |
$map_status_line->configure ('-text' => "$Translate{'WpLoadedAndSent'}: $WpFile"); |
} |
}], |
[Button => $Translate{'WpSave'}, -command => sub |
{ |
my $WpFile = $main->getSaveFile('-defaultextension' => ".xml", |
'-filetypes' => |
[['Waypoints', '.xml' ], |
['All Files', '*', ], |
], |
'-initialdir' => $Cfg->{'waypoint'}->{'WpDir'}, |
'-title' => $Translate{'WpSave'}, |
); |
&WpSaveFile ($WpFile); |
$map_status_line->configure ('-text' => "$Translate{'WpSaved'}: $WpFile"); |
}], |
'', # Separator |
[Button => $Translate{'WpDelete'}, -command => sub |
{ |
# find Wp-Hash for selected icon/tag |
my $WpIndex = &WpGetIndexFromId($MapCanvasId); |
if ( $WpIndex >= 0 ) |
{ |
&WpDelete ($WpIndex); |
# redraw connector-lines |
$WaypointsModified = 1; |
&WpRedrawLines(); |
&WpRedrawIcons(); # wg. Wp-Nummern |
my $WpNum = $WpIndex + 1; |
$map_status_line->configure ('-text' => "$Translate{'WpDeleted'}: $WpNum"); |
} |
}], |
[Button => $Translate{'WpAllDeleteAndSend'}, -command => sub |
{ |
undef @Waypoints; |
$WpPlayerIndex = 0; |
$WpPlayerHoldtime = -1; |
# remove all Wp-Icons and Wp-Number on canvas |
&WpHide(); |
&WpSendAll(); |
$map_status_line->configure ('-text' => "$Translate{'WpAllDeleted'}: $WpIndex"); |
}], |
'', # Separator |
[Button => $Translate{'KmlLoadAndPlay'}, -command => sub |
{ |
$KmlFile = $main->getOpenFile('-defaultextension' => ".kml", |
'-filetypes' => |
[['KML', '.kml' ], |
['All Files', '*', ], |
], |
'-initialdir' => $Cfg->{'waypoint'}->{'KmlDir'}, |
'-title' => $Translate{'KmlLoad'}, |
); |
if ( -f $KmlFile ) |
{ |
&KmlLoadFile($KmlFile); |
# switch player to KML mode and redraw track |
&PlayerKml(); |
$map_status_line->configure ('-text' => "$Translate{'KmlLoaded'}: $KmlFile" ); |
} |
}], |
'', # Separator |
[Button => $Translate{'WpFlyImmediately'}, -command => sub |
{ |
&MkFlyTo ( '-x' => $MapCanvasX, |
'-y' => $MapCanvasY, |
'-mode' => "Target" |
); |
# redraw connector-lines |
$WaypointsModified = 1; |
&WpRedrawLines(); |
$map_status_line->configure ('-text' => "$Translate{'TargetCoordSent'} -> Lat: $Lat Lon: $Lon x: $MapCanvasX y: $MapCanvasY"); |
}], |
] |
); |
$map_canvas->CanvasBind("<Button-3>" => [ sub |
{ |
$map_canvas->focus; |
my($w, $x, $y) = @_; |
($MapCanvasX, $MapCanvasY) = ($Tk::event->x, $Tk::event->y); |
$MapCanvasId = $map_canvas->find('withtag', 'current'); |
$map_menu->post($x, $y); |
}, Ev('X'), Ev('Y') ] ); |
# Mouse bindings |
$map_canvas->bind('Wp-PlayPause' => '<Button-1>' => \&CbPlayerPlayPause ); |
$map_canvas->bind('Wp-Next' => '<Button-1>' => \&CbPlayerNext ); |
$map_canvas->bind('Wp-Prev' => '<Button-1>' => \&CbPlayerPrev ); |
$map_canvas->bind('Wp-First' => '<Button-1>' => \&CbPlayerFirst ); |
$map_canvas->bind('Wp-Last' => '<Button-1>' => \&CbPlayerLast ); |
$map_canvas->bind('Wp-Home' => '<Button-1>' => \&CbPlayerHome ); |
$map_canvas->bind('Wp-Stop' => '<Button-1>' => \&CbPlayerStop ); |
$map_canvas->bind('Wp-WptKml' => '<Button-1>' => \&CbPlayerWptKml ); |
$map_canvas->bind('Wp-WptRandom' => '<Button-1>' => \&CbPlayerWptRandom ); |
$map_canvas->bind('Wp-Record' => '<Button-1>' => \&CbPlayerRecord ); |
# Focus Canvas, if any key pressed. Needed for the following key-bindings |
$main->bind('<Any-Enter>' => sub { $map_canvas->Tk::focus }); |
# Disable default arrow-key bindings on canvas |
$main->bind('Tk::Canvas',"<$_>",undef)for qw /Left Right Up Down/; |
# keyboard bindings |
$map_canvas->Tk::bind( '<Key-space>' , \&CbPlayerPlayPause ); |
$map_canvas->Tk::bind( '<Key-n>' , \&CbPlayerNext ); |
$map_canvas->Tk::bind( '<Key-p>' , \&CbPlayerPrev ); |
$map_canvas->Tk::bind( '<Key-f>' , \&CbPlayerFirst ); |
$map_canvas->Tk::bind( '<Key-l>' , \&CbPlayerLast ); |
$map_canvas->Tk::bind( '<Key-h>' , \&CbPlayerHome ); |
$map_canvas->Tk::bind( '<Key-s>' , \&CbPlayerStop ); |
$map_canvas->Tk::bind( '<Key-w>' , \&CbPlayerWptKml ); |
$map_canvas->Tk::bind( '<Key-k>' , \&CbPlayerWptKml ); |
$map_canvas->Tk::bind( '<Key-r>' , \&CbPlayerWptRandom ); |
$map_canvas->Tk::bind( '<Key-a>' , \&CbPlayerRecord ); |
$map_canvas->Tk::bind( '<Key-m>' , \&CbPlayerMute ); |
$map_canvas->Tk::bind( '<Key-v>' , \&CbPoi ); |
$map_canvas->Tk::bind( '<Key-0>' , [\&CbPlayerNum, "0"] ); |
$map_canvas->Tk::bind( '<Key-1>' , [\&CbPlayerNum, "1"] ); |
$map_canvas->Tk::bind( '<Key-2>' , [\&CbPlayerNum, "2"] ); |
$map_canvas->Tk::bind( '<Key-3>' , [\&CbPlayerNum, "3"] ); |
$map_canvas->Tk::bind( '<Key-4>' , [\&CbPlayerNum, "4"] ); |
$map_canvas->Tk::bind( '<Key-5>' , [\&CbPlayerNum, "5"] ); |
$map_canvas->Tk::bind( '<Key-6>' , [\&CbPlayerNum, "6"] ); |
$map_canvas->Tk::bind( '<Key-7>' , [\&CbPlayerNum, "7"] ); |
$map_canvas->Tk::bind( '<Key-8>' , [\&CbPlayerNum, "8"] ); |
$map_canvas->Tk::bind( '<Key-9>' , [\&CbPlayerNum, "9"] ); |
$map_canvas->Tk::bind( '<Key-Left>' , [\&CbPlayerMove, -1, 0] ); |
$map_canvas->Tk::bind( '<Key-Right>' , [\&CbPlayerMove, 1, 0] ); |
$map_canvas->Tk::bind( '<Key-Up>' , [\&CbPlayerMove, 0, 1] ); |
$map_canvas->Tk::bind( '<Key-Down>' , [\&CbPlayerMove, 0, -1] ); |
$map_canvas->Tk::bind( '<Key-Escape>', \&CbExit ); |
# |
# dynamic objecs on canvas |
# |
# current MK position on canvas |
$MkPos_x = $MapSizeX/2; |
$MkPos_y = $MapSizeY/2; |
# Line from MK to Home |
$map_canvas->createLine ( $MapSizeX/2, $MapSizeY/2, $MapSizeX/2, $MapSizeY/2, |
'-tags' => 'MK-Home-Line', |
'-arrow' => 'none', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeLine'}, |
'-width' => 3, |
); |
# Text Entfernung positioniert an der Home-Linie |
$map_canvas->createText ( $MapSizeX/2 + 8, $MapSizeY/2 - 8, |
'-tags' => 'MK-Home-Dist', |
'-text' => '0 m', |
'-anchor' => 'w', |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeDist'}, |
); |
# Line from MK to Target, draw invisible out of sight |
$map_canvas->createLine ( 0, -100, 0, -100, |
'-tags' => 'MK-Target-Line', |
'-arrow' => 'none', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetLine'}, |
'-width' => 3, |
); |
# Text Entfernung positioniert an der Target-Linie |
$map_canvas->createText ( 0, -100, |
'-tags' => 'MK-Target-Dist', |
'-text' => '0 m', |
'-anchor' => 'w', |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetDist'}, |
); |
# Line from MK to POI, draw invisible out of sight |
$map_canvas->createLine ( 0, -200, 0, -200, |
'-tags' => 'MK-POI-Line', |
'-arrow' => 'none', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorPoiLine'}, |
'-stipple' => "stipple4", |
'-width' => 1, |
); |
$map_canvas->lower('MK-POI-Line', 'Target'); |
# MK Geschwindigkeits-Vektor |
$MapMkSpeedLen = 60; # Länge Speed-Zeiger |
my $x0 = $MapSizeX/2; |
my $y0 = $MapSizeY/2; |
my $x1 = $MapSizeX/2; |
my $y1 = $MapSizeY/2 - $MapMkSpeedLen; |
$map_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-tags' => 'MK-Speed', |
'-arrow' => 'last', |
'-arrowshape' => [10, 10, 3 ], |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorSpeedVector'}, |
'-width' => 4, |
); |
# MK als Pfeilspitze einer Linie darstellen |
$MapMkLen = 25; |
my $x0 = $MapSizeX/2; |
my $y0 = $MapSizeY/2 + $MapMkLen/2; |
my $x1 = $MapSizeX/2; |
my $y1 = $MapSizeY/2 - $MapMkLen/2; |
$map_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-tags' => 'MK-Arrow', |
'-arrow' => 'last', |
'-arrowshape' => [25, 30, 10 ], |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorMkSatNo'}, |
'-width' => 1 |
); |
# OSD Texte auf Karte anzeigen |
my @Texts = ( |
# Tag Text Pos_x Pos_y Font |
'MK-OSD-Tim-Label', "TIM", $MapSizeX/2 - 40, 20, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Tim-Value', "00:00", $MapSizeX/2, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Tim-Left', "", $MapSizeX/2 + 90, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Bat-Label', "BAT", $MapSizeX/2 - 40, 50, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Bat-Value', "0.0 V", $MapSizeX/2, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
# 'MK-OSD-Bat-Level', "", $MapSizeX/2 + 90, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Spd-Label', "SPD", 10, 20, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Spd-Value', "0.0 km/h", 60, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Alt-Label', "ALT", 10, 50, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Alt-Value', "0 m", 60, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Odo-Label', "ODO", 10, 80, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Odo-Value', "0.000 km", 60, 80, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Sat-Label', "SAT", $MapSizeX - 230, 20, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Sat-Value', "0", $MapSizeX - 180, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Wp-Label', "WPT", $MapSizeX - 230, 50, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Wp-Value', "0 / 0", $MapSizeX - 180, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Mode-Label', "MOD", $MapSizeX - 230, 80, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Mode-Value', "", $MapSizeX - 180, 80, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Rec-Value', "", $MapSizeX - 180, 110, '-*-Arial-Bold-R-Normal--*-200-*', |
); |
my $i = 0; |
for $Text (0 .. $#Texts/5) |
{ |
my $Tag = $Texts[$i++]; |
my $Text = $Texts[$i++]; |
my $Pos_x = $Texts[$i++]; |
my $Pos_y = $Texts[$i++]; |
my $Font = $Texts[$i++]; |
$map_canvas->createText ( $Pos_x, $Pos_y, |
'-tags' => $Tag, |
'-text' => $Text, |
'-font' => $Font, |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'}, |
'-anchor' => 'w', |
); |
} |
# Variometer on canvas |
my @Polygon; |
for ( $y = -100; $y <= 100; $y += 10) |
{ |
my $Len = 5; |
if ( ($y % 50) == 0 ) |
{ |
$Len = 10; |
$map_canvas->createText ( $Len+5, $MapSizeY/2 + $y, |
'-tags' => 'Map-Variometer-Skala', |
'-text' => sprintf ("%3d", -$y / 10), |
'-anchor' => 'w', |
'-font' => '-*-Arial-Normal-R-Normal--*-150-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'}, |
); |
} |
push @Polygon, ( 0, $MapSizeY/2 + $y); |
push @Polygon, ($Len, $MapSizeY/2 + $y); |
push @Polygon, ( 0, $MapSizeY/2 + $y); |
} |
$map_canvas->createLine(@Polygon, |
'-tags' => 'Map-Variometer', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'}, |
'-width' => 2, |
'-arrow' => 'none', |
); |
# Vario Pointer |
$map_canvas->createPolygon( 5, $MapSizeY/2, 20, $MapSizeY/2+10, 20, $MapSizeY/2-10, |
'-tags' => 'Map-Variometer-Pointer', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometerPointer'}, |
'-outline' => 'black', '-width' => 1, |
); |
# Tracking Canvas |
if ( $Cfg->{'track'}->{'Active'} =~ /y/i ) |
{ |
# Canvas size |
$TrackSizeX = 125; |
$TrackSizeY = 100; |
$TrackOffY = $TrackSizeY - $MapSizeY + 20; |
$TrackPtrLen = 50; # Länge Zeiger |
# draw in map-canvas |
$track_canvas = $map_canvas; |
# Ziffernblatt |
my $x0 = $TrackSizeX/2 - $TrackPtrLen; |
my $y0 = $TrackSizeY + $TrackPtrLen - $TrackOffY; |
my $x1 = $TrackSizeX/2 + $TrackPtrLen; |
my $y1 = $TrackSizeY - $TrackPtrLen - $TrackOffY; |
$track_canvas->createArc ( $x0, $y0, $x1, $y1, |
'-extent' => '200', |
'-start' => '-10', |
'-style' => 'chord', |
'-outline' => 'gray', '-width' => '1', |
); |
# Skala Ziffernblatt |
for ($i=0; $i<=180; $i+=15) |
{ |
my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 20) * cos( deg2rad $i ); |
my $y0 = $TrackSizeY - ($TrackPtrLen - 20) * sin( deg2rad $i ) - $TrackOffY; |
my $x1 = $TrackSizeX/2 - ($TrackPtrLen - 28) * cos( deg2rad $i ); |
my $y1 = $TrackSizeY - ($TrackPtrLen - 28) * sin( deg2rad $i ) - $TrackOffY; |
$track_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-fill' => 'white', |
'-width' => 1, |
); |
} |
# Skala Beschriftung Ziffernblatt |
for ($i=0; $i<=180; $i+=45) |
{ |
my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 12) * cos( deg2rad $i ); |
my $y0 = $TrackSizeY - ($TrackPtrLen - 12) * sin( deg2rad $i ) - $TrackOffY; |
$track_canvas->createText ( $x0, $y0, |
'-text' => $i - 90, |
'-fill' => 'white', |
); |
} |
# Ziffernblatt Beschriftung Einheit |
my $x0 = $TrackSizeX/2; |
my $y0 = $MapSizeY -6; |
$track_canvas->createText ( $x0, $y0, |
'-text' => "Antenne Winkel", |
'-justify' => 'center', |
'-fill' => 'white', |
); |
# Zeiger |
my $x0 = $TrackSizeX/2; |
my $y0 = $TrackSizeY - 0 - $TrackOffY; |
my $x1 = $TrackSizeX/2; |
my $y1 = $TrackSizeY - ($TrackPtrLen - 22) - $TrackOffY; |
$track_ptr_id= $track_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-tags' => 'Track-Ptr', |
'-arrow' => 'last', |
'-arrowshape' => [20, 30, 5 ], |
'-fill' => 'red', |
'-width' => 8, |
); |
# Zeiger Center |
my $Dia = 7; |
my $x0 = $TrackSizeX/2 - $Dia; |
my $y0 = $TrackSizeY + $Dia - $TrackOffY; |
my $x1 = $TrackSizeX/2 + $Dia; |
my $y1 = $TrackSizeY - $Dia - $TrackOffY; |
$track_canvas->createArc ( $x0, $y0, $x1, $y1, |
'-extent' => '359', |
'-outline' => 'gray', '-width' => 1, |
'-fill' => 'gray', |
); |
} |
# |
# Load Start Scenario |
# |
# Waypoint file |
my $CfgVal = $Cfg->{'StartScenario'}->{'WpFile'}; |
if ( ! -f $CfgVal ) |
{ |
$CfgVal = $Cfg->{'waypoint'}->{'WpDir'} . "/" . $Cfg->{'StartScenario'}->{'WpFile'}; |
} |
if ( -f $CfgVal ) |
{ |
&WpLoadFile($CfgVal); |
# send all Wp to MK |
&WpSendAll(); |
} |
# KML file |
my $CfgVal = $Cfg->{'StartScenario'}->{'KmlFile'}; |
if ( ! -f $CfgVal ) |
{ |
$CfgVal = $Cfg->{'waypoint'}->{'KmlDir'} . "/" . $Cfg->{'StartScenario'}->{'KmlFile'}; |
} |
if ( -f $CfgVal ) |
{ |
&KmlLoadFile($CfgVal); |
} |
# PLayer Mode |
my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerMode'}; |
if ( $CfgVal =~ /Play/i ) { &PlayerPlay(); } |
if ( $CfgVal =~ /Pause/i ) { &PlayerPause(); } |
if ( $CfgVal =~ /Home/i ) { &PlayerHome(); } |
if ( $CfgVal =~ /Stop/i ) { &PlayerStop(); } |
# Player Random Mode |
my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerRandomMode'}; |
if ( $CfgVal eq "STD" ) { &PlayerRandomStd(); } |
if ( $CfgVal eq "RND" ) { &PlayerRandomRnd(); } |
if ( $CfgVal eq "MAP" ) { &PlayerRandomMap(); } |
# PLayer Wpt/Kml Mode |
my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerWptKmlMode'}; |
if ( $CfgVal eq "WPT" ) { &PlayerWpt(); } |
if ( $CfgVal eq "KML" ) { &PlayerKml(); } |
# Audio TTS Mute |
my $CfgVal = $Cfg->{'StartScenario'}->{'AudioMute'}; |
if ( $CfgVal =~ /y/i ) |
{ |
$TtsMute = 1; |
} |
# |
# Timer |
# |
require "libmktimer.pl"; |
MainLoop(); # should never end |
# |
# GUI Call Back |
# |
# Player CallBack: Play/Pause button |
sub CbPlayerPlayPause() |
{ |
if ( ($PlayerMode eq "Pause") or ($PlayerMode eq "Stop") or ($PlayerMode eq "Home") ) |
{ |
&PlayerPlay(); |
} |
else |
{ |
&PlayerPause(); |
} |
} |
# Player CallBack: Next |
sub CbPlayerNext() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetNext(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetNext(); |
} |
} |
} |
# Player CallBack: Prev |
sub CbPlayerPrev() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetPrev(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetPrev(); |
} |
} |
} |
# Player CallBack: First |
sub CbPlayerFirst() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetFirst(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetFirst(); |
} |
} |
} |
# Player CallBack: Last |
sub CbPlayerLast() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetLast(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetLast(); |
} |
} |
} |
# Player CallBack: Home |
sub CbPlayerHome() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
&PlayerHome(); |
} |
} |
# Player CallBack: Stop |
sub CbPlayerStop() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
&PlayerStop(); |
} |
} |
# Player CallBack: Move MK in Pause-Mode |
sub CbPlayerMove() |
{ |
my ($Id, $DirX, $DirY) = @_; |
if ( $PlayerMode eq 'Pause' and |
$PlayerPause_Lat ne "" and $PlayerPause_Lon ne "" ) |
{ |
my $Dist = $Cfg->{'waypoint'}->{'PauseMoveDist'} || 1; # 1m default |
my $BearingTop = &MapAngel() - 90.0; |
my $BearingKey = rad2deg atan2($DirX, $DirY); |
my $Bearing = $BearingTop + $BearingKey; |
($PlayerPause_Lat, $PlayerPause_Lon) = &MapGpsAt($PlayerPause_Lat, $PlayerPause_Lon, $Dist, $Bearing) |
} |
} |
# Player CallBack: Toggle WPT/KML button |
sub CbPlayerWptKml() |
{ |
if ( $PlayerWptKmlMode =~ /WPT/i ) |
{ |
&PlayerKml(); |
} |
elsif ( $PlayerWptKmlMode =~ /KML/i ) |
{ |
&PlayerWpt(); |
} |
} |
# Player CallBack: Toggle Random modes. STD -> RND -> MAP |
sub CbPlayerWptRandom() |
{ |
if ( $PlayerRandomMode eq "STD" ) |
{ |
&PlayerRandomRnd(); |
} |
elsif ( $PlayerRandomMode eq "RND" ) |
{ |
&PlayerRandomMap(); |
} |
else |
{ |
&PlayerRandomStd(); |
} |
} |
# Player CallBack: Togglle Record KML |
sub CbPlayerRecord() |
{ |
if ( $PlayerRecordMode =~ /REC/i ) |
{ |
&PlayerRecordOff(); |
} |
elsif ( $PlayerRecordMode eq "" ) |
{ |
&PlayerRecordOn(); |
} |
} |
# Player CallBack: Number Keys |
sub CbPlayerNum() |
{ |
my ($Id, $Num) = @_; |
$CbPlayerKey = "$CbPlayerKey" . "$Num"; |
} |
# Player CallBack: mute TTS audio |
sub CbPlayerMute() |
{ |
if ( $TtsMute ) |
{ |
$TtsMute = 0; |
} |
else |
{ |
$TtsMute = 1; |
} |
} |
# Switch POI Mode |
sub CbPoi() |
{ |
if ( $PoiMode ) |
{ |
$PoiMode = 0; |
&PoiHide(); |
} |
else |
{ |
$PoiMode = 1; |
&PoiShow(); |
} |
} |
# CallBack: Exit Mission Cockpit |
sub CbExit() |
{ |
# stop antenna tracking |
$TrackQueue->enqueue( "IDLE" ); |
# wait for tracker shutdown, with timeout |
for ($i=0; $i < 5; $i++) |
{ |
if ( $MkTrack{'State'} ne "Idle" ) |
{ |
sleep 1; |
} |
} |
exit; |
} |
# |
# subroutines moved to libmkcockpit.pl |
# Timer moved to libmktimer.pl |
# |
__END__ |
/MissionCockpit/tags/V0.2.7/mkcockpit.xml |
---|
0,0 → 1,84 |
<mkcockpit-Config CreationDate="20091010-213939"> |
<StartScenario AudioMute="n" |
KmlFile="" |
PlayerMode="Stop" |
PlayerRandomMode="STD" |
PlayerWptKmlMode="WPT" |
WpFile="" /> |
<geserver HttpPort="8080" /> |
<logging CsvLogDir="log" |
GpxLogDir="log" |
Intervall="0.5" |
KmlLogDir="log" /> |
<map MapDefault="Hemhofen" |
MapDir="map" /> |
<mkcockpit AltFactor="20" |
ColorAirfield="blue" |
ColorFootprint="magenta" |
ColorHomeDist="white" |
ColorHomeLine="red" |
ColorKmlTrack="gray" |
ColorMkSatGood="yellow" |
ColorMkSatLow="orange" |
ColorMkSatNo="red" |
ColorOsd="white" |
ColorPoiLine="white" |
ColorScale="white" |
ColorSpeedVector="white" |
ColorTargetDist="cyan" |
ColorTargetLine="green" |
ColorVariometer="white" |
ColorVariometerPointer="yellow" |
ColorWpConnector="gray" |
ColorWpNumber="gray" |
ColorWpResend="red" |
FootprintLength="120" |
IconFox="icon/bear_48.gif" |
IconHeartLarge="icon/heart_48.gif" |
IconHeartSmall="icon/heart_32.gif" |
IconPoi="icon/webcam_48.gif" |
IconSatellite="icon/satellite_64.gif" |
IconTarget="icon/target_48.gif" |
IconWaypoint="icon/waypoint_48.gif" |
UBatWarning="10.0" /> |
<mkcomm Port="COM1" |
PortSetSkip="n"/> |
<mksim ImageSize="300" /> |
<track Active="n" |
IconAntenna="icon/Antenna_48.gif" |
Port="COM8" |
PortSetSkip="n" |
ServoPanCtrl="15" |
ServoPanNeutral="3000" |
ServoPanSpeed="0" |
ServoTiltCtrl="46" |
ServoTiltNeutral="3000" |
ServoTiltSpeed="0" /> |
<tts Active="y" |
Options="-v de -a 200 -s 200" |
Program="C:/Programme/eSpeak/command_line/espeak.exe" |
StatusInterval="20" |
Welcome="Starte Mischn Kockpit, Bitte anschnallen, und das Rauchen einstellen." /> |
<waypoint DefaultEventFlag="0" |
DefaultHeading="0" |
DefaultHoldtime="5" |
DefaultToleranceRadius="5" |
IconFirst="icon/WpFirst.gif" |
IconHome="icon/WpHome.gif" |
IconKml="icon/ModeKml_48.gif" |
IconLast="icon/WpLast.gif" |
IconNext="icon/WpNext.gif" |
IconPause="icon/WpPause.gif" |
IconPlay="icon/WpPlay.gif" |
IconPrev="icon/WpPrev.gif" |
IconRandomMap="icon/RandomMap_48.gif" |
IconRandomOff="icon/RandomOff_48.gif" |
IconRandomOn="icon/RandomWpt_48.gif" |
IconRecord="icon/Record_48.gif" |
IconStop="icon/WpStop.gif" |
IconWpt="icon/ModeWpt_48.gif" |
KmlDir="log" |
KmlTimeBase="0.5" |
PauseMoveDist="1.0" |
WpDir="waypoints" /> |
</mkcockpit-Config> |
/MissionCockpit/tags/V0.2.7/mkcomm.pl |
---|
0,0 → 1,795 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# mkcomm.pl - MK Communication Routines |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-02-21 0.0.1 rw created |
# 2009-03-18 0.0.2 rw NC 0.14e |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-04-06 0.1.1 rw NC 0.15c |
# 2009-05-16 0.1.2 rw External control |
# 2009-08-15 0.1.3 rw SIG-Handler removed |
# 2009-10-05 0.1.4 rw COM-Ports > 9 + PortSetSkip configuration |
# Export Target-Hash to Simulator |
# |
############################################################################### |
$Version{'mkcomm.pl'} = "0.1.4 - 2009-10-05"; |
# MK Protokoll |
# http://www.mikrokopter.de/ucwiki/en/SerialCommands?highlight=(command) |
# http://www.mikrokopter.de/ucwiki/en/SerialProtocol?highlight=(protocol) |
# |
# Parameter |
# |
# Com Port of MK Comm-Device (BT, WI.232) |
if ( ! defined $Cfg->{'mkcomm'}->{'Port'} ) |
{ |
# set default |
$Cfg->{'mkcomm'}->{'Port'} = "COM4"; |
} |
$AddrFC = "b"; |
$AddrNC = "c"; |
$AddrMK3MAG = "d"; |
if ( $0 =~ /mkcomm.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
# change working directory to program path |
my $Cwd = substr ($0, 0, rindex ($0, "mkcomm.pl")); |
chdir $Cwd; |
# set path for local Perl libs |
push @INC, $Cwd . "perl/lib"; |
} |
# Packages |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Time::HiRes qw(usleep); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
if ( $^O =~ /Win32/i ) |
{ |
require Win32::SerialPort; # http://search.cpan.org/dist/Win32-SerialPort |
} |
else |
{ |
require Device::SerialPort; # http://search.cpan.org/~cook/Device-SerialPort-1.04/SerialPort.pm |
} |
require "libmap.pl"; |
# Hashes exported to other threads and main-program |
share (%MkOsd); |
share (%MkTarget); |
share (%MkNcDebug); |
share (%Mk); |
share (%MkSSim); # Target info for simulator |
# Queue for Sending to MK |
$MkSendQueue = Thread::Queue->new(); |
sub MkCommExit() |
{ |
# close COM port |
&MkClose(); |
if ( defined threads->self() ) |
{ |
threads->exit(); |
} |
exit; |
} |
sub MkInit() |
{ |
if ( defined $MkPort ) |
{ |
return; # already open |
} |
# open COM-Port |
my $MkComPort = $Cfg->{'mkcomm'}->{'Port'}; |
if ( $MkComPort =~ /^COM/i ) |
{ |
$MkComPort = "\\\\.\\" . $MkComPort; # \\.\COMnn for nn > 9 |
} |
undef $MkPort; |
if ( $^O =~ m/Win32/ ) |
{ |
$MkPort = Win32::SerialPort->new ($MkComPort) || die "Error open $MkComPort\n"; |
} |
else |
{ |
$MkPort = Device::SerialPort->new ($MkComPort) || die "Error open $MkComPort\n"; |
} |
if ( ! ($Cfg->{'mkcomm'}->{'PortSetSkip'} =~ /y/i) ) |
{ |
# Set COM parameters, don't set for Bluetooth device |
$MkPort->baudrate(57600); |
$MkPort->parity("none"); |
$MkPort->databits(8); |
$MkPort->stopbits(1); |
$MkPort->handshake('none'); |
$MkPort->write_settings; |
} |
$MkPort->read_const_time(100); # total = (avg * bytes) + const (ms) |
} |
# Read one line from MK |
# Check send-queue |
sub MkIOLine() |
{ |
# Init serial port |
&MkInit(); |
my $RxLine = ""; |
while ( 1 ) |
{ |
# Check Send-Queue |
my $Items = $MkSendQueue->pending(); |
if ( $Items >= 3 ) # Cmd, Addr, Data |
{ |
my ($Id, $Addr, $Data) = $MkSendQueue->dequeue(3); |
&MkSend ($Id, $Addr, $Data); |
} |
# Zeichenweise lesen, blockierend mit Timeout |
my ($RxLen, $RxChar) = $MkPort->read(1); |
if ( $RxLen == 1 ) |
{ |
if ( "$RxChar" eq "#" ) # 1st char of line |
{ |
$RxLine = "#"; |
} |
elsif ( "$RxChar" eq "\r" ) # last char of line |
{ |
return ($RxLine); |
} |
else |
{ |
$RxLine = "$RxLine" . "$RxChar"; # collect char |
} |
} |
} |
} |
# Read and decode a command from MK |
# process send queue in &MkIOLine() |
sub MkIO() |
{ |
my $RxData = &MkIOLine(); # Blocking Read for complete line |
# Zeile decodieren |
if ( substr ($RxData, 0, 1) eq '#' ) |
{ |
# Zeile decodieren |
$Header = substr($RxData, 0, 3); |
$Chksum = substr($RxData, -2); |
$Data = substr($RxData, 3, length ($RxData) -5); |
# CRC prüfen |
if ( &CrcCheck ("$Header" . "$Data", $Chksum ) ) |
{ |
# Base64 decodieren |
$Data = &Decode64($Data); |
# Daten auswerten und in shared Hash schreiben |
if ( &ProcessRx($Header, $Data) ) |
{ |
return 1; # alles OK |
} |
} |
} |
return 0; # keine Daten empfangen |
} |
# Send a command to MK |
sub MkSend() |
{ |
my ($Id, $Addr, $Data) = @_; |
# Init serial port |
&MkInit(); |
my $Base64Data = &Encode64($Data); |
my $TxData = "#" . "$Addr" . "$Id" . "$Base64Data"; |
my $Crc = &Crc($TxData); |
my $TxSend = "$TxData" . "$Crc" . "\r"; |
$MkPort->write($TxSend); |
} |
# close COM-Port |
sub MkClose() |
{ |
undef $MkPort; |
} |
# CRC Prüfung |
sub CrcCheck () |
{ |
my ($Data, $Crc) = @_; |
my $Check = &Crc($Data); |
if ( $Check ne $Crc ) |
{ |
return 0; # CRC passt nicht |
} |
return (1); # CRC OK |
} |
# CRC berechnen |
sub Crc () |
{ |
my ($Data) = @_; |
my $TmpCrc = 0; |
my $Len = length $Data; |
for ($i=0; $i<$Len; $i++) |
{ |
$TmpCrc += ord(substr($Data, $i, 1)); |
} |
$TmpCrc %= 4096; |
my $Crc1 = ord ("=") + $TmpCrc / 64; |
my $Crc2 = ord ("=") + $TmpCrc % 64; |
$Crc = pack("CC", $Crc1, $Crc2); |
return ($Crc); |
} |
# Empfangene Daten decodieren, modifiziertes Base64 |
sub Decode64() |
{ |
my ($DataIn) = @_; |
my $ptrIn = 0; |
my $DataOut = ""; |
my $len = length ($DataIn); |
while ( $len > 0 ) |
{ |
$a = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("="); |
$b = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("="); |
$c = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("="); |
$d = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("="); |
$x = ($a << 2) | ($b >> 4); |
$y = (($b & 0x0f) << 4) | ($c >> 2); |
$z = (($c & 0x03) << 6) | $d; |
foreach $i ( $x, $y, $z ) |
{ |
if ( $len--) |
{ |
my $Tmp = pack ('C1', $i); |
$DataOut = "$DataOut" . "$Tmp"; |
} |
else |
{ |
last; |
} |
} |
} |
return ($DataOut); |
} |
# zu sendende Daten codieren, modifiziertes Base64 |
sub Encode64() |
{ |
my ($Data) = @_; |
my $Length = length $Data; |
my $TxBuf = ""; |
my $ptr = 0; |
while( $Length > 0 ) |
{ |
my $a = 0; |
my $b = 0; |
my $c = 0; |
if ($Length) {$a = ord(substr ($Data, $ptr++, $Length--));} |
if ($Length) {$b = ord(substr ($Data, $ptr++, $Length--));} |
if ($Length) {$c = ord(substr ($Data, $ptr++, $Length--));} |
my $ac = ord("=") + ($a >> 2); |
my $bc = ord("=") + ( (($a & 0x03) << 4) | (($b & 0xf0) >> 4) ); |
my $cc = ord("=") + ( (($b & 0x0f) << 2) | (($c & 0xc0) >> 6) ); |
my $dc = ord("=") + ($c & 0x3f); |
$TxBuf = "$TxBuf" . pack ("C4", $ac, $bc, $cc, $dc); |
} |
return ($TxBuf); |
} |
# Empfangenen Datensatz verarbeiten |
sub ProcessRx() |
{ |
my ($Header, $Data) = @_; |
my $Adr = substr ($Header, 1, 1); # b=FC, c=NC, d=MK3MAG |
my $Id = substr ($Header, 2, 1); |
if ( $Id eq "O" ) |
{ |
# |
# OSD-Daten nach %MkOsd einlesen |
# |
# Struktur Datensatz: |
# u8 Version // version of the data structure |
# GPS_Pos_t CurrentPosition; |
# GPS_Pos_t TargetPosition; |
# GPS_PosDev_t TargetPositionDeviation; |
# GPS_Pos_t HomePosition; |
# GPS_PosDev_t HomePositionDeviation; |
# u8 WaypointIndex; // index of current waypoints running from 0 to WaypointNumber-1 |
# u8 WaypointNumber; // number of stored waypoints |
# u8 SatsInUse; // no of satellites used for position solution |
# s16 Altimeter; // hight according to air pressure |
# s16 Variometer; // climb(+) and sink(-) rate |
# u16 FlyingTime; // in seconds |
# u8 UBat; // Battery Voltage in 0.1 Volts |
# u16 GroundSpeed; // speed over ground in cm/s (2D) |
# s16 Heading; // current flight direction in deg as angle to north |
# s16 CompassHeading; // current compass value |
# s8 AngleNick; // current Nick angle in 1° |
# s8 AngleRoll; // current Rick angle in 1° |
# u8 RC_Quality; // RC_Quality |
# u8 MKFlags; // Flags from FC |
# u8 NCFlags; // Flags from NC |
# u8 Errorcode; // 0 --> okay |
# u8 OperatingRadius // current operation radius around the Home Position in m |
# s16 TopSpeed; // velocity in vertical direction in cm/s |
# u8 TargetHoldTime; // time in s to stay at the given target, counts down to 0 if target has been reached |
# u8 Reserve[4]; // for future use |
# GPS_Pos_t: |
# s32 Longitude; // in 1E-7 deg |
# s32 Latitude; // in 1E-7 deg |
# s32 Altitude; // in mm |
# u8 Status; // validity of data |
# GPS_PosDev_t: |
# s16 Distance; // distance to target in dm |
# s16 Bearing; // course to target in deg |
# Status: |
# INVALID = 0 |
# NEWDATA = 1 |
# PROCESSED = 2 |
# MKFlags 0x01: MOTOR_RUN, 0x02 FLY, 0x04: CALIBRATE, 0x08: START, 0x10: EMERGENCY_LANDING |
# NCFlags 0x01: FLAG_FREE, 0x02: FLAG_PH, 0x04: FLAG_CH, 0x08: FLAG_RANGE_LIMIT |
# 0x10: FLAG_NOSERIALLINK, 0x20: FLAG_TARGET_REACHED, FLAG_MANUAL_CONTROL: 0x40 |
# 0x80: FLAG_8 |
lock (%MkOsd); # until end of Block |
( |
$MkOsd{'Version'}, |
$MkOsd{'CurPos_Lon'}, |
$MkOsd{'CurPos_Lat'}, |
$MkOsd{'CurPos_Alt'}, |
$MkOsd{'CurPos_Stat'}, |
$MkOsd{'TargetPos_Lon'}, |
$MkOsd{'TargetPos_Lat'}, |
$MkOsd{'TargetPos_Alt'}, |
$MkOsd{'TargetPos_Stat'}, |
$MkOsd{'TargetPosDev_Dist'}, |
$MkOsd{'TargetPosDev_Bearing'}, |
$MkOsd{'HomePos_Lon'}, |
$MkOsd{'HomePos_Lat'}, |
$MkOsd{'HomePos_Alt'}, |
$MkOsd{'HomePos_Stat'}, |
$MkOsd{'HomePosDev_Dist'}, |
$MkOsd{'HomePosDev_Bearing'}, |
$MkOsd{'WaypointIndex'}, |
$MkOsd{'WaypointNumber'}, |
$MkOsd{'SatsInUse'}, |
$MkOsd{'Altimeter'}, |
$MkOsd{'Variometer'}, |
$MkOsd{'FlyingTime'}, |
$MkOsd{'UBat'}, |
$MkOsd{'GroundSpeed'}, |
$MkOsd{'Heading'}, |
$MkOsd{'CompassHeading'}, |
$MkOsd{'AngleNick'}, |
$MkOsd{'AngleRoll'}, |
$MkOsd{'RC_Quality'}, |
$MkOsd{'MKFlags'}, |
$MkOsd{'NCFlags'}, |
$MkOsd{'Errorcode'}, |
$MkOsd{'OperatingRadius'}, |
$MkOsd{'TopSpeed'}, |
$MkOsd{'TargetHoldTime'}, |
) = unpack ('ClllClllCsslllCssCCCssSCSssccCCCCCsC', $Data); |
$MkOsd{'CurPos_Lon'} = sprintf("%.7f", $MkOsd{'CurPos_Lon'} / 10000000); |
$MkOsd{'CurPos_Lat'} = sprintf("%.7f", $MkOsd{'CurPos_Lat'} / 10000000); |
$MkOsd{'CurPos_Alt'} = sprintf("%.3f", $MkOsd{'CurPos_Alt'} / 1000); |
$MkOsd{'TargetPos_Lon'} = sprintf("%.7f", $MkOsd{'TargetPos_Lon'} / 10000000); |
$MkOsd{'TargetPos_Lat'} = sprintf("%.7f", $MkOsd{'TargetPos_Lat'} / 10000000); |
$MkOsd{'TargetPos_Alt'} = sprintf("%.3f", $MkOsd{'TargetPos_Alt'} / 1000); |
$MkOsd{'HomePos_Lon'} = sprintf("%.7f", $MkOsd{'HomePos_Lon'} / 10000000); |
$MkOsd{'HomePos_Lat'} = sprintf("%.7f", $MkOsd{'HomePos_Lat'} / 10000000); |
$MkOsd{'HomePos_Alt'} = sprintf("%.3f", $MkOsd{'HomePos_Alt'} / 1000); |
$MkOsd{'UBat'} = sprintf("%.1f", $MkOsd{'UBat'} / 10); |
# Timestamp, wann der Datensatz geschtieben wurde |
$MkOsd{'_Timestamp'} = time; |
} |
elsif ( $Id eq "s" ) |
{ |
# |
# NC Target position in %MkTarget |
# |
# Datenstruktur: |
# GPS_Pos_t Position; // the gps position of the waypoint, see ubx.h for details |
# s16 Heading; // orientation, future implementation |
# u8 ToleranceRadius; // in meters, if the MK is within that range around the target, then the next target is |
# u8 HoldTime; // in seconds, if the MK was once in the tolerance area around a WP, |
# // this time defines the delay before the next WP is triggered |
# u8 Event_Flag; // future emplementation |
# u8 reserve[12]; // reserved |
lock (%MkTarget); # until end of block |
( |
$MkTarget{'Pos_Lon'}, |
$MkTarget{'Pos_Lat'}, |
$MkTarget{'Pos_Alt'}, |
$MkTarget{'Pos_Stat'}, |
$MkTarget{'Heading'}, |
$MkTarget{'ToleranceRadius'}, |
$MkTarget{'HoldTime'}, |
$MkTarget{'EventFlag'}, |
) = unpack ('lllCsCCC', $Data); |
$MkTarget{'Pos_Lon'} = sprintf("%.7f", $MkTarget{'Pos_Lon'} / 10000000); |
$MkTarget{'Pos_Lat'} = sprintf("%.7f", $MkTarget{'Pos_Lat'} / 10000000); |
$MkTarget{'Pos_Alt'} = sprintf("%.3f", $MkTarget{'Pos_Alt'} / 1000); |
# Timestamp, wann der Datensatz geschrieben wurdw |
$MkTarget{'_Timestamp'} = time; |
} |
elsif ( $Id eq "W" ) |
{ |
# |
# Request new waypoint |
# |
# Datenstruktur: |
# u8 Number of waypoint |
($WpNumber) = unpack ('C', $Data); |
# keine Ahnung wofuer das gut sein soll |
# print "Request new Waypoint Number: $WpNumber\n"; |
} |
elsif ( $Id eq "V" ) |
{ |
# |
# Version |
# |
# Datenstruktur: |
# u8 SWMajor |
# u8 SWMinor |
# u8 ProtoMajor |
# u8 ProtoMinor |
# u8 SWPatch |
# u8 Reserved[5] |
( |
$Mk{'SWMajor'}, |
$Mk{'SWMinor'}, |
$Mk{'ProtoMajor'}, |
$Mk{'ProtoMinor'}, |
$Mk{'SWPatch'}, |
) = unpack ('C5', $Data); |
$Mk{'_Timestamp'} = time; |
} |
elsif ( $Id eq "E" ) |
{ |
# |
# Error Text |
# |
# Datenstruktur: |
# s8 ErrorMsg[25] |
$Mk{'ErrorMsg'} = unpack ('Z25', $Data); |
} |
elsif ( $Id eq "D" ) |
{ |
# |
# NC Debug %MkNcDebug |
# |
# Datenstruktur: |
# u8 Digital[2]; |
# u16 Analog[32]; |
lock (%MkNcDebug); # until end of block |
( |
$MkNcDebug{'Digital_00'}, |
$MkNcDebug{'Digital_01'}, |
$MkNcDebug{'Analog_00'}, |
$MkNcDebug{'Analog_01'}, |
$MkNcDebug{'Analog_02'}, |
$MkNcDebug{'Analog_03'}, |
$MkNcDebug{'Analog_04'}, |
$MkNcDebug{'Analog_05'}, |
$MkNcDebug{'Analog_06'}, |
$MkNcDebug{'Analog_07'}, |
$MkNcDebug{'Analog_08'}, |
$MkNcDebug{'Analog_09'}, |
$MkNcDebug{'Analog_10'}, |
$MkNcDebug{'Analog_11'}, |
$MkNcDebug{'Analog_12'}, |
$MkNcDebug{'Analog_13'}, |
$MkNcDebug{'Analog_14'}, |
$MkNcDebug{'Analog_15'}, |
$MkNcDebug{'Analog_16'}, |
$MkNcDebug{'Analog_17'}, |
$MkNcDebug{'Analog_18'}, |
$MkNcDebug{'Analog_19'}, |
$MkNcDebug{'Analog_20'}, |
$MkNcDebug{'Analog_21'}, |
$MkNcDebug{'Analog_22'}, |
$MkNcDebug{'Analog_23'}, |
$MkNcDebug{'Analog_24'}, |
$MkNcDebug{'Analog_25'}, |
$MkNcDebug{'Analog_26'}, |
$MkNcDebug{'Analog_27'}, |
$MkNcDebug{'Analog_28'}, |
$MkNcDebug{'Analog_29'}, |
$MkNcDebug{'Analog_30'}, |
$MkNcDebug{'Analog_31'}, |
) = unpack ('C2s32', $Data); |
# Timestamp, wann der Datensatz geschrieben wurde |
$MkNcDebug{'_Timestamp'} = time; |
} |
elsif ( $Id eq "B" ) |
{ |
# |
# External Control |
# |
# Datenstruktur: |
# u8 ConfirmFrame; |
my ($ConfirmFrame) = unpack ('C5', $Data); |
} |
else |
{ |
print "Unknown Command: $Header $Data\n"; |
} |
} |
# send Target or Waypoint to MK |
sub MkFlyTo() |
{ |
my %Param = @_; |
my $x = $Param{'-x'}; |
my $y = $Param{'-y'}; |
my $Lat = $Param{'-lat'}; |
my $Lon = $Param{'-lon'}; |
my $Alt = $Param{'-alt'}; |
my $Heading = $Param{'-heading'}; |
my $ToleranceRadius = $Param{'-toleranceradius'}; |
my $Holdtime = $Param{'-holdtime'}; |
my $EventFlag = $Param{'-eventflag'}; |
my $Mode = $Param{'-mode'}; |
if ( $x ne "" and $y ne "" and $Lat eq "" and $Lon eq "" ) |
{ |
($Lat, $Lon) = &MapXY2Gps($x, $y); |
} |
if ( $Alt eq "" ) { $Alt = $MkOsd{'CurPos_Alt'}; } |
if ( $Heading eq "" ) { $Heading = $Cfg->{'waypoint'}->{'DefaultHeading'}; } |
if ( $ToleranceRadius eq "" ) { $ToleranceRadius = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; } |
if ( $Holdtime eq "" ) { $Holdtime = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; } |
if ( $EventFlag eq "" ) { $EventFlag = $Cfg->{'waypoint'}->{'DefaultEventFlag'}; } |
my $Status = 1; # valid |
if ( $Mode =~ /delete/i ) |
{ |
$Status = 0; # invalid -> delete NC WP-List |
} |
my $Lat_i = sprintf "%d", $Lat * 10000000; |
my $Lon_i = sprintf "%d", $Lon * 10000000; |
my $Alt_i = sprintf "%d", $Alt * 1000; |
# Datenstruktur: |
# GPS_Pos_t Position; // the gps position of the waypoint, see ubx.h for details |
# s16 Heading; // orientation, future implementation |
# u8 ToleranceRadius; // in meters, if the MK is within that range around the target, then the next target is |
# u8 HoldTime; // in seconds, if the MK was once in the tolerance area around a WP, |
# // this time defines the delay before the next WP is triggered |
# u8 Event_Flag; // future emplementation |
# u8 reserve[12]; // reserved |
my $Wp = pack ('lllCsC15', |
$Lon_i, |
$Lat_i, |
$Alt_i, |
$Status, |
$Heading, |
$ToleranceRadius, |
$Holdtime, |
$EventFlag, |
0,0,0,0,0,0,0,0,0,0,0,0, |
); |
if ( $Mode =~ /waypoint/i ) |
{ |
$MkSendQueue->enqueue( "w", "$AddrNC", $Wp ); |
# &MkSend( "w", "$AddrNC", $Wp ); |
} |
elsif ( $Mode =~ /target/i ) |
{ |
$MkSendQueue->enqueue( "s", "$AddrNC", $Wp ); |
# &MkSend( "w", "$AddrNC", $Wp ); |
# set Target information for Simulator |
$MkSim{'Target_Lat'} = $Lat; |
$MkSim{'Target_Lon'} = $Lon; |
$MkSim{'Target_Alt'} = $Alt; |
$MkSim{'Target_Status'} = $Status; |
$MkSim{'Target_Heading'} = $Heading; |
$MkSim{'Target_ToleranceRadius'} = $ToleranceRadius; |
$MkSim{'Target_Holdtime'} = $Holdtime; |
$MkSim{'Target_EventFlag'} = $EventFlag; |
# Timestamp, wann der Datensatz geschtieben wurde |
$MkSim{'_Timestamp'} = time; |
} |
else |
{ |
# ignore |
} |
return 0; |
} |
# send External control to MK |
sub ExternalControl() |
{ |
my %Param = @_; |
my $RemoteButtons = $Param{'-remotebuttons'}; |
my $Nick = $Param{'-nick'}; |
my $Roll = $Param{'-roll'}; |
my $Yaw = $Param{'-yaw'}; |
my $Gas = $Param{'-gas'}; |
my $Hight = $Param{'-hight'}; |
my $Free = $Param{'-free'}; |
my $Frame = $Param{'-frame'}; |
my $Config = $Param{'-config'}; |
# Datenstruktur: |
# u8 Digital[2]; |
# u8 RemoteButtons; |
# s8 Nick; |
# s8 Roll; |
# s8 Yaw; |
# u8 Gas; |
# s8 Height; |
# u8 free; |
# u8 Frame; |
# u8 Config; |
my $Ec = pack ('CCCcccCcCCC', |
0, 0, |
$RemoteButtons, |
$Nick, |
$Roll, |
$Yaw, |
$Gas, |
$Hight, |
$Free, |
$Frame, |
$Config |
); |
$MkSendQueue->enqueue( "b", "$AddrNC", $Ec ); |
# &MkSend( "b", "$AddrNC", $Ec ); |
return 0; |
} |
# when called as thread |
sub MkCommLoop() |
{ |
while (1) |
{ |
&MkIO(); |
} |
} |
# |
# Hauptprgramm |
# |
if ( $0 =~ /mkcomm.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
&MkCommLoop(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/perl/InstallPackages.bat |
---|
0,0 → 1,23 |
echo off |
echo Download and Installation of required Perl Packages |
call ppm install Tk |
call ppm install Tk::Balloon |
call ppm install Tk::Dialog |
call ppm install Tk::Notebook |
call ppm install Tk::JPEG |
call ppm install Tk::PNG |
call ppm install Math::Trig |
call ppm install XML::Simple |
call ppm install Geo::Ellipsoid |
call ppm install threads |
call ppm install threads::shared |
call ppm install Thread::Queue |
call ppm install Time::Hires |
rem call ppm install Win32::SerialPort |
call ppm install Win32::Locale |
call ppm install Clipboard |
call ppm install Spiffy |
call ppm install Image::Size |
echo done |
/MissionCockpit/tags/V0.2.7/perl/lib/Win32/SerialPort.pm |
---|
0,0 → 1,2969 |
package Win32::SerialPort; |
use Win32; |
use Win32API::CommPort qw( :STAT :PARAM 0.17 ); |
use Carp; |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
$VERSION = '0.19'; |
require Exporter; |
## require AutoLoader; |
@ISA = qw( Exporter Win32API::CommPort ); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= @Win32API::CommPort::EXPORT_OK; |
%EXPORT_TAGS = %Win32API::CommPort::EXPORT_TAGS; |
# parameters that must be included in a "save" and "checking subs" |
my %validate = ( |
ALIAS => "alias", |
BAUD => "baudrate", |
BINARY => "binary", |
DATA => "databits", |
E_MSG => "error_msg", |
EOFCHAR => "eof_char", |
ERRCHAR => "error_char", |
EVTCHAR => "event_char", |
HSHAKE => "handshake", |
PARITY => "parity", |
PARITY_EN => "parity_enable", |
RCONST => "read_const_time", |
READBUF => "set_read_buf", |
RINT => "read_interval", |
RTOT => "read_char_time", |
STOP => "stopbits", |
U_MSG => "user_msg", |
WCONST => "write_const_time", |
WRITEBUF => "set_write_buf", |
WTOT => "write_char_time", |
XOFFCHAR => "xoff_char", |
XOFFLIM => "xoff_limit", |
XONCHAR => "xon_char", |
XONLIM => "xon_limit", |
intr => "is_stty_intr", |
quit => "is_stty_quit", |
s_eof => "is_stty_eof", |
eol => "is_stty_eol", |
erase => "is_stty_erase", |
s_kill => "is_stty_kill", |
bsdel => "stty_bsdel", |
clear => "is_stty_clear", |
echo => "stty_echo", |
echoe => "stty_echoe", |
echok => "stty_echok", |
echonl => "stty_echonl", |
echoke => "stty_echoke", |
echoctl => "stty_echoctl", |
istrip => "stty_istrip", |
icrnl => "stty_icrnl", |
ocrnl => "stty_ocrnl", |
opost => "stty_opost", |
igncr => "stty_igncr", |
inlcr => "stty_inlcr", |
onlcr => "stty_onlcr", |
isig => "stty_isig", |
icanon => "stty_icanon", |
DVTYPE => "devicetype", |
HNAME => "hostname", |
HADDR => "hostaddr", |
DATYPE => "datatype", |
CFG_1 => "cfg_param_1", |
CFG_2 => "cfg_param_2", |
CFG_3 => "cfg_param_3", |
); |
# parameters supported by the stty method |
my %opts = ( "intr" => "is_stty_intr:argv_char", |
"quit" => "is_stty_quit:argv_char", |
"eof" => "is_stty_eof:argv_char", |
"eol" => "is_stty_eol:argv_char", |
"erase" => "is_stty_erase:argv_char", |
"kill" => "is_stty_kill:argv_char", |
"echo" => "stty_echo:1", |
"-echo" => "stty_echo:0", |
"echoe" => "stty_echoe:1", |
"-echoe" => "stty_echoe:0", |
"echok" => "stty_echok:1", |
"-echok" => "stty_echok:0", |
"echonl" => "stty_echonl:1", |
"-echonl" => "stty_echonl:0", |
"echoke" => "stty_echoke:1", |
"-echoke" => "stty_echoke:0", |
"echoctl" => "stty_echoctl:1", |
"-echoctl" => "stty_echoctl:0", |
"istrip" => "stty_istrip:1", |
"-istrip" => "stty_istrip:0", |
"icrnl" => "stty_icrnl:1", |
"-icrnl" => "stty_icrnl:0", |
"ocrnl" => "stty_ocrnl:1", |
"-ocrnl" => "stty_ocrnl:0", |
"igncr" => "stty_igncr:1", |
"-igncr" => "stty_igncr:0", |
"inlcr" => "stty_inlcr:1", |
"-inlcr" => "stty_inlcr:0", |
"onlcr" => "stty_onlcr:1", |
"-onlcr" => "stty_onlcr:0", |
"opost" => "stty_opost:1", |
"-opost" => "stty_opost:0", |
"isig" => "stty_isig:1", |
"-isig" => "stty_isig:0", |
"icanon" => "stty_icanon:1", |
"-icanon" => "stty_icanon:0", |
"parenb" => "parity_enable:1", |
"-parenb" => "parity_enable:0", |
"inpck" => "parity_enable:1", |
"-inpck" => "parity:none", |
"cs5" => "databits:5", |
"cs6" => "databits:6", |
"cs7" => "databits:7", |
"cs8" => "databits:8", |
"cstopb" => "stopbits:2", |
"-cstopb" => "stopbits:1", |
"parodd" => "parity:odd", |
"-parodd" => "parity:even", |
"clocal" => "handshake:none", |
"-clocal" => "handshake:dtr", |
"crtscts" => "handshake:rts", |
"-crtscts" => "handshake:none", |
"ixon" => "handshake:xoff", |
"-ixon" => "handshake:none", |
"ixoff" => "handshake:xoff", |
"-ixoff" => "handshake:none", |
"start" => "xon_char:argv_char", |
"stop" => "xoff_char:argv_char", |
); |
#### Package variable declarations #### |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $cfg_file_sig="Win32::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
my $Verbose = 0; |
# test*.t only - suppresses default messages |
sub set_test_mode_active { |
return unless (@_ == 2); |
Win32API::CommPort->set_no_messages($_[1]); |
# object not defined but :: upsets strict |
return (keys %validate); |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $device = shift; |
my @new_cmd = ($device); |
my $quiet = shift; |
if ($quiet) { |
push @new_cmd, 1; |
} |
my $self = $class->SUPER::new(@new_cmd); |
unless ($self) { |
return 0 if ($quiet); |
return; |
} |
# "private" data |
$self->{"_DEBUG"} = 0; |
$self->{U_MSG} = 0; |
$self->{E_MSG} = 0; |
$self->{OFS} = ""; |
$self->{ORS} = ""; |
$self->{"_T_INPUT"} = ""; |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
$self->{"_LASTLINE"} = ""; |
$self->{"_CLASTLINE"} = ""; |
$self->{"_SIZE"} = 1; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
$self->{"_PROMPT"} = ""; |
$self->{"_MATCH"} = []; |
$self->{"_CMATCH"} = []; |
@{ $self->{"_MATCH"} } = "\n"; |
@{ $self->{"_CMATCH"} } = "\n"; |
$self->{DVTYPE} = "none"; |
$self->{HNAME} = "localhost"; |
$self->{HADDR} = 0; |
$self->{DATYPE} = "raw"; |
$self->{CFG_1} = "none"; |
$self->{CFG_2} = "none"; |
$self->{CFG_3} = "none"; |
# user settable options for lookfor (the "stty" collection) |
# defaults like RedHat linux unless indicated |
# char to abort nextline subroutine |
$self->{intr} = "\cC"; # MUST be single char |
# char to abort perl |
$self->{quit} = "\cD"; # MUST be single char |
# end_of_file char (linux typ: "\cD") |
$self->{s_eof} = "\cZ"; # MUST be single char |
# end_of_line char |
$self->{eol} = "\cJ"; # MUST be single char |
# delete one character from buffer (backspace) |
$self->{erase} = "\cH"; # MUST be single char |
# clear line buffer |
$self->{s_kill} = "\cU"; # MUST be single char |
# written after erase character |
$self->{bsdel} = "\cH \cH"; |
# written after kill character |
my $space76 = " "x76; |
$self->{clear} = "\r$space76\r"; # 76 spaces |
# echo every character |
$self->{echo} = 0; |
# echo erase character with bsdel string |
$self->{echoe} = 1; |
# echo \n after kill character |
$self->{echok} = 1; |
# echo \n |
$self->{echonl} = 0; |
# echo clear string after kill character |
$self->{echoke} = 1; # linux console yes, serial no |
# echo "^Char" for control chars |
$self->{echoctl} = 0; # linux console yes, serial no |
# strip input to 7-bits |
$self->{istrip} = 0; |
# map \r to \n on input |
$self->{icrnl} = 0; |
# map \r to \n on output |
$self->{ocrnl} = 0; |
# ignore \r on input |
$self->{igncr} = 0; |
# map \n to \r on input |
$self->{inlcr} = 0; |
# map \n to \r\n on output |
$self->{onlcr} = 1; |
# enable output mapping |
$self->{opost} = 0; |
# enable quit and intr characters |
$self->{isig} = 0; # linux actually SUPPORTS signals |
# enable erase and kill characters |
$self->{icanon} = 0; |
my $token; |
my @bauds = $self->are_baudrate; |
foreach $token (@bauds) { $opts{$token} = "baudrate:$token"; } |
# initialize (in CommPort) and write_settings need these defined |
$self->{"_N_U_MSG"} = 0; |
$self->{"_N_E_MSG"} = 0; |
$self->{"_N_ALIAS"} = 0; |
$self->{"_N_intr"} = 0; |
$self->{"_N_quit"} = 0; |
$self->{"_N_s_eof"} = 0; |
$self->{"_N_eol"} = 0; |
$self->{"_N_erase"} = 0; |
$self->{"_N_s_kill"} = 0; |
$self->{"_N_bsdel"} = 0; |
$self->{"_N_clear"} = 0; |
$self->{"_N_echo"} = 0; |
$self->{"_N_echoe"} = 0; |
$self->{"_N_echok"} = 0; |
$self->{"_N_echonl"} = 0; |
$self->{"_N_echoke"} = 0; |
$self->{"_N_echoctl"} = 0; |
$self->{"_N_istrip"} = 0; |
$self->{"_N_icrnl"} = 0; |
$self->{"_N_ocrnl"} = 0; |
$self->{"_N_opost"} = 0; |
$self->{"_N_igncr"} = 0; |
$self->{"_N_inlcr"} = 0; |
$self->{"_N_onlcr"} = 0; |
$self->{"_N_isig"} = 0; |
$self->{"_N_icanon"} = 0; |
$self->{"_N_DVTYPE"} = 0; |
$self->{"_N_HNAME"} = 0; |
$self->{"_N_HADDR"} = 0; |
$self->{"_N_DATYPE"} = 0; |
$self->{"_N_CFG_1"} = 0; |
$self->{"_N_CFG_2"} = 0; |
$self->{"_N_CFG_3"} = 0; |
$self->{ALIAS} = $device; # so "\\.\+++" can be changed |
$self->{DEVICE} = $device; # clone so NAME stays in CommPort |
($self->{MAX_RXB}, $self->{MAX_TXB}) = $self->buffer_max; |
bless ($self, $class); |
return $self; |
} |
sub stty_intr { |
my $self = shift; |
if (@_ == 1) { $self->{intr} = shift; } |
return if (@_); |
return $self->{intr}; |
} |
sub stty_quit { |
my $self = shift; |
if (@_ == 1) { $self->{quit} = shift; } |
return if (@_); |
return $self->{quit}; |
} |
sub is_stty_eof { |
my $self = shift; |
if (@_ == 1) { $self->{s_eof} = chr(shift); } |
return if (@_); |
return ord($self->{s_eof}); |
} |
sub is_stty_eol { |
my $self = shift; |
if (@_ == 1) { $self->{eol} = chr(shift); } |
return if (@_); |
return ord($self->{eol}); |
} |
sub is_stty_quit { |
my $self = shift; |
if (@_ == 1) { $self->{quit} = chr(shift); } |
return if (@_); |
return ord($self->{quit}); |
} |
sub is_stty_intr { |
my $self = shift; |
if (@_ == 1) { $self->{intr} = chr(shift); } |
return if (@_); |
return ord($self->{intr}); |
} |
sub is_stty_erase { |
my $self = shift; |
if (@_ == 1) { $self->{erase} = chr(shift); } |
return if (@_); |
return ord($self->{erase}); |
} |
sub is_stty_kill { |
my $self = shift; |
if (@_ == 1) { $self->{s_kill} = chr(shift); } |
return if (@_); |
return ord($self->{s_kill}); |
} |
sub is_stty_clear { |
my $self = shift; |
my @chars; |
if (@_ == 1) { |
@chars = split (//, shift); |
for (@chars) { |
$_ = chr ( ord($_) - 32 ); |
} |
$self->{clear} = join("", @chars); |
return $self->{clear}; |
} |
return if (@_); |
@chars = split (//, $self->{clear}); |
for (@chars) { |
$_ = chr ( ord($_) + 32 ); |
} |
my $permute = join("", @chars); |
return $permute; |
} |
sub stty_eof { |
my $self = shift; |
if (@_ == 1) { $self->{s_eof} = shift; } |
return if (@_); |
return $self->{s_eof}; |
} |
sub stty_eol { |
my $self = shift; |
if (@_ == 1) { $self->{eol} = shift; } |
return if (@_); |
return $self->{eol}; |
} |
sub stty_erase { |
my $self = shift; |
if (@_ == 1) { |
my $tmp = shift; |
return unless (length($tmp) == 1); |
$self->{erase} = $tmp; |
} |
return if (@_); |
return $self->{erase}; |
} |
sub stty_kill { |
my $self = shift; |
if (@_ == 1) { |
my $tmp = shift; |
return unless (length($tmp) == 1); |
$self->{s_kill} = $tmp; |
} |
return if (@_); |
return $self->{s_kill}; |
} |
sub stty_bsdel { |
my $self = shift; |
if (@_ == 1) { $self->{bsdel} = shift; } |
return if (@_); |
return $self->{bsdel}; |
} |
sub stty_clear { |
my $self = shift; |
if (@_ == 1) { $self->{clear} = shift; } |
return if (@_); |
return $self->{clear}; |
} |
sub stty_echo { |
my $self = shift; |
if (@_ == 1) { $self->{echo} = yes_true ( shift ) } |
return if (@_); |
return $self->{echo}; |
} |
sub stty_echoe { |
my $self = shift; |
if (@_ == 1) { $self->{echoe} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoe}; |
} |
sub stty_echok { |
my $self = shift; |
if (@_ == 1) { $self->{echok} = yes_true ( shift ) } |
return if (@_); |
return $self->{echok}; |
} |
sub stty_echonl { |
my $self = shift; |
if (@_ == 1) { $self->{echonl} = yes_true ( shift ) } |
return if (@_); |
return $self->{echonl}; |
} |
sub stty_echoke { |
my $self = shift; |
if (@_ == 1) { $self->{echoke} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoke}; |
} |
sub stty_echoctl { |
my $self = shift; |
if (@_ == 1) { $self->{echoctl} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoctl}; |
} |
sub stty_istrip { |
my $self = shift; |
if (@_ == 1) { $self->{istrip} = yes_true ( shift ) } |
return if (@_); |
return $self->{istrip}; |
} |
sub stty_icrnl { |
my $self = shift; |
if (@_ == 1) { $self->{icrnl} = yes_true ( shift ) } |
return if (@_); |
return $self->{icrnl}; |
} |
sub stty_ocrnl { |
my $self = shift; |
if (@_ == 1) { $self->{ocrnl} = yes_true ( shift ) } |
return if (@_); |
return $self->{ocrnl}; |
} |
sub stty_opost { |
my $self = shift; |
if (@_ == 1) { $self->{opost} = yes_true ( shift ) } |
return if (@_); |
return $self->{opost}; |
} |
sub stty_igncr { |
my $self = shift; |
if (@_ == 1) { $self->{igncr} = yes_true ( shift ) } |
return if (@_); |
return $self->{igncr}; |
} |
sub stty_inlcr { |
my $self = shift; |
if (@_ == 1) { $self->{inlcr} = yes_true ( shift ) } |
return if (@_); |
return $self->{inlcr}; |
} |
sub stty_onlcr { |
my $self = shift; |
if (@_ == 1) { $self->{onlcr} = yes_true ( shift ) } |
return if (@_); |
return $self->{onlcr}; |
} |
sub stty_isig { |
my $self = shift; |
if (@_ == 1) { $self->{isig} = yes_true ( shift ) } |
return if (@_); |
return $self->{isig}; |
} |
sub stty_icanon { |
my $self = shift; |
if (@_ == 1) { $self->{icanon} = yes_true ( shift ) } |
return if (@_); |
return $self->{icanon}; |
} |
sub is_prompt { |
my $self = shift; |
if (@_ == 1) { $self->{"_PROMPT"} = shift; } |
return if (@_); |
return $self->{"_PROMPT"}; |
} |
sub are_match { |
my $self = shift; |
my $pat; |
my $patno = 0; |
my $reno = 0; |
my $re_next = 0; |
if (@_) { |
@{ $self->{"_MATCH"} } = @_; |
if ($] >= 5.005) { |
@{ $self->{"_CMATCH"} } = (); |
while ($pat = shift) { |
if ($re_next) { |
$re_next = 0; |
eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)'; |
} else { |
push (@{ $self->{"_CMATCH"} }, $pat); |
} |
if ($pat eq "-re") { |
$re_next++; |
} |
} |
} else { |
@{ $self->{"_CMATCH"} } = @_; |
} |
} |
return @{ $self->{"_MATCH"} }; |
} |
# parse values for start/restart |
sub get_start_values { |
return unless (@_ == 2); |
my $self = shift; |
my $filename = shift; |
unless ( open CF, "<$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
my ($signature, $name, @values) = <CF>; |
close CF; |
unless ( $cfg_file_sig eq $signature ) { |
carp "Invalid signature in $filename: $signature"; |
return; |
} |
chomp $name; |
unless ( $self->{DEVICE} eq $name ) { |
carp "Invalid Port DEVICE=$self->{DEVICE} in $filename: $name"; |
return; |
} |
if ($Verbose or not $self) { |
print "signature = $signature"; |
print "name = $name\n"; |
if ($Verbose) { |
print "values:\n"; |
foreach (@values) { print " $_"; } |
} |
} |
my $item; |
my $key; |
my $value; |
my $gosub; |
my $fault = 0; |
no strict 'refs'; # for $gosub |
foreach $item (@values) { |
chomp $item; |
($key, $value) = split (/,/, $item); |
if ($value eq "") { $fault++ } |
else { |
$gosub = $validate{$key}; |
unless (defined &$gosub ($self, $value)) { |
carp "Invalid parameter for $key=$value "; |
return; |
} |
} |
} |
use strict 'refs'; |
if ($fault) { |
carp "Invalid value in $filename"; |
undef $self; |
return; |
} |
1; |
} |
sub restart { |
return unless (@_ == 2); |
my $self = shift; |
my $filename = shift; |
unless ( $self->init_done ) { |
carp "Can't restart before Port has been initialized"; |
return; |
} |
get_start_values($self, $filename); |
write_settings($self); |
} |
sub start { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
return unless (@_); |
my $filename = shift; |
unless ( open CF, "<$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
my ($signature, $name, @values) = <CF>; |
close CF; |
unless ( $cfg_file_sig eq $signature ) { |
carp "Invalid signature in $filename: $signature"; |
return; |
} |
chomp $name; |
my $self = new ($class, $name); |
if ($Verbose or not $self) { |
print "signature = $signature"; |
print "class = $class\n"; |
print "name = $name\n"; |
if ($Verbose) { |
print "values:\n"; |
foreach (@values) { print " $_"; } |
} |
} |
if ($self) { |
if ( get_start_values($self, $filename) ) { |
write_settings ($self); |
} |
else { |
carp "Invalid value in $filename"; |
undef $self; |
return; |
} |
} |
return $self; |
} |
sub write_settings { |
my $self = shift; |
my @items = keys %validate; |
# initialize returns number of faults |
if ( $self->initialize(@items) ) { |
unless (nocarp) { |
carp "write_settings failed, closing port"; |
$self->close; |
} |
return; |
} |
$self->update_DCB; |
if ($Verbose) { |
print "writing settings to $self->{ALIAS}\n"; |
} |
1; |
} |
sub save { |
my $self = shift; |
my $item; |
my $getsub; |
my $value; |
return unless (@_); |
unless ($self->init_done) { |
carp "can't save until init_done"; |
return; |
} |
my $filename = shift; |
unless ( open CF, ">$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
print CF "$cfg_file_sig"; |
print CF "$self->{DEVICE}\n"; |
# used to "reopen" so must be DEVICE=NAME |
no strict 'refs'; # for $gosub |
while (($item, $getsub) = each %validate) { |
chomp $getsub; |
$value = scalar &$getsub($self); |
print CF "$item,$value\n"; |
} |
use strict 'refs'; |
close CF; |
if ($Verbose) { |
print "wrote file $filename for $self->{ALIAS}\n"; |
} |
1; |
} |
##### tied FileHandle support |
sub TIEHANDLE { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
return unless (@_); |
my $self = start($class, shift); |
return $self; |
} |
# WRITE this, LIST |
# This method will be called when the handle is written to via the |
# syswrite function. |
sub WRITE { |
return if (@_ < 3); |
my $self = shift; |
my $buf = shift; |
my $len = shift; |
my $offset = 0; |
if (@_) { $offset = shift; } |
my $out2 = substr($buf, $offset, $len); |
return unless ($self->post_print($out2)); |
return length($out2); |
} |
# PRINT this, LIST |
# This method will be triggered every time the tied handle is printed to |
# with the print() function. Beyond its self reference it also expects |
# the list that was passed to the print function. |
sub PRINT { |
my $self = shift; |
return unless (@_); |
my $ofs = $, ? $, : ""; |
if ($self->{OFS}) { $ofs = $self->{OFS}; } |
my $ors = $\ ? $\ : ""; |
if ($self->{ORS}) { $ors = $self->{ORS}; } |
my $output = join($ofs,@_); |
$output .= $ors; |
return $self->post_print($output); |
} |
sub output_field_separator { |
my $self = shift; |
my $prev = $self->{OFS}; |
if (@_) { $self->{OFS} = shift; } |
return $prev; |
} |
sub output_record_separator { |
my $self = shift; |
my $prev = $self->{ORS}; |
if (@_) { $self->{ORS} = shift; } |
return $prev; |
} |
sub post_print { |
my $self = shift; |
return unless (@_); |
my $output = shift; |
if ($self->stty_opost) { |
if ($self->stty_ocrnl) { $output =~ s/\r/\n/osg; } |
if ($self->stty_onlcr) { $output =~ s/\n/\r\n/osg; } |
} |
my $to_do = length($output); |
my $done = 0; |
my $written = 0; |
while ($done < $to_do) { |
my $out2 = substr($output, $done); |
$written = $self->write($out2); |
if (! defined $written) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
return 0 unless ($written); |
$done += $written; |
} |
$^E = 0; |
1; |
} |
# PRINTF this, LIST |
# This method will be triggered every time the tied handle is printed to |
# with the printf() function. Beyond its self reference it also expects |
# the format and list that was passed to the printf function. |
sub PRINTF { |
my $self = shift; |
my $fmt = shift; |
return unless ($fmt); |
return unless (@_); |
my $output = sprintf($fmt, @_); |
$self->PRINT($output); |
} |
# READ this, LIST |
# This method will be called when the handle is read from via the read |
# or sysread functions. |
sub READ { |
return if (@_ < 3); |
my $buf = \$_[1]; |
my ($self, $junk, $len, $offset) = @_; |
unless (defined $offset) { $offset = 0; } |
my $done = 0; |
my $count_in = 0; |
my $string_in = ""; |
my $in2 = ""; |
my $bufsize = $self->internal_buffer; |
while ($done < $len) { |
my $size = $len - $done; |
if ($size > $bufsize) { $size = $bufsize; } |
($count_in, $string_in) = $self->read($size); |
if ($count_in) { |
$in2 .= $string_in; |
$done += $count_in; |
$^E = 0; |
} |
elsif ($done) { |
$^E = 0; |
last; |
} |
else { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
last; |
} |
} |
my $tail = substr($$buf, $offset + $done); |
my $head = substr($$buf, 0, $offset); |
if ($self->{icrnl}) { $in2 =~ tr/\r/\n/; } |
if ($self->{inlcr}) { $in2 =~ tr/\n/\r/; } |
if ($self->{igncr}) { $in2 =~ s/\r//gos; } |
$$buf = $head.$in2.$tail; |
return $done if ($done); |
return; |
} |
# READLINE this |
# This method will be called when the handle is read from via <HANDLE>. |
# The method should return undef when there is no more data. |
sub READLINE { |
my $self = shift; |
return if (@_); |
my $gotit = ""; |
my $match = ""; |
my $was; |
if (wantarray) { |
my @lines; |
for (;;) { |
$was = $self->reset_error; |
if ($was) { |
$^E = 1117; # ERROR_IO_DEVICE |
return @lines if (@lines); |
return; |
} |
if (! defined ($gotit = $self->streamline($self->{"_SIZE"}))) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return @lines if (@lines); |
return; |
} |
$match = $self->matchclear; |
if ( ($gotit ne "") || ($match ne "") ) { |
$^E = 0; |
$gotit .= $match; |
push (@lines, $gotit); |
return @lines if ($gotit =~ /$self->{"_CLASTLINE"}/s); |
} |
} |
} |
else { |
for (;;) { |
$was = $self->reset_error; |
if ($was) { |
$^E = 1117; # ERROR_IO_DEVICE |
return; |
} |
if (! defined ($gotit = $self->lookfor($self->{"_SIZE"}))) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
$match = $self->matchclear; |
if ( ($gotit ne "") || ($match ne "") ) { |
$^E = 0; |
return $gotit.$match; # traditional <HANDLE> behavior |
} |
} |
} |
} |
# GETC this |
# This method will be called when the getc function is called. |
sub GETC { |
my $self = shift; |
my ($count, $in) = $self->read(1); |
if ($count == 1) { |
$^E = 0; |
return $in; |
} |
else { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
} |
# CLOSE this |
# This method will be called when the handle is closed via the close |
# function. |
sub CLOSE { |
my $self = shift; |
my $success = $self->close; |
if ($Verbose) { printf "CLOSE result:%d\n", $success; } |
return $success; |
} |
# DESTROY this |
# As with the other types of ties, this method will be called when the |
# tied handle is about to be destroyed. This is useful for debugging and |
# possibly cleaning up. |
sub DESTROY { |
my $self = shift; |
if ($Verbose) { print "SerialPort::DESTROY called.\n"; } |
$self->SUPER::DESTROY(); |
} |
############### |
sub alias { |
my $self = shift; |
if (@_) { $self->{ALIAS} = shift; } # should return true for legal names |
return $self->{ALIAS}; |
} |
sub user_msg { |
my $self = shift; |
if (@_) { $self->{U_MSG} = yes_true ( shift ) } |
return wantarray ? @binary_opt : $self->{U_MSG}; |
} |
sub error_msg { |
my $self = shift; |
if (@_) { $self->{E_MSG} = yes_true ( shift ) } |
return wantarray ? @binary_opt : $self->{E_MSG}; |
} |
sub devicetype { |
my $self = shift; |
if (@_) { $self->{DVTYPE} = shift; } # return true for legal names |
return $self->{DVTYPE}; |
} |
sub hostname { |
my $self = shift; |
if (@_) { $self->{HNAME} = shift; } # return true for legal names |
return $self->{HNAME}; |
} |
sub hostaddr { |
my $self = shift; |
if (@_) { $self->{HADDR} = shift; } # return true for assigned port |
return $self->{HADDR}; |
} |
sub datatype { |
my $self = shift; |
if (@_) { $self->{DATYPE} = shift; } # return true for legal types |
return $self->{DATYPE}; |
} |
sub cfg_param_1 { |
my $self = shift; |
if (@_) { $self->{CFG_1} = shift; } # return true for legal param |
return $self->{CFG_1}; |
} |
sub cfg_param_2 { |
my $self = shift; |
if (@_) { $self->{CFG_2} = shift; } # return true for legal param |
return $self->{CFG_2}; |
} |
sub cfg_param_3 { |
my $self = shift; |
if (@_) { $self->{CFG_3} = shift; } # return true for legal param |
return $self->{CFG_3}; |
} |
sub baudrate { |
my $self = shift; |
if (@_) { |
unless ( defined $self->is_baudrate( shift ) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set baudrate on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_baudrate : $self->is_baudrate; |
} |
sub status { |
my $self = shift; |
my $ok = 0; |
my $fmask = 0; |
my $v1 = $Verbose | $self->{"_DEBUG"}; |
my $v2 = $v1 | $self->{U_MSG}; |
my $v3 = $v1 | $self->{E_MSG}; |
my @stat = $self->is_status; |
return unless (scalar @stat); |
$fmask=$stat[ST_BLOCK]; |
if ($v1) { printf "BlockingFlags= %lx\n", $fmask; } |
if ($v2 && $fmask) { |
printf "Waiting for CTS\n" if ($fmask & BM_fCtsHold); |
printf "Waiting for DSR\n" if ($fmask & BM_fDsrHold); |
printf "Waiting for RLSD\n" if ($fmask & BM_fRlsdHold); |
printf "Waiting for XON\n" if ($fmask & BM_fXoffHold); |
printf "Waiting, XOFF was sent\n" if ($fmask & BM_fXoffSent); |
printf "End_of_File received\n" if ($fmask & BM_fEof); |
printf "Character waiting to TX\n" if ($fmask & BM_fTxim); |
} |
$fmask=$stat[ST_ERROR]; |
if ($v1) { printf "Error_BitMask= %lx\n", $fmask; } |
if ($v3 && $fmask) { |
# only prints if error is new (API resets each call) |
printf "Invalid MODE or bad HANDLE\n" if ($fmask & CE_MODE); |
printf "Receive Overrun detected\n" if ($fmask & CE_RXOVER); |
printf "Buffer Overrun detected\n" if ($fmask & CE_OVERRUN); |
printf "Parity Error detected\n" if ($fmask & CE_RXPARITY); |
printf "Framing Error detected\n" if ($fmask & CE_FRAME); |
printf "Break Signal detected\n" if ($fmask & CE_BREAK); |
printf "Transmit Buffer is full\n" if ($fmask & CE_TXFULL); |
} |
return @stat; |
} |
sub handshake { |
my $self = shift; |
if (@_) { |
unless ( $self->is_handshake(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set handshake on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_handshake : $self->is_handshake; |
} |
sub parity { |
my $self = shift; |
if (@_) { |
unless ( $self->is_parity(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set parity on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_parity : $self->is_parity; |
} |
sub databits { |
my $self = shift; |
if (@_) { |
unless ( $self->is_databits(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set databits on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_databits : $self->is_databits; |
} |
sub stopbits { |
my $self = shift; |
if (@_) { |
unless ( $self->is_stopbits(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set stopbits on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_stopbits : $self->is_stopbits; |
} |
# single value for save/start |
sub set_read_buf { |
my $self = shift; |
if (@_) { |
return unless (@_ == 1); |
my $rbuf = int shift; |
return unless (($rbuf > 0) and ($rbuf <= $self->{MAX_RXB})); |
$self->is_read_buf($rbuf); |
} |
return $self->is_read_buf; |
} |
# single value for save/start |
sub set_write_buf { |
my $self = shift; |
if (@_) { |
return unless (@_ == 1); |
my $wbuf = int shift; |
return unless (($wbuf >= 0) and ($wbuf <= $self->{MAX_TXB})); |
$self->is_write_buf($wbuf); |
} |
return $self->is_write_buf; |
} |
sub buffers { |
my $self = shift; |
if (@_ == 2) { |
my $rbuf = shift; |
my $wbuf = shift; |
unless (defined set_read_buf ($self, $rbuf)) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Can't set read buffer on $self->{ALIAS}"; |
} |
return; |
} |
unless (defined set_write_buf ($self, $wbuf)) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Can't set write buffer on $self->{ALIAS}"; |
} |
return; |
} |
$self->is_buffers($rbuf, $wbuf) || return; |
} |
elsif (@_) { return; } |
return wantarray ? $self->are_buffers : 1; |
} |
sub read { |
return unless (@_ == 2); |
my $self = shift; |
my $wanted = shift; |
my $ok = 0; |
my $result = ""; |
return unless ($wanted > 0); |
my $got = $self->read_bg ($wanted); |
if ($got != $wanted) { |
($ok, $got, $result) = $self->read_done(1); # block until done |
} |
else { ($ok, $got, $result) = $self->read_done(0); } |
print "read=$got\n" if ($Verbose); |
return ($got, $result); |
} |
sub lookclear { |
my $self = shift; |
if (nocarp && (@_ == 1)) { |
$self->{"_T_INPUT"} = shift; |
} |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
return if (@_); |
1; |
} |
sub linesize { |
my $self = shift; |
if (@_) { |
my $val = int shift; |
return if ($val < 0); |
$self->{"_SIZE"} = $val; |
} |
return $self->{"_SIZE"}; |
} |
sub lastline { |
my $self = shift; |
if (@_) { |
$self->{"_LASTLINE"} = shift; |
if ($] >= 5.005) { |
eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/'; |
} else { |
$self->{"_CLASTLINE"} = $self->{"_LASTLINE"}; |
} |
} |
return $self->{"_LASTLINE"}; |
} |
sub matchclear { |
my $self = shift; |
my $found = $self->{"_LMATCH"}; |
$self->{"_LMATCH"} = ""; |
return if (@_); |
return $found; |
} |
sub lastlook { |
my $self = shift; |
return if (@_); |
return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"}, |
$self->{"_LPATT"}, $self->{"_LOOK"} ); |
} |
sub lookfor { |
my $self = shift; |
my $size = 0; |
if (@_) { $size = shift; } |
my $loc = ""; |
my $count_in = 0; |
my $string_in = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
if ( ! $self->{"_LOOK"} ) { |
$loc = $self->{"_LASTLOOK"}; |
} |
if ($size) { |
my ($bbb, $iii, $ooo, $eee) = status($self); |
if ($iii > $size) { $size = $iii; } |
($count_in, $string_in) = $self->read($size); |
return unless ($count_in); |
$loc .= $string_in; |
} |
else { |
$loc .= $self->input; |
} |
if ($loc ne "") { |
if ($self->{icrnl}) { $loc =~ tr/\r/\n/; } |
my $n_char; |
my $mpos; |
my $erase_is_bsdel = 0; |
my $nl_after_kill = ""; |
my $clear_after_kill = 0; |
my $echo_ctl = 0; |
my $lookbuf; |
my $re_next = 0; |
my $got_match = 0; |
my $pat; |
my $lf_erase = ""; |
my $lf_kill = ""; |
my $lf_eof = ""; |
my $lf_quit = ""; |
my $lf_intr = ""; |
my $nl_2_crnl = 0; |
my $cr_2_nl = 0; |
if ($self->{opost}) { |
$nl_2_crnl = $self->{onlcr}; |
$cr_2_nl = $self->{ocrnl}; |
} |
if ($self->{echo}) { |
$erase_is_bsdel = $self->{echoe}; |
if ($self->{echok}) { |
$nl_after_kill = $self->{onlcr} ? "\r\n" : "\n"; |
} |
$clear_after_kill = $self->{echoke}; |
$echo_ctl = $self->{echoctl}; |
} |
if ($self->{icanon}) { |
$lf_erase = $self->{erase}; |
$lf_kill = $self->{s_kill}; |
$lf_eof = $self->{s_eof}; |
} |
if ($self->{isig}) { |
$lf_quit = $self->{quit}; |
$lf_intr = $self->{intr}; |
} |
my @loc_char = split (//, $loc); |
while (defined ($n_char = shift @loc_char)) { |
## printf STDERR "0x%x ", ord($n_char); |
if ($n_char eq $lf_erase) { |
if ($erase_is_bsdel && (length $self->{"_LOOK"}) ) { |
$mpos = chop $self->{"_LOOK"}; |
$self->write($self->{bsdel}); |
if ($echo_ctl && (($mpos lt "@")|($mpos eq chr(127)))) { |
$self->write($self->{bsdel}); |
} |
} |
} |
elsif ($n_char eq $lf_kill) { |
$self->{"_LOOK"} = ""; |
$self->write($self->{clear}) if ($clear_after_kill); |
$self->write($nl_after_kill); |
$self->write($self->{"_PROMPT"}); |
} |
elsif ($n_char eq $lf_intr) { |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
return; |
} |
elsif ($n_char eq $lf_quit) { |
exit; |
} |
else { |
$mpos = ord $n_char; |
if ($self->{istrip}) { |
if ($mpos > 127) { $n_char = chr($mpos - 128); } |
} |
$self->{"_LOOK"} .= $n_char; |
## print $n_char; |
if ($cr_2_nl) { $n_char =~ s/\r/\n/os; } |
if ($nl_2_crnl) { $n_char =~ s/\n/\r\n/os; } |
if (($mpos < 32) && $echo_ctl && |
($mpos != is_stty_eol($self))) { |
$n_char = chr($mpos + 64); |
$self->write("^$n_char"); |
} |
elsif (($mpos == 127) && $echo_ctl) { |
$self->write("^."); |
} |
elsif ($self->{echonl} && ($n_char =~ "\n")) { |
# also writes "\r\n" for onlcr |
$self->write($n_char); |
} |
elsif ($self->{echo}) { |
# also writes "\r\n" for onlcr |
$self->write($n_char); |
} |
$lookbuf = $self->{"_LOOK"}; |
if (($lf_eof ne "") and ($lookbuf =~ /$lf_eof$/)) { |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
return $lookbuf; |
} |
$count_in = 0; |
foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
if ($pat eq "-re") { |
$re_next++; |
$count_in++; |
next; |
} |
if ($re_next) { |
$re_next = 0; |
# always at $lookbuf end when processing single char |
if ( $lookbuf =~ s/$pat//s ) { |
$self->{"_LMATCH"} = $&; |
$got_match++; |
} |
} |
elsif (($mpos = index($lookbuf, $pat)) > -1) { |
$got_match++; |
$lookbuf = substr ($lookbuf, 0, $mpos); |
$self->{"_LMATCH"} = $pat; |
} |
if ($got_match) { |
$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
if (scalar @loc_char) { |
$self->{"_LASTLOOK"} = join("", @loc_char); |
## print ".$self->{\"_LASTLOOK\"}."; |
} |
else { |
$self->{"_LASTLOOK"} = ""; |
} |
$self->{"_LOOK"} = ""; |
return $lookbuf; |
} |
$count_in++; |
} |
} |
} |
} |
return ""; |
} |
sub streamline { |
my $self = shift; |
my $size = 0; |
if (@_) { $size = shift; } |
my $loc = ""; |
my $mpos; |
my $count_in = 0; |
my $string_in = ""; |
my $re_next = 0; |
my $got_match = 0; |
my $best_pos = 0; |
my $pat; |
my $match = ""; |
my $before = ""; |
my $after = ""; |
my $best_match = ""; |
my $best_before = ""; |
my $best_after = ""; |
my $best_pat = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
if ( ! $self->{"_LOOK"} ) { |
$loc = $self->{"_LASTLOOK"}; |
} |
if ($size) { |
my ($bbb, $iii, $ooo, $eee) = status($self); |
if ($iii > $size) { $size = $iii; } |
($count_in, $string_in) = $self->read($size); |
return unless ($count_in); |
$loc .= $string_in; |
} |
else { |
$loc .= $self->input; |
} |
if ($loc ne "") { |
$self->{"_LOOK"} .= $loc; |
$count_in = 0; |
foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
if ($pat eq "-re") { |
$re_next++; |
$count_in++; |
next; |
} |
if ($re_next) { |
$re_next = 0; |
if ( $self->{"_LOOK"} =~ /$pat/s ) { |
( $match, $before, $after ) = ( $&, $`, $' ); |
$got_match++; |
$mpos = length($before); |
if ($mpos) { |
next if ($best_pos && ($mpos > $best_pos)); |
$best_pos = $mpos; |
$best_pat = $self->{"_MATCH"}[$count_in]; |
$best_match = $match; |
$best_before = $before; |
$best_after = $after; |
} else { |
$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
$self->{"_LMATCH"} = $match; |
$self->{"_LASTLOOK"} = $after; |
$self->{"_LOOK"} = ""; |
return $before; |
# pattern at start will be best |
} |
} |
} |
elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) { |
$got_match++; |
$before = substr ($self->{"_LOOK"}, 0, $mpos); |
if ($mpos) { |
next if ($best_pos && ($mpos > $best_pos)); |
$best_pos = $mpos; |
$best_pat = $pat; |
$best_match = $pat; |
$best_before = $before; |
$mpos += length($pat); |
$best_after = substr ($self->{"_LOOK"}, $mpos); |
} else { |
$self->{"_LPATT"} = $pat; |
$self->{"_LMATCH"} = $pat; |
$before = substr ($self->{"_LOOK"}, 0, $mpos); |
$mpos += length($pat); |
$self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos); |
$self->{"_LOOK"} = ""; |
return $before; |
# match at start will be best |
} |
} |
$count_in++; |
} |
if ($got_match) { |
$self->{"_LPATT"} = $best_pat; |
$self->{"_LMATCH"} = $best_match; |
$self->{"_LASTLOOK"} = $best_after; |
$self->{"_LOOK"} = ""; |
return $best_before; |
} |
} |
return ""; |
} |
sub input { |
return unless (@_ == 1); |
my $self = shift; |
my $result = ""; |
if (nocarp && $self->{"_T_INPUT"}) { |
$result = $self->{"_T_INPUT"}; |
$self->{"_T_INPUT"} = ""; |
return $result; |
} |
my $ok = 0; |
my $got_p = " "x4; |
my ($bbb, $wanted, $ooo, $eee) = status($self); |
return "" if ($eee); |
return "" unless $wanted; |
my $got = $self->read_bg ($wanted); |
if ($got != $wanted) { |
# block if unexpected happens |
($ok, $got, $result) = $self->read_done(1); # block until done |
} |
else { ($ok, $got, $result) = $self->read_done(0); } |
### print "input: got= $got result=$result\n"; |
return $got ? $result : ""; |
} |
sub write { |
return unless (@_ == 2); |
my $self = shift; |
my $wbuf = shift; |
my $ok = 1; |
return 0 if ($wbuf eq ""); |
my $lbuf = length ($wbuf); |
my $written = $self->write_bg ($wbuf); |
if ($written != $lbuf) { |
($ok, $written) = $self->write_done(1); # block until done |
} |
if ($Verbose) { |
print "wbuf=$wbuf\n"; |
print "lbuf=$lbuf\n"; |
print "written=$written\n"; |
} |
return unless ($ok); |
return $written; |
} |
sub transmit_char { |
my $self = shift; |
return unless (@_ == 1); |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
return unless $self->xmit_imm_char ($v); |
return wantarray ? @byte_opt : 1; |
} |
sub xon_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_xon_char($v); |
} |
return wantarray ? @byte_opt : $self->is_xon_char; |
} |
sub xoff_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_xoff_char($v); |
} |
return wantarray ? @byte_opt : $self->is_xoff_char; |
} |
sub eof_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_eof_char($v); |
} |
return wantarray ? @byte_opt : $self->is_eof_char; |
} |
sub event_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_event_char($v); |
} |
return wantarray ? @byte_opt : $self->is_event_char; |
} |
sub error_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_error_char($v); |
} |
return wantarray ? @byte_opt : $self->is_error_char; |
} |
sub xon_limit { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->is_xon_limit($v); |
} |
return wantarray ? (0, SHORTsize) : $self->is_xon_limit; |
} |
sub xoff_limit { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->is_xoff_limit($v); |
} |
return wantarray ? (0, SHORTsize) : $self->is_xoff_limit; |
} |
sub read_interval { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_interval( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_interval; |
} |
sub read_char_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_char_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_char_time; |
} |
sub read_const_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_const_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_const_time; |
} |
sub write_const_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_write_const_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_write_const_time; |
} |
sub write_char_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_write_char_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_write_char_time; |
} |
# true/false parameters |
sub binary { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_binary( shift ); |
} |
return $self->is_binary; |
} |
sub parity_enable { |
my $self = shift; |
if (@_) { |
if ( $self->can_parity_enable ) { |
$self->is_parity_enable( shift ); |
} |
elsif ($self->{U_MSG}) { |
carp "Can't set parity enable on $self->{ALIAS}"; |
} |
} |
return $self->is_parity_enable; |
} |
sub modemlines { |
return unless (@_ == 1); |
my $self = shift; |
my $result = $self->is_modemlines; |
if ($Verbose) { |
print "CTS is ON\n" if ($result & MS_CTS_ON); |
print "DSR is ON\n" if ($result & MS_DSR_ON); |
print "RING is ON\n" if ($result & MS_RING_ON); |
print "RLSD is ON\n" if ($result & MS_RLSD_ON); |
} |
return $result; |
} |
sub stty { |
my $ob = shift; |
my $token; |
if (@_) { |
my $ok = 1; |
no strict 'refs'; # for $gosub |
while ($token = shift) { |
if (exists $opts{$token}) { |
## print " $opts{$token}\n"; |
my ($gosub, $value) = split (':', $opts{$token}); |
if ($value eq "argv_char") { $value = &argv_char(shift); } |
if (defined $value) { |
&$gosub($ob, $value); |
} else { |
nocarp or carp "bad value for parameter $token\n"; |
$ok = 0; |
} |
} |
else { |
nocarp or carp "parameter $token not found\n"; |
$ok = 0; |
} |
} |
use strict 'refs'; |
return $ok; |
} |
else { |
my @settings; # array returned by () |
my $current = $ob->baudrate; |
push @settings, "$current"; |
push @settings, "intr"; |
push @settings, cntl_char($ob->stty_intr); |
push @settings, "quit"; |
push @settings, cntl_char($ob->stty_quit); |
push @settings, "erase"; |
push @settings, cntl_char($ob->stty_erase); |
push @settings, "kill"; |
push @settings, cntl_char($ob->stty_kill); |
push @settings, "eof"; |
push @settings, cntl_char($ob->stty_eof); |
push @settings, "eol"; |
push @settings, cntl_char($ob->stty_eol); |
push @settings, "start"; |
push @settings, cntl_char(chr $ob->xon_char); |
push @settings, "stop"; |
push @settings, cntl_char(chr $ob->xoff_char); |
# "stop" is last CHAR type |
push @settings, ($ob->stty_echo ? "" : "-")."echo"; |
push @settings, ($ob->stty_echoe ? "" : "-")."echoe"; |
push @settings, ($ob->stty_echok ? "" : "-")."echok"; |
push @settings, ($ob->stty_echonl ? "" : "-")."echonl"; |
push @settings, ($ob->stty_echoke ? "" : "-")."echoke"; |
push @settings, ($ob->stty_echoctl ? "" : "-")."echoctl"; |
push @settings, ($ob->stty_istrip ? "" : "-")."istrip"; |
push @settings, ($ob->stty_icrnl ? "" : "-")."icrnl"; |
push @settings, ($ob->stty_ocrnl ? "" : "-")."ocrnl"; |
push @settings, ($ob->stty_igncr ? "" : "-")."igncr"; |
push @settings, ($ob->stty_inlcr ? "" : "-")."inlcr"; |
push @settings, ($ob->stty_onlcr ? "" : "-")."onlcr"; |
push @settings, ($ob->stty_opost ? "" : "-")."opost"; |
push @settings, ($ob->stty_isig ? "" : "-")."isig"; |
push @settings, ($ob->stty_icanon ? "" : "-")."icanon"; |
$current = $ob->databits; |
push @settings, "cs$current"; |
push @settings, (($ob->stopbits == 2) ? "" : "-")."cstopb"; |
$current = $ob->handshake; |
push @settings, (($current eq "dtr") ? "" : "-")."clocal"; |
push @settings, (($current eq "rts") ? "" : "-")."crtscts"; |
push @settings, (($current eq "xoff") ? "" : "-")."ixoff"; |
push @settings, (($current eq "xoff") ? "" : "-")."ixon"; |
my $parity = $ob->parity; |
if ($parity eq "none") { |
push @settings, "-parenb"; |
push @settings, "-parodd"; |
push @settings, "-inpck"; |
} |
else { |
$current = $ob->is_parity_enable; |
push @settings, ($current ? "" : "-")."parenb"; |
push @settings, (($parity eq "odd") ? "" : "-")."parodd"; |
push @settings, ($current ? "" : "-")."inpck"; |
# mark and space not supported |
} |
return @settings; |
} |
} |
sub cntl_char { |
my $n_char = shift; |
return "<undef>" unless (defined $n_char); |
my $pos = ord $n_char; |
if ($pos < 32) { |
$n_char = "^".chr($pos + 64); |
} |
if ($pos > 126) { |
$n_char = sprintf "0x%x", $pos; |
} |
return $n_char; |
} |
sub argv_char { |
my $n_char = shift; |
return unless (defined $n_char); |
my $pos = $n_char; |
if ($n_char =~ s/^\^//) { |
$pos = ord($n_char) - 64; |
} |
elsif ($n_char =~ s/^0x//) { |
$pos = hex($n_char); |
} |
elsif ($n_char =~ /^0/) { |
$pos = oct($n_char); |
} |
## print "pos = $pos\n"; |
return $pos; |
} |
sub debug { |
my $self = shift; |
if (ref($self)) { |
if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); } |
else { |
my $tmp = $self->{"_DEBUG"}; |
nocarp || carp "Debug level: $self->{ALIAS} = $tmp"; |
$self->debug_comm($tmp); |
return $self->{"_DEBUG"}; |
} |
} else { |
$Verbose = yes_true ($self); |
nocarp || carp "SerialPort Debug Class = $Verbose"; |
Win32API::CommPort::debug_comm($Verbose); |
return $Verbose; |
} |
} |
sub close { |
my $self = shift; |
return unless (defined $self->{ALIAS}); |
if ($Verbose or $self->{"_DEBUG"}) { |
carp "Closing $self " . $self->{ALIAS}; |
} |
my $success = $self->SUPER::close; |
$self->{DEVICE} = undef; |
$self->{ALIAS} = undef; |
if ($Verbose) { |
printf "SerialPort close result:%d\n", $success; |
} |
return $success; |
} |
1; # so the require or use succeeds |
# Autoload methods go after =cut, and are processed by the autosplit program. |
__END__ |
=pod |
=head1 NAME |
Win32::SerialPort - User interface to Win32 Serial API calls |
=head1 SYNOPSIS |
require 5.003; |
use Win32::SerialPort qw( :STAT 0.19 ); |
=head2 Constructors |
$PortObj = new Win32::SerialPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
$PortObj = start Win32::SerialPort ($Configuration_File_Name) |
|| die "Can't start $Configuration_File_Name: $^E\n"; |
$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die "Can't tie using $Configuration_File_Name: $^E\n"; |
=head2 Configuration Utility Methods |
$PortObj->alias("MODEM1"); |
# before using start, restart, or tie |
$PortObj->save($Configuration_File_Name) |
|| warn "Can't save $Configuration_File_Name: $^E\n"; |
# after new, must check for failure |
$PortObj->write_settings || undef $PortObj; |
print "Can't change Device_Control_Block: $^E\n" unless ($PortObj); |
# rereads file to either return open port to a known state |
# or switch to a different configuration on the same port |
$PortObj->restart($Configuration_File_Name) |
|| warn "Can't reread $Configuration_File_Name: $^E\n"; |
# "app. variables" saved in $Configuration_File, not used internally |
$PortObj->devicetype('none'); # CM11, CM17, 'weeder', 'modem' |
$PortObj->hostname('localhost'); # for socket-based implementations |
$PortObj->hostaddr(0); # false unless specified |
$PortObj->datatype('raw'); # in case an application needs_to_know |
$PortObj->cfg_param_1('none'); # null string '' hard to save/restore |
$PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
$PortObj->cfg_param_3('none'); # one may end up as a log file path |
# specials for test suite only |
@necessary_param = Win32::SerialPort->set_test_mode_active(1); |
$PortObj->lookclear("loopback to next 'input' method"); |
=head2 Configuration Parameter Methods |
# most methods can be called three ways: |
$PortObj->handshake("xoff"); # set parameter |
$flowcontrol = $PortObj->handshake; # current value (scalar) |
@handshake_opts = $PortObj->handshake; # permitted choices (list) |
# similar |
$PortObj->baudrate(9600); |
$PortObj->parity("odd"); |
$PortObj->databits(8); |
$PortObj->stopbits(1); |
# range parameters return (minimum, maximum) in list context |
$PortObj->xon_limit(100); # bytes left in buffer |
$PortObj->xoff_limit(100); # space left in buffer |
$PortObj->xon_char(0x11); |
$PortObj->xoff_char(0x13); |
$PortObj->eof_char(0x0); |
$PortObj->event_char(0x0); |
$PortObj->error_char(0); # for parity errors |
$PortObj->buffers(4096, 4096); # read, write |
# returns current in list context |
$PortObj->read_interval(100); # max time between read char (milliseconds) |
$PortObj->read_char_time(5); # avg time between read char |
$PortObj->read_const_time(100); # total = (avg * bytes) + const |
$PortObj->write_char_time(5); |
$PortObj->write_const_time(100); |
# true/false parameters (return scalar context only) |
$PortObj->binary(T); # just say Yes (Win 3.x option) |
$PortObj->parity_enable(F); # faults during input |
$PortObj->debug(0); |
=head2 Operating Methods |
($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->status |
|| warn "could not get port status\n"; |
if ($BlockingFlags) { warn "Port is blocked"; } |
if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
# The API resets errors when reading status, $LatchErrorFlags |
# is all $ErrorFlags seen since the last reset_error |
Additional useful constants may be exported eventually. If the only fault |
action desired is a message, B<status> provides I<Built-In> BitMask processing: |
$PortObj->error_msg(1); # prints hardware messages like "Framing Error" |
$PortObj->user_msg(1); # prints function messages like "Waiting for CTS" |
($count_in, $string_in) = $PortObj->read($InBytes); |
warn "read unsuccessful\n" unless ($count_in == $InBytes); |
$count_out = $PortObj->write($output_string); |
warn "write failed\n" unless ($count_out); |
warn "write incomplete\n" if ( $count_out != length($output_string) ); |
if ($string_in = $PortObj->input) { PortObj->write($string_in); } |
# simple echo with no control character processing |
$PortObj->transmit_char(0x03); # bypass buffer (and suspend) |
$ModemStatus = $PortObj->modemlines; |
if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
=head2 Methods used with Tied FileHandles |
$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die "Can't tie: $^E\n"; ## TIEHANDLE ## |
print FH "text"; ## PRINT ## |
$char = getc FH; ## GETC ## |
syswrite FH, $out, length($out), 0; ## WRITE ## |
$line = <FH>; ## READLINE ## |
@lines = <FH>; ## READLINE ## |
printf FH "received: %s", $line; ## PRINTF ## |
read (FH, $in, 5, 0) or die "$^E"; ## READ ## |
sysread (FH, $in, 5, 0) or die "$^E"; ## READ ## |
close FH || warn "close failed"; ## CLOSE ## |
undef $PortObj; |
untie *FH; ## DESTROY ## |
$PortObj->linesize(10); # with READLINE |
$PortObj->lastline("_GOT_ME_"); # with READLINE, list only |
$old_ors = $PortObj->output_record_separator("RECORD"); # with PRINT |
$old_ofs = $PortObj->output_field_separator("COMMA"); # with PRINT |
=head2 Destructors |
$PortObj->close || warn "close failed"; |
# passed to CommPort to release port to OS - needed to reopen |
# close will not usually DESTROY the object |
# also called as: close FH || warn "close failed"; |
undef $PortObj; |
# preferred unless reopen expected since it triggers DESTROY |
# calls $PortObj->close but does not confirm success |
# MUST precede untie - do all three IN THIS SEQUENCE before re-tie. |
untie *FH; |
=head2 Methods for I/O Processing |
$PortObj->are_match("text", "\n"); # possible end strings |
$PortObj->lookclear; # empty buffers |
$PortObj->write("Feed Me:"); # initial prompt |
$PortObj->is_prompt("More Food:"); # new prompt after "kill" char |
my $gotit = ""; |
my $match1 = ""; |
until ("" ne $gotit) { |
$gotit = $PortObj->lookfor; # poll until data ready |
die "Aborted without match\n" unless (defined $gotit); |
last if ($gotit); |
$match1 = $PortObj->matchclear; # match is first thing received |
last if ($match1); |
sleep 1; # polling sample time |
} |
printf "gotit = %s\n", $gotit; # input BEFORE the match |
my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
# input that MATCHED, input AFTER the match, PATTERN that matched |
# input received INSTEAD when timeout without match |
if ($match1) { |
$match = $match1; |
} |
printf "lastlook-match = %s -after = %s -pattern = %s\n", |
$match, $after, $pattern; |
$gotit = $PortObj->lookfor($count); # block until $count chars received |
$PortObj->are_match("-re", "pattern", "text"); |
# possible match strings: "pattern" is a regular expression, |
# "text" is a literal string |
$gotit = $PortObj->streamline; # poll until data ready |
$gotit = $PortObj->streamline($count);# block until $count chars received |
# fast alternatives to lookfor with no character processing |
$PortObj->stty_intr("\cC"); # char to abort lookfor method |
$PortObj->stty_quit("\cD"); # char to abort perl |
$PortObj->stty_eof("\cZ"); # end_of_file char |
$PortObj->stty_eol("\cJ"); # end_of_line char |
$PortObj->stty_erase("\cH"); # delete one character from buffer (backspace) |
$PortObj->stty_kill("\cU"); # clear line buffer |
$PortObj->is_stty_intr(3); # ord(char) to abort lookfor method |
$qc = $PortObj->is_stty_quit; # ($qc == 4) for "\cD" |
$PortObj->is_stty_eof(26); |
$PortObj->is_stty_eol(10); |
$PortObj->is_stty_erase(8); |
$PortObj->is_stty_kill(21); |
my $air = " "x76; |
$PortObj->stty_clear("\r$air\r"); # written after kill character |
$PortObj->is_stty_clear; # internal version for config file |
$PortObj->stty_bsdel("\cH \cH"); # written after erase character |
$PortObj->stty_echo(0); # echo every character |
$PortObj->stty_echoe(1); # if echo erase character with bsdel string |
$PortObj->stty_echok(1); # if echo \n after kill character |
$PortObj->stty_echonl(0); # if echo \n |
$PortObj->stty_echoke(1); # if echo clear string after kill character |
$PortObj->stty_echoctl(0); # if echo "^Char" for control chars |
$PortObj->stty_istrip(0); # strip input to 7-bits |
$PortObj->stty_icrnl(0); # map \r to \n on input |
$PortObj->stty_ocrnl(0); # map \r to \n on output |
$PortObj->stty_igncr(0); # ignore \r on input |
$PortObj->stty_inlcr(0); # map \n to \r on input |
$PortObj->stty_onlcr(1); # map \n to \r\n on output |
$PortObj->stty_opost(0); # enable output mapping |
$PortObj->stty_isig(0); # enable quit and intr characters |
$PortObj->stty_icanon(0); # enable erase and kill characters |
$PortObj->stty("-icanon"); # disable eof, erase and kill char, Unix-style |
@stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
=head2 Capability Methods inherited from Win32API::CommPort |
These return scalar context only. |
can_baud can_databits can_stopbits |
can_dtrdsr can_handshake can_parity_check |
can_parity_config can_parity_enable can_rlsd |
can_16bitmode is_rs232 is_modem |
can_rtscts can_xonxoff can_xon_char |
can_spec_char can_interval_timeout can_total_timeout |
buffer_max can_rlsd_config |
=head2 Operating Methods inherited from Win32API::CommPort |
write_bg write_done read_bg |
read_done reset_error suspend_tx |
resume_tx dtr_active rts_active |
break_active xoff_active xon_active |
purge_all purge_rx purge_tx |
pulse_rts_on pulse_rts_off pulse_dtr_on |
pulse_dtr_off ignore_null ignore_no_dsr |
subst_pe_char abort_on_error output_xoff |
output_dsr output_cts tx_on_xoff |
input_xoff get_tick_count |
=head1 DESCRIPTION |
This module uses Win32API::CommPort for raw access to the API calls and |
related constants. It provides an object-based user interface to allow |
higher-level use of common API call sequences for dealing with serial |
ports. |
Uses features of the Win32 API to implement non-blocking I/O, serial |
parameter setting, event-loop operation, and enhanced error handling. |
To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
This is expected to change to an empty list reference, C<[]>, when Perl |
supports that form in this usage. |
=head2 Initialization |
The primary constructor is B<new> with a F<PortName> (as the Registry |
knows it) specified. This will create an object, and get the available |
options and capabilities via the Win32 API. The object is a superset |
of a B<Win32API::CommPort> object, and supports all of its methods. |
The port is not yet ready for read/write access. First, the desired |
I<parameter settings> must be established. Since these are tuning |
constants for an underlying hardware driver in the Operating System, |
they are all checked for validity by the methods that set them. The |
B<write_settings> method writes a new I<Device Control Block> to the |
driver. The B<write_settings> method will return true if the port is |
ready for access or C<undef> on failure. Ports are opened for binary |
transfers. A separate C<binmode> is not needed. The USER must release |
the object if B<write_settings> does not succeed. |
Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
to open a port prints a error message to STDOUT by default. Since only |
one application at a time can "own" the port, one source of failure was |
"port in use". There was previously no way to check this without getting |
a "fail message". Setting C<$quiet> disables this built-in message. It |
also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
used for testing this condition - other faults may still return C<undef>). |
Use of C<$quiet> only applies to B<new>. |
=over 8 |
Certain parameters I<MUST> be set before executing B<write_settings>. |
Others will attempt to deduce defaults from the hardware or from other |
parameters. The I<Required> parameters are: |
=item baudrate |
Any legal value. |
=item parity |
One of the following: "none", "odd", "even", "mark", "space". |
If you select anything except "none", you will need to set B<parity_enable>. |
=item databits |
An integer from 5 to 8. |
=item stopbits |
Legal values are 1, 1.5, and 2. But 1.5 only works with 5 databits, 2 does |
not work with 5 databits, and other combinations may not work on all |
hardware if parity is also used. |
=back |
The B<handshake> setting is recommended but no longer required. Select one |
of the following: "none", "rts", "xoff", "dtr". |
Some individual parameters (eg. baudrate) can be changed after the |
initialization is completed. These will be validated and will |
update the I<Device Control Block> as required. The B<save> |
method will write the current parameters to a file that B<start, tie,> and |
B<restart> can use to reestablish a functional setup. |
$PortObj = new Win32::SerialPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
$PortObj->user_msg(ON); |
$PortObj->databits(8); |
$PortObj->baudrate(9600); |
$PortObj->parity("none"); |
$PortObj->stopbits(1); |
$PortObj->handshake("rts"); |
$PortObj->buffers(4096, 4096); |
$PortObj->write_settings || undef $PortObj; |
$PortObj->save($Configuration_File_Name); |
$PortObj->baudrate(300); |
$PortObj->restart($Configuration_File_Name); # back to 9600 baud |
$PortObj->close || die "failed to close"; |
undef $PortObj; # frees memory back to perl |
The F<PortName> maps to both the Registry I<Device Name> and the |
I<Properties> associated with that device. A single I<Physical> port |
can be accessed using two or more I<Device Names>. But the options |
and setup data will differ significantly in the two cases. A typical |
example is a Modem on port "COM2". Both of these F<PortNames> open |
the same I<Physical> hardware: |
$P1 = new Win32::SerialPort ("COM2"); |
$P2 = new Win32::SerialPort ("\\\\.\\Nanohertz Modem model K-9"); |
$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
of modem-specific added options and features. The "raw" API calls return |
different size configuration structures in the two cases. Win32 uses the |
"\\.\" prefix to identify "named" devices. Since both names use the same |
I<Physical> hardware, they can not both be used at the same time. The OS |
will complain. Consider this A Good Thing. Use B<alias> to convert the |
name used by "built-in" messages. |
$P2->alias("FIDO"); |
The second constructor, B<start> is intended to simplify scripts which |
need a constant setup. It executes all the steps from B<new> to |
B<write_settings> based on a previously saved configuration. This |
constructor will return C<undef> on a bad configuration file or failure |
of a validity check. The returned object is ready for access. |
$PortObj2 = start Win32::SerialPort ($Configuration_File_Name) |
|| die; |
The third constructor, B<tie>, combines the B<start> with Perl's |
support for tied FileHandles (see I<perltie>). Win32::SerialPort |
implements the complete set of methods: TIEHANDLE, PRINT, PRINTF, |
WRITE, READ, GETC, READLINE, CLOSE, and DESTROY. Tied FileHandle |
support was new with Version 0.14. |
$PortObj2 = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die; |
The implementation attempts to mimic STDIN/STDOUT behaviour as closely |
as possible: calls block until done, data strings that exceed internal |
buffers are divided transparently into multiple calls, and B<stty_onlcr> |
and B<stty_ocrnl> are applied to output data (WRITE, PRINT, PRINTF) when |
B<stty_opost> is true. In Version 0.17, the output separators C<$,> and |
C<$\> are also applied to PRINT if set. Since PRINTF is treated internally |
as a single record PRINT, C<$\> will be applied. Output separators are not |
applied to WRITE (called as C<syswrite FH, $scalar, $length, [$offset]>). |
The B<output_record_separator> and B<output_field_separator> methods can set |
I<Port-FileHandle-Specific> versions of C<$,> and C<$\> if desired. |
The input_record_separator C<$/> is not explicitly supported - but an |
identical function can be obtained with a suitable B<are_match> setting. |
Record separators are experimental in Version 0.17. They are not saved |
in the configuration_file. |
The tied FileHandle methods may be combined with the Win32::SerialPort |
methods for B<read, input>, and B<write> as well as other methods. The |
typical restrictions against mixing B<print> with B<syswrite> do not |
apply. Since both B<(tied) read> and B<sysread> call the same C<$ob-E<gt>READ> |
method, and since a separate C<$ob-E<gt>read> method has existed for some |
time in Win32::SerialPort, you should always use B<sysread> with the |
tied interface. Beginning in Version 0.17, B<sysread> checks the input |
against B<stty_icrnl>, B<stty_inlcr>, and B<stty_igncr>. With B<stty_igncr> |
active, the B<sysread> returns the count of all characters received including |
and C<\r> characters subsequently deleted. |
Because all the tied methods block, they should ALWAYS be used with |
timeout settings and are not suitable for background operations and |
polled loops. The B<sysread> method may return fewer characters than |
requested when a timeout occurs. The method call is still considered |
successful. If a B<sysread> times out after receiving some characters, |
the actual elapsed time may be as much as twice the programmed limit. |
If no bytes are received, the normal timing applies. |
=head2 Configuration and Capability Methods |
Starting in Version 0.18, a number of I<Application Variables> are saved |
in B<$Configuration_File>. These parameters are not used internally. But |
methods allow setting and reading them. The intent is to facilitate the |
use of separate I<configuration scripts> to create the files. Then an |
application can use B<start> as the Constructor and not bother with |
command line processing or managing its own small configuration file. |
The default values and number of parameters is subject to change. |
$PortObj->devicetype('none'); |
$PortObj->hostname('localhost'); # for socket-based implementations |
$PortObj->hostaddr(0); # a "false" value |
$PortObj->datatype('raw'); # 'record' is another possibility |
$PortObj->cfg_param_1('none'); |
$PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
$PortObj->cfg_param_3('none'); |
The Win32 Serial Comm API provides extensive information concerning |
the capabilities and options available for a specific port (and |
instance). "Modem" ports have different capabilties than "RS-232" |
ports - even if they share the same Hardware. Many traditional modem |
actions are handled via TAPI. "Fax" ports have another set of options - |
and are accessed via MAPI. Yet many of the same low-level API commands |
and data structures are "common" to each type ("Modem" is implemented |
as an "RS-232" superset). In addition, Win95 supports a variety of |
legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
16-data-bit paths, and 256Kbaud. |
=over 8 |
Binary selections will accept as I<true> any of the following: |
C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
Anything else is I<false>. |
There are a large number of possible configuration and option parameters. |
To facilitate checking option validity in scripts, most configuration |
methods can be used in three different ways: |
=item method called with an argument |
The parameter is set to the argument, if valid. An invalid argument |
returns I<false> (undef) and the parameter is unchanged. The function |
will also I<carp> if B<$user_msg> is I<true>. After B<write_settings>, |
the port will be updated immediately if allowed. Otherwise, the value |
will be applied when B<write_settings> is called. |
=item method called with no argument in scalar context |
The current value is returned. If the value is not initialized either |
directly or by default, return "undef" which will parse to I<false>. |
For binary selections (true/false), return the current value. All |
current values from "multivalue" selections will parse to I<true>. |
Current values may differ from requested values until B<write_settings>. |
There is no way to see requests which have not yet been applied. |
Setting the same parameter again overwrites the first request. Test |
the return value of the setting method to check "success". |
=item method called with no argument in list context |
Return a list consisting of all acceptable choices for parameters with |
discrete choices. Return a list C<(minimum, maximum)> for parameters |
which can be set to a range of values. Binary selections have no need |
to call this way - but will get C<(0,1)> if they do. Beginning in |
Version 0.16, Binary selections inherited from Win32API::CommPort may |
not return anything useful in list context. The null list C<(undef)> |
will be returned for failed calls in list context (e.g. for an invalid |
or unexpected argument). |
=item Asynchronous (Background) I/O |
The module handles Polling (do if Ready), Synchronous (block until |
Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
choices provided by the API. No effort has yet been made to interact with |
Windows events. But background I/O has been used successfully with the |
Perl Tk modules and callbacks from the event loop. |
=item Timeouts |
The API provides two timing models. The first applies only to reading and |
essentially determines I<Read Not Ready> by checking the time between |
consecutive characters. The B<ReadFile> operation returns if that time |
exceeds the value set by B<read_interval>. It does this by timestamping |
each character. It appears that at least one character must by received in |
I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
is then reset by each succeeding character. If no characters are received, |
the read will block indefinitely. |
Setting B<read_interval> to C<0xffffffff> will do a non-blocking read. |
The B<ReadFile> returns immediately whether or not any characters are |
actually read. This replicates the behavior of the API. |
The other model defines the total time allowed to complete the operation. |
A fixed overhead time is added to the product of bytes and per_byte_time. |
A wide variety of timeout options can be defined by selecting the three |
parameters: fixed, each, and size. |
Read_Total = B<read_const_time> + (B<read_char_time> * bytes_to_read) |
Write_Total = B<write_const_time> + (B<write_char_time> * bytes_to_write) |
When reading a known number of characters, the I<Read_Total> mechanism is |
recommended. This mechanism I<MUST> be used with I<tied FileHandles> because |
the tie methods can make multiple internal API calls in response to a single |
B<sysread> or B<READLINE>. The I<Read_Interval> mechanism is suitable for |
a B<read> method that expects a response of variable or unknown size. You |
should then also set a long I<Read_Total> timeout as a "backup" in case |
no bytes are received. |
=back |
=head2 Exports |
Nothing is exported by default. Nothing is currently exported. Optional |
tags from Win32API::CommPort are passed through. |
=over 4 |
=item :PARAM |
Utility subroutines and constants for parameter setting and test: |
LONGsize SHORTsize nocarp yes_true |
OS_Error internal_buffer |
=item :STAT |
Serial communications constants from Win32API::CommPort. Included are the |
constants for ascertaining why a transmission is blocked: |
BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
Which incoming bits are active: |
MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
What hardware errors have been detected: |
CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL CE_MODE |
Offsets into the array returned by B<status:> |
ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
=back |
=head2 Stty Emulation |
Nothing wrong with dreaming! A subset of stty options is available |
through a B<stty> method. The purpose is support of existing serial |
devices which have embedded knowledge of Unix communication line and |
login practices. It is also needed by Tom Christiansen's Perl Power Tools |
project. This is new and experimental in Version 0.15. The B<stty> method |
returns an array of "traditional stty values" when called with no |
arguments. With arguments, it sets the corresponding parameters. |
$ok = $PortObj->stty("-icanon"); # equivalent to stty_icanon(0) |
@stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
$ok = $PortObj->stty("cs7",19200); # multiple parameters |
$ok = $PortObj->stty(@stty_save); # many parameters |
The distribution includes a demo script, stty.plx, which gives details |
of usage. Not all Unix parameters are currently supported. But the array |
will contain all those which can be set. The order in C<@stty_all> will |
match the following pattern: |
baud, # numeric, always first |
"intr", character, # the parameters which set special characters |
"name", character, ... |
"stop", character, # "stop" will always be the last "pair" |
"parameter", # the on/off settings |
"-parameter", ... |
Version 0.13 added the primitive functions required to implement this |
feature. A number of methods named B<stty_xxx> do what an |
I<experienced stty user> would expect. |
Unlike B<stty> on Unix, the B<stty_xxx> operations apply only to I/O |
processed via the B<lookfor> method or the I<tied FileHandle> methods. |
The B<read, input, read_done, write> methods all treat data as "raw". |
The following stty functions have related SerialPort functions: |
--------------------------------------------------------------- |
stty (control) SerialPort Default Value |
---------------- ------------------ ------------- |
parenb inpck parity_enable from port |
parodd parity from port |
cs5 cs6 cs7 cs8 databits from port |
cstopb stopbits from port |
clocal crtscts handshake from port |
ixon ixoff handshake from port |
time read_const_time from port |
110 300 600 1200 2400 baudrate from port |
4800 9600 19200 38400 baudrate |
75 134.5 150 1800 fixed baud only - not selectable |
g, "stty < /dev/x" start, save none |
sane restart none |
stty (input) SerialPort Default Value |
---------------- ------------------ ------------- |
istrip stty_istrip off |
igncr stty_igncr off |
inlcr stty_inlcr off |
icrnl stty_icrnl on |
parmrk error_char from port (off typ) |
stty (output) SerialPort Default Value |
---------------- ------------------ ------------- |
ocrnl stty_ocrnl off if opost |
onlcr stty_onlcr on if opost |
opost stty_opost off |
stty (local) SerialPort Default Value |
---------------- ------------------ ------------- |
raw read, write, input none |
cooked lookfor none |
echo stty_echo off |
echoe stty_echoe on if echo |
echok stty_echok on if echo |
echonl stty_echonl off |
echoke stty_echoke on if echo |
echoctl stty_echoctl off |
isig stty_isig off |
icanon stty_icanon off |
stty (char) SerialPort Default Value |
---------------- ------------------ ------------- |
intr stty_intr "\cC" |
is_stty_intr 3 |
quit stty_quit "\cD" |
is_stty_quit 4 |
erase stty_erase "\cH" |
is_stty_erase 8 |
(erase echo) stty_bsdel "\cH \cH" |
kill stty_kill "\cU" |
is_stty_kill 21 |
(kill echo) stty_clear "\r {76}\r" |
is_stty_clear "-@{76}-" |
eof stty_eof "\cZ" |
is_stty_eof 26 |
eol stty_eol "\cJ" |
is_stty_eol 10 |
start xon_char from port ("\cQ" typ) |
is_xon_char 17 |
stop xoff_char from port ("\cS" typ) |
is_xoff_char 19 |
The following stty functions have no equivalent in SerialPort: |
-------------------------------------------------------------- |
[-]hup [-]ignbrk [-]brkint [-]ignpar |
[-]tostop susp 0 50 |
134 200 exta extb |
[-]cread [-]hupcl |
The stty function list is taken from the documentation for IO::Stty by |
Austin Schutz. |
=head2 Lookfor and I/O Processing |
Many of the B<stty_xxx> methods support features which are necessary for |
line-oriented input (such as command-line handling). These include methods |
which select control-keys to delete characters (B<stty_erase>) and lines |
(B<stty_kill>), define input boundaries (B<stty_eol, stty_eof>), and abort |
processing (B<stty_intr, stty_quit>). These keys also have B<is_stty_xxx> |
methods which convert the key-codes to numeric equivalents which can be |
saved in the configuration file. |
Some communications programs have a different but related need - to collect |
(or discard) input until a specific pattern is detected. For lines, the |
pattern is a line-termination. But there are also requirements to search |
for other strings in the input such as "username:" and "password:". The |
B<lookfor> method provides a consistant mechanism for solving this problem. |
It searches input character-by-character looking for a match to any of the |
elements of an array set using the B<are_match> method. It returns the |
entire input up to the match pattern if a match is found. If no match |
is found, it returns "" unless an input error or abort is detected (which |
returns undef). |
The actual match and the characters after it (if any) may also be viewed |
using the B<lastlook> method. In Version 0.13, the match test included |
a C<s/$pattern//s> test which worked fine for literal text but returned |
the I<Regular Expression> that matched when C<$pattern> contained any Perl |
metacharacters. That was probably a bug - although no one reported it. |
In Version 0.14, B<lastlook> returns both the input and the pattern from |
the match test. It also adopts the convention from Expect.pm that match |
strings are literal text (tested using B<index>) unless preceeded in the |
B<are_match> list by a B<"-re",> entry. The default B<are_match> list |
is C<("\n")>, which matches complete lines. |
my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
# input that MATCHED, input AFTER the match, PATTERN that matched |
# input received INSTEAD when timeout without match ("" if match) |
$PortObj->are_match("text1", "-re", "pattern", "text2"); |
# possible match strings: "pattern" is a regular expression, |
# "text1" and "text2" are literal strings |
The I<Regular Expression> handling in B<lookfor> is still |
experimental. Please let me know if you use it (or can't use it), so |
I can confirm bug fixes don't break your code. For literal strings, |
C<$match> and C<$pattern> should be identical. The C<$instead> value |
returns the internal buffer tested by the match logic. A successful |
match or a B<lookclear> resets it to "" - so it is only useful for error |
handling such as timeout processing or reporting unexpected responses. |
The B<lookfor> method is designed to be sampled periodically (polled). Any |
characters after the match pattern are saved for a subsequent B<lookfor>. |
Internally, B<lookfor> is implemented using the nonblocking B<input> method |
when called with no parameter. If called with a count, B<lookfor> calls |
C<$PortObj-E<gt>read(count)> which blocks until the B<read> is I<Complete> or |
a I<Timeout> occurs. The blocking alternative should not be used unless a |
fault time has been defined using B<read_interval, read_const_time, and |
read_char_time>. It exists mostly to support the I<tied FileHandle> |
functions B<sysread, getc,> and B<E<lt>FHE<gt>>. |
The internal buffers used by B<lookfor> may be purged by the B<lookclear> |
method (which also clears the last match). For testing, B<lookclear> can |
accept a string which is "looped back" to the next B<input>. This feature |
is enabled only when C<set_test_mode_active(1)>. Normally, B<lookclear> |
will return C<undef> if given parameters. It still purges the buffers and |
last_match in that case (but nothing is "looped back"). You will want |
B<stty_echo(0)> when exercising loopback. |
Version 0.15 adds a B<matchclear> method. It is designed to handle the |
"special case" where the match string is the first character(s) received |
by B<lookfor>. In this case, C<$lookfor_return == "">, B<lookfor> does |
not provide a clear indication that a match was found. The B<matchclear> |
returns the same C<$match> that would be returned by B<lastlook> and |
resets it to "" without resetting any of the other buffers. Since the |
B<lookfor> already searched I<through> the match, B<matchclear> is used |
to both detect and step-over "blank" lines. |
The character-by-character processing used by B<lookfor> to support the |
I<stty emulation> is fine for interactive activities and tasks which |
expect short responses. But it has too much "overhead" to handle fast |
data streams. Version 0.15 adds a B<streamline> method which is a fast, |
line-oriented alternative with no echo support or input handling except |
for pattern searching. Exact benchmarks will vary with input data and |
patterns, but my tests indicate B<streamline> is 10-20 times faster then |
B<lookfor> when uploading files averaging 25-50 characters per line. |
Since B<streamline> uses the same internal buffers, the B<lookclear, |
lastlook, are_match, and matchclear> methods act the same in both cases. |
In fact, calls to B<streamline> and B<lookfor> can be interleaved if desired |
(e.g. an interactive task that starts an upload and returns to interactive |
activity when it is complete). |
Beginning in Version 0.15, the B<READLINE> method supports "list context". |
A tied FileHandle can slurp in a whole file with an "@lines = E<lt>FHE<gt>" |
construct. In "scalar context", B<READLINE> calls B<lookfor>. But it calls |
B<streamline> in "list context". Both contexts also call B<matchclear> |
to detect "empty" lines and B<reset_error> to detect hardware problems. |
The existance of a hardware fault is reported with C<$^E>, although the |
specific fault is only reported when B<error_msg> is true. |
There are two additional methods for supporting "list context" input: |
B<lastline> sets an "end_of_file" I<Regular Expression>, and B<linesize> |
permits changing the "packet size" in the blocking read operation to allow |
tuning performance to data characteristics. These two only apply during |
B<READLINE>. The default for B<linesize> is 1. There is no default for |
the B<lastline> method. |
In Version 0.15, I<Regular Expressions> set by B<are_match> and B<lastline> |
will be pre-compiled using the I<qr//> construct on Perl 5.005 and higher. |
This doubled B<lookfor> and B<streamline> speed in my tests with |
I<Regular Expressions> - but actual improvements depend on both patterns |
and input data. |
The functionality of B<lookfor> includes a limited subset of the capabilities |
found in Austin Schutz's I<Expect.pm> for Unix (and Tcl's expect which it |
resembles). The C<$before, $match, $pattern, and $after> return values are |
available if someone needs to create an "expect" subroutine for porting a |
script. When using multiple patterns, there is one important functional |
difference: I<Expect.pm> looks at each pattern in turn and returns the first |
match found; B<lookfor> and B<streamline> test all patterns and return the |
one found I<earliest> in the input if more than one matches. |
Because B<lookfor> can be used to manage a command-line environment much |
like a Unix serial login, a number of "stty-like" methods are included to |
handle the issues raised by serial logins. One issue is dissimilar line |
terminations. This is addressed by the following methods: |
$PortObj->stty_icrnl; # map \r to \n on input |
$PortObj->stty_igncr; # ignore \r on input |
$PortObj->stty_inlcr; # map \n to \r on input |
$PortObj->stty_ocrnl; # map \r to \n on output |
$PortObj->stty_onlcr; # map \n to \r\n on output |
$PortObj->stty_opost; # enable output mapping |
The default specifies a raw device with no input or output processing. |
In Version 0.14, the default was a device which sends "\r" at the end |
of a line, requires "\r\n" to terminate incoming lines, and expects the |
"host" to echo every keystroke. Many "dumb terminals" act this way and |
the defaults were similar to Unix defaults. But some users found this |
ackward and confusing. |
Sometimes, you want perl to echo input characters back to the serial |
device (and other times you don't want that). |
$PortObj->stty_echo; # echo every character |
$PortObj->stty_echoe; # if echo erase with bsdel string (default) |
$PortObj->stty_echok; # if echo \n after kill character (default) |
$PortObj->stty_echonl; # echo \n even if stty_echo(0) |
$PortObj->stty_echoke; # if echo clear string after kill (default) |
$PortObj->stty_echoctl; # if echo "^Char" for control chars |
$PortObj->stty_istrip; # strip input to 7-bits |
my $air = " "x76; # overwrite entire line with spaces |
$PortObj->stty_clear("\r$air\r"); # written after kill character |
$PortObj->is_prompt("PROMPT:"); # need to write after kill |
$PortObj->stty_bsdel("\cH \cH"); # written after erase character |
# internal method that permits clear string with \r in config file |
my $plus32 = "@"x76; # overwrite line with spaces (ord += 32) |
$PortObj->is_stty_clear("-$plus32-"); # equivalent to stty_clear |
=head1 NOTES |
The object returned by B<new> or B<start> is NOT a I<FileHandle>. You |
will be disappointed if you try to use it as one. If you need a |
I<FileHandle>, you must use B<tie> as the constructor. |
e.g. the following is WRONG!!____C<print $PortObj "some text";> |
You need something like this (Perl 5.005): |
# construct |
$tie_ob = tie(*FOO,'Win32::SerialPort', $cfgfile) |
or die "Can't start $cfgfile\n"; |
print FOO "enter char: "; # destination is FileHandle, not Object |
my $in = getc FOO; |
syswrite FOO, "$in\n", 2, 0; |
print FOO "enter line: "; |
$in = <FOO>; |
printf FOO "received: %s\n", $in; |
print FOO "enter 5 char: "; |
sysread (FOO, $in, 5, 0) or die; |
printf FOO "received: %s\n", $in; |
# destruct |
close FOO || print "close failed\n"; |
undef $tie_ob; # Don't forget this one!! |
untie *FOO; |
Always include the C<undef $tie_ob> before the B<untie>. See the I<Gotcha> |
description in I<perltie>. |
The Perl 5.004 implementation of I<tied FileHandles> is missing |
B<close> and B<syswrite>. The Perl 5.003 version is essentially unusable. |
If you need these functions, consider Perl 5.005 seriously. |
An important note about Win32 filenames. The reserved device names such |
as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
Thanks to Ken White for testing on NT. |
There is a linux clone of this module implemented using I<POSIX.pm>. |
It also runs on AIX and Solaris, and will probably run on other POSIX |
systems as well. It does not currently support the complete set of methods - |
although portability of user programs is excellent for the calls it does |
support. It is available from CPAN as I<Device::SerialPort>. |
=head1 KNOWN LIMITATIONS |
Since everything is (sometimes convoluted but still pure) Perl, you can |
fix flaws and change limits if required. But please file a bug report if |
you do. This module has been tested with each of the binary perl versions |
for which Win32::API is supported: AS builds 315, 316, 500-509 and GS |
5.004_02. It has only been tested on Intel hardware. |
Although the B<lookfor, stty_xxx, and Tied FileHandle> mechanisms are |
considered stable, they have only been tested on a small subset of possible |
applications. While "\r" characters may be included in the clear string |
using B<is_stty_clear> internally, "\n" characters may NOT be included |
in multi-character strings if you plan to save the strings in a configuration |
file (which uses "\n" as an internal terminator). |
=over 4 |
=item Tutorial |
With all the options, this module needs a good tutorial. It doesn't |
have a complete one yet. A I<"How to get started"> tutorial appeared |
B<The Perl Journal #13> (March 1999). Examples from the article are |
available from http://tpj.com and from http://members.aol.com/Bbirthisel. |
The demo programs in the distribution are a good starting point for |
additional examples. |
=item Buffers |
The size of the Win32 buffers are selectable with B<buffers>. But each read |
method currently uses a fixed internal buffer of 4096 bytes. This can be |
changed in the Win32API::CommPort source and read with B<internal_buffer>. |
The XS version will support dynamic buffer sizing. Large operations are |
automatically converted to multiple smaller ones by the B<tied FileHandle> |
methods. |
=item Modems |
Lots of modem-specific options are not supported. The same is true of |
TAPI, MAPI. I<API Wizards> are welcome to contribute. |
=item API Options |
Lots of options are just "passed through from the API". Some probably |
shouldn't be used together. The module validates the obvious choices when |
possible. For something really fancy, you may need additional API |
documentation. Available from I<Micro$oft Pre$$>. |
=back |
=head1 BUGS |
On Win32, a port must B<close> before it can be reopened again by the same |
process. If a physical port can be accessed using more than one name (see |
above), all names are treated as one. The perl script can also be run |
multiple times within a single batch file or shell script. The I<Makefile.PL> |
spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
but it works. |
On NT, a B<read_done> or B<write_done> returns I<False> if a background |
operation is aborted by a purge. Win95 returns I<True>. |
EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
A few NT systems seem to set B<can_parity_enable> true, but do not actually |
support setting B<parity_enable>. This may be a characteristic of certain |
third-party serial drivers. |
__Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
=head1 AUTHORS |
Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
=head1 SEE ALSO |
Win32API::CommPort - the low-level API calls which support this module |
Win32API::File I<when available> |
Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
Expect.pm - Austin Schutz's adaptation of TCL's "expect" for Unix Perls |
=head1 COPYRIGHT |
Copyright (C) 1999, Bill Birthisel. All rights reserved. |
This module is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head2 COMPATIBILITY |
Most of the code in this module has been stable since version 0.12. |
Except for items indicated as I<Experimental>, I do not expect functional |
changes which are not fully backwards compatible. However, Version 0.16 |
removes the "dummy (0, 1) list" which was returned by many binary methods |
in case they were called in list context. I do not know of any use outside |
the test suite for that feature. |
Version 0.12 added an I<Install.PL> script to put modules into the documented |
Namespaces. The script uses I<MakeMaker> tools not available in |
ActiveState 3xx builds. Users of those builds will need to install |
differently (see README). Programs in the test suite are modified for |
the current version. Additions to the configurtion files generated by |
B<save> prevent those created by Version 0.18 from being used by earlier |
Versions. 4 November 1999. |
=cut |
/MissionCockpit/tags/V0.2.7/perl/lib/Win32API/CommPort.pm |
---|
0,0 → 1,3146 |
# This part includes the low-level API calls |
package Win32API::CommPort; |
use Win32; |
use Win32::API 0.01; |
if ( $] < 5.004 ) { |
my $no_silly_warning = $Win32::API::VERSION; |
$no_silly_warning = $Win32::API::pack; |
} |
use Carp; |
use strict; |
#### API declarations #### |
no strict 'subs'; # these may be imported someday |
use vars qw( |
$_CloseHandle $_CreateFile $_GetCommState |
$_ReadFile $_SetCommState $_SetupComm |
$_PurgeComm $_CreateEvent $_GetCommTimeouts |
$_SetCommTimeouts $_GetCommProperties $_ClearCommBreak |
$_ClearCommError $_EscapeCommFunction $_GetCommConfig |
$_GetCommMask $_GetCommModemStatus $_SetCommBreak |
$_SetCommConfig $_SetCommMask $_TransmitCommChar |
$_WaitCommEvent $_WriteFile $_ResetEvent |
$_GetOverlappedResult |
); |
$_CreateFile = new Win32::API("kernel32", "CreateFile", |
[P, N, N, N, N, N, N], N); |
$_CloseHandle = new Win32::API("kernel32", "CloseHandle", [N], N); |
$_GetCommState = new Win32::API("kernel32", "GetCommState", [N, P], I); |
$_SetCommState = new Win32::API("kernel32", "SetCommState", [N, P], I); |
$_SetupComm = new Win32::API("kernel32", "SetupComm", [N, N, N], I); |
$_PurgeComm = new Win32::API("kernel32", "PurgeComm", [N, N], I); |
$_CreateEvent = new Win32::API("kernel32", "CreateEvent", [P, I, I, P], N); |
$_GetCommTimeouts = new Win32::API("kernel32", "GetCommTimeouts", |
[N, P], I); |
$_SetCommTimeouts = new Win32::API("kernel32", "SetCommTimeouts", |
[N, P], I); |
$_GetCommProperties = new Win32::API("kernel32", "GetCommProperties", |
[N, P], I); |
$_ReadFile = new Win32::API("kernel32", "ReadFile", [N, P, N, P, P], I); |
$_WriteFile = new Win32::API("kernel32", "WriteFile", [N, P, N, P, P], I); |
$_TransmitCommChar = new Win32::API("kernel32", "TransmitCommChar", [N, I], I); |
$_ClearCommBreak = new Win32::API("kernel32", "ClearCommBreak", [N], I); |
$_SetCommBreak = new Win32::API("kernel32", "SetCommBreak", [N], I); |
$_ClearCommError = new Win32::API("kernel32", "ClearCommError", [N, P, P], I); |
$_EscapeCommFunction = new Win32::API("kernel32", "EscapeCommFunction", |
[N, N], I); |
$_GetCommModemStatus = new Win32::API("kernel32", "GetCommModemStatus", |
[N, P], I); |
$_GetOverlappedResult = new Win32::API("kernel32", "GetOverlappedResult", |
[N, P, P, I], I); |
#### these are not used yet |
$_GetCommConfig = new Win32::API("kernel32", "GetCommConfig", [N, P, P], I); |
$_GetCommMask = new Win32::API("kernel32", "GetCommMask", [N, P], I); |
$_SetCommConfig = new Win32::API("kernel32", "SetCommConfig", [N, P, N], I); |
$_SetCommMask = new Win32::API("kernel32", "SetCommMask", [N, N], I); |
$_WaitCommEvent = new Win32::API("kernel32", "WaitCommEvent", [N, P, P], I); |
$_ResetEvent = new Win32::API("kernel32", "ResetEvent", [N], I); |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $RBUF_Size); |
$VERSION = '0.19'; |
$RBUF_Size = 4096; |
require Exporter; |
## require AutoLoader; |
@ISA = qw(Exporter); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= qw(); |
%EXPORT_TAGS = (STAT => [qw( BM_fCtsHold BM_fDsrHold |
BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof |
BM_fTxim BM_AllBits |
MS_CTS_ON MS_DSR_ON |
MS_RING_ON MS_RLSD_ON |
CE_RXOVER CE_OVERRUN |
CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL |
CE_MODE ST_BLOCK |
ST_INPUT ST_OUTPUT |
ST_ERROR )], |
RAW => [qw( CloseHandle CreateFile |
GetCommState ReadFile |
SetCommState SetupComm |
PurgeComm CreateEvent |
GetCommTimeouts SetCommTimeouts |
GetCommProperties ClearCommBreak |
ClearCommError EscapeCommFunction |
GetCommConfig GetCommMask |
GetCommModemStatus SetCommBreak |
SetCommConfig SetCommMask |
TransmitCommChar WaitCommEvent |
WriteFile ResetEvent |
GetOverlappedResult |
PURGE_TXABORT PURGE_RXABORT |
PURGE_TXCLEAR PURGE_RXCLEAR |
SETXOFF SETXON |
SETRTS CLRRTS |
SETDTR CLRDTR |
SETBREAK CLRBREAK |
EV_RXCHAR EV_RXFLAG |
EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD |
EV_BREAK EV_ERR |
EV_RING EV_PERR |
EV_RX80FULL EV_EVENT1 |
EV_EVENT2 ERROR_IO_INCOMPLETE |
ERROR_IO_PENDING )], |
COMMPROP => [qw( BAUD_USER BAUD_075 BAUD_110 |
BAUD_134_5 BAUD_150 BAUD_300 |
BAUD_600 BAUD_1200 BAUD_1800 |
BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 |
BAUD_38400 BAUD_56K BAUD_57600 |
BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM |
PST_RS232 PST_RS422 PST_RS423 |
PST_RS449 PST_SCANNER PST_X25 |
PST_NETWORK_BRIDGE PST_PARALLELPORT |
PST_TCPIP_TELNET PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK |
PCF_16BITMODE PCF_DTRDSR |
PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR |
PCF_TOTALTIMEOUTS PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING |
SP_PARITY SP_PARITY_CHECK SP_RLSD |
SP_STOPBITS SP_SERIALCOMM |
DATABITS_5 DATABITS_6 DATABITS_7 |
DATABITS_8 DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD |
PARITY_EVEN PARITY_MARK |
COMMPROP_INITIALIZED )], |
DCB => [qw( CBR_110 CBR_300 CBR_600 |
CBR_1200 CBR_2400 CBR_4800 |
CBR_9600 CBR_14400 CBR_19200 |
CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE |
DTR_CONTROL_HANDSHAKE RTS_CONTROL_DISABLE |
RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY |
ODDPARITY SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity |
FM_fOutxCtsFlow FM_fOutxDsrFlow |
FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX |
FM_fInX FM_fErrorChar |
FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 )], |
PARAM => [qw( LONGsize SHORTsize OS_Error |
nocarp internal_buffer yes_true )]); |
Exporter::export_ok_tags('STAT', 'RAW', 'COMMPROP', 'DCB', 'PARAM'); |
$EXPORT_TAGS{ALL} = \@EXPORT_OK; |
#### subroutine wrappers for API calls |
sub CloseHandle { |
return unless ( 1 == @_ ); |
return $_CloseHandle->Call( shift ); |
} |
sub CreateFile { |
return $_CreateFile->Call( @_ ); |
# returns handle |
} |
sub GetCommState { |
return $_GetCommState->Call( @_ ); |
} |
sub SetCommState { |
return $_SetCommState->Call( @_ ); |
} |
sub SetupComm { |
return $_SetupComm->Call( @_ ); |
} |
sub PurgeComm { |
return $_PurgeComm->Call( @_ ); |
} |
sub CreateEvent { |
return $_CreateEvent->Call( @_ ); |
} |
sub GetCommTimeouts { |
return $_GetCommTimeouts->Call( @_ ); |
} |
sub SetCommTimeouts { |
return $_SetCommTimeouts->Call( @_ ); |
} |
sub GetCommProperties { |
return $_GetCommProperties->Call( @_ ); |
} |
sub ReadFile { |
return $_ReadFile->Call( @_ ); |
} |
sub WriteFile { |
return $_WriteFile->Call( @_ ); |
} |
sub TransmitCommChar { |
return $_TransmitCommChar->Call( @_ ); |
} |
sub ClearCommBreak { |
return unless ( 1 == @_ ); |
return $_ClearCommBreak->Call( shift ); |
} |
sub SetCommBreak { |
return unless ( 1 == @_ ); |
return $_SetCommBreak->Call( shift ); |
} |
sub ClearCommError { |
return $_ClearCommError->Call( @_ ); |
} |
sub EscapeCommFunction { |
return $_EscapeCommFunction->Call( @_ ); |
} |
sub GetCommModemStatus { |
return $_GetCommModemStatus->Call( @_ ); |
} |
sub GetOverlappedResult { |
return $_GetOverlappedResult->Call( @_ ); |
} |
sub GetCommConfig { |
return $_GetCommConfig->Call( @_ ); |
} |
sub GetCommMask { |
return $_GetCommMask->Call( @_ ); |
} |
sub SetCommConfig { |
return $_SetCommConfig->Call( @_ ); |
} |
sub SetCommMask { |
return $_SetCommMask->Call( @_ ); |
} |
sub WaitCommEvent { |
return $_WaitCommEvent->Call( @_ ); |
} |
sub ResetEvent { |
return unless ( 1 == @_ ); |
return $_ResetEvent->Call( shift ); |
} |
#### "constant" declarations from Win32 header files #### |
#### compatible with ActiveState #### |
## COMMPROP structure |
sub SP_SERIALCOMM { 0x1 } |
sub BAUD_075 { 0x1 } |
sub BAUD_110 { 0x2 } |
sub BAUD_134_5 { 0x4 } |
sub BAUD_150 { 0x8 } |
sub BAUD_300 { 0x10 } |
sub BAUD_600 { 0x20 } |
sub BAUD_1200 { 0x40 } |
sub BAUD_1800 { 0x80 } |
sub BAUD_2400 { 0x100 } |
sub BAUD_4800 { 0x200 } |
sub BAUD_7200 { 0x400 } |
sub BAUD_9600 { 0x800 } |
sub BAUD_14400 { 0x1000 } |
sub BAUD_19200 { 0x2000 } |
sub BAUD_38400 { 0x4000 } |
sub BAUD_56K { 0x8000 } |
sub BAUD_57600 { 0x40000 } |
sub BAUD_115200 { 0x20000 } |
sub BAUD_128K { 0x10000 } |
sub BAUD_USER { 0x10000000 } |
sub PST_FAX { 0x21 } |
sub PST_LAT { 0x101 } |
sub PST_MODEM { 0x6 } |
sub PST_NETWORK_BRIDGE { 0x100 } |
sub PST_PARALLELPORT { 0x2 } |
sub PST_RS232 { 0x1 } |
sub PST_RS422 { 0x3 } |
sub PST_RS423 { 0x4 } |
sub PST_RS449 { 0x5 } |
sub PST_SCANNER { 0x22 } |
sub PST_TCPIP_TELNET { 0x102 } |
sub PST_UNSPECIFIED { 0 } |
sub PST_X25 { 0x103 } |
sub PCF_16BITMODE { 0x200 } |
sub PCF_DTRDSR { 0x1 } |
sub PCF_INTTIMEOUTS { 0x80 } |
sub PCF_PARITY_CHECK { 0x8 } |
sub PCF_RLSD { 0x4 } |
sub PCF_RTSCTS { 0x2 } |
sub PCF_SETXCHAR { 0x20 } |
sub PCF_SPECIALCHARS { 0x100 } |
sub PCF_TOTALTIMEOUTS { 0x40 } |
sub PCF_XONXOFF { 0x10 } |
sub SP_BAUD { 0x2 } |
sub SP_DATABITS { 0x4 } |
sub SP_HANDSHAKING { 0x10 } |
sub SP_PARITY { 0x1 } |
sub SP_PARITY_CHECK { 0x20 } |
sub SP_RLSD { 0x40 } |
sub SP_STOPBITS { 0x8 } |
sub DATABITS_5 { 1 } |
sub DATABITS_6 { 2 } |
sub DATABITS_7 { 4 } |
sub DATABITS_8 { 8 } |
sub DATABITS_16 { 16 } |
sub DATABITS_16X { 32 } |
sub STOPBITS_10 { 1 } |
sub STOPBITS_15 { 2 } |
sub STOPBITS_20 { 4 } |
sub PARITY_NONE { 256 } |
sub PARITY_ODD { 512 } |
sub PARITY_EVEN { 1024 } |
sub PARITY_MARK { 2048 } |
sub PARITY_SPACE { 4096 } |
sub COMMPROP_INITIALIZED { 0xe73cf52e } |
## DCB structure |
sub CBR_110 { 110 } |
sub CBR_300 { 300 } |
sub CBR_600 { 600 } |
sub CBR_1200 { 1200 } |
sub CBR_2400 { 2400 } |
sub CBR_4800 { 4800 } |
sub CBR_9600 { 9600 } |
sub CBR_14400 { 14400 } |
sub CBR_19200 { 19200 } |
sub CBR_38400 { 38400 } |
sub CBR_56000 { 56000 } |
sub CBR_57600 { 57600 } |
sub CBR_115200 { 115200 } |
sub CBR_128000 { 128000 } |
sub CBR_256000 { 256000 } |
sub DTR_CONTROL_DISABLE { 0 } |
sub DTR_CONTROL_ENABLE { 1 } |
sub DTR_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_DISABLE { 0 } |
sub RTS_CONTROL_ENABLE { 1 } |
sub RTS_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_TOGGLE { 3 } |
sub EVENPARITY { 2 } |
sub MARKPARITY { 3 } |
sub NOPARITY { 0 } |
sub ODDPARITY { 1 } |
sub SPACEPARITY { 4 } |
sub ONESTOPBIT { 0 } |
sub ONE5STOPBITS { 1 } |
sub TWOSTOPBITS { 2 } |
## Flowcontrol bit mask in DCB |
sub FM_fBinary { 0x1 } |
sub FM_fParity { 0x2 } |
sub FM_fOutxCtsFlow { 0x4 } |
sub FM_fOutxDsrFlow { 0x8 } |
sub FM_fDtrControl { 0x30 } |
sub FM_fDsrSensitivity { 0x40 } |
sub FM_fTXContinueOnXoff { 0x80 } |
sub FM_fOutX { 0x100 } |
sub FM_fInX { 0x200 } |
sub FM_fErrorChar { 0x400 } |
sub FM_fNull { 0x800 } |
sub FM_fRtsControl { 0x3000 } |
sub FM_fAbortOnError { 0x4000 } |
sub FM_fDummy2 { 0xffff8000 } |
## COMSTAT bit mask |
sub BM_fCtsHold { 0x1 } |
sub BM_fDsrHold { 0x2 } |
sub BM_fRlsdHold { 0x4 } |
sub BM_fXoffHold { 0x8 } |
sub BM_fXoffSent { 0x10 } |
sub BM_fEof { 0x20 } |
sub BM_fTxim { 0x40 } |
sub BM_AllBits { 0x7f } |
## PurgeComm bit mask |
sub PURGE_TXABORT { 0x1 } |
sub PURGE_RXABORT { 0x2 } |
sub PURGE_TXCLEAR { 0x4 } |
sub PURGE_RXCLEAR { 0x8 } |
## GetCommModemStatus bit mask |
sub MS_CTS_ON { 0x10 } |
sub MS_DSR_ON { 0x20 } |
sub MS_RING_ON { 0x40 } |
sub MS_RLSD_ON { 0x80 } |
## EscapeCommFunction operations |
sub SETXOFF { 0x1 } |
sub SETXON { 0x2 } |
sub SETRTS { 0x3 } |
sub CLRRTS { 0x4 } |
sub SETDTR { 0x5 } |
sub CLRDTR { 0x6 } |
sub SETBREAK { 0x8 } |
sub CLRBREAK { 0x9 } |
## ClearCommError bit mask |
sub CE_RXOVER { 0x1 } |
sub CE_OVERRUN { 0x2 } |
sub CE_RXPARITY { 0x4 } |
sub CE_FRAME { 0x8 } |
sub CE_BREAK { 0x10 } |
sub CE_TXFULL { 0x100 } |
#### LPT only |
# sub CE_PTO { 0x200 } |
# sub CE_IOE { 0x400 } |
# sub CE_DNS { 0x800 } |
# sub CE_OOP { 0x1000 } |
#### LPT only |
sub CE_MODE { 0x8000 } |
## GetCommMask bits |
sub EV_RXCHAR { 0x1 } |
sub EV_RXFLAG { 0x2 } |
sub EV_TXEMPTY { 0x4 } |
sub EV_CTS { 0x8 } |
sub EV_DSR { 0x10 } |
sub EV_RLSD { 0x20 } |
sub EV_BREAK { 0x40 } |
sub EV_ERR { 0x80 } |
sub EV_RING { 0x100 } |
sub EV_PERR { 0x200 } |
sub EV_RX80FULL { 0x400 } |
sub EV_EVENT1 { 0x800 } |
sub EV_EVENT2 { 0x1000 } |
## Allowed OVERLAP errors |
sub ERROR_IO_INCOMPLETE { 996 } |
sub ERROR_IO_PENDING { 997 } |
#### "constant" declarations compatible with ActiveState #### |
my $DCBformat="LLLSSSCCCCCCCCS"; |
my $CP_format1="SSLLLLLLLLLSSLLLLSA*"; # rs232 |
my $CP_format6="SSLLLLLLLLLSSLLLLLLLLLLLLLLLLLLLLLLLA*"; # modem |
my $CP_format0="SA50LA244"; # pre-read |
my $OVERLAPPEDformat="LLLLL"; |
my $TIMEOUTformat="LLLLL"; |
my $COMSTATformat="LLL"; |
my $cfg_file_sig="Win32API::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
sub SHORTsize { 0xffff; } |
sub LONGsize { 0xffffffff; } |
sub ST_BLOCK {0} # status offsets for caller |
sub ST_INPUT {1} |
sub ST_OUTPUT {2} |
sub ST_ERROR {3} # latched |
#### Package variable declarations #### |
my @Yes_resp = ( |
"YES","Y", |
"ON", |
"TRUE","T", |
"1" |
); |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $Babble = 0; |
my $testactive = 0; # test mode active |
## my $null=[]; |
my $null=0; |
my $zero=0; |
# Preloaded methods go here. |
sub OS_Error { print Win32::FormatMessage ( Win32::GetLastError() ); } |
sub get_tick_count { return Win32::GetTickCount(); } |
# test*.t only - suppresses default messages |
sub set_no_messages { |
return unless (@_ == 2); |
$testactive = yes_true($_[1]); |
} |
sub nocarp { return $testactive } |
sub internal_buffer { return $RBUF_Size } |
sub yes_true { |
my $choice = uc shift; |
my $ans = 0; |
foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) } |
return $ans; |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $self = {}; |
my $ok = 0; # API return value |
my $hr = 0; # temporary hashref |
my $fmask = 0; # temporary for bit banging |
my $fix_baud = 0; |
my $key; |
my $value; |
my $CommPropBlank = " "; |
# COMMPROP only used during new |
my $CommProperties = " "x300; # extra buffer for modems |
my $CP_Length = 0; |
my $CP_Version = 0; |
my $CP_ServiceMask = 0; |
my $CP_Reserved1 = 0; |
my $CP_MaxBaud = 0; |
my $CP_ProvCapabilities = 0; |
my $CP_SettableParams = 0; |
my $CP_SettableBaud = 0; |
my $CP_SettableData = 0; |
my $CP_SettableStopParity = 0; |
my $CP_ProvSpec1 = 0; |
my $CP_ProvSpec2 = 0; |
my $CP_ProvChar_start = 0; |
my $CP_Filler = 0; |
# MODEMDEVCAPS |
my $MC_ReqSize = 0; |
my $MC_SpecOffset = 0; |
my $MC_SpecSize = 0; |
my $MC_ProvVersion = 0; |
my $MC_ManfOffset = 0; |
my $MC_ManfSize = 0; |
my $MC_ModOffset = 0; |
my $MC_ModSize = 0; |
my $MC_VerOffset = 0; |
my $MC_VerSize = 0; |
my $MC_DialOpt = 0; |
my $MC_CallFailTime = 0; |
my $MC_IdleTime = 0; |
my $MC_SpkrVol = 0; |
my $MC_SpkrMode = 0; |
my $MC_ModOpt = 0; |
my $MC_MaxDTE = 0; |
my $MC_MaxDCE = 0; |
my $MC_Filler = 0; |
$self->{NAME} = shift; |
my $quiet = shift; |
$self->{"_HANDLE"}=CreateFile("$self->{NAME}", |
0xc0000000, |
0, |
$null, |
3, |
0x40000000, |
$null); |
# device name |
# GENERIC_READ | GENERIC_WRITE |
# no FILE_SHARE_xx |
# no SECURITY_xx |
# OPEN_EXISTING |
# FILE_FLAG_OVERLAPPED |
# template file |
unless ($self->{"_HANDLE"} >= 1) { |
$self->{"_HANDLE"} = 0; |
return 0 if ($quiet); |
return if (nocarp); |
OS_Error; |
carp "can't open device: $self->{NAME}\n"; |
return; |
} |
# let Win32 know we allowed room for modem properties |
$CP_Length = 300; |
$CP_ProvSpec1 = COMMPROP_INITIALIZED; |
$CommProperties = pack($CP_format0, |
$CP_Length, |
$CommPropBlank, |
$CP_ProvSpec1, |
$CommPropBlank); |
$ok=GetCommProperties($self->{"_HANDLE"}, $CommProperties); |
unless ( $ok ) { |
OS_Error; |
carp "can't get COMMPROP block"; |
undef $self; |
return; |
} |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$CP_Filler)= unpack($CP_format1, $CommProperties); |
if (($CP_Length > 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.7/track.pl |
---|
0,0 → 1,631 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# mktrack.pl - Tracking Antenne |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-02-14 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-06-14 0.1.1 rw Tilt-Servo added |
# 2009-08-15 0.1.2 rw Flip Pan/Tilt servo for >180 degree |
# config servo direction and range |
# optional get antenna home position from Map-config |
# Signal handler replaced by command-queue |
# 2009-09-30 0.1.3 rw Commandline parameter added |
# 2009-10-07 0.1.4 rw COM-Port > 9 |
# Servo Speed, neutral position and 8 bit position |
# Add Coldstart command |
# Relax servo at shutdown |
# PortSetSkip config |
# |
############################################################################### |
$Version{'track.pl'} = "0.1.4 - 2009-10-05"; |
if ( $0 =~ /track.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
# change working directory to program path |
my $Cwd = substr ($0, 0, rindex ($0, "track.pl")); |
chdir $Cwd; |
# set path for local Perl libs |
push @INC, $Cwd . "perl/lib"; |
} |
# Packages |
use Time::HiRes qw(usleep gettimeofday); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Math::Trig; |
use Geo::Ellipsoid; # http://search.cpan.org/dist/Geo-Ellipsoid-1.12/lib/Geo/Ellipsoid.pm |
# http://www.kompf.de/gps/distcalc.html |
# http://www.herrmann-w.de/Geocaching/Downloads/Richt.XLS |
# http://williams.best.vwh.net/avform.htm |
# http://williams.best.vwh.net/gccalc.html |
# http://de.wikipedia.org/wiki/Orthodrome |
if ( $^O =~ /Win32/i ) |
{ |
require Win32::SerialPort; # http://search.cpan.org/dist/Win32-SerialPort |
} |
else |
{ |
require Device::SerialPort; # http://search.cpan.org/~cook/Device-SerialPort-1.04/SerialPort.pm |
} |
require "mkcomm.pl"; # MK communication |
# Sharing for Threads |
share (@ServoPos); |
share (%MkTrack); |
# Queue for receiving commands |
$TrackQueue = Thread::Queue->new(); |
# Commandline |
my %CmdLine = @ARGV; |
# |
# Parameter |
# |
# System Timer |
$SysTimerResolution = 1000; # Resolution in us |
# Com Port for Pololu Mikro-Servoboard |
# http://www.shop.robotikhardware.de/shop/catalog/product_info.php?cPath=65&products_id=118 |
my $ComPort = $Cfg->{'track'}->{'Port'} || "COM8"; |
my $ServoPanCtrl = $Cfg->{'track'}->{'ServoPanCtrl'} || (0x00 | 15); |
my $ServoTiltCtrl = $Cfg->{'track'}->{'ServoTiltCtrl'} || (0x20 | 15 ); |
my $ServoPanSpeed = $Cfg->{'track'}->{'ServoPanSpeed'} || 0; |
my $ServoTiltSpeed = $Cfg->{'track'}->{'ServoTiltSpeed'} || 0; |
my $ServoPanNeutral = $Cfg->{'track'}->{'ServoPanNeutral'} || 3000; |
my $ServoTiltNeutral = $Cfg->{'track'}->{'ServoTiltNeutral'} || 3000; |
$MkTrack{'ServoPanCtrl'} = $ServoPanCtrl; |
$MkTrack{'ServoTiltCtrl'} = $ServoTiltCtrl; |
$MkTrack{'ServoPanSpeed'} = $ServoPanSpeed; |
$MkTrack{'ServoTiltSpeed'} = $ServoTiltSpeed; |
$MkTrack{'ServoPanNeutral'} = $ServoPanNeutral; |
$MkTrack{'ServoTiltNeutral'} = $ServoTiltNeutral; |
# Servo parameter |
$ServoPan = 0; # Servo channel Pan |
$ServoTilt = 1; # Servo channel Tilt |
$MkTrack{'ServoPan'} = $ServoPan; |
$MkTrack{'ServoTilt'} = $ServoTilt; |
@ServoSpeed = (200/40, 200/40, 200/40, 200/40, 200/40, 200/40, 200/40, 200/40); # ms/degree |
$ServoConstPpm = 20; # PPM protocol overhead in ms |
@ServoTest = ( [ 90, 0 ], # Pan, Tilt in degrees for servo test |
[ 180, 0 ], |
[ 180, 90 ], |
[ 90, 0 ], |
[ 0, 0 ], |
[ 0, 90 ], |
[ 90, 0 ], |
[ 90, 180 ], |
[ 90, 0 ], ); |
# Tracking |
$TrackInterval = 50; # in ms |
# |
# Timer |
# |
sub SetTimer_ms() |
{ |
return $SysTimerCount_ms + $_[0]; |
} |
sub CheckTimer_ms() |
{ |
my $Diff = $_[0] - $SysTimerCount_ms; |
return ($Diff <= 0); |
} |
# |
# Servo |
# |
sub ServoInit() |
{ |
# open COM-Port |
undef $ServoPort; |
if ( $ComPort =~ /^COM/i ) |
{ |
$ComPort = "\\\\.\\" . $ComPort; # for Port > 9 required |
} |
if ( $^O =~ m/Win32/ ) |
{ |
$ServoPort = Win32::SerialPort->new ($ComPort) || die "Error open $ComPort\n"; |
} |
else |
{ |
$ServoPort = Device::SerialPort->new ($ComPort) || die "Error open $ComPort\n"; |
} |
if ( ! ($Cfg->{'track'}->{'PortSetSkip'} =~ /y/i) ) |
{ |
# Set COM parameters, don't set for Bluetooth device |
$ServoPort->baudrate(38400); |
$ServoPort->parity("none"); |
$ServoPort->databits(8); |
$ServoPort->stopbits(1); |
$ServoPort->handshake('none'); |
$ServoPort->write_settings; |
} |
# Byte 1: sync - Pololu Mode |
# Byte 2: device |
# Byte 3: command |
# Byte 4: Servo num |
# Byte 5: Set Speed 0, 1..127, 0=full speed |
# Speed Pan/Tilt servo #0/#1 |
my $Output = pack('C*', 0x80, 0x01, 0x01, 0, $ServoPanSpeed ); |
$ServoPort->write($Output); |
my $Output = pack('C*', 0x80, 0x01, 0x01, 1, $ServoTiltSpeed ); |
$ServoPort->write($Output); |
# Byte 5: Set Parameter |
# Bit 6: Servo on/off |
# Bit 5: Direction |
# Bit 4-0: Servo Range |
# Set Pan/Tilt servo #0/#1 |
my $Output = pack('C*', 0x80, 0x01, 0x00, 0, 0x40 | $ServoPanCtrl ); |
$ServoPort->write($Output); |
my $Output = pack('C*', 0x80, 0x01, 0x00, 1, 0x40 | $ServoTiltCtrl ); |
$ServoPort->write($Output); |
# Byte 5/6: Neutral in 0.5us |
# Neutral Pan/Tilt servo #0/#1 |
my $Output = pack('C*', 0x80, 0x01, 0x05, 0, $ServoPanNeutral >> 7, $ServoPanNeutral & 0x7f); |
$ServoPort->write($Output); |
my $Output = pack('C*', 0x80, 0x01, 0x05, 1, $ServoTiltNeutral >> 7, $ServoTiltNeutral & 0x7f); |
$ServoPort->write($Output); |
@ServoStartTime = (0, 0, 0, 0, 0, 0, 0, 0); # Timestamp of last ServoMove() call |
@ServoEndTime = (0, 0, 0, 0, 0, 0, 0, 0); # Timestamp of estimated arrival at end position |
@ServoPos = (90, 90, 90, 90, 90, 90, 90, 90); # Current servo position 0..180 degree |
} |
sub ServoMove() |
{ |
my ($Num, $Angel, $Time) = @_; |
my $Overhead = 0; |
if ( $Angel != $ServoPos[$Num] ) |
{ |
if ( $Angel < 0) {$Angel = 0;} |
if ( $Angel > 180) {$Angel = 180;} |
my $Pos = int ($Angel * 255/180 + 0.5); # angel 0..180 degree to servo position 0..255 |
# output to COM port |
# Byte 1: sync - Pololu Mode |
# Byte 2: device |
# Byte 3: command |
# Byte 4: Servo num |
# Byte 5/6: servo position 0..255 |
my $Output = pack('C*', 0x80, 0x01, 0x03, $Num, $Pos >> 7, $Pos & 0x7f); |
$ServoPort->write($Output); |
$Overhead += $ServoConstPpm; # PPM protocol overhead |
} |
# set timer stuff for travel time predicion |
my $LastAngel = $ServoPos[$Num]; |
my $EstimatedTime = abs($Angel - $LastAngel) * $ServoSpeed[$Num] + $Overhead; |
if ( $Time > 0 ) |
{ |
# Parameter override |
$EstimatedTime = $Time; |
} |
$ServoStartTime[$Num] = $SysTimerCount_ms; |
$ServoEndTime[$Num] = $SysTimerCount_ms + $EstimatedTime; |
$ServoPos[$Num] = $Angel; |
return $ServoEndTime[$Num]; |
} |
# switch off servo |
sub ServoRelax() |
{ |
if ( defined $ServoPort ) |
{ |
# Byte 1: sync - Pololu Mode |
# Byte 2: device |
# Byte 3: command |
# Byte 4: Servo num |
# Byte 5: Set Parameter |
# Bit 6: Servo on/off |
# Bit 5: Direction |
# Bit 4-0: Servo Range |
# Set Pan/Tilt servo #0/#1 |
my $Output = pack('C*', 0x80, 0x01, 0x00, 0, 0x00 | $ServoPanCtrl ); |
$ServoPort->write($Output); |
my $Output = pack('C*', 0x80, 0x01, 0x00, 1, 0x00 | $ServoTiltCtrl ); |
$ServoPort->write($Output); |
} |
} |
# Check, if servo has reached end position |
sub ServoCheck() |
{ |
my $Num = $_[0]; |
return &CheckTimer_ms($ServoEndTime[$Num]); |
} |
sub ServoClose() |
{ |
# close COM-Port |
undef $ServoPort; |
} |
# |
# Track it |
# |
sub TrackAntennaGps() |
{ |
# initialize system-timer |
$SysTimerCount_ms = 0; |
$SysTimerError = 0; |
($t0_s, $t0_us) = gettimeofday; |
# |
# State maschine |
# |
my $State = "Idle"; |
while (1) |
{ |
$MkTrack{'State'} = $State; # export state |
# |
# Idle |
# |
if ( $State eq "Idle" ) |
{ |
# nothing to do. Wait for commands in TrackQueue |
} |
# |
# ColdStart |
# |
elsif ( $State eq "ColdStart" ) |
{ |
&ServoInit(); |
$ServoTestIndex = 0; |
$State = "InitServoTest"; |
} |
# |
# Start servo test |
# doesn't really make much sense, but looks cool:-) |
# |
elsif ( $State eq "InitServoTest") |
{ |
if ( &ServoCheck ($ServoPan) and &ServoCheck ($ServoTilt) ) |
{ |
my $PanPos = $ServoTest[$ServoTestIndex][0]; |
my $TiltPos = $ServoTest[$ServoTestIndex][1]; |
$ServoTestIndex ++; |
if ( defined $PanPos and defined $TiltPos ) |
{ |
my $Delay = 200; |
my $LastPan = $ServoPos[$ServoPan]; |
my $LastTilt = $ServoPos[$ServoTilt]; |
my $EstimatedPan = 1000; |
if ( $ServoPanSpeed != 0 ) |
{ |
# about 2ms/180degree pulse, 50us/s servo pulse change per unit |
$EstimatedPan = abs($PanPos - $LastPan) * 0.002/180 / ($ServoPanSpeed * 0.000050) * 1000 + $Delay; |
} |
my $EstimatedTilt = 1000; |
if ( $ServoTiltSpeed != 0 ) |
{ |
# about 2ms/180degree pulse, 50us/s servo pulse change per unit |
$EstimatedTilt = abs($TiltPos - $LastTilt) * 0.002/180 / ($ServoTiltSpeed * 0.000050) * 1000 + $Delay; |
} |
&ServoMove ($ServoPan, $PanPos, $EstimatedPan); # override travel time |
&ServoMove ($ServoTilt, $TiltPos, $EstimatedTilt); # override travel time |
} |
else |
{ |
# complete |
$ServoTestIndex = 0; |
$State = "WaitGps"; |
} |
} |
} |
# |
# Servo test finisched |
# |
# Wait for GPS Home position and compass |
# |
elsif ( $State eq "WaitGps" ) |
{ |
if ( &ServoCheck ($ServoPan) ) |
{ |
lock (%MkOsd); # until end of block |
lock (%MkTrack); |
if ( $MkOsd{'_Timestamp'} >= time-2 and |
$MkOsd{'SatsInUse'} >= 6 ) |
{ |
# gültige OSD daten vom MK und guter Satellitenempfang |
# take GPS and compass from map definition or MK as antenna home-position |
$MkTrack{'HomePos_Lon'} = $Map{'Track_Lon'} || $MkOsd{'HomePos_Lon'}; |
$MkTrack{'HomePos_Lat'} = $Map{'Track_Lat'} || $MkOsd{'HomePos_Lat'}; |
$MkTrack{'HomePos_Alt'} = $Map{'Track_Alt'} || $MkOsd{'HomePos_Alt'}; |
$MkTrack{'CompassHeading'} = $Map{'Track_Bearing'} || $MkOsd{'CompassHeading'}; |
$TrackTimer = &SetTimer_ms($TrackInterval); |
$State = "TrackGps"; |
} |
} |
} |
# |
# GPS Fix Home position |
# Track now |
# |
elsif ( $State eq "TrackGps" ) |
{ |
if ( &CheckTimer_ms($TrackTimer) and &ServoCheck($ServoPan) ) |
{ |
$TrackTimer = &SetTimer_ms($TrackInterval); # reload Timer |
lock (%MkOsd); # until end of block |
lock (%MkTrack); |
if ( $MkOsd{'_Timestamp'} >= time -2 and |
$MkOsd{'SatsInUse'} >= 4 ) |
{ |
# valid OSD data from the MK and sufficient satellites |
my $Track_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
my ($Dist, $Bearing) = $Track_Geo->to($MkTrack{'HomePos_Lat'}, $MkTrack{'HomePos_Lon'}, |
$MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}); |
my $Dir_h = $MkTrack{'CompassHeading'}; |
my $Dir_c = $MkOsd{'CompassHeading'}; |
if ( $Dist < 4 ) # meter |
{ |
# Too close to Home-Position. Set antenna to middle position |
$Bearing = $Dir_h; |
} |
$MkTrack{'Bearing'} = sprintf ("%d", $Bearing); |
$MkTrack{'Dist'} = sprintf ("%d", $Dist); |
$MkTrack{'CurPos_Lon'} = $MkOsd{'CurPos_Lon'}; |
$MkTrack{'CurPos_Lat'} = $MkOsd{'CurPos_Lat'}; |
$MkTrack{'CurPos_Alt'} = $MkOsd{'CurPos_Alt'}; |
# antenna pan direction: 0..180 degree, centre = 90 |
my $AngelPan = $Bearing - $Dir_h + 90; |
$AngelPan = $AngelPan % 360; |
# antenna tilt direction: 0..180 degree, centre is up, 0 is front |
my $AngelTilt = rad2deg(atan2(($MkOsd{'CurPos_Alt'} - $MkTrack{'HomePos_Alt'}), $Dist)); |
if ( $AngelTilt < 0 ) { $AngelTilt = 0; } |
if ( $AngelTilt > 180 ) { $AngelTilt = 180; } |
if ( $AngelPan >= 180 ) |
{ |
# Flip Pan/Tilt |
$AngelPan = $AngelPan - 180; |
$AngelTilt = 180 - $AngelTilt; |
} |
$MkTrack{'AngelPan'} = $AngelPan; |
$MkTrack{'AngelTilt'} = $AngelTilt; |
&ServoMove ($ServoPan, $AngelPan); |
&ServoMove ($ServoTilt, $AngelTilt); |
# Timestamp, wann der Datensatz geschtieben wurde |
$MkTrack{'_Timestamp'} = time; |
} |
} |
} |
else |
{ |
# Restart |
$State = "ColdStart"; |
} |
# |
# check command queue |
# |
while ( $TrackQueue->pending() > 0 ) |
{ |
my $Cmd = $TrackQueue->dequeue(1); |
if ( $Cmd =~ /COLDSTART/i ) |
{ |
$State = "ColdStart"; |
} |
if ( $Cmd =~ /IDLE/i ) |
{ |
if ( defined $ServoPort ) |
{ |
# move all Servo to neutral position |
&ServoMove ($ServoPan, 90); |
&ServoMove ($ServoTilt, 0); |
sleep 1; |
&ServoRelax(); # swith off servo |
} |
$State = "Idle"; |
} |
} |
# |
# update system-timer |
# |
($t1_s, $t1_us) = gettimeofday; |
$SysTimerSleep_us = ($t0_s - $t1_s) * 1000000 + $t0_us - $t1_us + $SysTimerCount_ms * $SysTimerResolution; |
if ($SysTimerSleep_us > 0) |
{ |
usleep ($SysTimerSleep_us); |
} |
else |
{ |
$SysTimerError ++; |
} |
$SysTimerCount_ms ++; |
} |
} |
# |
# Main Program |
# |
if ( $0 =~ /track.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
# |
# Commandline Parameter |
# |
my $TrackPort = $CmdLine{'-TrackPort'}; |
if ( $TrackPort ne "" ) |
{ |
$ComPort = $TrackPort; |
} |
my $MkPort = $CmdLine{'-MkPort'}; |
if ( $MkPort ne "" ) |
{ |
$Cfg->{'mkcomm'}->{'Port'} = $MkPort; |
} |
my $PanCtrl = $CmdLine{'-PanCtrl'}; |
if ( $PanCtrl ne "" ) |
{ |
$ServoPanCtrl = $PanCtrl; |
} |
my $TiltCtrl = $CmdLine{'-TiltCtrl'}; |
if ( $TiltCtrl ne "" ) |
{ |
$ServoTiltCtrl = $TiltCtrl; |
} |
my $PanSpeed = $CmdLine{'-PanSpeed'}; |
if ( $PanSpeed ne "" ) |
{ |
$ServoPanSpeed = $PanSpeed; |
} |
my $TiltSpeed = $CmdLine{'-TiltSpeed'}; |
if ( $TiltSpeed ne "" ) |
{ |
$ServoTiltSpeed = $TiltSpeed; |
} |
my $PanNeutral = $CmdLine{'-PanNeutral'}; |
if ( $PanNeutral ne "" ) |
{ |
$ServoPanNeutral = $PanNeutral; |
} |
my $TiltNeutral = $CmdLine{'-TiltNeutral'}; |
if ( $TiltNeutral ne "" ) |
{ |
$ServoTiltNeutral = $TiltNeutral; |
} |
# Kommunikation zum MK herstellen |
# Input: %MkOsd, %MkTarget, %MkNcDebug |
# Ouput: Thread-Queue: $MkSendQueue |
$mk_thr = threads->create (\&MkCommLoop) -> detach(); |
$TrackQueue->enqueue("COLDSTART"); # start command |
&TrackAntennaGps(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/translate.pl |
---|
0,0 → 1,628 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# translate.pl - Translation fuer MK Datensaetze |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-02-23 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-05-06 0.1.1 rw NC 0.15c |
# 2009-05-17 0.1.2 rw Waypoint Player |
# 2009-06-11 0.1.3 rw DE/EN support. English by Mark Griffin |
# 2009-07-25 0.1.4 rw KML Player |
# 2009-07-26 0.1.5 rw MK System messages |
# 2009-08-08 0.1.7 rw TTS |
# 2009-09-05 0.1.8 rw POI |
# 2009-10-05 0.1.9 rw Servo Speed, Neutral |
# MK Sim |
# |
############################################################################### |
$Version{'translate.pl'} = "0.1.9 - 2009-10-08"; |
use Win32::Locale; # http://search.cpan.org/~sburke/Win32-Locale-0.04/Locale.pm |
%Translate_DE = ( |
# NC Debug |
"Analog_00" => "Angel Nick", |
"Analog_01" => "Angel Roll", |
"Analog_02" => "ACC Nick", |
"Analog_03" => "ACC Roll", |
"Analog_05" => "MK-Flags", |
"Analog_06" => "NC-Flags", |
"Analog_09" => "GPS Data", |
"Analog_10" => "Compass Heading", |
"Analog_11" => "Gyro Heading", |
"Analog_12" => "SPI Error", |
"Analog_13" => "SPI OK", |
"Analog_14" => "I2C Error", |
"Analog_15" => "I2C OK", |
"Analog_16" => "FC Kalman K", |
"Analog_17" => "ACC Speed North", |
"Analog_18" => "ACC Speed East", |
"Analog_19" => "GPS ACC", |
"Analog_20" => "Max Drift", |
"Analog_21" => "Speed North", |
"Analog_22" => "Speed East", |
"Analog_23" => "P-Part", |
"Analog_24" => "I-Part", |
"Analog_25" => "D-Part", |
"Analog_26" => "PID-Part", |
"Analog_27" => "Distance North", |
"Analog_28" => "Distance East", |
"Analog_29" => "GPS Nick", |
"Analog_30" => "GPS Roll", |
"Analog_31" => "Empfangene Satellitten", |
# NC OSD |
"Altimeter" => "Höhe (Luftdruck)", |
"AngleNick" => "Winkel Nick", |
"AngleRoll" => "Winkel Roll", |
"CompassHeading" => "Richtung Kompass", |
"CurPos_Alt" => "Position Höhe", |
"CurPos_Lat" => "Position Latitude", |
"CurPos_Lon" => "Position Longitude", |
"CurPos_Stat" => "Position Status", |
"Errorcode" => "Fehler Code", |
"FlyingTime" => "Flugzeit", |
"GroundSpeed" => "Geschw. über Grund", |
"Heading" => "Richtung", |
"HomePosDev_Bearing" => "Homepos. Richtung", |
"HomePosDev_Dist" => "Homepos. Entfernung", |
"HomePos_Alt" => "Homepos. Höhe", |
"HomePos_Lat" => "Homepos. Latitude", |
"HomePos_Lon" => "Homepos. Longitude", |
"HomePos_Stat" => "Homepos. Status", |
"MKFlags" => "MK Flags", |
"NCFlags" => "NC Flags", |
"OperatingRadius" => "Operating Radius", |
"RC_Quality" => "RC Signalstärke", |
"SatsInUse" => "Empfangene Satellitten", |
"TargetHoldTime" => "Wartezeit am Ziel", |
"TargetPosDev_Bearing" => "Ziel Richtung", |
"TargetPosDev_Dist" => "Ziel Entfernung", |
"TargetPos_Alt" => "Ziel Höhe", |
"TargetPos_Lat" => "Ziel Latitude", |
"TargetPos_Lon" => "Ziel Longitude", |
"TargetPos_Stat" => "Ziel Status", |
"TopSpeed" => "Geschwindigkeit vertikal", |
"UBat" => "Batterie Spannung", |
"Variometer" => "Variometer", |
"WaypointIndex" => "Wegpunkt Index", |
"WaypointNumber" => "Wegpunkt Nummer", |
"_Timestamp" => "_Zeitstempel", |
# NC Target |
"EventFlag" => "Event Flag", |
"Richtung" => "Richtung", |
"HoldTime" => "Wartezeit", |
"Pos_Alt" => "Position Höhe", |
"Pos_Lat" => "Position Latitude", |
"Pos_Lon" => "Position Longitude", |
"Pos_Stat" => "Position Status", |
"ToleranceRadius" => "Toleranz Radius", |
# Configuration |
"geserver" => "Google Earth Server", |
"logging" => "Logging", |
"map" => "Karte", |
"mkcockpit" => "Mission Cockpit", |
"mkcomm" => "MK Kommunikation", |
"Port" => "Port *", |
"PortSetSkip" => "Keine Port Parameter (Y für BT) *", |
"track" => "Tracking Antenne", |
"waypoint" => "Wegpunkte", |
"HttpPort" => "HTTP Port *", |
"CsvLogDir" => "CSV Log-Verzeichnis *", |
"GpxLogDir" => "GPX Log-Verzeichnis *", |
"KmlLogDir" => "KML Log-Verzeichnis *", |
"MapDefault" => "Kartendefinition Hintergrundbild *", |
"MapDir" => "Verzeichnis fuer Karten *", |
"Active" => "Aktiv *", |
"AltFactor" => "Faktor Höhe(Luftdruck) nach Meter", |
"DefaultEventFlag" => "Default Event-Flag", |
"DefaultHeading" => "Default Heading", |
"DefaultHoldtime" => "Default Holdtime", |
"DefaultToleranceRadius"=> "Default Toleranz Radius", |
"WpDir" => "Verzeichnis Wegpunkte *", |
"ColorAirfield" => "Farbe Flugfeldbegrenzung *", |
"ColorHomeDist" => "Farbe Text Entfernung Home *", |
"ColorHomeLine" => "Farbe Linie Entfernung Home *", |
"ColorKmlTrack" => "Farbe KML Spur", |
"ColorMkSatGood" => "Farbe MK guter Sat-Empfang", |
"ColorMkSatLow" => "Farbe MK schlechter Sat-Empfang", |
"ColorMkSatNo" => "Farbe MK kein Sat-Empfang", |
"ColorOsd" => "Farbe OSD *", |
"ColorSpeedVector" => "Farbe Speed-Vektor *", |
"ColorTargetDist" => "Farbe Text Entfernung Ziel *", |
"ColorTargetLine" => "Farbe Linie Entfernung Ziel *", |
"ColorVariometer" => "Farbe Variometer-Skala *", |
"ColorVariometerPointer"=> "Farbe Variometer-Zeiger *", |
"ColorWpConnector" => "Farbe Wegpunkt-Connector", |
"ColorWpResend" => "Farbe Wp-Conn. geaendert", |
"ColorWpNumber" => "Farbe Wegpunkt Nummer", |
"ColorFootprint" => "Farbe Footprint", |
"FootprintLength" => "Länge Footprint (in s)", |
"IconFox" => "Icon Fuchsjagd *", |
"IconHeartLarge" => "Icon Heartbeat gross *", |
"IconHeartSmall" => "Icon Heartbeat klein *", |
"IconSatellite" => "Icon Satellit *", |
"IconTarget" => "Icon Ziel *", |
"IconWaypoint" => "Icon Wegpunkt *", |
"Intervall" => "Intervall (in s) *", |
"UBatWarning" => "Batterie Warnung (in V) ", |
"IconFirst" => "Icon erster WP *", |
"IconHome" => "Icon Home *", |
"IconLast" => "Icon letzter WP *", |
"IconNext" => "Icon nächster WP *", |
"IconPause" => "Icon Pause *", |
"IconPlay" => "Icon Play *", |
"IconPrev" => "Icon vorheriger WP *", |
"IconStop" => "Icon Stop WP-Player *", |
"KmlDir" => "Verzeichnis KML-Files *", |
"KmlTimeBase" => "KML Player Zeitbasis (s) *", |
"PauseMoveDist" => "Pause-Verschiebe-Länge (m) *", |
"tts" => "Text To Speech", |
"StartScenario" => "Start Szenario", |
"KmlFile" => "KML Dateiname *", |
"WpFile" => "Waypoint Dateiname *", |
"PlayerMode" => "Player Modus (Play, Pause, Home, Stop) *", |
"PlayerRandomMode" => "Random Modus (STD, RND, MAP) *", |
"PlayerWptKmlMode" => "Event- oder zeitgesteuert (WPT, KML) *", |
"AudioMute" => "Audio stumm schalten (y/n) *", |
"ServoPanCtrl" => "Servo Pan Control *", |
"ServoTiltCtrl" => "Servo Tilt Control *", |
"ServoPanSpeed" => "Servo Pan Speed *", |
"ServoTiltSpeed" => "Servo Tilt Speed *", |
"ServoPanNeutral" => "Servo Pan Mittelstellung *", |
"ServoTiltNeutral" => "Servo Tilt Mittelstellung *", |
"IconAntenna" => "Icon Antenne *", |
"mksim" => "Simulator", |
"ImageSize" => "Größe Bild", |
# Waypoint |
"MapX" => "X-Position auf Karte", |
"MapY" => "Y-Position auf Karte", |
"Event_Flag" => "Event Flag", |
"Holdtime" => "Wartezeit am Wegpunkt", |
# GUI (MkCockpit.pl) |
"File" => "~Datei", |
"Preferences" => "Einstellungen", |
"Exit" => "Ende", |
"Debug" => "D~ebug", |
"NcOsdDataset" => "NC ~OSD Datensatz (O)", |
"NcTargetDataset" => "NC ~Target Datensatz (s)", |
"NcDebugDataset" => "NC ~Debug Datensatz (D)", |
"NcOther" => "NC ~Sonstiges", |
"TrackingDebugDataset" => "Tracking ~Antenne Debug Datensatz", |
"Help" => "~Hilfe", |
"Version" => "Version", |
"About" => "Über", |
"AboutMissionCockpit" => "Über Mission Cockpit", |
"StatusLine" => "Statuszeile", |
"Map" => "Karte", |
"MapDebugDataset" => "Map Datensatz", |
"MkDebugSim" => "MK Simulator", |
"MkMotorRun" => "Motor läuft", |
"MkFly" => "Fliegt", |
"MkCalibrate" => "Calibrierung", |
"MkStart" => "Motor Start", |
"MkEmergency" => "Notlandung", |
"NcFlagFree" => "Free", |
"NcFlagPH" => "PH", |
"NcFlagCH" => "CH", |
"NcFlagRangeLimit" => "Range Limit", |
"NcFlagNoSerialLink" => "No Serial Link", |
"NcFlagTargetReached" => "Target reached", |
"NcFlagManualControl" => "Manual Control", |
"DataLink" => "Daten Link", |
"Balloon-MK-Arrow" => "MikroKopter", |
"Balloon-MK-Home-Line" => "Hier gehts nach Hause", |
"Balloon-MK-Home-Dist" => "Entfernung nach Hause", |
"Balloon-MK-Target-Line" => "Hier gehts zum Ziel", |
"Balloon-MK-Target-Dist" => "Entfernung zum Ziel", |
"Balloon-MK-Speed" => "Geschwindigkeits-Vektor", |
"Balloon-Map-Variometer" => "Variometer", |
"Balloon-Map-Variometer-Pointer" => "Variometer", |
"Balloon-Map-Variometer-Skala" => "Variometer", |
"Balloon-Fox" => "Ziel für Fuchsjagd", |
"Balloon-Heartbeat" => "Aktivität Datenübertragung zum MK", |
"Balloon-Satellite" => "Guter Satelliten-Empfang", |
"Balloon-Waypoint" => "Wegpunkt", |
"Balloon-Map-Border" => "Flugplatz", |
"Balloon-Waypoint-Connector" => "Verbinder Wegpunkte", |
"Balloon-Wp-PlayPause" => "Play/Pause (Leertaste)", |
"Balloon-Wp-Stop" => "Stop Player(s)", |
"Balloon-Wp-First" => "Zum ersten Waypoint (f)", |
"Balloon-Wp-Last" => "Zum letzten Waypoint (l)", |
"Balloon-Wp-Next" => "Zum nächsten Waypoint (n)", |
"Balloon-Wp-Prev" => "Zum vorgerigen Waypoint (p)", |
"Balloon-Wp-Home" => "Zur Home-Position (h)", |
"Balloon-Wp-WptKml" => "Waypoint oder KML Mode (w,k)", |
"Balloon-Wp-WptRandom" => "Random Mode (r)", |
"Balloon-Wp-Record" => "Aufnahme (a)", |
"Balloon-TrackAntenna" => "Tracking Antenne", |
"Balloon-Poi" => "Point Of Interest", |
"TargetCoordSent" => "Ziel-Koordinaten gesendet", |
"WpMoved" => "Wegpunkt verschoben", |
"WpAddAndSend" => "Wegpunkt hinzufügen und senden", |
"WpSavedAndSent" => "Wegpunkt gespeichert und gesendet", |
"WpProperties" => "Wegpunkt Eigenschaften", |
"WpResendAll" => "Alle Wegpunkte erneut senden", |
"WpAllSent" => "Alle Wegpunkte gesendet", |
"WpLoadAndSend" => "Wegpunkte laden und senden", |
"WpLoad" => "Wegpunkte laden", |
"WpLoadedAndSent" => "Wegpunkte geladen und gesendet", |
"WpSave" => "Wegpunkte speichern", |
"WpSaved" => "Wegpunkte in gespeichert", |
"WpDelete" => "Wegpunkt löschen", |
"WpDeleted" => "Wegpunkt gelöscht", |
"WpAllDeleteAndSend" => "Alle Wegpunkte löschen und senden", |
"WpAllDeleted" => "Alle Wegpunkte gelöscht", |
"WpFlyImmediately" => "Ziel sofort anfliegen", |
"Abort" => "Abbruch", |
"RestartRequired" => "*) Aenderungen werden erst nach Programm-Neustart wirksam!", |
"KmlLoadAndPlay" => "KML Datei laden", |
"KmlLoad" => "KML laden", |
"KmlLoaded" => "KML geladen", |
"PoiMoved" => "POI verschoben", |
# MK System Meldungen |
"MsgNoSatReception" => "Kein SAT Empfang", |
"MsgWeakSatReception" => "Schwacher SAT Empfang", |
"MsgBatWarning" => "Akku Warnung", |
"MsgNoData" => "Kein Daten-Link", |
"MsgRangeLimit" => "Reichweiten Warnung", |
"MsgRcWarning" => "RC Reichweiten Warnung", |
"MsgRcError" => "Kein RC Empfang", |
"MsgMotorOff" => "Motor ist aus", |
"MsgNotFlying", => "MK ist am Boden", |
"MsgCalibrate", => "Kalibrierung", |
"MsgStart" => "Motor start ...", |
"MsgEmergencyLanding" => "Notlandung", |
"MsgOutsideBorder", => "MK ausserhalb Flugfeld", |
"MsgCrossingBorder", => "Mk kreuzt Flugfeldbegrenzung", |
# TTS |
"TtsBattery" => "Batterie, %d komma %d Volt", |
"TtsFlightTimeMinSec" => "Flugzeit, %d Minuten, %d Sekunden", |
"TtsFlightTimeSec" => "Flugzeit, %d Sekunden", |
"TtsAltitude" => "Höhe, %d Meter", |
"TtsAltitudeNegative" => "Höhe, Minus %d Meter", |
"TtsSatellite" => "Sattelliten, %d", |
"TtsBatteryWarning" => "Niedrige, Batterie Spannung", |
"TtsRcWeak" => "schwacher, RC Empfang", |
"TtsRcNo" => "Kein, RC Empfang", |
"TtsCrossingBorder" => "Kreuzt, Flug feld Begrenzung", |
"TtsOutsideAirfield" => "Ausserhalb, Flug feld", |
"TtsRange" => "Reichweiten Warnung", |
"TtsNoDataLink" => "Kein, Daten Link", |
"TtsNextTarget" => "Fliege zum nächsten Ziel", |
"TtsTargetReached" => "Ziel erreicht", |
"TtsFun" => "Huiiii, das macht Spass!", |
); |
%Translate_EN = ( |
# NC Debug |
"Analog_00" => "Angel Nick", |
"Analog_01" => "Angel Roll", |
"Analog_02" => "ACC Nick", |
"Analog_03" => "ACC Roll", |
"Analog_05" => "MK-Flags", |
"Analog_06" => "NC-Flags", |
"Analog_09" => "GPS Data", |
"Analog_10" => "Compass Heading", |
"Analog_11" => "Gyro Heading", |
"Analog_12" => "SPI Error", |
"Analog_13" => "SPI OK", |
"Analog_14" => "I2C Error", |
"Analog_15" => "I2C OK", |
"Analog_16" => "FC Kalman K", |
"Analog_17" => "ACC Speed North", |
"Analog_18" => "ACC Speed East", |
"Analog_19" => "GPS ACC", |
"Analog_20" => "Max Drift", |
"Analog_21" => "Speed North", |
"Analog_22" => "Speed East", |
"Analog_23" => "P-Part", |
"Analog_24" => "I-Part", |
"Analog_25" => "D-Part", |
"Analog_26" => "PID-Part", |
"Analog_27" => "Distance North", |
"Analog_28" => "Distance East", |
"Analog_29" => "GPS Nick", |
"Analog_30" => "GPS Roll", |
"Analog_31" => "Satellite Receive", |
# NC OSD |
"Altimeter" => "Altitude (air)", |
"AngleNick" => "Nick angle", |
"AngleRoll" => "Roll angle", |
"CompassHeading" => "Compass Heading", |
"CurPos_Alt" => "Position Höhe", |
"CurPos_Lat" => "Position Latitude", |
"CurPos_Lon" => "Position Longitude", |
"CurPos_Stat" => "Position Status", |
"Errorcode" => "Error Code", |
"FlyingTime" => "Flying time", |
"GroundSpeed" => "Ground speed", |
"Heading" => "Heading", |
"HomePosDev_Bearing" => "Homeposition Bearing", |
"HomePosDev_Dist" => "Homeposition Distance", |
"HomePos_Alt" => "Homeposition Altitude", |
"HomePos_Lat" => "Homeposition Latitude", |
"HomePos_Lon" => "Homeposition Longitude", |
"HomePos_Stat" => "Homeposition Status", |
"MKFlags" => "MK Flags", |
"NCFlags" => "NC Flags", |
"OperatingRadius" => "Operating Radius", |
"RC_Quality" => "RC Signal quality", |
"SatsInUse" => "Satellites in use", |
"TargetHoldTime" => "Target hold time", |
"TargetPosDev_Bearing" => "Target Richtung", |
"TargetPosDev_Dist" => "Target Distance", |
"TargetPos_Alt" => "Target Altitude", |
"TargetPos_Lat" => "Target Latitude", |
"TargetPos_Lon" => "Target Longitude", |
"TargetPos_Stat" => "Target Status", |
"TopSpeed" => "Vertical Speed", |
"UBat" => "Battery Voltage", |
"Variometer" => "Variometer", |
"WaypointIndex" => "Waypoint Index", |
"WaypointNumber" => "Waypoint Number", |
"_Timestamp" => "_Timestamp", |
# NC Target |
"EventFlag" => "Event Flag", |
"Richtung" => "Direction", |
"HoldTime" => "Hold Time", |
"Pos_Alt" => "Position Altitude", |
"Pos_Lat" => "Position Latitude", |
"Pos_Lon" => "Position Longitude", |
"Pos_Stat" => "Position Status", |
"ToleranceRadius" => "Tolerance Radius", |
# Configuration |
"geserver" => "Google Earth Server", |
"logging" => "Logging", |
"map" => "Map", |
"mkcockpit" => "Mission Cockpit", |
"mkcomm" => "MK Communication", |
"Port" => "Port *", |
"PortSetSkip" => "Don't set Port Parameter (Y for BT) *", |
"track" => "Tracking Antenna", |
"waypoint" => "Waypoint", |
"HttpPort" => "HTTP Port *", |
"CsvLogDir" => "CSV Log directory *", |
"GpxLogDir" => "GPX Log directory *", |
"KmlLogDir" => "KML Log directory *", |
"MapDefault" => "Map default Background image *", |
"MapDir" => "Map Directory *", |
"Active" => "Active *", |
"AltFactor" => "Altitude factor (air) in Meter", |
"DefaultEventFlag" => "Default Event-Flag", |
"DefaultHeading" => "Default Heading", |
"DefaultHoldtime" => "Default Holdtime", |
"DefaultToleranceRadius"=> "Default Tolerance Radius", |
"WpDir" => "Waypoint directory *", |
"ColorAirfield" => "Color Airfield boundary *", |
"ColorHomeDist" => "Color Text Distance Home *", |
"ColorHomeLine" => "Color Line Distance Home *", |
"ColorKmlTrack" => "Color KML Track", |
"ColorMkSatGood" => "Color MK good Sat reception", |
"ColorMkSatLow" => "Color MK weak Sat reception", |
"ColorMkSatNo" => "Color MK no Sat reception", |
"ColorOsd" => "Color OSD *", |
"ColorSpeedVector" => "Color Speed-Vector *", |
"ColorTargetDist" => "Color Text Target distance *", |
"ColorTargetLine" => "Color Linie Target distance *", |
"ColorVariometer" => "Color Variometer Scale *", |
"ColorVariometerPointer"=> "Color Variometer pointer *", |
"ColorWpConnector" => "Color Waypoint connector", |
"ColorWpResend" => "Color Wp-Conn. changed", |
"ColorWpNumber" => "Color Waypoint Number", |
"ColorFootprint" => "Color Footprint", |
"FootprintLength" => "Länge Footprint (in s)", |
"IconFox" => "Icon Fox *", |
"IconHeartLarge" => "Icon Heartbeat large *", |
"IconHeartSmall" => "Icon Heartbeat small *", |
"IconSatellite" => "Icon Satellite *", |
"IconTarget" => "Icon Target *", |
"IconWaypoint" => "Icon Waypoint *", |
"Intervall" => "Interval (in s) *", |
"UBatWarning" => "Battery Warning (in V) ", |
"IconFirst" => "Icon first WP *", |
"IconHome" => "Icon Home *", |
"IconLast" => "Icon last WP *", |
"IconNext" => "Icon next WP *", |
"IconPause" => "Icon Pause *", |
"IconPlay" => "Icon Play *", |
"IconPrev" => "Icon previous WP *", |
"IconStop" => "Icon Stop WP-Player *", |
"KmlDir" => "Directory KML-Files *", |
"KmlTimeBase" => "KML Player Timebase (s) *", |
"PauseMoveDist" => "Pause Move Distance (m) *", |
"tts" => "Text To Speech", |
"StartScenario" => "Start Scenario", |
"KmlFile" => "KML Filename *", |
"WpFile" => "Waypoint Filename *", |
"PlayerMode" => "Player Mode (Play, Pause, Home, Stop) *", |
"PlayerRandomMode" => "Random Mode (STD, RND, MAP) *", |
"PlayerWptKmlMode" => "Event- or time controlled (WPT, KML) *", |
"AudioMute" => "Mute Audio (y/n) *", |
"ServoPanCtrl" => "Servo Pan Control *", |
"ServoTiltCtrl" => "Servo Tilt Control *", |
"ServoPanSpeed" => "Servo Pan Speed *", |
"ServoTiltSpeed" => "Servo Tilt Speed *", |
"ServoPanNeutral" => "Servo Pan Neutral *", |
"ServoTiltNeutral" => "Servo Tilt Neutral *", |
"IconAntenna" => "Icon Antenna *", |
"mksim" => "Simulator", |
"ImageSize" => "Image Size", |
# Waypoint |
"MapX" => "X-Position on the map", |
"MapY" => "Y-Position on the map", |
"Event_Flag" => "Event Flag", |
"Holdtime" => "Waiting time at Waypoint", |
# GUI (MkCockpit.pl) |
"File" => "~File", |
"Preferences" => "Preferences", |
"Exit" => "E~xit", |
"Debug" => "D~ebug", |
"NcOsdDataset" => "NC ~OSD Record (O)", |
"NcTargetDataset" => "NC ~Target Record (s)", |
"NcDebugDataset" => "NC ~Debug Record (D)", |
"NcOther" => "NC ~Other", |
"TrackingDebugDataset" => "Tracking ~Antenna Debug Record", |
"Help" => "~Help", |
"Version" => "Version", |
"About" => "About", |
"AboutMissionCockpit" => "About Mission Cockpit", |
"StatusLine" => "Status line", |
"Map" => "Map", |
"MapDebugDataset" => "Map Record", |
"MkDebugSim" => "MK Simulator", |
"Balloon-MK-Arrow" => "MikroKopter", |
"Balloon-MK-Home-Line" => "This way to Home", |
"Balloon-MK-Home-Dist" => "Distance to Home", |
"Balloon-MK-Target-Line" => "This way to the Target", |
"Balloon-MK-Target-Dist" => "Distance to Target", |
"Balloon-MK-Speed" => "Speed vector", |
"Balloon-Map-Variometer" => "Variometer", |
"Balloon-Map-Variometer-Pointer" => "Variometer", |
"Balloon-Map-Variometer-Skala" => "Variometer", |
"Balloon-Fox" => "Target for Fox hunting", |
"Balloon-Heartbeat" => "MK data activity", |
"Balloon-Satellite" => "Good satellite reception", |
"Balloon-Waypoint" => "Waypoint", |
"Balloon-Map-Border" => "Airfield", |
"Balloon-Waypoint-Connector" => "Waypoint connector", |
"Balloon-Wp-PlayPause" => "Play/Pause (Space)", |
"Balloon-Wp-Stop" => "Stop Player(s)", |
"Balloon-Wp-First" => "Go to 1st Waypoint (f)", |
"Balloon-Wp-Last" => "Go to last Waypoint (l)", |
"Balloon-Wp-Next" => "Go to next Waypoint (n)", |
"Balloon-Wp-Prev" => "Go to previous Waypoint (p)", |
"Balloon-Wp-Home" => "Coming Home (h)", |
"Balloon-Wp-WptKml" => "Waypoint or KML Mode (w,k)", |
"Balloon-Wp-WptRandom" => "Random Mode (r)", |
"Balloon-Wp-Record" => "Record (a)", |
"Balloon-TrackAntenna" => "Tracking Antenna", |
"Balloon-Poi" => "Point Of Interest", |
"TargetCoordSent" => "Target coordinates sent", |
"WpMoved" => "Waypoint moved", |
"WpAddAndSend" => "Add and send Waypoint", |
"WpSavedAndSent" => "Waypoint saved and sent", |
"WpProperties" => "Waypoint preferneces", |
"WpResendAll" => "Resend all Wayoints", |
"WpAllSent" => "All Waypoints sent", |
"WpLoadAndSend" => "Load and send Waypoints", |
"WpLoad" => "Load Waypoints", |
"WpLoadedAndSent" => "Waypoints loaded and sent", |
"WpSave" => "Save Waypoints", |
"WpSaved" => "Waypoints saved", |
"WpDelete" => "Delete Waypoint", |
"WpDeleted" => "Waypoint deleted", |
"WpAllDeleteAndSend" => "Delete and send all Waypoints", |
"WpAllDeleted" => "All Waypoints deleted", |
"WpFlyImmediately" => "Fly immediately to Target", |
"Abort" => "Abort", |
"RestartRequired" => "*) Restart of Program required!", |
"KmlLoadAndPlay" => "Load KML file", |
"KmlLoad" => "KML load", |
"KmlLoaded" => "KML file loaded", |
"PoiMoved" => "POI moved", |
# MK System Messages |
"MsgNoSatReception" => "No SAT Reception", |
"MsgWeakSatReception" => "Weak SAT Reception", |
"MsgBatWarning" => "Battery Warning", |
"MsgNoData" => "No Data-Link", |
"MsgRangeLimit" => "Range Limit Warning", |
"MsgRcWarning" => "RC Warning", |
"MsgRcError" => "No RC Reception", |
"MsgMotorOff" => "Engine is OFF", |
"MsgNotFlying", => "MK on Ground", |
"MsgCalibrate", => "Calibration", |
"MsgStart" => "STart Engines ...", |
"MsgEmergencyLanding" => "Emergency Landing", |
"MsgOutsideBorder", => "MK outside Airfield", |
"MsgCrossingBorder", => "Mk crossing Airfield Border", |
# TTS |
"TtsBattery" => "Battery, %d dot %d Volt", |
"TtsFlightTimeMinSec" => "Flight Time, %d Minutes, %d Seconds", |
"TtsFlightTimeSec" => "Flight Time, %d Seconds", |
"TtsAltitude" => "Altitude, %d Meter", |
"TtsAltitudeNegative" => "Altitude, Minus %d Meter", |
"TtsSatellite" => "Satellite, %d", |
"TtsBatteryWarning" => "Batterie, Warning", |
"TtsRcWeak" => "weak, Remote Control Reception", |
"TtsRcNo" => "No, Remote Control Reception", |
"TtsCrossingBorder" => "Crossing, Airfield, Border", |
"TtsOutsideAirfield" => "Outside, Airfield", |
"TtsRange" => "Range Warning", |
"TtsNoDataLink" => "No Data Link", |
"TtsNextTarget" => "Fly to next Target", |
"TtsTargetReached" => "Target reached", |
"TtsFun" => "yes, this is fun!", |
); |
# automatic language selection according to LOCALE setting |
my $Lang = Win32::Locale::get_language(); |
if ( $Lang =~ /de/i ) |
{ |
%Translate = %Translate_DE; |
} |
else |
{ |
%Translate = %Translate_EN; |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/tts.pl |
---|
0,0 → 1,180 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# tts.pl - Text To Speech |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-08-08 0.0.1 rw created |
# |
############################################################################### |
$Version{'tts.pl'} = "0.0.1 - 2009-08-08"; |
# Packages |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Time::HiRes qw(usleep); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
# eSpeak software required, download from: http://espeak.sourceforge.net/ |
# Queues for Sending Mesages to TTS Thread |
$TtsSendQueueLow = Thread::Queue->new(); # for low prio messages |
$TtsSendQueueMedium = Thread::Queue->new(); # for medium prio messages |
$TtsSendQueueHigh = Thread::Queue->new(); # for high prio messages |
$TtsMute = 0; # Mute audio switch |
# Main loop, never ending |
sub TtsLoop() |
{ |
# say hello |
# Parameter |
local $Program = $Cfg->{'tts'}->{'Program'} || "C:/Program Files/eSpeak/command_line/espeak.exe"; |
local $Options = $Cfg->{'tts'}->{'Options'} || "-v de -a 200 -b"; |
local $Welcome = $Cfg->{'tts'}->{'Welcome'} || "Starte Mischn Kockpit"; |
if ( ! -f $Program ) |
{ |
print "TTS: Program \"$Program\" does not exist. Exit\n"; |
return; |
} |
# say hello |
&TtsCall ($Welcome); |
while ( 1 ) |
{ |
# process all High prio Messages |
while ( $TtsSendQueueHigh->pending() > 0 ) |
{ |
my $Text = $TtsSendQueueHigh->dequeue(1); |
&TtsCall($Text); |
} |
# process all Medium prio Messages |
while ( $TtsSendQueueMedium->pending() > 0 and |
$TtsSendQueueHigh->pending() == 0 ) |
{ |
my $Text = $TtsSendQueueMedium->dequeue(1); |
&TtsCall($Text); |
} |
# Check Low prio Messages one by one |
if ( $TtsSendQueueLow->pending() > 0 and |
$TtsSendQueueMedium->pending() == 0 and |
$TtsSendQueueHigh->pending() == 0 ) |
{ |
my $Text = $TtsSendQueueLow->dequeue(1); |
&TtsCall($Text); |
} |
usleep (100000); # 100ms |
} |
} |
# call TTS program |
sub TtsCall() |
{ |
my ($Text) = @_; |
my $Cmd = "\"$Program\" $Options \"$Text\""; |
system $Cmd; |
} |
# Add Text to TTS-Queue |
sub TtsSpeak () |
{ |
my ($Prio, $Text) = @_; |
if ( ! $TtsMute and $Cfg->{'tts'}->{'Active'} =~ /y/i ) |
{ |
if ( $Prio eq 'HIGH' ) |
{ |
$TtsSendQueueHigh->enqueue( $Text); |
} |
elsif ( $Prio eq 'MEDIUM' ) |
{ |
$TtsSendQueueMedium->enqueue( $Text); |
} |
else |
{ |
$TtsSendQueueLow->enqueue( $Text); |
} |
} |
} |
# Clear pending Messages |
sub TtsClear () |
{ |
my ($Prio) = @_; |
while ($Prio eq 'HIGH' and $TtsSendQueueHigh->pending() >0 ) |
{ |
$TtsSendQueueHigh->dequeue(); |
} |
while ($Prio eq 'MEDIUM' and $TtsSendQueueMedium->pending() >0 ) |
{ |
$TtsSendQueueMedium->dequeue(); |
} |
while ($Prio eq 'LOW' and $TtsSendQueueLow->pending() >0 ) |
{ |
$TtsSendQueueLow->dequeue(); |
} |
} |
# |
# Hauptprgramm |
# |
if ( $0 =~ /tts.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
&TtsLoop(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.7/waypoints/mk.xml |
---|
0,0 → 1,122 |
<Waypoints> |
<WP-0000 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.71" |
MapY="0.67" |
Pos_Alt="" |
Pos_Lat="49.6837414446281" |
Pos_Lon="10.9459311414637" |
Tag="Waypoint-1239375886.2" |
ToleranceRadius="3" /> |
<WP-0001 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.47" |
MapY="0.68" |
Pos_Alt="" |
Pos_Lat="49.684656513215" |
Pos_Lon="10.9465540413906" |
Tag="Waypoint-1239375890.7" |
ToleranceRadius="3" /> |
<WP-0002 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.43625" |
MapY="0.501666666666667" |
Pos_Alt="" |
Pos_Lat="49.6845423570467" |
Pos_Lon="10.9474221184355" |
Tag="Waypoint-1239375893.5" |
ToleranceRadius="3" /> |
<WP-0003 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.49375" |
MapY="0.558333333333333" |
Pos_Alt="" |
Pos_Lat="49.6844029200217" |
Pos_Lon="10.9470164120763" |
Tag="Waypoint-1239375896.1" |
ToleranceRadius="3" /> |
<WP-0004 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.53875" |
MapY="0.481666666666667" |
Pos_Alt="" |
Pos_Lat="49.6841302979111" |
Pos_Lon="10.9472243787302" |
Tag="Waypoint-1239375900.0" |
ToleranceRadius="3" /> |
<WP-0005 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.55875" |
MapY="0.663333333333333" |
Pos_Alt="" |
Pos_Lat="49.6843006077667" |
Pos_Lon="10.9463800092622" |
Tag="Waypoint-1239375903.7" |
ToleranceRadius="3" /> |
<WP-0006 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.59" |
MapY="0.648333333333333" |
Pos_Alt="" |
Pos_Lat="49.6841629520505" |
Pos_Lon="10.9463583820715" |
Tag="Waypoint-1239375909.8" |
ToleranceRadius="3" /> |
<WP-0007 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.57125" |
MapY="0.481666666666667" |
Pos_Alt="" |
Pos_Lat="49.6840082126091" |
Pos_Lon="10.9471341454465" |
Tag="Waypoint-1239375914.6" |
ToleranceRadius="3" /> |
<WP-0008 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.5875" |
MapY="0.561666666666667" |
Pos_Alt="" |
Pos_Lat="49.6840552537022" |
Pos_Lon="10.9467416509168" |
Tag="Waypoint-1239375916.8" |
ToleranceRadius="3" /> |
<WP-0009 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.63125" |
MapY="0.466666666666667" |
Pos_Alt="" |
Pos_Lat="49.6837625584122" |
Pos_Lon="10.9470326951553" |
Tag="Waypoint-1239375924.3" |
ToleranceRadius="3" /> |
<WP-0010 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.60125" |
MapY="0.561666666666667" |
Pos_Alt="" |
Pos_Lat="49.6840036020774" |
Pos_Lon="10.9467034758118" |
Tag="Waypoint-1239375927.4" |
ToleranceRadius="3" /> |
<WP-0011 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.65125" |
MapY="0.653333333333333" |
Pos_Alt="" |
Pos_Lat="49.6839396219786" |
Pos_Lon="10.9461666201847" |
Tag="Waypoint-1239375935.4" |
ToleranceRadius="3" /> |
</Waypoints> |