Subversion Repositories Projects

Compare Revisions

Ignore whitespace Rev 809 → Rev 810

/MissionCockpit/tags/V0.5.1/icon/WpNext.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
/MissionCockpit/tags/V0.5.1/icon/WpNext.gif
New file
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/waypoint_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/waypoint_48.gif
===================================================================
--- tags/V0.5.1/icon/waypoint_48.gif (revision 0)
+++ tags/V0.5.1/icon/waypoint_48.gif (revision 810)
/tags/V0.5.1/icon/waypoint_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/RandomWpt_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/RandomWpt_48.gif
===================================================================
--- tags/V0.5.1/icon/RandomWpt_48.gif (revision 0)
+++ tags/V0.5.1/icon/RandomWpt_48.gif (revision 810)
/tags/V0.5.1/icon/RandomWpt_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/RandomOff_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/RandomOff_48.gif
===================================================================
--- tags/V0.5.1/icon/RandomOff_48.gif (revision 0)
+++ tags/V0.5.1/icon/RandomOff_48.gif (revision 810)
/tags/V0.5.1/icon/RandomOff_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/RandomOn_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/RandomOn_48.gif
===================================================================
--- tags/V0.5.1/icon/RandomOn_48.gif (revision 0)
+++ tags/V0.5.1/icon/RandomOn_48.gif (revision 810)
/tags/V0.5.1/icon/RandomOn_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/Record_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/Record_48.gif
===================================================================
--- tags/V0.5.1/icon/Record_48.gif (revision 0)
+++ tags/V0.5.1/icon/Record_48.gif (revision 810)
/tags/V0.5.1/icon/Record_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/RandomMap_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/RandomMap_48.gif
===================================================================
--- tags/V0.5.1/icon/RandomMap_48.gif (revision 0)
+++ tags/V0.5.1/icon/RandomMap_48.gif (revision 810)
/tags/V0.5.1/icon/RandomMap_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/ModeWpt_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/ModeWpt_48.gif
===================================================================
--- tags/V0.5.1/icon/ModeWpt_48.gif (revision 0)
+++ tags/V0.5.1/icon/ModeWpt_48.gif (revision 810)
/tags/V0.5.1/icon/ModeWpt_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpStop.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpStop.gif
===================================================================
--- tags/V0.5.1/icon/WpStop.gif (revision 0)
+++ tags/V0.5.1/icon/WpStop.gif (revision 810)
/tags/V0.5.1/icon/WpStop.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpFirst.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpFirst.gif
===================================================================
--- tags/V0.5.1/icon/WpFirst.gif (revision 0)
+++ tags/V0.5.1/icon/WpFirst.gif (revision 810)
/tags/V0.5.1/icon/WpFirst.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/satellite_64.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/satellite_64.gif
===================================================================
--- tags/V0.5.1/icon/satellite_64.gif (revision 0)
+++ tags/V0.5.1/icon/satellite_64.gif (revision 810)
/tags/V0.5.1/icon/satellite_64.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/Antenna_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/Antenna_48.gif
===================================================================
--- tags/V0.5.1/icon/Antenna_48.gif (revision 0)
+++ tags/V0.5.1/icon/Antenna_48.gif (revision 810)
/tags/V0.5.1/icon/Antenna_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpHome.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpHome.gif
===================================================================
--- tags/V0.5.1/icon/WpHome.gif (revision 0)
+++ tags/V0.5.1/icon/WpHome.gif (revision 810)
/tags/V0.5.1/icon/WpHome.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/target_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/target_48.gif
===================================================================
--- tags/V0.5.1/icon/target_48.gif (revision 0)
+++ tags/V0.5.1/icon/target_48.gif (revision 810)
/tags/V0.5.1/icon/target_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/ModeKml_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/ModeKml_48.gif
===================================================================
--- tags/V0.5.1/icon/ModeKml_48.gif (revision 0)
+++ tags/V0.5.1/icon/ModeKml_48.gif (revision 810)
/tags/V0.5.1/icon/ModeKml_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/heart_32.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/heart_32.gif
===================================================================
--- tags/V0.5.1/icon/heart_32.gif (revision 0)
+++ tags/V0.5.1/icon/heart_32.gif (revision 810)
/tags/V0.5.1/icon/heart_32.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/webcam_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/webcam_48.gif
===================================================================
--- tags/V0.5.1/icon/webcam_48.gif (revision 0)
+++ tags/V0.5.1/icon/webcam_48.gif (revision 810)
/tags/V0.5.1/icon/webcam_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpLast.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpLast.gif
===================================================================
--- tags/V0.5.1/icon/WpLast.gif (revision 0)
+++ tags/V0.5.1/icon/WpLast.gif (revision 810)
/tags/V0.5.1/icon/WpLast.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpPlay.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpPlay.gif
===================================================================
--- tags/V0.5.1/icon/WpPlay.gif (revision 0)
+++ tags/V0.5.1/icon/WpPlay.gif (revision 810)
/tags/V0.5.1/icon/WpPlay.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/heart_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/heart_48.gif
===================================================================
--- tags/V0.5.1/icon/heart_48.gif (revision 0)
+++ tags/V0.5.1/icon/heart_48.gif (revision 810)
/tags/V0.5.1/icon/heart_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/waypoint_24x48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/waypoint_24x48.gif
===================================================================
--- tags/V0.5.1/icon/waypoint_24x48.gif (revision 0)
+++ tags/V0.5.1/icon/waypoint_24x48.gif (revision 810)
/tags/V0.5.1/icon/waypoint_24x48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpPrev.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpPrev.gif
===================================================================
--- tags/V0.5.1/icon/WpPrev.gif (revision 0)
+++ tags/V0.5.1/icon/WpPrev.gif (revision 810)
/tags/V0.5.1/icon/WpPrev.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/bear_48.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/bear_48.gif
===================================================================
--- tags/V0.5.1/icon/bear_48.gif (revision 0)
+++ tags/V0.5.1/icon/bear_48.gif (revision 810)
/tags/V0.5.1/icon/bear_48.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/icon/WpPause.gif
===================================================================
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Index: tags/V0.5.1/icon/WpPause.gif
===================================================================
--- tags/V0.5.1/icon/WpPause.gif (revision 0)
+++ tags/V0.5.1/icon/WpPause.gif (revision 810)
/tags/V0.5.1/icon/WpPause.gif
Property changes:
Added: svn:mime-type
## -0,0 +1 ##
+application/octet-stream
\ No newline at end of property
Index: tags/V0.5.1/libmouse.pl
===================================================================
--- tags/V0.5.1/libmouse.pl (revision 0)
+++ tags/V0.5.1/libmouse.pl (revision 810)
@@ -0,0 +1,133 @@
+#!/usr/bin/perl
+#!/usr/bin/perl -d:ptkdb
+
+###############################################################################
+#
+# libmouse.pl - 3D Mouse Space Navigator
+#
+# 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-12-09 0.0.1 rw created
+#
+###############################################################################
+
+$Version{'libmouse.pl'} = "0.0.1 - 2009-12-09";
+
+# 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
+
+# Hashes exported to other threads and main-program
+share (%Stick);
+
+my $StickRange = 1024; # global stick range
+my $Bias = $StickRange/2;
+my $ResMouse = 1000; # +-500
+my $MousePrg = "bin/3DMouse.exe";
+
+sub Mouse3D()
+ {
+ if ( ! -f $MousePrg )
+ {
+ return;
+ }
+
+ $Stick{'StickRange'} = $StickRange;
+ $Stick{'MouseRotX'} = $Bias;
+ $Stick{'MouseRotY'} = $Bias;
+ $Stick{'MouseRotZ'} = $Bias;
+ $Stick{'MouseTranX'} = $Bias;
+ $Stick{'MouseTranY'} = $Bias;
+ $Stick{'MouseTranZ'} = $Bias;
+ $Stick{'MouseButton'} = 0;
+ $Stick{'_MouseTimestamp'} = time;
+
+ $Stick{'_MousePid'} = open (my $fh, "$MousePrg |");
+
+ while (my $Line = <$fh> )
+ {
+ if ( $Line =~ /Device 0: DOF: T: (\S*)\s*(\S*)\s*(\S*) R: (\S*)\s*(\S*)\s*(\S*)/g )
+ {
+ $TranslateX= $1;
+ $TranslateY= $2;
+ $TranslateZ= $3;
+ $RotateX= $4;
+ $RotateY= $5;
+ $RotateZ= $6;
+
+ lock (%Stick); # until end of block
+
+ $Stick{'MouseRotX'} = $Bias - int ($RotateY / $ResMouse * $StickRange);
+ $Stick{'MouseRotY'} = $Bias - int ($RotateX / $ResMouse * $StickRange);
+ $Stick{'MouseRotZ'} = $Bias + int ($RotateZ / $ResMouse * $StickRange);
+ $Stick{'MouseTranX'} = $Bias + int ($TranslateX / $ResMouse * $StickRange);
+ $Stick{'MouseTranY'} = $Bias - int ($TranslateY / $ResMouse * $StickRange);
+ $Stick{'MouseTranZ'} = $Bias + int ($TranslateZ / $ResMouse * $StickRange);
+ $Stick{'_MouseTimestamp'} = time;
+ }
+ elsif ( $Line =~ /Device 0: Button mask: (\S*)/g )
+ {
+ $Button = $1;
+
+ lock (%Stick); # until end of block
+ $Stick{'MouseButton'} = sprintf ("%d", $Button);
+ $Stick{'_MouseTimestamp'} = time;
+ }
+ }
+ }
+
+
+# Kill Mouse3D Proceess
+sub Mouse3DStop()
+ {
+ my $MousePid = $Stick{'_MousePid'};
+ if ( $MousePid ne "" )
+ {
+ kill -9, $MousePid;
+ }
+ }
+
+
+# check, if button "Num" pressed, Num = 0 .. n
+sub MouseButton()
+ {
+ my ($Num) = @_;
+
+ return (($Stick{'MouseButton'} >> $Num) & 1) == 1;
+ }
+
+1;
+
+__END__
Index: tags/V0.5.1/geserver.pl
===================================================================
--- tags/V0.5.1/geserver.pl (revision 0)
+++ tags/V0.5.1/geserver.pl (revision 810)
@@ -0,0 +1,209 @@
+#!/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
+# 20091215 0.1.1 rw Move cfg to "logging"-section
+#
+###############################################################################
+
+$Version{'geserver.pl'} = "0.1.1 - 2009-12-15";
+
+#
+# Parameter
+#
+
+$port_listen = $Cfg->{'logging'}->{'HttpPort'} || 8080;
+
+
+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__
Index: tags/V0.5.1/waypoints/mk.xml
===================================================================
--- tags/V0.5.1/waypoints/mk.xml (revision 0)
+++ tags/V0.5.1/waypoints/mk.xml (revision 810)
@@ -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>
Index: tags/V0.5.1/mkcomm.pl
===================================================================
--- tags/V0.5.1/mkcomm.pl (revision 0)
+++ tags/V0.5.1/mkcomm.pl (revision 810)
@@ -0,0 +1,918 @@
+#!/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
+# 2009-10-24 0.3.0 rw NC 0.17b
+# 2010-02-10 0.4.0 rw Port read timout reduced from 100ms to 10ms
+# Serial Channel
+# Extern Control
+# Controls via joystick or 3D-Mouse
+# Navidata Current, Capacity
+# 2010-02-18 0.4.1 rw LCD Stick/Poti^
+# 2010-03-07 0.4.2 rw MKFLAG: LOWBAT
+# 2010-07-01 0.5.0 rw WP/POI adjustments for NC 0.19/0.20
+# Hardware Error Codes
+#
+###############################################################################
+
+$Version{'mkcomm.pl'} = "0.5.0 - 2010-07-01";
+
+# 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'} = "COM5";
+ }
+
+$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
+share (%MkSerialChannel);
+
+
+$Mk{'_RxCrcError'} = 0; # statistics
+
+# 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(10); # 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 )
+ {
+ $Mk{'_BytesRx'} ++; # Statistics
+
+ 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);
+
+# print "$Header\n";
+
+ # 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
+ }
+ }
+ else
+ {
+ $Mk{'_RxCrcError'} ++; # Statistics
+ }
+ }
+
+ 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";
+
+ $Mk{'_BytesTx'} += length $TxSend; # Statistics
+
+ $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 RC_RSSI; // Receiver signal strength (since version 2 added)
+ # s16 SetpointAltitude; // setpoint for altitude
+ # u8 Gas; // for future use
+ # u16 Current; // actual current in 0.1A steps
+ # u16 UsedCapacity; // used capacity in mAh
+
+
+ # 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
+ # 0x20: LOWBAT, 0x40: SPI_RX_ERR
+ # 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'},
+ $MkOsd{'RC_RSSI'},
+ $MkOsd{'SetPointAltitude'},
+ $MkOsd{'Gas'},
+ $MkOsd{'Current'},
+ $MkOsd{'UsedCapacity'},
+ ) = unpack ('ClllClllCsslllCssCCCssSCSssccCCCCCsCCsCSS', $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);
+ $MkOsd{'Current'} = sprintf("%.1f", $MkOsd{'Current'} / 10);
+
+ # Timestamp, wann der Datensatz geschtieben wurde
+ $MkOsd{'_Timestamp'} = time;
+ $MkOsd{'_FrameCount'} ++;
+ }
+
+ 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 wurde
+ $MkTarget{'_Timestamp'} = time;
+ $MkTarget{'_FrameCount'} ++;
+ }
+
+ 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 HardwareError[5]
+
+ (
+ $Mk{'SWMajor'},
+ $Mk{'SWMinor'},
+ $Mk{'ProtoMajor'},
+ $Mk{'ProtoMinor'},
+ $Mk{'SWPatch'},
+ $Mk{'HardwareError1'},
+ $Mk{'HardwareError2'},
+ $Mk{'HardwareError3'},
+ $Mk{'HardwareError4'},
+ $Mk{'HardwareError5'},
+ ) = unpack ('C10', $Data);
+
+ $Mk{'_Timestamp'} = time;
+ $Mk{'_FrameCount'} ++;
+ }
+
+ 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;
+ $MkNcDebug{'_FrameCount'} ++;
+ }
+
+ elsif ( $Id eq "B" )
+ {
+ #
+ # External Control
+ #
+ # Datenstruktur:
+ # u8 ConfirmFrame;
+
+ my ($ConfirmFrame) = unpack ('C5', $Data);
+
+ }
+ elsif ( $Id eq "L" )
+ {
+ #
+ # LCD Screen
+ #
+ # Datenstruktur:
+ # u8 Menuitem
+ # u8 MaxMenuItem
+ # char[80] Display Text
+
+ my ($MenuItem, $MaxMenuItem, $LcdLine) = unpack ('CCA80', $Data);
+ if ( $LcdLine =~ /Po1:\s*(\d+)\s*Po2:\s*(\d+)\s*Po3:\s*(\d+)\s*Po4:\s*(\d+)/i )
+ {
+ $Stick{'RcPoti1'} = $1;
+ $Stick{'RcPoti2'} = $2;
+ $Stick{'RcPoti3'} = $3;
+ $Stick{'RcPoti4'} = $4;
+ }
+ elsif ( $LcdLine =~ /Po5:\s*(\d+)\s*Po6:\s*(\d+)\s*Po7:\s*(\d+)\s*Po8:\s*(\d+)/i )
+ {
+ $Stick{'RcPoti5'} = $1;
+ $Stick{'RcPoti6'} = $2;
+ $Stick{'RcPoti7'} = $3;
+ $Stick{'RcPoti8'} = $4;
+ }
+ elsif ( $LcdLine =~ /Ni:\s*(-*\d+)\s*Ro:\s*(-*\d+)\s*Gs:\s*(-*\d+)\s*Ya:\s*(-*\d+)/i )
+ {
+ $Stick{'RcStickNick'} = $1;
+ $Stick{'RcStickRoll'} = $2;
+ $Stick{'RcStickGas'} = $3;
+ $Stick{'RcStickGier'} = $4;
+ }
+ $Stick{'_RcTimestamp'} = time;
+ $Stick{'_RcFrameCount'} ++;
+ }
+ 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'}; # 0..360: Heading, <0: POI-Index, >360: Invalid
+ my $ToleranceRadius = $Param{'-toleranceradius'};
+ my $Holdtime = $Param{'-holdtime'};
+ my $EventFlag = $Param{'-eventflag'};
+ my $Mode = $Param{'-mode'};
+ my $Index = $Param{'-index'}; # 1..n (dummy ... will be overwritten in NC:uart1.c)
+ my $Type = $Param{'-type'}; # 0=WP, 1=POI
+
+ 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
+ $Index = -1; # required from NC0.19 onward
+ }
+
+ 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 Index; // to indentify different waypoints, workaround for bad communications PC <-> NC
+ # u8 Type; // typeof Waypoint (0=WP, 1=POI)
+ # u8 reserve[10]; // reserved
+
+ my $Wp = pack ('lllCsC15',
+ $Lon_i,
+ $Lat_i,
+ $Alt_i,
+ $Status,
+ $Heading,
+ $ToleranceRadius,
+ $Holdtime,
+ $EventFlag,
+ $Index + 1,
+ $Type,
+ 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( "s", "$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 SendExternalControl()
+ {
+ my %Param = @_;
+
+ my $RemoteButtons = $Param{'-remotebuttons'};
+ my $Nick = $Param{'-nick'};
+ my $Roll = $Param{'-roll'};
+ my $Gier = $Param{'-gier'};
+ 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;
+
+ # Config/Bit 0 and FC-Parameter ExternControl > 128:
+ # Nich/Roll/Yaw added to RC-Channel
+ # Gas wird auf max. RC-Gas begrenzt
+
+ my $Ec = pack ('CCCcccCcCCC',
+ 0, 0,
+ $RemoteButtons,
+ $Nick,
+ $Roll,
+ $Gier,
+ $Gas,
+ $Hight,
+ $Free,
+ $Frame, # Frame/Command counter, ungleich 0
+ $Config,
+ );
+
+ $MkSendQueue->enqueue( "b", "$AddrFC", $Ec );
+ # &MkSend( "b", "$AddrFC", $Ec );
+
+ return 0;
+ }
+
+
+# send serial Channel values from %MkSerialChannel to MK/FC
+sub SendSerialChannel()
+ {
+
+ # Datenstruktur:
+ # s8 Channel[12];
+
+ lock (%MkSerialChannel); # until end of block
+
+ my $SP = pack ('c12',
+ $MkSerialChannel{'SerialChannel01'},
+ $MkSerialChannel{'SerialChannel02'},
+ $MkSerialChannel{'SerialChannel03'},
+ $MkSerialChannel{'SerialChannel04'},
+ $MkSerialChannel{'SerialChannel05'},
+ $MkSerialChannel{'SerialChannel06'},
+ $MkSerialChannel{'SerialChannel07'},
+ $MkSerialChannel{'SerialChannel08'},
+ $MkSerialChannel{'SerialChannel09'},
+ $MkSerialChannel{'SerialChannel10'},
+ $MkSerialChannel{'SerialChannel11'},
+ $MkSerialChannel{'SerialChannel12'},
+ );
+
+ $MkSendQueue->enqueue( "y", "$AddrFC", $SP );
+ # &MkSend( "y", "$AddrFC", $SP );
+
+ 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__
+
Index: tags/V0.5.1/libmapdef.pl
===================================================================
--- tags/V0.5.1/libmapdef.pl (revision 0)
+++ tags/V0.5.1/libmapdef.pl (revision 810)
@@ -0,0 +1,469 @@
+###############################################################################
+#
+# libmapdef.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)
+# 2009-11-08 0.1.5 rw Avoid div/0, if P1=P2
+# 2010-05-16 0.1.6 rw Check empty Border in XML
+# 2010-09-09 0.1.7 rw Load JPEG/PNG containig Geo-Information
+# rename map/map.pl --> libmapdef.pl
+#
+###############################################################################
+
+$Version{'libmapdef.pl'} = "0.1.7 - 2010-09-09";
+
+use XML::Simple; # http://search.cpan.org/dist/XML-Simple-2.18/lib/XML/Simple.pm
+use Image::ExifTool qw(:Public); # http://search.cpan.org/~exiftool/Image-ExifTool-8.25/lib/Image/ExifTool.pod
+
+
+# Load maps from filesystem (XML, KML, JPEG/PNG)
+sub MapDefLoad()
+ {
+
+ %Maps =
+ (
+ Default => {
+ 'Name' => "Default",
+ 'File' => 'default-800.gif',
+ # 'Size_X' => '800',
+ # 'Size_Y => '600',
+
+ '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;
+ if ( $Value ne "" )
+ {
+ 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
+ }
+
+ if ( $Maps{$Name}->{'P1_x'} == $Maps{$Name}->{'P2_x'} and
+ $Maps{$Name}->{'P1_y'} == $Maps{$Name}->{'P2_y'} )
+ {
+ # Avoid div/0 if P1=P2
+ $Maps{$Name}->{'P1_x'} += 1;
+ }
+ }
+ }
+ }
+
+ #
+ # load additional Maps from JPEG/PNG containing Geo-Information
+ #
+ my $MapDir = $Cfg->{'map'}->{'MapDir'} || "map";
+ if ( -d $MapDir )
+ {
+ opendir DIR, $MapDir;
+ my @Files = readdir DIR;
+ closedir DIR;
+
+ my @ImgFiles;
+ push @ImgFiles, grep /\.jpg$/, @Files;
+ push @ImgFiles, grep /\.png$/, @Files;
+
+ foreach $Image (@ImgFiles)
+ {
+ my $ImgFile = "$MapDir/$Image";
+ if ( -f $ImgFile )
+ {
+ # take only image files which are not already used in %Maps
+ $bUsed = "";
+ foreach $Map (keys %Maps)
+ {
+ if ( $Maps{$Map}->{'File'} =~ /^${Image}$/i )
+ {
+ $bUsed = "X";
+ last;
+ }
+ }
+
+ if ( $bUsed ne "X" )
+ {
+ # take image
+ my ($Width, $Height, $ImgInfo) = &GetImageInfo($ImgFile);
+ my $Comment = $$ImgInfo{'Comment'};
+ my $Name = substr ($Image, 0, -4); # remove extension
+
+ # Image from Kopter-Tool
+ my @Fields = split ",", $Comment;
+ if ( $Fields[0] =~ /Geo-Information/i )
+ {
+ my ($RoLat, $RoLon) = split ":", $Fields[1];
+ my ($LoLat, $LoLon) = split ":", $Fields[2];
+ my ($RuLat, $RuLon) = split ":", $Fields[3];
+ my ($LuLat, $LuLon) = split ":", $Fields[4];
+
+ $Maps{$Name}->{'Name'} = $Name;
+ $Maps{$Name}->{'File'} = $Image;
+ $Maps{$Name}->{'P1_x'} = 0;
+ $Maps{$Name}->{'P1_y'} = 0;
+ $Maps{$Name}->{'P2_x'} = $Width;
+ $Maps{$Name}->{'P2_y'} = $Height;
+ $Maps{$Name}->{'P1_Lat'} = $LoLat;
+ $Maps{$Name}->{'P1_Lon'} = $LoLon;
+ $Maps{$Name}->{'P2_Lat'} = $RuLat;
+ $Maps{$Name}->{'P2_Lon'} = $RuLon;
+ }
+
+ # GeoMapTool Image for Mission Cockpit
+ my @Fields = split ";", $Comment;
+ foreach $Param (@Fields)
+ {
+ my ($Key, $Value) = split ":", $Param;
+ if ( $Key eq "P" )
+ {
+ my ($P1_x, $P1_y, $P2_x, $P2_y, $P1_Lat, $P1_Lon, $P2_Lat, $P2_Lon) = split ",", $Value;
+ $Maps{$Name}->{'P1_x'} = $P1_x;
+ $Maps{$Name}->{'P1_y'} = $P1_y;
+ $Maps{$Name}->{'P2_x'} = $P2_x;
+ $Maps{$Name}->{'P2_y'} = $P2_y;
+ $Maps{$Name}->{'P1_Lat'} = $P1_Lat;
+ $Maps{$Name}->{'P1_Lon'} = $P1_Lon;
+ $Maps{$Name}->{'P2_Lat'} = $P2_Lat;
+ $Maps{$Name}->{'P2_Lon'} = $P2_Lon;
+
+ $Maps{$Name}->{'File'} = $Image;
+ $Maps{$Name}->{'Name'} = $Name;
+ }
+ if ( $Key eq "Home" )
+ {
+ my ($Home_Lat, $Home_Lon) = split ",", $Value;
+ $Maps{$Name}->{'Home_Lat'} = $Home_Lat;
+ $Maps{$Name}->{'Home_Lon'} = $Home_Lon;
+ }
+ if ( $Key eq "Poi" )
+ {
+ my ($Poi_Lat, $Poi_Lon) = split ",", $Value;
+ $Maps{$Name}->{'Poi_Lat'} = $Poi_Lat;
+ $Maps{$Name}->{'Poi_Lon'} = $Poi_Lon;
+ }
+ if ( $Key eq "Border" )
+ {
+ my @Border = split ',', $Value;
+ @{$Maps{$Name}->{'Border'}} = @Border;
+ }
+ }
+ }
+ }
+ }
+ }
+
+ # Die verwendete Karte
+ &MapSetCurrentFromCfg();
+ }
+
+
+# Set $Maps{'Current'} from Cfg-Setting
+sub MapSetCurrentFromCfg()
+ {
+
+ # Todo: Karte automatisch anhand der aktuellen GPS Position auswählen
+
+ 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";
+ }
+
+ # optional map specific Cfg setup from map definition
+ # Aktuell gültige Karte
+ my %Map = %{$Maps{'Current'}};
+
+ foreach $Key (keys %Map)
+ {
+ # Cfg:Section:Keyword
+ if ( $Key =~ /^Cfg:(\S*):(\S*)/i )
+ {
+ $Section = $1;
+ $Keyword = $2;
+ $Cfg->{$Section}->{$Keyword} = $Map{$Key};
+ }
+ }
+
+ # Get size of image
+ my $ImgFile = "$Cfg->{'map'}->{'MapDir'}/$Map{'File'}";
+ my ($Width, $Height) = &GetImageInfo($ImgFile);
+ if ( $Maps{'Current'}->{'Size_X'} eq "" )
+ {
+ $Maps{'Current'}->{'Size_X'} = $Width;
+ }
+ if ( $Maps{'Current'}->{'Size_Y'} eq "" )
+ {
+ $Maps{'Current'}->{'Size_Y'} = $Height;
+ }
+
+ # Option list from map config dialog
+ @{ $CfgOpt{MapDefault} } = sort keys %Maps
+ }
+
+
+# Get size and EXIF data of Image
+sub GetImageInfo()
+ {
+ my ($File) = @_;
+
+ my $ExifTool = new Image::ExifTool;
+ my $ImgInfo = $ExifTool->ImageInfo($File);
+
+ my $Width;
+ my $Height;
+
+ my $ImageSize = $$ImgInfo{'ImageSize'};
+ ($Width, $Height) = split "x", $ImageSize;
+
+ if ( $Width eq "" )
+ {
+ $Width = $$ImgInfo{'ImageWidth'};
+ }
+ if ( $Height eq "" )
+ {
+ $Height = $$ImgInfo{'ImageHeight'};
+ }
+
+ if ( $Width eq "" )
+ {
+ $Width = $$ImgInfo{'ExifImageWidth'};
+ }
+ if ( $Height eq "" )
+ {
+ $Height = $$ImgInfo{'ExifImageHeight'};
+ }
+
+ return ($Width, $Height, $ImgInfo);
+ }
+
+
+1;
+
+__END__
Index: tags/V0.5.1/plugin/example.pl.off
===================================================================
--- tags/V0.5.1/plugin/example.pl.off (revision 0)
+++ tags/V0.5.1/plugin/example.pl.off (revision 810)
@@ -0,0 +1,25 @@
+
+###############################################################################
+#
+# example.pl - Example Plugin for Mission Cockpit event engine
+#
+###############################################################################
+#
+# 2010-01-30 0.0.1 rw created
+#
+###############################################################################
+
+$Version{'plugin/example.pl'} = "0.0.1 - 2010-01-30";
+
+
+# say hello
+print "Load Plugin: example.pl\n";
+
+#
+# function library for event engine
+#
+
+sub MyExample()
+ {
+ print "Plugin: Example\n";
+ }
\ No newline at end of file
Index: tags/V0.5.1/mkcockpit.pl
===================================================================
--- tags/V0.5.1/mkcockpit.pl (revision 0)
+++ tags/V0.5.1/mkcockpit.pl (revision 810)
@@ -0,0 +1,1857 @@
+#!/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
+# 2009-10-25 0.3.0 rw NC 0.17
+# Read/Write KopterTool WPL Waypoint list
+# Cfg Optionmenues
+# 2010-02-09 0.4.0 rw Canvas - Popup focus improvement
+# bugfix "WP hinzufügen und senden" in classic mode
+# Grid on canvas
+# joystick and 3D-Mouse
+# remove main window status line
+# Event engine
+# Serial Channel
+# External Control
+# Expo, Dualrate
+# Player Pause move relative to MAP or MK
+# Load plugin directory
+# Current, UsedCapacity, Power added
+# RETURN turns off External-Control + Serial Channel
+# 2010-02-15 0.4.1 rw F-Keys for Event
+# 2010-03-20 0.4.2 rw Maestro Servo Controller
+# 2010-07-01 0.5.0 rw WP/POI adjustments for NC 0.19/0.20
+# TTS system messages closer to current situation
+# NC Hardware Error Codes
+# 2010-09-09 0.5.1 rw Use exifTool
+# rename map/map.pl --> libmapdef.pl
+# Tracker start at motor start
+# Start web browser (GeoMapTool)
+# Change Map without program restart
+# Support JPEG from geomaptool.de
+#
+###############################################################################
+
+$Version = "0.5.1 - 2010-09-09";
+
+# 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 Tk::Tree;
+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 Tk::BrowseEntry; # http://search.cpan.org/~srezic/Tk-804.028/pod/BrowseEntry.pod
+
+# 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 "libmapdef.pl"; # Map definition
+
+&MapDefLoad(); # Load the Maps in hash %Maps
+
+require "libmap.pl"; # map subs
+require "translate.pl"; # Übersetzungstable
+require "tts.pl"; # Text to Speech
+require "libmkcockpit.pl"; # Subroutines
+require "libmksim.pl"; # MK Simulator
+require "libcfgopt.pl"; # Option menu values
+require "libmouse.pl"; # 3D Mouse
+require "libjoystick.pl"; # joystick
+
+# Commandline parameter
+my %CmdLine = @ARGV;
+
+# Aktuell gültige Karte
+my %Map = %{$Maps{'Current'}};
+
+# Canvas size - get image size
+$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();
+ }
+
+# 3D Mouse Thread
+$mouse_thr = threads->create (\&Mouse3D) -> detach();
+
+# Joystick Thread
+$joystick_thr = threads->create (\&Joystick) -> 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
+$PlayerPauseMode = "MAP"; # MAP, MK
+$WpPlayerIndex = 0;
+$WpPlayerHoldtime = -1;
+$KmlPlayerIndex = 0;
+$PlayerPause_Lat = "";
+$PlayerPause_Lon = "";
+
+# Point Of Interest (POI)
+my $Poi_x = $MapSizeX/2-50;
+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
+$TxExtOn = 0; # Tx External-Control/SerialChannel off
+
+# Event configuration
+my $XmlEventConfigFile = $Cfg->{'StartScenario'}->{'EventFile'} || "event/mkevent.xml";
+if ( ! -f $XmlEventConfigFile )
+ {
+ $XmlEventConfigFile = "event/" . $XmlEventConfigFile;
+ }
+if ( -f $XmlEventConfigFile )
+ {
+ $Event = XMLin($XmlEventConfigFile);
+ }
+
+if ( scalar keys %{$Event} == 0 )
+ {
+ # create new dummy event, if no XML or XML is empty
+ &EventInit("Dummy", $Event);
+ }
+
+my %EventStat; # internal state of event maschine
+
+
+# load user plugins
+opendir DIR, "plugin";
+my @Plugin = readdir DIR;
+closedir DIR;
+@Plugin = grep /\.pl$/, @Plugin;
+foreach my $File (@Plugin)
+ {
+ require "plugin/$File";
+ }
+
+
+# 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]);
+ }
+
+# Catch delete window event and exit
+$main->protocol( 'WM_DELETE_WINDOW' => sub
+ {
+ &CbExit();
+ });
+
+# disable main window Key-Bindings for F10
+$main->bind('all', '<Key-F10>', undef);
+
+#-----------------------------------------------------------------
+# 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' => sub
+ {
+ # Reload Map directory
+ &MapDefLoad();
+ &Configure ($XmlConfigFile, $Cfg, "CONFIG");
+ },
+ );
+ $menu_file->command('-label' => $Translate{'ConfigEvent'},
+ '-command' => [\&Configure, $XmlEventConfigFile, $Event, "EVENT", ],
+ );
+ $menu_file->separator;
+ $menu_file->command('-label' => $Translate{'GeoMapTool'},
+ '-command' => [\&StartBrowser, "http://www.geomaptool.de", ],
+ );
+ $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->command('-label' => $Translate{'TrackingDebugDataset'},
+ '-command' => [\&DisplayHash, \%MkTrack, $Translate{'TrackingDebugDataset'}, "Display Refresh Heartbeat"],
+ );
+
+ $menu_debug->command('-label' => $Translate{'MapDebugDataset'},
+ '-command' => [\&DisplayHash, \%Map, $Translate{'MapDebugDataset'}, "Display"],
+ );
+ $menu_debug->command('-label' => $Translate{'SystemDebug'},
+ '-command' => [\&DisplayHash, \%System, $Translate{'SystemDebug'}, "Display Refresh"],
+ );
+ $menu_debug->separator;
+ $menu_debug->command('-label' => $Translate{'StickDebug'},
+ '-command' => [\&DisplayHash, \%Stick, $Translate{'StickDebug'}, "Display Refresh"],
+ );
+ $menu_debug->command('-label' => $Translate{'SerialChannel'},
+ '-command' => [\&DisplayHash, \%MkSerialChannel, $Translate{'SerialChannel'}, "Display Refresh SerialChannel"],
+ );
+ $menu_debug->command('-label' => $Translate{'ExternControl'},
+ '-command' => [\&DisplayHash, \%MkExternControl, $Translate{'ExternControl'}, "Display Refresh ExternControl"],
+ );
+ $menu_debug->separator;
+ $menu_debug->command('-label' => $Translate{'MkDebugSim'},
+ '-command' => \&MkSim,
+ );
+
+
+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) 2010 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;
+ });
+
+
+#-----------------------------------------------------------------
+# 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( -background => 'lightgray',
+ ) -> pack( -side => 'top',
+ -anchor => 'w',
+ -fill => 'x',
+ -expand => 1,
+ );
+
+$map_top_label = $frame_map_top->Label (-text => "$Translate{'Map'}: $Map{'Name'} ($Map{'File'})",
+ -background => 'lightgray',
+ -relief => 'flat',
+ ) -> pack( -side => 'left' );
+
+
+# 10 placeholders for status texts in upper status line. Field update in libmktimer
+for ($i=0; $i<10; $i++)
+ {
+ $map_status_top[$i] = $frame_map_top->Label ( -text => "",
+ -background => 'lightgray',
+ -anchor => 'e',
+ ) -> pack (-side => 'right',
+ -anchor => 'e',
+ -padx => 1,
+ );
+ }
+
+# Map Statuszeile
+$map_status = $frame_map->Frame( -background => 'lightgray',
+ ) -> pack( -side => 'bottom',
+ -anchor => 'w',
+ -fill => 'x',
+ -expand => 1,
+ );
+$map_status_line = $map_status->Label ( -text => $Translate{'StatusLine'},
+ -background => 'lightgray',
+ ) -> pack (-side => 'left',
+ -anchor => 'w',
+ -expand => 1,
+ );
+
+# 10 placeholders for event status in lower status line. Field update in libmktimer
+for ($i=0; $i<10; $i++)
+ {
+ $map_status_event[$i] = $map_status->Label ( -text => "",
+ -background => 'lightgray',
+ -anchor => 'e',
+ ) -> pack (-side => 'right',
+ -anchor => 'e',
+ -padx => 1,
+ );
+ }
+
+#
+# Map Canvas
+#
+&CanvasCreate();
+
+
+# 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->{'_MapX_Rel'} = $x / $MapSizeX;
+ $Wp->{'_MapY_Rel'} = $y / $MapSizeY;
+ $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
+ my ($Lat, $Lon) = &MapXY2Gps($MapCanvasX, $MapCanvasY);
+ &MkFlyTo ( -lat => $Lat,
+ -lon => $Lon,
+ -mode => "Waypoint",
+ -index => scalar @Waypoints,
+ );
+
+ # Add Wp to Waypoints list
+ &WpAdd (-lat => $Lat,
+ -lon => $Lon,
+ -x => $MapCanvasX,
+ -y => $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' =>
+ [['Mission Cockpit', '.xml' ],
+ ['Mikrokopter Tool', '.wpl' ],
+ ['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' =>
+ [['Mission Cockpit', '.xml' ],
+ ['Mikrokopter Tool', '.wpl' ],
+ ['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
+ {
+ &WpDeleteAll();
+ &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" );
+ }
+
+ }],
+ ]
+ );
+$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
+my $bBindFocus = 0;
+$main->bind('<Any-Enter>' => sub
+ {
+ if ($bBindFocus == 0)
+ {
+ # focus only once. Verhindern vom canvas-popup, wenn Config-Dialog aktiv ist.
+ # funktioniert so, habe aber keine Ahnung warum
+ $map_canvas->Tk::focus;
+ $bBindFocus = 1;
+ }
+ });
+
+
+# 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-g>' , \&CbGrid );
+$map_canvas->Tk::bind( '<Key-x>' , \&CbPlayerPauseMode );
+$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 );
+$map_canvas->Tk::bind( '<Key-Return>', \&CbTxOnOff );
+
+# Fct-Keys F1 .. F12
+for ($i=1; $i <= 12; $i++)
+ {
+ $map_canvas->Tk::bind( "<KeyPress-F$i>", [\&CbFctKeyPress, "$i"] );
+ $map_canvas->Tk::bind( "<KeyRelease-F$i>", [\&CbFctKeyRelease, "$i"] );
+ }
+$Stick{'FctKey'} = 0;
+
+
+#
+# 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(); }
+
+# PLayer Pause Mode
+my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerPauseMode'};
+if ( $CfgVal eq "MAP" ) { &PlayerPauseMode("MAP"); }
+if ( $CfgVal eq "MK" ) { &PlayerPauseMode("MK"); }
+
+# Audio TTS Mute
+my $CfgVal = $Cfg->{'StartScenario'}->{'AudioMute'};
+if ( $CfgVal =~ /y/i )
+ {
+ $TtsMute = 1;
+ }
+
+# External-Contorl/Serial Channel Tx On/Off
+my $CfgVal = $Cfg->{'StartScenario'}->{'TxExtOn'};
+if ( $CfgVal =~ /y/i )
+ {
+ $TxExtOn = 1;
+ }
+
+#
+# Timer
+#
+require "libmktimer.pl";
+
+MainLoop(); # should never end
+
+
+#
+# Canvas handling
+#
+
+# Create map canvas
+sub CanvasCreate()
+ {
+ if ( defined $map_canvas )
+ {
+ # update size
+ $map_canvas->configure ('-width' => $MapSizeX,
+ '-height' => $MapSizeY,
+ );
+ }
+ else
+ {
+ # create new
+ $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, 10,
+ 'HeartbeatLarge', 'Heartbeat', "$Cfg->{'mkcockpit'}->{'IconHeartLarge'}", $MapSizeX/4-10, -100,
+ 'Satellite-Photo', 'Satellite', "$Cfg->{'mkcockpit'}->{'IconSatellite'}", $MapSizeX-50, -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->delete($Tag);
+ $map_canvas->createImage( $Pos_x, $Pos_y,
+ -tags => $Tag,
+ -anchor => 'nw',
+ -image => $Image,
+ );
+ }
+
+
+ # Calibration Points
+ $map_canvas->delete('Calibration');
+ $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,
+ );
+
+ # display scale on canvas
+ 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->delete('Scale');
+ $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->delete('Scale-Text');
+ $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->delete('Map-Border');
+ $map_canvas->createPolygon( @Map{'Border'},
+ '-tags' => 'Map-Border',
+ '-fill' => '',
+ '-outline' => $Cfg->{'mkcockpit'}->{'ColorAirfield'}, '-width' => 2,
+ );
+ $map_canvas->raise('Map-Border', 'Map'); # Border above Map
+
+
+ #
+ # dynamic objecs on canvas
+ #
+
+ # current MK position on canvas
+ $MkPos_x = $MapSizeX/2;
+ $MkPos_y = $MapSizeY/2;
+
+ # Line from MK to Home
+ $map_canvas->delete('MK-Home-Line');
+ $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->delete('MK-Home-Dist');
+ $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->delete('MK-Target-Line');
+ $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->delete('MK-Target-Dist');
+ $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->delete('MK-POI-Line');
+ $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->delete('MK-Speed');
+ $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->delete('MK-Arrow');
+ $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 + 30, 20, '-*-Arial-Bold-R-Normal--*-150-*',
+ 'MK-OSD-Tim-Value', "00:00", $MapSizeX/2 + 80, 20, '-*-Arial-Bold-R-Normal--*-270-*',
+ 'MK-OSD-Bat-Label', "BAT", $MapSizeX/2 + 30, 50, '-*-Arial-Bold-R-Normal--*-150-*',
+ 'MK-OSD-Bat-Value', "0.0 V", $MapSizeX/2 + 80, 50, '-*-Arial-Bold-R-Normal--*-270-*',
+ 'MK-OSD-Cap-Label', "CAP", $MapSizeX/2 - 150, 20, '-*-Arial-Bold-R-Normal--*-150-*',
+ 'MK-OSD-Cap-Value', "0.00 Ah", $MapSizeX/2 - 100, 20, '-*-Arial-Bold-R-Normal--*-270-*',
+ 'MK-OSD-Cur-Label', "CUR", $MapSizeX/2 - 150, 50, '-*-Arial-Bold-R-Normal--*-150-*',
+ 'MK-OSD-Cur-Value', "0.0 A", $MapSizeX/2 - 100, 50, '-*-Arial-Bold-R-Normal--*-270-*',
+ 'MK-OSD-Pow-Label', "POW", $MapSizeX/2 - 150, 80, '-*-Arial-Bold-R-Normal--*-150-*',
+ 'MK-OSD-Pow-Value', "0.0 W", $MapSizeX/2 - 100, 80, '-*-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->delete($Tag);
+ $map_canvas->createText ( $Pos_x, $Pos_y,
+ '-tags' => $Tag,
+ '-text' => $Text,
+ '-font' => $Font,
+ '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+ '-anchor' => 'w',
+ );
+ }
+
+
+ # Variometer on canvas
+ $map_canvas->delete('Map-Variometer-Skala');
+
+ 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->delete('Map-Variometer');
+ $map_canvas->createLine(@Polygon,
+ '-tags' => 'Map-Variometer',
+ '-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'},
+ '-width' => 2,
+ '-arrow' => 'none',
+ );
+ # Vario Pointer
+ $map_canvas->delete('Map-Variometer-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,
+ );
+
+ # Crosshair
+ $map_canvas->delete('Map-Crosshair');
+ $map_canvas->createLine ( 0, $MapSizeY/2, $MapSizeX, $MapSizeY/2,
+ '-tags' => ['Map-Crosshair', 'Map-Crosshair-X'],
+ '-arrow' => 'none',
+ '-fill' => $Cfg->{'map'}->{'CrosshairColor'},
+ '-width' => 1,
+ );
+ $map_canvas->createLine ( $MapSizeX/2, 0, $MapSizeX/2, $MapSizeY,
+ '-tags' => ['Map-Crosshair', 'Map-Crosshair-Y'],
+ '-arrow' => 'none',
+ '-fill' => $Cfg->{'map'}->{'CrosshairColor'},
+ '-width' => 1,
+ );
+ $map_canvas->lower('Map-Crosshair', 'Map'); # hide below map
+
+
+ # Tracking Canvas
+
+ if ( $Cfg->{'track'}->{'Active'} =~ /y/i )
+ {
+ # Canvas size
+ $TrackSizeX = 125;
+ $TrackSizeY = 100;
+ $TrackOffY = $TrackSizeY - $MapSizeY + $TrackSizeY/2;
+ $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;
+ $map_canvas->delete('Map-Tracker');
+ $track_canvas->createArc ( $x0, $y0, $x1, $y1,
+ '-tags' => 'Map-Tracker',
+ '-extent' => '359',
+ '-start' => '0',
+ '-style' => 'chord',
+ '-outline' => 'gray', '-width' => '1',
+ );
+
+ # Skala Ziffernblatt
+ for ($i=0; $i<360; $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,
+ '-tags' => 'Map-Tracker',
+ '-fill' => 'white',
+ '-width' => 1,
+ );
+ }
+
+ # Skala Beschriftung Ziffernblatt
+ for ($i=-180; $i<180; $i+=45)
+ {
+ my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 12) * cos( deg2rad $i+90 );
+ my $y0 = $TrackSizeY - ($TrackPtrLen - 12) * sin( deg2rad $i+90 ) - $TrackOffY;
+ $track_canvas->createText ( $x0, $y0,
+ '-tags' => 'Map-Tracker',
+ '-text' => $i,
+ '-fill' => 'white',
+ );
+ }
+
+ # Zeiger Pan
+ my $x0 = $TrackSizeX/2;
+ my $y0 = $TrackSizeY - 0 - $TrackOffY;
+ my $x1 = $TrackSizeX/2;
+ my $y1 = $TrackSizeY - ($TrackPtrLen - 22) - $TrackOffY;
+ $track_canvas->createLine ( $x0, $y0, $x1, $y1,
+ '-tags' => [ 'Map-Tracker', 'Track-Ptr-Pan' ],
+ '-arrow' => 'last',
+ '-arrowshape' => [20, 30, 5 ],
+ '-fill' => 'red',
+ '-width' => 8,
+ );
+ # Zeiger Tilt
+ my $x0 = $TrackSizeX/2;
+ my $y0 = $TrackSizeY - 0 - $TrackOffY;
+ my $x1 = $TrackSizeX/2;
+ my $y1 = $TrackSizeY - ($TrackPtrLen - 22) - $TrackOffY;
+ $track_canvas->createLine ( $x0, $y0, $x1, $y1,
+ '-tags' => [ 'Map-Tracker', 'Track-Ptr-Tilt' ],
+ '-fill' => 'white',
+ '-width' => 1,
+ );
+
+ # 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,
+ '-tags' => 'Map-Tracker',
+ '-extent' => '359',
+ '-outline' => 'gray', '-width' => 1,
+ '-fill' => 'gray',
+ );
+ }
+
+
+ $map_status_line->configure ('-text' => "" );
+ $map_top_label->configure (-text => "$Translate{'Map'}: $Map{'Name'} ($Map{'File'})", );
+ }
+
+
+# Redraw map canvas after Map change
+sub CanvasRedraw()
+ {
+ # Aktuell gültige Karte
+ &MapSetCurrentFromCfg();
+
+ # global map variables used everywhere
+ %Map = %{$Maps{'Current'}};
+ $MapSizeX = $Map{'Size_X'};
+ $MapSizeY = $Map{'Size_Y'};
+
+ # Draw new Canvas
+ &CanvasCreate();
+
+ # Re-calculate WP Lat/Lon from X/Y for map
+ &WpRecalc();
+
+ # PLayer Mode
+ if ( $PlayerMode =~ /Play/i ) { &PlayerPlay(); }
+ if ( $PlayerMode =~ /Pause/i ) { &PlayerPause(); }
+ if ( $PlayerMode =~ /Home/i ) { &PlayerHome(); }
+ if ( $PlayerMode =~ /Stop/i ) { &PlayerStop(); }
+
+ # Player Random Mode
+ if ( $PlayerRandomMode eq "STD" ) { &PlayerRandomStd(); }
+ if ( $PlayerRandomMode eq "RND" ) { &PlayerRandomRnd(); }
+ if ( $PlayerRandomMode eq "MAP" ) { &PlayerRandomMap(); }
+
+ # PLayer Wpt/Kml Mode
+ if ( $PlayerWptKmlMode eq "WPT" ) { &PlayerWpt(); }
+ if ( $PlayerWptKmlMode eq "KML" ) { &PlayerKml(); }
+
+ # PLayer Pause Mode
+ if ( $PlayerPauseMode eq "MAP" ) { &PlayerPauseMode("MAP"); }
+ if ( $PlayerPauseMode eq "MK" ) { &PlayerPauseMode("MK"); }
+
+ # Set POI position
+ ($Poi_Lat, $Poi_Lon) = &MapXY2Gps($Poi_x + 24, $Poi_y + 48);
+ if ( $PoiMode )
+ {
+ &PoiShow();
+ }
+ else
+ {
+ &PoiHide();
+ }
+
+
+ # delete Footprint
+ @Footprint = ();
+ &FootprintRedraw();
+ }
+
+
+
+# Start Web Browser with URL
+sub StartBrowser()
+ {
+ ($Url) = @_;
+ system ("start $Url")
+ }
+
+#
+# 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->{'map'}->{'PauseMoveDist'} || 1; # 1m default
+
+ my $BearingTop = &MapAngel() - 90.0;
+ my $BearingKey = rad2deg atan2($DirX, $DirY);
+ my $Bearing = $BearingTop + $BearingKey;
+ if ( $PlayerPauseMode eq "MK" )
+ {
+ # MK Reference
+ $Bearing = $MkOsd{'CompassHeading'} + $BearingKey;
+ }
+
+ ($PlayerPause_Lat, $PlayerPause_Lon) = &MapGpsAt($PlayerPause_Lat, $PlayerPause_Lon, $Dist, $Bearing);
+
+ # restart crosshair display timer
+ $CrosshairTimerCnt = 0;
+ }
+ }
+
+
+# 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();
+ }
+ }
+
+# Grid on canvas
+$GridIsOn = 0;
+sub CbGrid()
+ {
+ if ( $GridIsOn )
+ {
+ $GridIsOn = 0;
+ &GridHide();
+ }
+ else
+ {
+ $GridIsOn = 1;
+ &GridShow();
+ }
+ }
+
+# Player Pause Mode
+sub CbPlayerPauseMode()
+ {
+ if ( $PlayerPauseMode eq "MAP" )
+ {
+ &PlayerPauseMode("MK");
+ }
+ else
+ {
+ &PlayerPauseMode("MAP");
+ }
+ }
+
+# External-Control, SerialChannel On/Off
+sub CbTxOnOff()
+ {
+ if ( $TxExtOn == 1 )
+ {
+ $TxExtOn = 0;
+ }
+ else
+ {
+ $TxExtOn = 1;
+ }
+ }
+
+
+# Function Key Press
+sub CbFctKeyPress()
+ {
+ my ($Id, $Num) = @_;
+
+ $Num --;
+ $Stick{'FctKey'} |= (1 << $Num);
+ }
+
+
+# Function Key Release
+sub CbFctKeyRelease()
+ {
+ my ($Id, $Num) = @_;
+
+ $Num --;
+ $Stick{'FctKey'} ^= (1 << $Num);
+ }
+
+
+# CallBack: Exit Mission Cockpit
+sub CbExit()
+ {
+
+ # stop 3D Mouse
+ &Mouse3DStop();
+
+ # stop Joystick
+ &JoystickStop();
+
+ # stop antenna tracking
+ $TrackQueue->enqueue( "IDLE" );
+
+ # wait for tracker shutdown, with timeout
+ if ( $Cfg->{'track'}->{'Active'} =~ /y/i )
+ {
+ for ($i=0; $i < 5; $i++)
+ {
+ if ( $MkTrack{'State'} ne "Idle" )
+ {
+ sleep 1;
+ }
+ }
+ }
+
+ exit;
+ }
+
+
+__END__
Index: tags/V0.5.1/logging.pl
===================================================================
--- tags/V0.5.1/logging.pl (revision 0)
+++ tags/V0.5.1/logging.pl (revision 810)
@@ -0,0 +1,445 @@
+#!/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
+# 2010-01-23 0.1.9 rw kosmetics
+# no logging, if simulator is active
+# 2010-06-24 0.5.0 rw GPX logging match MK format
+#
+###############################################################################
+
+$Version{'logging.pl'} = "0.5.0 - 2010-06-24";
+
+#
+# Parameter
+#
+
+my $LoopTime = $Cfg->{'logging'}->{'Intervall'} || 1; # in s
+$LoopTime *= 1000000; # in us
+
+# 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);
+
+require "mkcomm.pl"; # MK communication
+require "geserver.pl"; # Google Earth Server
+require "translate.pl"; # Übersetzungstable
+
+# Queue for receiving commands
+$LogQueue = Thread::Queue->new();
+
+my $LogState = "LOG"; # LOG, OFF
+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";
+
+ # print labes at first line
+
+ # wait for hash labels
+ while ( $MkOsd{'_Timestamp'} eq "" or $MkNcDebug{'_Timestamp'} eq "" )
+ {
+ sleep 1;
+ }
+
+ # 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";
+
+ $LogCsvIsOpen = 1;
+ }
+
+ 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>Mission Cockpit 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
+ my $Elevation = &Altitude();
+
+ printf LOGGPX <<EOF;
+ <trkpt lat="$MkOsd{'CurPos_Lat'}" lon="$MkOsd{'CurPos_Lon'}">
+ <ele>$Elevation</ele>
+ <time>${UtcTimeStamp}</time>
+ <sat>$MkOsd{'SatsInUse'}</sat>
+ <course>$MkOsd{'CompassHeading'}</course>
+ <speed>$Speed</speed>
+ <extensions>
+ <Altimeter>$MkOsd{'Altimeter'}</Altimeter>
+ <Variometer>$MkOsd{'Variometer'}</Variometer>
+ <Course>$MkOsd{'Heading'}</Course>
+ <GroundSpeed>$MkOsd{'GroundSpeed'}</GroundSpeed>
+ <VerticalSpeed>$MkOsd{'TopSpeed'}</VerticalSpeed>
+ <FlightTime>$MkOsd{'FlyingTime'}</FlightTime>
+ <Voltage>$MkOsd{'UBat'}</Voltage>
+ <Current>$MkOsd{'Current'}</Current>
+ <Capacity>$MkOsd{'UsedCapacity'}</Capacity>
+ <RCQuality>$MkOsd{'RC_Quality'}</RCQuality>
+ <RCRSSI>$MkOsd{'RC_RSSI'}</RCRSSI>
+ <Compass>$MkOsd{'CompassHeading'}</Compass>
+ <NickAngle>$MkOsd{'AngleNick'}</NickAngle>
+ <RollAngle>$MkOsd{'AngleRoll'}</RollAngle>
+ <NCFlag>$MkOsd{'NCFlags'}</NCFlag>
+ <MKFlag>$MkOsd{'MKFlags'}</MKFlag>
+ <ErrorCode>$MkOsd{'ErrorCode'}</ErrorCode>
+ <TargetLat>$MkOsd{'TargetPos_Lat'}</TargetLat>
+ <TargetLon>$MkOsd{'TargetPos_Lon'}</TargetLon>
+ <TargetAlt>$MkOsd{'TargetPos_Alt'}</TargetAlt>
+ <TargetBearing>$MkOsd{'TargetPosDev_Bearing'}</TargetBearing>
+ <TargetDistance>$MkOsd{'TargetPosDev_Dist'}</TargetDistance>
+ <Waypoint>$MkOsd{'WaypointIndex'} / $MkOsd{'WaypointNumber'}</Waypoint>
+ <RCSticks>0, 0, 0</RCSticks>
+ <GPSSticks>0, 0, 0</GPSSticks>
+ </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>Mission Cockpit 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 $Alt = &Altitude();
+ if ( $Alt < 0 ) { $Alt = 0; }
+ printf LOGKML " %f, %f, %f\n", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $Alt;
+ }
+ 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)
+ {
+
+ # check commnd queue
+ if ( $LogQueue->pending() > 0 )
+ {
+ $LogState = $LogQueue->dequeue(1);
+ }
+
+ if ( $LogState eq "LOG" )
+ {
+ &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__
Index: tags/V0.5.1/LICENSE.TXT
===================================================================
--- tags/V0.5.1/LICENSE.TXT (revision 0)
+++ tags/V0.5.1/LICENSE.TXT (revision 810)
@@ -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
+
Index: tags/V0.5.1/libjoystick.pl
===================================================================
--- tags/V0.5.1/libjoystick.pl (revision 0)
+++ tags/V0.5.1/libjoystick.pl (revision 810)
@@ -0,0 +1,150 @@
+#!/usr/bin/perl
+#!/usr/bin/perl -d:ptkdb
+
+###############################################################################
+#
+# libjoystick.pl - Joystick controls
+#
+# 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-12-06 0.0.1 rw created
+# 2010-06-20 0.0.2 rw check hasPOV
+#
+###############################################################################
+
+$Version{'libjoystick.pl'} = "0.0.2 - 2010-06-20";
+
+# 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 Time::HiRes qw(usleep); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm
+use Win32::MultiMedia::Joystick; # http://aspn.activestate.com/ASPN/CodeDoc/Win32-MultiMedia/Joystick/Joystick.html
+
+# Hashes exported to other threads and main-program
+share (%Stick);
+
+my $StickNum = "JOY1";
+my $StickRange = 1024; # global stick range
+
+$Stick{'StickRange'} = $StickRange;
+$Stick{'JoystickX'} = 512;
+$Stick{'JoystickY'} = 512;
+$Stick{'JoystickZ'} = 512;
+$Stick{'JoystickR'} = 512;
+$Stick{'JoystickU'} = 512;
+$Stick{'JoystickV'} = 512;
+$Stick{'JoystickButton'} = 0;
+$Stick{'JoystickPov'} = 0xffff;
+$Stick{'_JoystickTimestamp'} = time;
+
+my $Joystick = Win32::MultiMedia::Joystick->new($StickNum);
+if ( defined $Joystick )
+ {
+ $StickNumAxes = $Joystick->NumAxes;
+ $StickNumButtons = $Joystick->NumButtons;
+
+ $StickXmin = $Joystick->Xmin;
+ $StickXmax = $Joystick->Xmax;
+ $StickYmin = $Joystick->Ymin;
+ $StickYmax = $Joystick->Ymax;
+ $StickZmin = $Joystick->Zmin;
+ $StickZmax = $Joystick->Zmax;
+
+ $StickRmin = $Joystick->Rmin;
+ $StickRmax = $Joystick->Rmax;
+ $StickUmin = $Joystick->Umin;
+ $StickUmax = $Joystick->Umax;
+ $StickVmin = $Joystick->Vmin;
+ $StickVmax = $Joystick->Vmax;
+
+ $Stick{'JoystickAxes'} = $StickNumAxes;
+ $Stick{'JoystickNumButtons'} = $StickNumButtons;
+ $Stick{'_JoystickTimestamp'} = time;
+ }
+
+
+sub Joystick()
+ {
+ while ( usleep (10000) ) # 10ms loop
+ {
+ if ( defined $Joystick and $Stick{'JoystickAxes'} > 0)
+ {
+ $Joystick->update;
+
+ my $x = $Joystick->X;
+ my $y = $Joystick->Y;
+ my $z = $Joystick->Z;
+ my $r = $Joystick->R;
+ my $u = $Joystick->U;
+ my $v = $Joystick->V;
+ my $Button = $Joystick->Buttons;
+ my $Pov = $Joystick->POV;
+
+ lock (%Stick); # until end of block
+
+ $Stick{'JoystickX'} = int ($x / ($StickXmax - $StickXmin) * $StickRange + 0.5);
+ $Stick{'JoystickY'} = $StickRange - int ($y / ($StickYmax - $StickYmin) * $StickRange + 0.5);
+ $Stick{'JoystickZ'} = $StickRange - int ($z / ($StickYmax - $StickYmin) * $StickRange + 0.5);
+ $Stick{'JoystickR'} = int ($r / ($StickRmax - $StickRmin) * $StickRange + 0.5);
+ $Stick{'JoystickU'} = int ($u / ($StickUmax - $StickUmin) * $StickRange + 0.5);
+ $Stick{'JoystickV'} = int ($v / ($StickVmax - $StickVmin) * $StickRange + 0.5);
+ $Stick{'JoystickButton'} = $Button;
+ if ( $Joystick->hasPOV )
+ {
+ $Stick{'JoystickPov'} = $Pov;
+ }
+ $Stick{'_JoystickTimestamp'} = time;
+ }
+ }
+ }
+
+
+sub JoystickStop ()
+ {
+ # Nothing to do
+ }
+
+
+# check, if button "Num" pressed, Num = 0 .. n
+sub JoystickButton()
+ {
+ my ($Num) = @_;
+
+ return (($Stick{'JoystickButton'} >> $Num) & 1) == 1;
+ }
+
+1;
+
+__END__
Index: tags/V0.5.1/perl/lib/Win32API/CommPort-Orig.pm
===================================================================
--- tags/V0.5.1/perl/lib/Win32API/CommPort-Orig.pm (revision 0)
+++ tags/V0.5.1/perl/lib/Win32API/CommPort-Orig.pm (revision 810)
@@ -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
Index: tags/V0.5.1/perl/lib/Win32API/CommPort.pm
===================================================================
--- tags/V0.5.1/perl/lib/Win32API/CommPort.pm (revision 0)
+++ tags/V0.5.1/perl/lib/Win32API/CommPort.pm (revision 810)
@@ -0,0 +1,3146 @@
+# This part includes the low-level API calls
+package Win32API::CommPort;
+
+use Win32;
+use Win32::API 0.01;
+if ( $] < 5.004 ) {
+ my $no_silly_warning = $Win32::API::VERSION;
+ $no_silly_warning = $Win32::API::pack;
+}
+
+use Carp;
+use strict;
+
+ #### API declarations ####
+no strict 'subs'; # these may be imported someday
+
+use vars qw(
+ $_CloseHandle $_CreateFile $_GetCommState
+ $_ReadFile $_SetCommState $_SetupComm
+ $_PurgeComm $_CreateEvent $_GetCommTimeouts
+ $_SetCommTimeouts $_GetCommProperties $_ClearCommBreak
+ $_ClearCommError $_EscapeCommFunction $_GetCommConfig
+ $_GetCommMask $_GetCommModemStatus $_SetCommBreak
+ $_SetCommConfig $_SetCommMask $_TransmitCommChar
+ $_WaitCommEvent $_WriteFile $_ResetEvent
+ $_GetOverlappedResult
+);
+
+$_CreateFile = new Win32::API("kernel32", "CreateFile",
+ [P, N, N, N, N, N, N], N);
+$_CloseHandle = new Win32::API("kernel32", "CloseHandle", [N], N);
+$_GetCommState = new Win32::API("kernel32", "GetCommState", [N, P], I);
+$_SetCommState = new Win32::API("kernel32", "SetCommState", [N, P], I);
+$_SetupComm = new Win32::API("kernel32", "SetupComm", [N, N, N], I);
+$_PurgeComm = new Win32::API("kernel32", "PurgeComm", [N, N], I);
+$_CreateEvent = new Win32::API("kernel32", "CreateEvent", [P, I, I, P], N);
+$_GetCommTimeouts = new Win32::API("kernel32", "GetCommTimeouts",
+ [N, P], I);
+$_SetCommTimeouts = new Win32::API("kernel32", "SetCommTimeouts",
+ [N, P], I);
+$_GetCommProperties = new Win32::API("kernel32", "GetCommProperties",
+ [N, P], I);
+$_ReadFile = new Win32::API("kernel32", "ReadFile", [N, P, N, P, P], I);
+$_WriteFile = new Win32::API("kernel32", "WriteFile", [N, P, N, P, P], I);
+$_TransmitCommChar = new Win32::API("kernel32", "TransmitCommChar", [N, I], I);
+$_ClearCommBreak = new Win32::API("kernel32", "ClearCommBreak", [N], I);
+$_SetCommBreak = new Win32::API("kernel32", "SetCommBreak", [N], I);
+$_ClearCommError = new Win32::API("kernel32", "ClearCommError", [N, P, P], I);
+$_EscapeCommFunction = new Win32::API("kernel32", "EscapeCommFunction",
+ [N, N], I);
+$_GetCommModemStatus = new Win32::API("kernel32", "GetCommModemStatus",
+ [N, P], I);
+$_GetOverlappedResult = new Win32::API("kernel32", "GetOverlappedResult",
+ [N, P, P, I], I);
+
+#### these are not used yet
+
+$_GetCommConfig = new Win32::API("kernel32", "GetCommConfig", [N, P, P], I);
+$_GetCommMask = new Win32::API("kernel32", "GetCommMask", [N, P], I);
+$_SetCommConfig = new Win32::API("kernel32", "SetCommConfig", [N, P, N], I);
+$_SetCommMask = new Win32::API("kernel32", "SetCommMask", [N, N], I);
+$_WaitCommEvent = new Win32::API("kernel32", "WaitCommEvent", [N, P, P], I);
+$_ResetEvent = new Win32::API("kernel32", "ResetEvent", [N], I);
+
+use strict;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $RBUF_Size);
+$VERSION = '0.19';
+$RBUF_Size = 4096;
+
+require Exporter;
+## require AutoLoader;
+
+@ISA = qw(Exporter);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+
+@EXPORT= qw();
+@EXPORT_OK= qw();
+%EXPORT_TAGS = (STAT => [qw( BM_fCtsHold BM_fDsrHold
+ BM_fRlsdHold BM_fXoffHold
+ BM_fXoffSent BM_fEof
+ BM_fTxim BM_AllBits
+ MS_CTS_ON MS_DSR_ON
+ MS_RING_ON MS_RLSD_ON
+ CE_RXOVER CE_OVERRUN
+ CE_RXPARITY CE_FRAME
+ CE_BREAK CE_TXFULL
+ CE_MODE ST_BLOCK
+ ST_INPUT ST_OUTPUT
+ ST_ERROR )],
+
+ RAW => [qw( CloseHandle CreateFile
+ GetCommState ReadFile
+ SetCommState SetupComm
+ PurgeComm CreateEvent
+ GetCommTimeouts SetCommTimeouts
+ GetCommProperties ClearCommBreak
+ ClearCommError EscapeCommFunction
+ GetCommConfig GetCommMask
+ GetCommModemStatus SetCommBreak
+ SetCommConfig SetCommMask
+ TransmitCommChar WaitCommEvent
+ WriteFile ResetEvent
+ GetOverlappedResult
+ PURGE_TXABORT PURGE_RXABORT
+ PURGE_TXCLEAR PURGE_RXCLEAR
+ SETXOFF SETXON
+ SETRTS CLRRTS
+ SETDTR CLRDTR
+ SETBREAK CLRBREAK
+ EV_RXCHAR EV_RXFLAG
+ EV_TXEMPTY EV_CTS
+ EV_DSR EV_RLSD
+ EV_BREAK EV_ERR
+ EV_RING EV_PERR
+ EV_RX80FULL EV_EVENT1
+ EV_EVENT2 ERROR_IO_INCOMPLETE
+ ERROR_IO_PENDING )],
+
+ COMMPROP => [qw( BAUD_USER BAUD_075 BAUD_110
+ BAUD_134_5 BAUD_150 BAUD_300
+ BAUD_600 BAUD_1200 BAUD_1800
+ BAUD_2400 BAUD_4800 BAUD_7200
+ BAUD_9600 BAUD_14400 BAUD_19200
+ BAUD_38400 BAUD_56K BAUD_57600
+ BAUD_115200 BAUD_128K
+
+ PST_FAX PST_LAT PST_MODEM
+ PST_RS232 PST_RS422 PST_RS423
+ PST_RS449 PST_SCANNER PST_X25
+ PST_NETWORK_BRIDGE PST_PARALLELPORT
+ PST_TCPIP_TELNET PST_UNSPECIFIED
+
+ PCF_INTTIMEOUTS PCF_PARITY_CHECK
+ PCF_16BITMODE PCF_DTRDSR
+ PCF_SPECIALCHARS PCF_RLSD
+ PCF_RTSCTS PCF_SETXCHAR
+ PCF_TOTALTIMEOUTS PCF_XONXOFF
+
+ SP_BAUD SP_DATABITS SP_HANDSHAKING
+ SP_PARITY SP_PARITY_CHECK SP_RLSD
+ SP_STOPBITS SP_SERIALCOMM
+
+ DATABITS_5 DATABITS_6 DATABITS_7
+ DATABITS_8 DATABITS_16 DATABITS_16X
+
+ STOPBITS_10 STOPBITS_15 STOPBITS_20
+ PARITY_SPACE PARITY_NONE PARITY_ODD
+ PARITY_EVEN PARITY_MARK
+ COMMPROP_INITIALIZED )],
+
+ DCB => [qw( CBR_110 CBR_300 CBR_600
+ CBR_1200 CBR_2400 CBR_4800
+ CBR_9600 CBR_14400 CBR_19200
+ CBR_38400 CBR_56000 CBR_57600
+ CBR_115200 CBR_128000 CBR_256000
+
+ DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE
+ DTR_CONTROL_HANDSHAKE RTS_CONTROL_DISABLE
+ RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE
+ RTS_CONTROL_TOGGLE
+
+ EVENPARITY MARKPARITY NOPARITY
+ ODDPARITY SPACEPARITY
+
+ ONESTOPBIT ONE5STOPBITS TWOSTOPBITS
+
+ FM_fBinary FM_fParity
+ FM_fOutxCtsFlow FM_fOutxDsrFlow
+ FM_fDtrControl FM_fDsrSensitivity
+ FM_fTXContinueOnXoff FM_fOutX
+ FM_fInX FM_fErrorChar
+ FM_fNull FM_fRtsControl
+ FM_fAbortOnError FM_fDummy2 )],
+
+ PARAM => [qw( LONGsize SHORTsize OS_Error
+ nocarp internal_buffer yes_true )]);
+
+
+Exporter::export_ok_tags('STAT', 'RAW', 'COMMPROP', 'DCB', 'PARAM');
+
+$EXPORT_TAGS{ALL} = \@EXPORT_OK;
+
+#### subroutine wrappers for API calls
+
+sub CloseHandle {
+ return unless ( 1 == @_ );
+ return $_CloseHandle->Call( shift );
+}
+
+sub CreateFile {
+ return $_CreateFile->Call( @_ );
+ # returns handle
+}
+
+sub GetCommState {
+ return $_GetCommState->Call( @_ );
+}
+
+sub SetCommState {
+ return $_SetCommState->Call( @_ );
+}
+
+sub SetupComm {
+ return $_SetupComm->Call( @_ );
+}
+
+sub PurgeComm {
+ return $_PurgeComm->Call( @_ );
+}
+
+sub CreateEvent {
+ return $_CreateEvent->Call( @_ );
+}
+
+sub GetCommTimeouts {
+ return $_GetCommTimeouts->Call( @_ );
+}
+
+sub SetCommTimeouts {
+ return $_SetCommTimeouts->Call( @_ );
+}
+
+sub GetCommProperties {
+ return $_GetCommProperties->Call( @_ );
+}
+
+sub ReadFile {
+ return $_ReadFile->Call( @_ );
+}
+
+sub WriteFile {
+ return $_WriteFile->Call( @_ );
+}
+
+sub TransmitCommChar {
+ return $_TransmitCommChar->Call( @_ );
+}
+
+sub ClearCommBreak {
+ return unless ( 1 == @_ );
+ return $_ClearCommBreak->Call( shift );
+}
+
+sub SetCommBreak {
+ return unless ( 1 == @_ );
+ return $_SetCommBreak->Call( shift );
+}
+
+sub ClearCommError {
+ return $_ClearCommError->Call( @_ );
+}
+
+sub EscapeCommFunction {
+ return $_EscapeCommFunction->Call( @_ );
+}
+
+sub GetCommModemStatus {
+ return $_GetCommModemStatus->Call( @_ );
+}
+
+sub GetOverlappedResult {
+ return $_GetOverlappedResult->Call( @_ );
+}
+
+sub GetCommConfig {
+ return $_GetCommConfig->Call( @_ );
+}
+
+sub GetCommMask {
+ return $_GetCommMask->Call( @_ );
+}
+
+sub SetCommConfig {
+ return $_SetCommConfig->Call( @_ );
+}
+
+sub SetCommMask {
+ return $_SetCommMask->Call( @_ );
+}
+
+sub WaitCommEvent {
+ return $_WaitCommEvent->Call( @_ );
+}
+
+sub ResetEvent {
+ return unless ( 1 == @_ );
+ return $_ResetEvent->Call( shift );
+}
+
+#### "constant" declarations from Win32 header files ####
+#### compatible with ActiveState ####
+
+## COMMPROP structure
+sub SP_SERIALCOMM { 0x1 }
+sub BAUD_075 { 0x1 }
+sub BAUD_110 { 0x2 }
+sub BAUD_134_5 { 0x4 }
+sub BAUD_150 { 0x8 }
+sub BAUD_300 { 0x10 }
+sub BAUD_600 { 0x20 }
+sub BAUD_1200 { 0x40 }
+sub BAUD_1800 { 0x80 }
+sub BAUD_2400 { 0x100 }
+sub BAUD_4800 { 0x200 }
+sub BAUD_7200 { 0x400 }
+sub BAUD_9600 { 0x800 }
+sub BAUD_14400 { 0x1000 }
+sub BAUD_19200 { 0x2000 }
+sub BAUD_38400 { 0x4000 }
+sub BAUD_56K { 0x8000 }
+sub BAUD_57600 { 0x40000 }
+sub BAUD_115200 { 0x20000 }
+sub BAUD_128K { 0x10000 }
+sub BAUD_USER { 0x10000000 }
+sub PST_FAX { 0x21 }
+sub PST_LAT { 0x101 }
+sub PST_MODEM { 0x6 }
+sub PST_NETWORK_BRIDGE { 0x100 }
+sub PST_PARALLELPORT { 0x2 }
+sub PST_RS232 { 0x1 }
+sub PST_RS422 { 0x3 }
+sub PST_RS423 { 0x4 }
+sub PST_RS449 { 0x5 }
+sub PST_SCANNER { 0x22 }
+sub PST_TCPIP_TELNET { 0x102 }
+sub PST_UNSPECIFIED { 0 }
+sub PST_X25 { 0x103 }
+sub PCF_16BITMODE { 0x200 }
+sub PCF_DTRDSR { 0x1 }
+sub PCF_INTTIMEOUTS { 0x80 }
+sub PCF_PARITY_CHECK { 0x8 }
+sub PCF_RLSD { 0x4 }
+sub PCF_RTSCTS { 0x2 }
+sub PCF_SETXCHAR { 0x20 }
+sub PCF_SPECIALCHARS { 0x100 }
+sub PCF_TOTALTIMEOUTS { 0x40 }
+sub PCF_XONXOFF { 0x10 }
+sub SP_BAUD { 0x2 }
+sub SP_DATABITS { 0x4 }
+sub SP_HANDSHAKING { 0x10 }
+sub SP_PARITY { 0x1 }
+sub SP_PARITY_CHECK { 0x20 }
+sub SP_RLSD { 0x40 }
+sub SP_STOPBITS { 0x8 }
+sub DATABITS_5 { 1 }
+sub DATABITS_6 { 2 }
+sub DATABITS_7 { 4 }
+sub DATABITS_8 { 8 }
+sub DATABITS_16 { 16 }
+sub DATABITS_16X { 32 }
+sub STOPBITS_10 { 1 }
+sub STOPBITS_15 { 2 }
+sub STOPBITS_20 { 4 }
+sub PARITY_NONE { 256 }
+sub PARITY_ODD { 512 }
+sub PARITY_EVEN { 1024 }
+sub PARITY_MARK { 2048 }
+sub PARITY_SPACE { 4096 }
+sub COMMPROP_INITIALIZED { 0xe73cf52e }
+
+## DCB structure
+sub CBR_110 { 110 }
+sub CBR_300 { 300 }
+sub CBR_600 { 600 }
+sub CBR_1200 { 1200 }
+sub CBR_2400 { 2400 }
+sub CBR_4800 { 4800 }
+sub CBR_9600 { 9600 }
+sub CBR_14400 { 14400 }
+sub CBR_19200 { 19200 }
+sub CBR_38400 { 38400 }
+sub CBR_56000 { 56000 }
+sub CBR_57600 { 57600 }
+sub CBR_115200 { 115200 }
+sub CBR_128000 { 128000 }
+sub CBR_256000 { 256000 }
+sub DTR_CONTROL_DISABLE { 0 }
+sub DTR_CONTROL_ENABLE { 1 }
+sub DTR_CONTROL_HANDSHAKE { 2 }
+sub RTS_CONTROL_DISABLE { 0 }
+sub RTS_CONTROL_ENABLE { 1 }
+sub RTS_CONTROL_HANDSHAKE { 2 }
+sub RTS_CONTROL_TOGGLE { 3 }
+sub EVENPARITY { 2 }
+sub MARKPARITY { 3 }
+sub NOPARITY { 0 }
+sub ODDPARITY { 1 }
+sub SPACEPARITY { 4 }
+sub ONESTOPBIT { 0 }
+sub ONE5STOPBITS { 1 }
+sub TWOSTOPBITS { 2 }
+
+## Flowcontrol bit mask in DCB
+sub FM_fBinary { 0x1 }
+sub FM_fParity { 0x2 }
+sub FM_fOutxCtsFlow { 0x4 }
+sub FM_fOutxDsrFlow { 0x8 }
+sub FM_fDtrControl { 0x30 }
+sub FM_fDsrSensitivity { 0x40 }
+sub FM_fTXContinueOnXoff { 0x80 }
+sub FM_fOutX { 0x100 }
+sub FM_fInX { 0x200 }
+sub FM_fErrorChar { 0x400 }
+sub FM_fNull { 0x800 }
+sub FM_fRtsControl { 0x3000 }
+sub FM_fAbortOnError { 0x4000 }
+sub FM_fDummy2 { 0xffff8000 }
+
+## COMSTAT bit mask
+sub BM_fCtsHold { 0x1 }
+sub BM_fDsrHold { 0x2 }
+sub BM_fRlsdHold { 0x4 }
+sub BM_fXoffHold { 0x8 }
+sub BM_fXoffSent { 0x10 }
+sub BM_fEof { 0x20 }
+sub BM_fTxim { 0x40 }
+sub BM_AllBits { 0x7f }
+
+## PurgeComm bit mask
+sub PURGE_TXABORT { 0x1 }
+sub PURGE_RXABORT { 0x2 }
+sub PURGE_TXCLEAR { 0x4 }
+sub PURGE_RXCLEAR { 0x8 }
+
+## GetCommModemStatus bit mask
+sub MS_CTS_ON { 0x10 }
+sub MS_DSR_ON { 0x20 }
+sub MS_RING_ON { 0x40 }
+sub MS_RLSD_ON { 0x80 }
+
+## EscapeCommFunction operations
+sub SETXOFF { 0x1 }
+sub SETXON { 0x2 }
+sub SETRTS { 0x3 }
+sub CLRRTS { 0x4 }
+sub SETDTR { 0x5 }
+sub CLRDTR { 0x6 }
+sub SETBREAK { 0x8 }
+sub CLRBREAK { 0x9 }
+
+## ClearCommError bit mask
+sub CE_RXOVER { 0x1 }
+sub CE_OVERRUN { 0x2 }
+sub CE_RXPARITY { 0x4 }
+sub CE_FRAME { 0x8 }
+sub CE_BREAK { 0x10 }
+sub CE_TXFULL { 0x100 }
+#### LPT only
+# sub CE_PTO { 0x200 }
+# sub CE_IOE { 0x400 }
+# sub CE_DNS { 0x800 }
+# sub CE_OOP { 0x1000 }
+#### LPT only
+sub CE_MODE { 0x8000 }
+
+## GetCommMask bits
+sub EV_RXCHAR { 0x1 }
+sub EV_RXFLAG { 0x2 }
+sub EV_TXEMPTY { 0x4 }
+sub EV_CTS { 0x8 }
+sub EV_DSR { 0x10 }
+sub EV_RLSD { 0x20 }
+sub EV_BREAK { 0x40 }
+sub EV_ERR { 0x80 }
+sub EV_RING { 0x100 }
+sub EV_PERR { 0x200 }
+sub EV_RX80FULL { 0x400 }
+sub EV_EVENT1 { 0x800 }
+sub EV_EVENT2 { 0x1000 }
+
+## Allowed OVERLAP errors
+sub ERROR_IO_INCOMPLETE { 996 }
+sub ERROR_IO_PENDING { 997 }
+
+#### "constant" declarations compatible with ActiveState ####
+
+my $DCBformat="LLLSSSCCCCCCCCS";
+my $CP_format1="SSLLLLLLLLLSSLLLLSA*"; # rs232
+my $CP_format6="SSLLLLLLLLLSSLLLLLLLLLLLLLLLLLLLLLLLA*"; # modem
+my $CP_format0="SA50LA244"; # pre-read
+
+my $OVERLAPPEDformat="LLLLL";
+my $TIMEOUTformat="LLLLL";
+my $COMSTATformat="LLL";
+my $cfg_file_sig="Win32API::SerialPort_Configuration_File -- DO NOT EDIT --\n";
+
+sub SHORTsize { 0xffff; }
+sub LONGsize { 0xffffffff; }
+
+sub ST_BLOCK {0} # status offsets for caller
+sub ST_INPUT {1}
+sub ST_OUTPUT {2}
+sub ST_ERROR {3} # latched
+
+
+#### Package variable declarations ####
+
+my @Yes_resp = (
+ "YES","Y",
+ "ON",
+ "TRUE","T",
+ "1"
+ );
+
+my @binary_opt = (0, 1);
+my @byte_opt = (0, 255);
+
+my $Babble = 0;
+my $testactive = 0; # test mode active
+
+## my $null=[];
+my $null=0;
+my $zero=0;
+
+# Preloaded methods go here.
+
+sub OS_Error { print Win32::FormatMessage ( Win32::GetLastError() ); }
+
+sub get_tick_count { return Win32::GetTickCount(); }
+
+ # test*.t only - suppresses default messages
+sub set_no_messages {
+ return unless (@_ == 2);
+ $testactive = yes_true($_[1]);
+}
+
+sub nocarp { return $testactive }
+
+sub internal_buffer { return $RBUF_Size }
+
+sub yes_true {
+ my $choice = uc shift;
+ my $ans = 0;
+ foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) }
+ return $ans;
+}
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $self = {};
+ my $ok = 0; # API return value
+ my $hr = 0; # temporary hashref
+ my $fmask = 0; # temporary for bit banging
+ my $fix_baud = 0;
+ my $key;
+ my $value;
+ my $CommPropBlank = " ";
+
+ # COMMPROP only used during new
+ my $CommProperties = " "x300; # extra buffer for modems
+ my $CP_Length = 0;
+ my $CP_Version = 0;
+ my $CP_ServiceMask = 0;
+ my $CP_Reserved1 = 0;
+ my $CP_MaxBaud = 0;
+ my $CP_ProvCapabilities = 0;
+ my $CP_SettableParams = 0;
+ my $CP_SettableBaud = 0;
+ my $CP_SettableData = 0;
+ my $CP_SettableStopParity = 0;
+ my $CP_ProvSpec1 = 0;
+ my $CP_ProvSpec2 = 0;
+ my $CP_ProvChar_start = 0;
+ my $CP_Filler = 0;
+
+ # MODEMDEVCAPS
+ my $MC_ReqSize = 0;
+ my $MC_SpecOffset = 0;
+ my $MC_SpecSize = 0;
+ my $MC_ProvVersion = 0;
+ my $MC_ManfOffset = 0;
+ my $MC_ManfSize = 0;
+ my $MC_ModOffset = 0;
+ my $MC_ModSize = 0;
+ my $MC_VerOffset = 0;
+ my $MC_VerSize = 0;
+ my $MC_DialOpt = 0;
+ my $MC_CallFailTime = 0;
+ my $MC_IdleTime = 0;
+ my $MC_SpkrVol = 0;
+ my $MC_SpkrMode = 0;
+ my $MC_ModOpt = 0;
+ my $MC_MaxDTE = 0;
+ my $MC_MaxDCE = 0;
+ my $MC_Filler = 0;
+
+ $self->{NAME} = shift;
+ my $quiet = shift;
+
+ $self->{"_HANDLE"}=CreateFile("$self->{NAME}",
+ 0xc0000000,
+ 0,
+ $null,
+ 3,
+ 0x40000000,
+ $null);
+ # device name
+ # GENERIC_READ | GENERIC_WRITE
+ # no FILE_SHARE_xx
+ # no SECURITY_xx
+ # OPEN_EXISTING
+ # FILE_FLAG_OVERLAPPED
+ # template file
+
+ unless ($self->{"_HANDLE"} >= 1) {
+ $self->{"_HANDLE"} = 0;
+ return 0 if ($quiet);
+ return if (nocarp);
+ OS_Error;
+ carp "can't open device: $self->{NAME}\n";
+ return;
+ }
+
+ # let Win32 know we allowed room for modem properties
+ $CP_Length = 300;
+ $CP_ProvSpec1 = COMMPROP_INITIALIZED;
+ $CommProperties = pack($CP_format0,
+ $CP_Length,
+ $CommPropBlank,
+ $CP_ProvSpec1,
+ $CommPropBlank);
+
+ $ok=GetCommProperties($self->{"_HANDLE"}, $CommProperties);
+
+ unless ( $ok ) {
+ OS_Error;
+ carp "can't get COMMPROP block";
+ undef $self;
+ return;
+ }
+
+ ($CP_Length,
+ $CP_Version,
+ $CP_ServiceMask,
+ $CP_Reserved1,
+ $self->{"_MaxTxQueue"},
+ $self->{"_MaxRxQueue"},
+ $CP_MaxBaud,
+ $self->{"_TYPE"},
+ $CP_ProvCapabilities,
+ $CP_SettableParams,
+ $CP_SettableBaud,
+ $CP_SettableData,
+ $CP_SettableStopParity,
+ $self->{WRITEBUF},
+ $self->{READBUF},
+ $CP_ProvSpec1,
+ $CP_ProvSpec2,
+ $CP_ProvChar_start,
+ $CP_Filler)= unpack($CP_format1, $CommProperties);
+
+ if (($CP_Length > 66) and ($self->{"_TYPE"} == PST_RS232)) {
+ carp "invalid COMMPROP block length= $CP_Length";
+ undef $self;
+ return;
+ }
+ if ($CP_ServiceMask != SP_SERIALCOMM) {
+ carp "doesn't claim to be a serial port\n";
+ undef $self;
+ return;
+ }
+ if ($self->{"_TYPE"} == PST_MODEM) {
+ ($CP_Length,
+ $CP_Version,
+ $CP_ServiceMask,
+ $CP_Reserved1,
+ $self->{"_MaxTxQueue"},
+ $self->{"_MaxRxQueue"},
+ $CP_MaxBaud,
+ $self->{"_TYPE"},
+ $CP_ProvCapabilities,
+ $CP_SettableParams,
+ $CP_SettableBaud,
+ $CP_SettableData,
+ $CP_SettableStopParity,
+ $self->{WRITEBUF},
+ $self->{READBUF},
+ $CP_ProvSpec1,
+ $CP_ProvSpec2,
+ $CP_ProvChar_start,
+ $MC_ReqSize,
+ $MC_SpecOffset,
+ $MC_SpecSize,
+ $MC_ProvVersion,
+ $MC_ManfOffset,
+ $MC_ManfSize,
+ $MC_ModOffset,
+ $MC_ModSize,
+ $MC_VerOffset,
+ $MC_VerSize,
+ $MC_DialOpt,
+ $MC_CallFailTime,
+ $MC_IdleTime,
+ $MC_SpkrVol,
+ $MC_SpkrMode,
+ $MC_ModOpt,
+ $MC_MaxDTE,
+ $MC_MaxDCE,
+ $MC_Filler)= unpack($CP_format6, $CommProperties);
+
+ if ($Babble) {
+ printf "\nMODEMDEVCAPS:\n";
+ printf "\$MC_ActualSize= %d\n", $CP_ProvChar_start;
+ printf "\$MC_ReqSize= %d\n", $MC_ReqSize;
+ printf "\$MC_SpecOffset= %d\n", $MC_SpecOffset;
+ printf "\$MC_SpecSize= %d\n", $MC_SpecSize;
+ if ($MC_SpecOffset) {
+ printf " DeviceSpecificData= %s\n", substr ($CommProperties,
+ 60+$MC_SpecOffset, $MC_SpecSize);
+ }
+ printf "\$MC_ProvVersion= %d\n", $MC_ProvVersion;
+ printf "\$MC_ManfOffset= %d\n", $MC_ManfOffset;
+ printf "\$MC_ManfSize= %d\n", $MC_ManfSize;
+ if ($MC_ManfOffset) {
+ printf " Manufacturer= %s\n", substr ($CommProperties,
+ 60+$MC_ManfOffset, $MC_ManfSize);
+ }
+ printf "\$MC_ModOffset= %d\n", $MC_ModOffset;
+ printf "\$MC_ModSize= %d\n", $MC_ModSize;
+ if ($MC_ModOffset) {
+ printf " Model= %s\n", substr ($CommProperties,
+ 60+$MC_ModOffset, $MC_ModSize);
+ }
+ printf "\$MC_VerOffset= %d\n", $MC_VerOffset;
+ printf "\$MC_VerSize= %d\n", $MC_VerSize;
+ if ($MC_VerOffset) {
+ printf " Version= %s\n", substr ($CommProperties,
+ 60+$MC_VerOffset, $MC_VerSize);
+ }
+ printf "\$MC_DialOpt= %lx\n", $MC_DialOpt;
+ printf "\$MC_CallFailTime= %d\n", $MC_CallFailTime;
+ printf "\$MC_IdleTime= %d\n", $MC_IdleTime;
+ printf "\$MC_SpkrVol= %d\n", $MC_SpkrVol;
+ printf "\$MC_SpkrMode= %d\n", $MC_SpkrMode;
+ printf "\$MC_ModOpt= %lx\n", $MC_ModOpt;
+ printf "\$MC_MaxDTE= %d\n", $MC_MaxDTE;
+ printf "\$MC_MaxDCE= %d\n", $MC_MaxDCE;
+ $MC_Filler= $MC_Filler; # for -w
+ }
+## $MC_ReqSize = 250;
+ if ($CP_ProvChar_start != $MC_ReqSize) {
+ printf "\nARGH, a Bug! The \$CommProperties buffer must be ";
+ printf "at least %d bytes.\n", $MC_ReqSize+60;
+ }
+ }
+
+## if (1 | $Babble) {
+ if ($Babble) {
+ printf "\$CP_Length= %d\n", $CP_Length;
+ printf "\$CP_Version= %d\n", $CP_Version;
+ printf "\$CP_ServiceMask= %lx\n", $CP_ServiceMask;
+ printf "\$CP_Reserved1= %lx\n", $CP_Reserved1;
+ printf "\$CP_MaxTxQueue= %lx\n", $self->{"_MaxTxQueue"};
+ printf "\$CP_MaxRxQueue= %lx\n", $self->{"_MaxRxQueue"};
+ printf "\$CP_MaxBaud= %lx\n", $CP_MaxBaud;
+ printf "\$CP_ProvSubType= %lx\n", $self->{"_TYPE"};
+ printf "\$CP_ProvCapabilities= %lx\n", $CP_ProvCapabilities;
+ printf "\$CP_SettableParams= %lx\n", $CP_SettableParams;
+ printf "\$CP_SettableBaud= %lx\n", $CP_SettableBaud;
+ printf "\$CP_SettableData= %x\n", $CP_SettableData;
+ printf "\$CP_SettableStopParity= %x\n", $CP_SettableStopParity;
+ printf "\$CP_CurrentTxQueue= %lx\n", $self->{WRITEBUF};
+ printf "\$CP_CurrentRxQueue= %lx\n", $self->{READBUF};
+ printf "\$CP_ProvSpec1= %lx\n", $CP_ProvSpec1;
+ printf "\$CP_ProvSpec2= %lx\n", $CP_ProvSpec2;
+ }
+
+ # "private" data
+ $self->{"_INIT"} = undef;
+ $self->{"_DEBUG_C"} = 0;
+ $self->{"_LATCH"} = 0;
+ $self->{"_W_BUSY"} = 0;
+ $self->{"_R_BUSY"} = 0;
+
+ $self->{"_TBUFMAX"} = $self->{"_MaxTxQueue"} ?
+ $self->{"_MaxTxQueue"} : LONGsize;
+ $self->{"_RBUFMAX"} = $self->{"_MaxRxQueue"} ?
+ $self->{"_MaxRxQueue"} : LONGsize;
+
+ # buffers
+ $self->{"_R_OVERLAP"} = " "x24;
+ $self->{"_W_OVERLAP"} = " "x24;
+ $self->{"_TIMEOUT"} = " "x24;
+ $self->{"_RBUF"} = " "x $RBUF_Size;
+
+ # allowed setting hashes
+ $self->{"_L_BAUD"} = {};
+ $self->{"_L_STOP"} = {};
+ $self->{"_L_PARITY"} = {};
+ $self->{"_L_DATA"} = {};
+ $self->{"_L_HSHAKE"} = {};
+
+ # capability flags
+
+ $fmask = $CP_SettableParams;
+ $self->{"_C_BAUD"} = $fmask & SP_BAUD;
+ $self->{"_C_DATA"} = $fmask & SP_DATABITS;
+ $self->{"_C_STOP"} = $fmask & SP_STOPBITS;
+ $self->{"_C_HSHAKE"} = $fmask & SP_HANDSHAKING;
+ $self->{"_C_PARITY_CFG"} = $fmask & SP_PARITY;
+ $self->{"_C_PARITY_EN"} = $fmask & SP_PARITY_CHECK;
+ $self->{"_C_RLSD_CFG"} = $fmask & SP_RLSD;
+
+ $fmask = $CP_ProvCapabilities;
+ $self->{"_C_RLSD"} = $fmask & PCF_RLSD;
+ $self->{"_C_PARITY_CK"} = $fmask & PCF_PARITY_CHECK;
+ $self->{"_C_DTRDSR"} = $fmask & PCF_DTRDSR;
+ $self->{"_C_16BITMODE"} = $fmask & PCF_16BITMODE;
+ $self->{"_C_RTSCTS"} = $fmask & PCF_RTSCTS;
+ $self->{"_C_XONXOFF"} = $fmask & PCF_XONXOFF;
+ $self->{"_C_XON_CHAR"} = $fmask & PCF_SETXCHAR;
+ $self->{"_C_SPECHAR"} = $fmask & PCF_SPECIALCHARS;
+ $self->{"_C_INT_TIME"} = $fmask & PCF_INTTIMEOUTS;
+ $self->{"_C_TOT_TIME"} = $fmask & PCF_TOTALTIMEOUTS;
+
+ if ($self->{"_C_INT_TIME"}) {
+ $self->{"_N_RINT"} = LONGsize; # min interval default
+ }
+ else {
+ $self->{"_N_RINT"} = 0;
+ }
+ $self->{"_N_RTOT"} = 0;
+ $self->{"_N_RCONST"} = 0;
+
+ if ($self->{"_C_TOT_TIME"}) {
+ $self->{"_N_WCONST"} = 201; # startup overhead + 1
+ $self->{"_N_WTOT"} = 11; # per char out + 1
+ }
+ else {
+ $self->{"_N_WTOT"} = 0;
+ $self->{"_N_WCONST"} = 0;
+ }
+
+ $hr = \%{$self->{"_L_HSHAKE"}};
+
+ if ($self->{"_C_HSHAKE"}) {
+ ${$hr}{"xoff"} = "xoff" if ($fmask & PCF_XONXOFF);
+ ${$hr}{"rts"} = "rts" if ($fmask & PCF_RTSCTS);
+ ${$hr}{"dtr"} = "dtr" if ($fmask & PCF_DTRDSR);
+ ${$hr}{"none"} = "none";
+ }
+ else { $self->{"_N_HSHAKE"} = undef; }
+
+#### really just using the keys here, so value = Win32_definition
+#### in case we ever need it for something else
+
+# first check for programmable baud
+
+ $hr = \%{$self->{"_L_BAUD"}};
+
+ if ($CP_MaxBaud & BAUD_USER) {
+ $fmask = $CP_SettableBaud;
+ ${$hr}{110} = CBR_110 if ($fmask & BAUD_110);
+ ${$hr}{300} = CBR_300 if ($fmask & BAUD_300);
+ ${$hr}{600} = CBR_600 if ($fmask & BAUD_600);
+ ${$hr}{1200} = CBR_1200 if ($fmask & BAUD_1200);
+ ${$hr}{2400} = CBR_2400 if ($fmask & BAUD_2400);
+ ${$hr}{4800} = CBR_4800 if ($fmask & BAUD_4800);
+ ${$hr}{9600} = CBR_9600 if ($fmask & BAUD_9600);
+ ${$hr}{14400} = CBR_14400 if ($fmask & BAUD_14400);
+ ${$hr}{19200} = CBR_19200 if ($fmask & BAUD_19200);
+ ${$hr}{38400} = CBR_38400 if ($fmask & BAUD_38400);
+ ${$hr}{56000} = CBR_56000 if ($fmask & BAUD_56K);
+ ${$hr}{57600} = CBR_57600 if ($fmask & BAUD_57600);
+ ${$hr}{115200} = CBR_115200 if ($fmask & BAUD_115200);
+ ${$hr}{128000} = CBR_128000 if ($fmask & BAUD_128K);
+ ${$hr}{256000} = CBR_256000 if (0); # reserved ??
+ }
+ else {
+ # get fixed baud from CP_MaxBaud
+ $fmask = $CP_MaxBaud;
+ $fix_baud = 75 if ($fmask & BAUD_075);
+ $fix_baud = 110 if ($fmask & BAUD_110);
+ $fix_baud = 134.5 if ($fmask & BAUD_134_5);
+ $fix_baud = 150 if ($fmask & BAUD_150);
+ $fix_baud = 300 if ($fmask & BAUD_300);
+ $fix_baud = 600 if ($fmask & BAUD_600);
+ $fix_baud = 1200 if ($fmask & BAUD_1200);
+ $fix_baud = 1800 if ($fmask & BAUD_1800);
+ $fix_baud = 2400 if ($fmask & BAUD_2400);
+ $fix_baud = 4800 if ($fmask & BAUD_4800);
+ $fix_baud = 7200 if ($fmask & BAUD_7200);
+ $fix_baud = 9600 if ($fmask & BAUD_9600);
+ $fix_baud = 14400 if ($fmask & BAUD_14400);
+ $fix_baud = 19200 if ($fmask & BAUD_19200);
+ $fix_baud = 34800 if ($fmask & BAUD_38400);
+ $fix_baud = 56000 if ($fmask & BAUD_56K);
+ $fix_baud = 57600 if ($fmask & BAUD_57600);
+ $fix_baud = 115200 if ($fmask & BAUD_115200);
+ $fix_baud = 128000 if ($fmask & BAUD_128K);
+ ${$hr}{$fix_baud} = $fix_baud;
+ $self->{"_N_BAUD"} = undef;
+ }
+
+#### data bits
+
+ $fmask = $CP_SettableData;
+
+ if ($self->{"_C_DATA"}) {
+
+ $hr = \%{$self->{"_L_DATA"}};
+
+ ${$hr}{5} = 5 if ($fmask & DATABITS_5);
+ ${$hr}{6} = 6 if ($fmask & DATABITS_6);
+ ${$hr}{7} = 7 if ($fmask & DATABITS_7);
+ ${$hr}{8} = 8 if ($fmask & DATABITS_8);
+ ${$hr}{16} = 16 if ($fmask & DATABITS_16);
+## ${$hr}{16X} = 16 if ($fmask & DATABITS_16X);
+ }
+ else { $self->{"_N_DATA"} = undef; }
+
+#### value = (DCB Win32_definition + 1) so 0 means unchanged
+
+ $fmask = $CP_SettableStopParity;
+
+ if ($self->{"_C_STOP"}) {
+
+ $hr = \%{$self->{"_L_STOP"}};
+
+ ${$hr}{1} = 1 + ONESTOPBIT if ($fmask & STOPBITS_10);
+ ${$hr}{1.5} = 1 + ONE5STOPBITS if ($fmask & STOPBITS_15);
+ ${$hr}{2} = 1 + TWOSTOPBITS if ($fmask & STOPBITS_20);
+ }
+ else { $self->{"_N_STOP"} = undef; }
+
+ if ($self->{"_C_PARITY_CFG"}) {
+
+ $hr = \%{$self->{"_L_PARITY"}};
+
+ ${$hr}{"none"} = 1 + NOPARITY if ($fmask & PARITY_NONE);
+ ${$hr}{"even"} = 1 + EVENPARITY if ($fmask & PARITY_EVEN);
+ ${$hr}{"odd"} = 1 + ODDPARITY if ($fmask & PARITY_ODD);
+ ${$hr}{"mark"} = 1 + MARKPARITY if ($fmask & PARITY_MARK);
+ ${$hr}{"space"} = 1 + SPACEPARITY if ($fmask & PARITY_SPACE);
+ }
+ else { $self->{"_N_PARITY"} = undef; }
+
+ $hr = 0; # no loops
+
+ # changable dcb parameters
+ # 0 = no change requested
+ # mask_on: requested value for OR
+ # mask_off: complement of requested value for AND
+
+ $self->{"_N_FM_ON"} = 0;
+ $self->{"_N_FM_OFF"} = 0;
+
+ $self->{"_N_AUX_ON"} = 0;
+ $self->{"_N_AUX_OFF"} = 0;
+
+ ### "VALUE" is initialized from DCB by default (but also in %validate)
+
+ # 0 = no change requested
+ # integer: requested value or (value+1 if 0 is a legal value)
+ # binary: 1=false requested, 2=true requested
+
+ $self->{"_N_XONLIM"} = 0;
+ $self->{"_N_XOFFLIM"} = 0;
+ $self->{"_N_XOFFCHAR"} = 0;
+ $self->{"_N_XONCHAR"} = 0;
+ $self->{"_N_ERRCHAR"} = 0;
+ $self->{"_N_EOFCHAR"} = 0;
+ $self->{"_N_EVTCHAR"} = 0;
+ $self->{"_N_BINARY"} = 0;
+ $self->{"_N_PARITY_EN"} = 0;
+
+ ### "_N_items" for save/start
+
+ $self->{"_N_READBUF"} = 0;
+ $self->{"_N_WRITEBUF"} = 0;
+ $self->{"_N_HSHAKE"} = 0;
+
+ ### The "required" DCB values are deliberately NOT defined. That way,
+ ### write_settings can verify they "exist" to assure they got set.
+ ### $self->{"_N_BAUD"}
+ ### $self->{"_N_DATA"}
+ ### $self->{"_N_STOP"}
+ ### $self->{"_N_PARITY"}
+
+
+ $self->{"_R_EVENT"} = CreateEvent($null, # no security
+ 1, # explicit reset req
+ 0, # initial event reset
+ $null); # no name
+ unless ($self->{"_R_EVENT"}) {
+ OS_Error;
+ carp "could not create required read event";
+ undef $self;
+ return;
+ }
+
+ $self->{"_W_EVENT"} = CreateEvent($null, # no security
+ 1, # explicit reset req
+ 0, # initial event reset
+ $null); # no name
+ unless ($self->{"_W_EVENT"}) {
+ OS_Error;
+ carp "could not create required write event";
+ undef $self;
+ return;
+ }
+ $self->{"_R_OVERLAP"} = pack($OVERLAPPEDformat,
+ $zero, # osRead_Internal,
+ $zero, # osRead_InternalHigh,
+ $zero, # osRead_Offset,
+ $zero, # osRead_OffsetHigh,
+ $self->{"_R_EVENT"});
+
+ $self->{"_W_OVERLAP"} = pack($OVERLAPPEDformat,
+ $zero, # osWrite_Internal,
+ $zero, # osWrite_InternalHigh,
+ $zero, # osWrite_Offset,
+ $zero, # osWrite_OffsetHigh,
+ $self->{"_W_EVENT"});
+
+ # Device Control Block (DCB)
+ unless ( fetch_DCB ($self) ) {
+ carp "can't read Device Control Block for $self->{NAME}\n";
+ undef $self;
+ return;
+ }
+ $self->{"_L_BAUD"}{$self->{BAUD}} = $self->{BAUD}; # actual must be ok
+
+ # Read Timeouts
+ unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) {
+ carp "Error in GetCommTimeouts";
+ undef $self;
+ return;
+ }
+
+ ($self->{RINT},
+ $self->{RTOT},
+ $self->{RCONST},
+ $self->{WTOT},
+ $self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"});
+
+ bless ($self, $class);
+ return $self;
+}
+
+sub fetch_DCB {
+ my $self = shift;
+ my $ok;
+ my $hr;
+ my $fmask;
+ my $key;
+ my $value;
+ my $dcb = " "x32;
+
+ GetCommState($self->{"_HANDLE"}, $dcb) or return;
+
+ ($self->{"_DCBLength"},
+ $self->{BAUD},
+ $self->{"_BitMask"},
+ $self->{"_ResvWORD"},
+ $self->{XONLIM},
+ $self->{XOFFLIM},
+ $self->{DATA},
+ $self->{"_Parity"},
+ $self->{"_StopBits"},
+ $self->{XONCHAR},
+ $self->{XOFFCHAR},
+ $self->{ERRCHAR},
+ $self->{EOFCHAR},
+ $self->{EVTCHAR},
+ $self->{"_PackWORD"})= unpack($DCBformat, $dcb);
+
+ if ($self->{"_DCBLength"} > 32) {
+ carp "invalid DCB block length";
+ return;
+ }
+
+ if ($Babble) {
+ printf "DCBLength= %d\n", $self->{"_DCBLength"};
+ printf "BaudRate= %d\n", $self->{BAUD};
+ printf "BitMask= %lx\n", $self->{"_BitMask"};
+ printf "ResvWORD= %x\n", $self->{"_ResvWORD"};
+ printf "XonLim= %x\n", $self->{XONLIM};
+ printf "XoffLim= %x\n", $self->{XOFFLIM};
+ printf "ByteSize= %d\n", $self->{DATA};
+ printf "Parity= %d\n", $self->{"_Parity"};
+ printf "StopBits= %d\n", $self->{"_StopBits"};
+ printf "XonChar= %x\n", $self->{XONCHAR};
+ printf "XoffChar= %x\n", $self->{XOFFCHAR};
+ printf "ErrorChar= %x\n", $self->{ERRCHAR};
+ printf "EofChar= %x\n", $self->{EOFCHAR};
+ printf "EvtChar= %x\n", $self->{EVTCHAR};
+ printf "PackWORD= %x\n", $self->{"_PackWORD"};
+ printf "handle= %d\n\n", $self->{"_HANDLE"};
+ }
+
+ $fmask = 1 + $self->{"_StopBits"};
+ while (($key, $value) = each %{ $self->{"_L_STOP"} }) {
+ if ($value == $fmask) {
+ $self->{STOP} = $key;
+ }
+ }
+
+ $fmask = 1 + $self->{"_Parity"};
+ while (($key, $value) = each %{ $self->{"_L_PARITY"} }) {
+ if ($value == $fmask) {
+ $self->{PARITY} = $key;
+ }
+ }
+
+ $fmask = $self->{"_BitMask"};
+
+ $hr = DTR_CONTROL_HANDSHAKE;
+ $ok = RTS_CONTROL_HANDSHAKE;
+
+ if ($fmask & ( $hr << 4) ) {
+ $self->{HSHAKE} = "dtr";
+ }
+ elsif ($fmask & ( $ok << 12) ) {
+ $self->{HSHAKE} = "rts";
+ }
+ elsif ($fmask & ( FM_fOutX | FM_fInX ) ) {
+ $self->{HSHAKE} = "xoff";
+ }
+ else {
+ $self->{HSHAKE} = "none";
+ }
+
+ $self->{BINARY} = ($fmask & FM_fBinary);
+ $self->{PARITY_EN} = ($fmask & FM_fParity);
+
+ if ($fmask & FM_fDummy2) {
+ carp "Unknown DCB Flow Mask Bit in $self->{NAME}";
+ }
+ 1;
+}
+
+sub init_done {
+ my $self = shift;
+ return 0 unless (defined $self->{"_INIT"});
+ return $self->{"_INIT"};
+}
+
+
+sub update_DCB {
+ my $self = shift;
+ my $ok = 0;
+
+ return unless (defined $self->{"_INIT"});
+
+ fetch_DCB ($self);
+
+ if ($self->{"_N_HSHAKE"}) {
+ $self->{HSHAKE} = $self->{"_N_HSHAKE"};
+ if ($self->{HSHAKE} eq "dtr" ) {
+ $self->{"_N_FM_ON"} = 0x1028;
+ $self->{"_N_FM_OFF"} = 0xffffdceb;
+ }
+ elsif ($self->{HSHAKE} eq "rts" ) {
+ $self->{"_N_FM_ON"} = 0x2014;
+ $self->{"_N_FM_OFF"} = 0xffffecd7;
+ }
+ elsif ($self->{HSHAKE} eq "xoff" ) {
+ $self->{"_N_FM_ON"} = 0x1310;
+ $self->{"_N_FM_OFF"} = 0xffffdfd3;
+ }
+ else {
+ $self->{"_N_FM_ON"} = 0x1010;
+ $self->{"_N_FM_OFF"} = 0xffffdcd3;
+ }
+ $self->{"_N_HSHAKE"} = 0;
+ }
+
+ if ($self->{"_N_PARITY_EN"}) {
+ if (2 == $self->{"_N_PARITY_EN"}) {
+ $self->{"_N_FM_ON"} |= FM_fParity; # enable
+ if ($self->{"_N_FM_OFF"}) {
+ $self->{"_N_FM_OFF"} |= FM_fParity;
+ }
+ else { $self->{"_N_FM_OFF"} = LONGsize; }
+ }
+ else {
+ if ($self->{"_N_FM_ON"}) {
+ $self->{"_N_FM_ON"} &= ~FM_fParity; # disable
+ }
+ if ($self->{"_N_FM_OFF"}) {
+ $self->{"_N_FM_OFF"} &= ~FM_fParity;
+ }
+ else { $self->{"_N_FM_OFF"} = ~FM_fParity; }
+ }
+## DEBUG ##
+## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ##
+## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ##
+## DEBUG ##
+ $self->{"_N_PARITY_EN"} = 0;
+ }
+
+## DEBUG ##
+## printf "_N_AUX_ON=%lx\n", $self->{"_N_AUX_ON"}; ## DEBUG ##
+## printf "_N_AUX_OFF=%lx\n", $self->{"_N_AUX_OFF"}; ## DEBUG ##
+## DEBUG ##
+
+ if ( $self->{"_N_AUX_ON"} or $self->{"_N_AUX_OFF"} ) {
+ if ( $self->{"_N_FM_OFF"} ) {
+ $self->{"_N_FM_OFF"} &= $self->{"_N_AUX_OFF"};
+ }
+ else {
+ $self->{"_N_FM_OFF"} = $self->{"_N_AUX_OFF"};
+ }
+ $self->{"_N_FM_ON"} |= $self->{"_N_AUX_ON"};
+ $self->{"_N_AUX_ON"} = 0;
+ $self->{"_N_AUX_OFF"} = 0;
+ }
+## DEBUG ##
+## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ##
+## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ##
+## DEBUG ##
+
+ if ( $self->{"_N_FM_ON"} or $self->{"_N_FM_OFF"} ) {
+ $self->{"_BitMask"} &= $self->{"_N_FM_OFF"};
+ $self->{"_BitMask"} |= $self->{"_N_FM_ON"};
+ $self->{"_N_FM_ON"} = 0;
+ $self->{"_N_FM_OFF"} = 0;
+ }
+
+ if ($self->{"_N_XONLIM"}) {
+ $self->{XONLIM} = $self->{"_N_XONLIM"} - 1;
+ $self->{"_N_XONLIM"} = 0;
+ }
+
+ if ($self->{"_N_XOFFLIM"}) {
+ $self->{XOFFLIM} = $self->{"_N_XOFFLIM"} - 1;
+ $self->{"_N_XOFFLIM"} = 0;
+ }
+
+ if ($self->{"_N_BAUD"}) {
+ $self->{BAUD} = $self->{"_N_BAUD"};
+ $self->{"_N_BAUD"} = 0;
+ }
+
+ if ($self->{"_N_DATA"}) {
+ $self->{DATA} = $self->{"_N_DATA"};
+ $self->{"_N_DATA"} = 0;
+ }
+
+ if ($self->{"_N_STOP"}) {
+ $self->{"_StopBits"} = $self->{"_N_STOP"} - 1;
+ $self->{"_N_STOP"} = 0;
+ }
+
+ if ($self->{"_N_PARITY"}) {
+ $self->{"_Parity"} = $self->{"_N_PARITY"} - 1;
+ $self->{"_N_PARITY"} = 0;
+ }
+
+ if ($self->{"_N_XONCHAR"}) {
+ $self->{XONCHAR} = $self->{"_N_XONCHAR"} - 1;
+ $self->{"_N_XONCHAR"} = 0;
+ }
+
+ if ($self->{"_N_XOFFCHAR"}) {
+ $self->{XOFFCHAR} = $self->{"_N_XOFFCHAR"} - 1;
+ $self->{"_N_XOFFCHAR"} = 0;
+ }
+
+ if ($self->{"_N_ERRCHAR"}) {
+ $self->{ERRCHAR} = $self->{"_N_ERRCHAR"} - 1;
+ $self->{"_N_ERRCHAR"} = 0;
+ }
+
+ if ($self->{"_N_EOFCHAR"}) {
+ $self->{EOFCHAR} = $self->{"_N_EOFCHAR"} - 1;
+ $self->{"_N_EOFCHAR"} = 0;
+ }
+
+ if ($self->{"_N_EVTCHAR"}) {
+ $self->{EVTCHAR} = $self->{"_N_EVTCHAR"} - 1;
+ $self->{"_N_EVTCHAR"} = 0;
+ }
+
+ my $dcb = pack($DCBformat,
+ $self->{"_DCBLength"},
+ $self->{BAUD},
+ $self->{"_BitMask"},
+ $self->{"_ResvWORD"},
+ $self->{XONLIM},
+ $self->{XOFFLIM},
+ $self->{DATA},
+ $self->{"_Parity"},
+ $self->{"_StopBits"},
+ $self->{XONCHAR},
+ $self->{XOFFCHAR},
+ $self->{ERRCHAR},
+ $self->{EOFCHAR},
+ $self->{EVTCHAR},
+ $self->{"_PackWORD"});
+
+ if ( SetCommState($self->{"_HANDLE"}, $dcb) ) {
+ print "updated DCB for $self->{NAME}\n" if ($Babble);
+## DEBUG ##
+## printf "DEBUG BitMask= %lx\n", $self->{"_BitMask"}; ## DEBUG ##
+## DEBUG ##
+ }
+ else {
+ carp "SetCommState failed";
+ OS_Error;
+ if ($Babble) {
+ printf "\ntried to write:\n";
+ printf "DCBLength= %d\n", $self->{"_DCBLength"};
+ printf "BaudRate= %d\n", $self->{BAUD};
+ printf "BitMask= %lx\n", $self->{"_BitMask"};
+ printf "ResvWORD= %x\n", $self->{"_ResvWORD"};
+ printf "XonLim= %x\n", $self->{XONLIM};
+ printf "XoffLim= %x\n", $self->{XOFFLIM};
+ printf "ByteSize= %d\n", $self->{DATA};
+ printf "Parity= %d\n", $self->{"_Parity"};
+ printf "StopBits= %d\n", $self->{"_StopBits"};
+ printf "XonChar= %x\n", $self->{XONCHAR};
+ printf "XoffChar= %x\n", $self->{XOFFCHAR};
+ printf "ErrorChar= %x\n", $self->{ERRCHAR};
+ printf "EofChar= %x\n", $self->{EOFCHAR};
+ printf "EvtChar= %x\n", $self->{EVTCHAR};
+ printf "PackWORD= %x\n", $self->{"_PackWORD"};
+ printf "handle= %d\n", $self->{"_HANDLE"};
+ }
+ }
+}
+
+sub initialize {
+ my $self = shift;
+ my $item;
+ my $fault = 0;
+ foreach $item (@_) {
+ unless (exists $self->{"_N_$item"}) {
+ # must be "exists" so undef=not_settable
+ $fault++;
+ nocarp or carp "Missing REQUIRED setting for $item";
+ }
+ }
+ unless ($self->{"_INIT"}) {
+ $self->{"_INIT"} = 1 unless ($fault);
+ $self->{"_BitMask"} = 0x1011;
+ $self->{XONLIM} = 100 unless ($self->{"_N_XONLIM"});
+ $self->{XOFFLIM} = 100 unless ($self->{"_N_XOFFLIM"});
+ $self->{XONCHAR} = 0x11 unless ($self->{"_N_XONCHAR"});
+ $self->{XOFFCHAR} = 0x13 unless ($self->{"_N_XOFFCHAR"});
+ $self->{ERRCHAR} = 0 unless ($self->{"_N_ERRCHAR"});
+ $self->{EOFCHAR} = 0 unless ($self->{"_N_EOFCHAR"});
+ $self->{EVTCHAR} = 0 unless ($self->{"_N_EVTCHAR"});
+
+ update_timeouts($self);
+ }
+
+ if ($self->{"_N_READBUF"} or $self->{"_N_WRITEBUF"}) {
+ if ($self->{"_N_READBUF"}) {
+ $self->{READBUF} = $self->{"_N_READBUF"};
+ }
+ if ($self->{"_N_WRITEBUF"}) {
+ $self->{WRITEBUF} = $self->{"_N_WRITEBUF"};
+ }
+ $self->{"_N_READBUF"} = 0;
+ $self->{"_N_WRITEBUF"} = 0;
+ SetupComm($self->{"_HANDLE"}, $self->{READBUF}, $self->{WRITEBUF});
+ }
+ purge_all($self);
+ return $fault;
+}
+
+sub is_status {
+ my $self = shift;
+ my $ok = 0;
+ my $error_p = " "x4;
+ my $CommStatus = " "x12;
+
+ if (@_ and $testactive) {
+ $self->{"_LATCH"} |= shift;
+ }
+
+ $ok=ClearCommError($self->{"_HANDLE"}, $error_p, $CommStatus);
+
+ my $Error_BitMask = unpack("L", $error_p);
+ $self->{"_LATCH"} |= $Error_BitMask;
+ my @stat = unpack($COMSTATformat, $CommStatus);
+ push @stat, $self->{"_LATCH"};
+
+ $stat[ST_BLOCK] &= BM_AllBits;
+ if ( $Babble or $self->{"_DEBUG_C"} ) {
+ printf "Blocking Bits= %d\n", $stat[ST_BLOCK];
+ printf "Input Queue= %d\n", $stat[ST_INPUT];
+ printf "Output Queue= %d\n", $stat[ST_OUTPUT];
+ printf "Latched Errors= %d\n", $stat[ST_ERROR];
+ printf "ok= %d\n", $ok;
+ }
+ return ($ok ? @stat : undef);
+}
+
+sub reset_error {
+ my $self = shift;
+ my $was = $self->{"_LATCH"};
+ $self->{"_LATCH"} = 0;
+ return $was;
+}
+
+sub can_baud {
+ my $self = shift;
+ return $self->{"_C_BAUD"};
+}
+
+sub can_databits {
+ my $self = shift;
+ return $self->{"_C_DATA"};
+}
+
+sub can_stopbits {
+ my $self = shift;
+ return $self->{"_C_STOP"};
+}
+
+sub can_dtrdsr {
+ my $self = shift;
+ return $self->{"_C_DTRDSR"};
+}
+
+sub can_handshake {
+ my $self = shift;
+ return $self->{"_C_HSHAKE"};
+}
+
+sub can_parity_check {
+ my $self = shift;
+ return $self->{"_C_PARITY_CK"};
+}
+
+sub can_parity_config {
+ my $self = shift;
+ return $self->{"_C_PARITY_CFG"};
+}
+
+sub can_parity_enable {
+ my $self = shift;
+ return $self->{"_C_PARITY_EN"};
+}
+
+sub can_rlsd_config {
+ my $self = shift;
+ return $self->{"_C_RLSD_CFG"};
+}
+
+sub can_rlsd {
+ my $self = shift;
+ return $self->{"_C_RLSD"};
+}
+
+sub can_16bitmode {
+ my $self = shift;
+ return $self->{"_C_16BITMODE"};
+}
+
+sub is_rs232 {
+ my $self = shift;
+ return ($self->{"_TYPE"} == PST_RS232);
+}
+
+sub is_modem {
+ my $self = shift;
+ return ($self->{"_TYPE"} == PST_MODEM);
+}
+
+sub can_rtscts {
+ my $self = shift;
+ return $self->{"_C_RTSCTS"};
+}
+
+sub can_xonxoff {
+ my $self = shift;
+ return $self->{"_C_XONXOFF"};
+}
+
+sub can_xon_char {
+ my $self = shift;
+ return $self->{"_C_XON_CHAR"};
+}
+
+sub can_spec_char {
+ my $self = shift;
+ return $self->{"_C_SPECHAR"};
+}
+
+sub can_interval_timeout {
+ my $self = shift;
+ return $self->{"_C_INT_TIME"};
+}
+
+sub can_total_timeout {
+ my $self = shift;
+ return $self->{"_C_TOT_TIME"};
+}
+
+sub is_handshake {
+ my $self = shift;
+ if (@_) {
+ return unless $self->{"_C_HSHAKE"};
+ return unless (defined $self->{"_L_HSHAKE"}{$_[0]});
+ $self->{"_N_HSHAKE"} = $self->{"_L_HSHAKE"}{$_[0]};
+ update_DCB ($self);
+ }
+ return unless fetch_DCB ($self);
+ return $self->{HSHAKE};
+}
+
+sub are_handshake {
+ my $self = shift;
+ return unless $self->{"_C_HSHAKE"};
+ return if (@_);
+ return keys(%{$self->{"_L_HSHAKE"}});
+}
+
+sub is_baudrate {
+ my $self = shift;
+ if (@_) {
+ return unless $self->{"_C_BAUD"};
+ return unless (defined $self->{"_L_BAUD"}{$_[0]});
+ $self->{"_N_BAUD"} = int shift;
+ update_DCB ($self);
+ }
+ return unless fetch_DCB ($self);
+ return $self->{BAUD};
+}
+
+sub are_baudrate {
+ my $self = shift;
+ return unless $self->{"_C_BAUD"};
+ return if (@_);
+ return keys(%{$self->{"_L_BAUD"}});
+}
+
+sub is_parity {
+ my $self = shift;
+ if (@_) {
+ return unless $self->{"_C_PARITY_CFG"};
+ return unless (defined $self->{"_L_PARITY"}{$_[0]});
+ $self->{"_N_PARITY"} = $self->{"_L_PARITY"}{$_[0]};
+ update_DCB ($self);
+ }
+ return unless fetch_DCB ($self);
+ return $self->{PARITY};
+}
+
+sub are_parity {
+ my $self = shift;
+ return unless $self->{"_C_PARITY_CFG"};
+ return if (@_);
+ return keys(%{$self->{"_L_PARITY"}});
+}
+
+sub is_databits {
+ my $self = shift;
+ if (@_) {
+ return unless $self->{"_C_DATA"};
+ return unless (defined $self->{"_L_DATA"}{$_[0]});
+ $self->{"_N_DATA"} = $self->{"_L_DATA"}{$_[0]};
+ update_DCB ($self);
+ }
+ return unless fetch_DCB ($self);
+ return $self->{DATA};
+}
+
+sub are_databits {
+ my $self = shift;
+ return unless $self->{"_C_DATA"};
+ return if (@_);
+ return keys(%{$self->{"_L_DATA"}});
+}
+
+sub is_stopbits {
+ my $self = shift;
+ if (@_) {
+ return unless $self->{"_C_STOP"};
+ return unless (defined $self->{"_L_STOP"}{$_[0]});
+ $self->{"_N_STOP"} = $self->{"_L_STOP"}{$_[0]};
+ update_DCB ($self);
+ }
+ return unless fetch_DCB ($self);
+ return $self->{STOP};
+}
+
+sub are_stopbits {
+ my $self = shift;
+ return unless $self->{"_C_STOP"};
+ return if (@_);
+ return keys(%{$self->{"_L_STOP"}});
+}
+
+# single value for save/start
+sub is_read_buf {
+ my $self = shift;
+ if (@_) { $self->{"_N_READBUF"} = int shift; }
+ return $self->{READBUF};
+}
+
+# single value for save/start
+sub is_write_buf {
+ my $self = shift;
+ if (@_) { $self->{"_N_WRITEBUF"} = int shift; }
+ return $self->{WRITEBUF};
+}
+
+sub is_buffers {
+ my $self = shift;
+
+ return unless (@_ == 2);
+ my $rbuf = shift;
+ my $wbuf = shift;
+ SetupComm($self->{"_HANDLE"}, $rbuf, $wbuf) or return;
+ $self->{"_N_READBUF"} = 0;
+ $self->{"_N_WRITEBUF"} = 0;
+ $self->{READBUF} = $rbuf;
+ $self->{WRITEBUF} = $wbuf;
+ 1;
+}
+
+sub read_bg {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $wanted = shift;
+ return unless ($wanted > 0);
+ if ($self->{"_R_BUSY"}) {
+ nocarp or carp "Second Read attempted before First is done";
+ return;
+ }
+ my $got_p = " "x4;
+ my $ok;
+ my $got = 0;
+ if ($wanted > $RBUF_Size) {
+ $wanted = $RBUF_Size;
+ warn "read buffer limited to $RBUF_Size bytes at the moment";
+ }
+ $self->{"_R_BUSY"} = 1;
+
+ $ok=ReadFile( $self->{"_HANDLE"},
+ $self->{"_RBUF"},
+ $wanted,
+ $got_p,
+ $self->{"_R_OVERLAP"});
+
+ if ($ok) {
+ $got = unpack("L", $got_p);
+ $self->{"_R_BUSY"} = 0;
+ }
+ return $got;
+}
+
+sub write_bg {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $wbuf = shift;
+ if ($self->{"_W_BUSY"}) {
+ nocarp or carp "Second Write attempted before First is done";
+ return;
+ }
+ my $ok;
+ my $got_p = " "x4;
+ return 0 if ($wbuf eq "");
+ my $lbuf = length ($wbuf);
+ my $written = 0;
+ $self->{"_W_BUSY"} = 1;
+
+ $ok=WriteFile( $self->{"_HANDLE"},
+ $wbuf,
+ $lbuf,
+ $got_p,
+ $self->{"_W_OVERLAP"});
+
+ if ($ok) {
+ $written = unpack("L", $got_p);
+ $self->{"_W_BUSY"} = 0;
+ }
+ if ($Babble) {
+ print "error=$ok\n";
+ print "wbuf=$wbuf\n";
+ print "lbuf=$lbuf\n";
+ print "write_bg=$written\n";
+ }
+ return $written;
+}
+
+sub read_done {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $wait = yes_true ( shift );
+ my $ov;
+ my $got_p = " "x4;
+ my $wanted = 0;
+ $self->{"_R_BUSY"} = 1;
+
+ $ov=GetOverlappedResult( $self->{"_HANDLE"},
+ $self->{"_R_OVERLAP"},
+ $got_p,
+ $wait);
+ if ($ov) {
+ $wanted = unpack("L", $got_p);
+ $self->{"_R_BUSY"} = 0;
+ print "read_done=$wanted\n" if ($Babble);
+ return (1, $wanted, substr($self->{"_RBUF"}, 0, $wanted));
+ }
+ return (0, 0, "");
+}
+
+sub write_done {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $wait = yes_true ( shift );
+ my $ov;
+ my $got_p = " "x4;
+ my $written = 0;
+ $self->{"_W_BUSY"} = 1;
+
+ $ov=GetOverlappedResult( $self->{"_HANDLE"},
+ $self->{"_W_OVERLAP"},
+ $got_p,
+ $wait);
+ if ($ov) {
+ $written = unpack("L", $got_p);
+ $self->{"_W_BUSY"} = 0;
+ print "write_done=$written\n" if ($Babble);
+ return (1, $written);
+ }
+ return (0, $written);
+}
+
+sub purge_all {
+ my $self = shift;
+ return if (@_);
+
+ # PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR
+ unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000f) ) {
+ carp "Error in PurgeComm";
+ OS_Error;
+ return;
+ }
+ $self->{"_R_BUSY"} = 0;
+ $self->{"_W_BUSY"} = 0;
+ return 1;
+}
+
+sub purge_rx {
+ my $self = shift;
+ return if (@_);
+
+ # PURGE_RXABORT | PURGE_RXCLEAR
+ unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000a) ) {
+ OS_Error;
+ carp "Error in PurgeComm";
+ return;
+ }
+ $self->{"_R_BUSY"} = 0;
+ return 1;
+}
+
+sub purge_tx {
+ my $self = shift;
+ return if (@_);
+
+ # PURGE_TXABORT | PURGE_TXCLEAR
+ unless ( PurgeComm($self->{"_HANDLE"}, 0x00000005) ) {
+ OS_Error;
+ carp "Error in PurgeComm";
+ return;
+ }
+ $self->{"_W_BUSY"} = 0;
+ return 1;
+}
+
+sub are_buffers {
+ my $self = shift;
+ return if (@_);
+ return ($self->{READBUF}, $self->{WRITEBUF});
+}
+
+sub buffer_max {
+ my $self = shift;
+ return if (@_);
+ return ($self->{"_RBUFMAX"}, $self->{"_TBUFMAX"});
+}
+
+sub suspend_tx {
+ my $self = shift;
+ return if (@_);
+ return SetCommBreak($self->{"_HANDLE"});
+}
+
+sub resume_tx {
+ my $self = shift;
+ return if (@_);
+ return ClearCommBreak($self->{"_HANDLE"});
+}
+
+sub xmit_imm_char {
+ my $self = shift;
+ return unless (@_ == 1);
+ my $v = int shift;
+ unless ( TransmitCommChar($self->{"_HANDLE"}, $v) ) {
+ carp "Can't transmit char: $v";
+ return;
+ }
+ 1;
+}
+
+sub is_xon_char {
+ my $self = shift;
+ if ((@_ == 1) and $self->{"_C_XON_CHAR"}) {
+ $self->{"_N_XONCHAR"} = 1 + shift;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{XONCHAR};
+}
+
+sub is_xoff_char {
+ my $self = shift;
+ if ((@_ == 1) and $self->{"_C_XON_CHAR"}) {
+ $self->{"_N_XOFFCHAR"} = 1 + shift;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{XOFFCHAR};
+}
+
+sub is_eof_char {
+ my $self = shift;
+ if ((@_ == 1) and $self->{"_C_SPECHAR"}) {
+ $self->{"_N_EOFCHAR"} = 1 + shift;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{EOFCHAR};
+}
+
+sub is_event_char {
+ my $self = shift;
+ if ((@_ == 1) and $self->{"_C_SPECHAR"}) {
+ $self->{"_N_EVTCHAR"} = 1 + shift;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{EVTCHAR};
+}
+
+sub is_error_char {
+ my $self = shift;
+ if ((@_ == 1) and $self->{"_C_SPECHAR"}) {
+ $self->{"_N_ERRCHAR"} = 1 + shift;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{ERRCHAR};
+}
+
+sub is_xon_limit {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_XONXOFF"});
+ my $v = int shift;
+ return if (($v < 0) or ($v > SHORTsize));
+ $self->{"_N_XONLIM"} = ++$v;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{XONLIM};
+}
+
+sub is_xoff_limit {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_XONXOFF"});
+ my $v = int shift;
+ return if (($v < 0) or ($v > SHORTsize));
+ $self->{"_N_XOFFLIM"} = ++$v;
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ return $self->{XOFFLIM};
+}
+
+sub is_read_interval {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_INT_TIME"});
+ my $v = int shift;
+ return if (($v < 0) or ($v > LONGsize));
+ if ($v == LONGsize) {
+ $self->{"_N_RINT"} = $v; # Win32 uses as flag
+ }
+ else {
+ $self->{"_N_RINT"} = ++$v;
+ }
+ return unless update_timeouts ($self);
+ }
+ return $self->{RINT};
+}
+
+sub is_read_char_time {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_TOT_TIME"});
+ my $v = int shift;
+ return if (($v < 0) or ($v >= LONGsize));
+ $self->{"_N_RTOT"} = ++$v;
+ return unless update_timeouts ($self);
+ }
+ return $self->{RTOT};
+}
+
+sub is_read_const_time {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_TOT_TIME"});
+ my $v = int shift;
+ return if (($v < 0) or ($v >= LONGsize));
+ $self->{"_N_RCONST"} = ++$v;
+ return unless update_timeouts ($self);
+ }
+ return $self->{RCONST};
+}
+
+sub is_write_const_time {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_TOT_TIME"});
+ my $v = int shift;
+ return if (($v < 0) or ($v >= LONGsize));
+ $self->{"_N_WCONST"} = ++$v;
+ return unless update_timeouts ($self);
+ }
+ return $self->{WCONST};
+}
+
+sub is_write_char_time {
+ my $self = shift;
+ if (@_) {
+ return unless ($self->{"_C_TOT_TIME"});
+ my $v = int shift;
+ return if (($v < 0) or ($v >= LONGsize));
+ $self->{"_N_WTOT"} = ++$v;
+ return unless update_timeouts ($self);
+ }
+ return $self->{WTOT};
+}
+
+sub update_timeouts {
+ return unless (@_ == 1);
+ my $self = shift;
+ unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) {
+ carp "Error in GetCommTimeouts";
+ return;
+ }
+
+ ($self->{RINT},
+ $self->{RTOT},
+ $self->{RCONST},
+ $self->{WTOT},
+ $self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"});
+
+ if ($self->{"_N_RINT"}) {
+ if ($self->{"_N_RINT"} == LONGsize) {
+ $self->{RINT} = $self->{"_N_RINT"}; # Win32 uses as flag
+ }
+ else {
+ $self->{RINT} = $self->{"_N_RINT"} -1;
+ }
+ $self->{"_N_RINT"} = 0;
+ }
+
+ if ($self->{"_N_RTOT"}) {
+ $self->{RTOT} = $self->{"_N_RTOT"} -1;
+ $self->{"_N_RTOT"} = 0;
+ }
+
+ if ($self->{"_N_RCONST"}) {
+ $self->{RCONST} = $self->{"_N_RCONST"} -1;
+ $self->{"_N_RCONST"} = 0;
+ }
+
+ if ($self->{"_N_WTOT"}) {
+ $self->{WTOT} = $self->{"_N_WTOT"} -1;
+ $self->{"_N_WTOT"} = 0;
+ }
+
+ if ($self->{"_N_WCONST"}) {
+ $self->{WCONST} = $self->{"_N_WCONST"} -1;
+ $self->{"_N_WCONST"} = 0;
+ }
+
+ $self->{"_TIMEOUT"} = pack($TIMEOUTformat,
+ $self->{RINT},
+ $self->{RTOT},
+ $self->{RCONST},
+ $self->{WTOT},
+ $self->{WCONST});
+
+ if ( SetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) {
+ return 1;
+ }
+ else {
+ carp "Error in SetCommTimeouts";
+ return;
+ }
+}
+
+
+ # true/false parameters
+
+sub is_binary {
+ my $self = shift;
+ if (@_) {
+ $self->{"_N_BINARY"} = 1 + yes_true ( shift );
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+ ### printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fBinary);
+}
+
+sub is_parity_enable {
+ my $self = shift;
+ if (@_) {
+ $self->{"_N_PARITY_EN"} = 1 + yes_true ( shift );
+ update_DCB ($self);
+ }
+ return unless fetch_DCB ($self);
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ## DEBUG ##
+ return ($self->{"_BitMask"} & FM_fParity);
+}
+
+sub ignore_null {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fNull;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fNull;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fNull;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fNull);
+}
+
+sub ignore_no_dsr {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fDsrSensitivity;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fDsrSensitivity;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fDsrSensitivity;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fDsrSensitivity);
+}
+
+sub subst_pe_char {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fErrorChar;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fErrorChar;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fErrorChar;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fErrorChar);
+}
+
+sub abort_on_error {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fAbortOnError;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fAbortOnError;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fAbortOnError;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fAbortOnError);
+}
+
+sub output_dsr {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fOutxDsrFlow;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fOutxDsrFlow;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fOutxDsrFlow;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fOutxDsrFlow);
+}
+
+sub output_cts {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fOutxCtsFlow;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fOutxCtsFlow;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fOutxCtsFlow;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fOutxCtsFlow);
+}
+
+sub input_xoff {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fInX;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fInX;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fInX;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fInX);
+}
+
+sub output_xoff {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fOutX;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fOutX;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fOutX;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fOutX);
+}
+
+sub tx_on_xoff {
+ my $self = shift;
+ if (@_) {
+ if ($self->{"_N_AUX_OFF"}) {
+ $self->{"_N_AUX_OFF"} &= ~FM_fTXContinueOnXoff;
+ }
+ else {
+ $self->{"_N_AUX_OFF"} = ~FM_fTXContinueOnXoff;
+ }
+ if ( yes_true ( shift ) ) {
+ $self->{"_N_AUX_ON"} |= FM_fTXContinueOnXoff;
+ }
+ update_DCB ($self);
+ }
+ else {
+ return unless fetch_DCB ($self);
+ }
+## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ###
+ return ($self->{"_BitMask"} & FM_fTXContinueOnXoff);
+}
+
+sub dtr_active {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $onoff = yes_true ( shift ) ? SETDTR : CLRDTR ;
+ return EscapeCommFunction($self->{"_HANDLE"}, $onoff);
+}
+
+sub rts_active {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $onoff = yes_true ( shift ) ? SETRTS : CLRRTS ;
+ return EscapeCommFunction($self->{"_HANDLE"}, $onoff);
+}
+
+ # pulse parameters
+
+sub pulse_dtr_off {
+ return unless (@_ == 2);
+ if ( ($] < 5.005) and ($] >= 5.004) ) {
+ nocarp or carp "\npulse_dtr_off not supported on version $]\n";
+ return;
+ }
+ my $self = shift;
+ my $delay = shift;
+ $self->dtr_active(0) or carp "Did not pulse DTR off";
+ Win32::Sleep($delay);
+ $self->dtr_active(1) or carp "Did not restore DTR on";
+ Win32::Sleep($delay);
+}
+
+sub pulse_rts_off {
+ return unless (@_ == 2);
+ if ( ($] < 5.005) and ($] >= 5.004) ) {
+ nocarp or carp "\npulse_rts_off not supported on version $]\n";
+ return;
+ }
+ my $self = shift;
+ my $delay = shift;
+ $self->rts_active(0) or carp "Did not pulse RTS off";
+ Win32::Sleep($delay);
+ $self->rts_active(1) or carp "Did not restore RTS on";
+ Win32::Sleep($delay);
+}
+
+sub pulse_break_on {
+ return unless (@_ == 2);
+ if ( ($] < 5.005) and ($] >= 5.004) ) {
+ nocarp or carp "\npulse_break_on not supported on version $]\n";
+ return;
+ }
+ my $self = shift;
+ my $delay = shift;
+ $self->break_active(1) or carp "Did not pulse BREAK on";
+ Win32::Sleep($delay);
+ $self->break_active(0) or carp "Did not restore BREAK off";
+ Win32::Sleep($delay);
+}
+
+sub pulse_dtr_on {
+ return unless (@_ == 2);
+ if ( ($] < 5.005) and ($] >= 5.004) ) {
+ nocarp or carp "\npulse_dtr_on not supported on version $]\n";
+ return;
+ }
+ my $self = shift;
+ my $delay = shift;
+ $self->dtr_active(1) or carp "Did not pulse DTR on";
+ Win32::Sleep($delay);
+ $self->dtr_active(0) or carp "Did not restore DTR off";
+ Win32::Sleep($delay);
+}
+
+sub pulse_rts_on {
+ return unless (@_ == 2);
+ if ( ($] < 5.005) and ($] >= 5.004) ) {
+ nocarp or carp "\npulse_rts_on not supported on version $]\n";
+ return;
+ }
+ my $self = shift;
+ my $delay = shift;
+ $self->rts_active(1) or carp "Did not pulse RTS on";
+ Win32::Sleep($delay);
+ $self->rts_active(0) or carp "Did not restore RTS off";
+ Win32::Sleep($delay);
+}
+
+sub break_active {
+ return unless (@_ == 2);
+ my $self = shift;
+ my $onoff = yes_true ( shift ) ? SETBREAK : CLRBREAK ;
+ return EscapeCommFunction($self->{"_HANDLE"}, $onoff);
+}
+
+sub xon_active {
+ return unless (@_ == 1);
+ my $self = shift;
+ return EscapeCommFunction($self->{"_HANDLE"}, SETXON);
+}
+
+sub xoff_active {
+ return unless (@_ == 1);
+ my $self = shift;
+ return EscapeCommFunction($self->{"_HANDLE"}, SETXOFF);
+}
+
+sub is_modemlines {
+ return unless (@_ == 1);
+ my $self = shift;
+ my $mstat = " " x4;
+ unless ( GetCommModemStatus($self->{"_HANDLE"}, $mstat) ) {
+ carp "Error in GetCommModemStatus";
+ return;
+ }
+ my $result = unpack ("L", $mstat);
+ return $result;
+}
+
+sub debug_comm {
+ my $self = shift;
+ if (ref($self)) {
+ if (@_) { $self->{"_DEBUG_C"} = yes_true ( shift ); }
+ else {
+ nocarp or carp "Debug level: $self->{NAME} = $self->{\"_DEBUG_C\"}";
+ return $self->{"_DEBUG_C"};
+ }
+ } else {
+ $Babble = yes_true ($self);
+ nocarp or carp "CommPort Debug Class = $Babble";
+ return $Babble;
+ }
+}
+
+sub close {
+ my $self = shift;
+ my $ok;
+ my $success = 1;
+
+ return unless (defined $self->{NAME});
+
+ if ($Babble) {
+ carp "Closing $self " . $self->{NAME};
+ }
+ if ($self->{"_HANDLE"}) {
+ purge_all ($self);
+ update_timeouts ($self); # if any running ??
+ $ok=CloseHandle($self->{"_HANDLE"});
+ if (! $ok) {
+ print "Error Closing handle $self->{\"_HANDLE\"} for $self->{NAME}\n";
+ OS_Error;
+ $success = 0;
+ }
+ elsif ($Babble) {
+ print "Closing Device handle $self->{\"_HANDLE\"} for $self->{NAME}\n";
+ }
+ $self->{"_HANDLE"} = undef;
+ }
+ if ($self->{"_R_EVENT"}) {
+ $ok=CloseHandle($self->{"_R_EVENT"});
+ if (! $ok) {
+ print "Error closing Read Event handle $self->{\"_R_EVENT\"} for $self->{NAME}\n";
+ OS_Error;
+ $success = 0;
+ }
+ $self->{"_R_EVENT"} = undef;
+ }
+ if ($self->{"_W_EVENT"}) {
+ $ok=CloseHandle($self->{"_W_EVENT"});
+ if (! $ok) {
+ print "Error closing Write Event handle $self->{\"_W_EVENT\"} for $self->{NAME}\n";
+ OS_Error;
+ $success = 0;
+ }
+ $self->{"_W_EVENT"} = undef;
+ }
+ $self->{NAME} = undef;
+ if ($Babble) {
+ printf "CommPort close result:%d\n", $success;
+ }
+ return $success;
+}
+
+sub DESTROY {
+ my $self = shift;
+ return unless (defined $self->{NAME});
+
+ if ($Babble or $self->{"_DEBUG_C"}) {
+ print "Destroying $self->{NAME}\n" if (defined $self->{NAME});
+ }
+ $self->close;
+}
+
+1; # so the require or use succeeds
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Win32API::CommPort - Raw Win32 system API calls for serial communications.
+
+=head1 SYNOPSIS
+
+ use Win32; ## not required under all circumstances
+ require 5.003;
+ use Win32API::CommPort qw( :PARAM :STAT 0.19 );
+
+ ## when available ## use Win32API::File 0.07 qw( :ALL );
+
+=head2 Constructors
+
+ $PortObj = new Win32API::CommPort ($PortName, $quiet)
+ || die "Can't open $PortName: $^E\n"; # $quiet is optional
+
+ @required = qw( BAUD DATA STOP );
+ $faults = $PortObj->initialize(@required);
+ if ($faults) { die "Required parameters not set before initialize\n"; }
+
+=head2 Configuration Utility Methods
+
+ set_no_messages(1); # test suite use
+
+ # exported by :PARAM
+ nocarp || carp "Something fishy";
+ $a = SHORTsize; # 0xffff
+ $a = LONGsize; # 0xffffffff
+ $answer = yes_true("choice"); # 1 or 0
+ OS_Error unless ($API_Call_OK); # prints error
+
+ $PortObj->init_done || die "Not done";
+
+ $PortObj->fetch_DCB || die "Not done";
+ $PortObj->update_DCB || die "Not done";
+
+ $milliseconds = $PortObj->get_tick_count;
+
+=head2 Capability Methods (read only)
+
+ # true/false capabilities
+ $a = $PortObj->can_baud; # else fixed
+ $a = $PortObj->can_databits;
+ $a = $PortObj->can_stopbits;
+ $a = $PortObj->can_dtrdsr;
+ $a = $PortObj->can_handshake;
+ $a = $PortObj->can_parity_check;
+ $a = $PortObj->can_parity_config;
+ $a = $PortObj->can_parity_enable;
+ $a = $PortObj->can_rlsd; # receive line signal detect (carrier)
+ $a = $PortObj->can_rlsd_config;
+ $a = $PortObj->can_16bitmode;
+ $a = $PortObj->is_rs232;
+ $a = $PortObj->is_modem;
+ $a = $PortObj->can_rtscts;
+ $a = $PortObj->can_xonxoff;
+ $a = $PortObj->can_xon_char;
+ $a = $PortObj->can_spec_char;
+ $a = $PortObj->can_interval_timeout;
+ $a = $PortObj->can_total_timeout;
+
+ # list output capabilities
+ ($rmax, $wmax) = $PortObj->buffer_max;
+ ($rbuf, $wbuf) = $PortObj->are_buffers; # current
+ @choices = $PortObj->are_baudrate; # legal values
+ @choices = $PortObj->are_handshake;
+ @choices = $PortObj->are_parity;
+ @choices = $PortObj->are_databits;
+ @choices = $PortObj->are_stopbits;
+
+=head2 Configuration Methods
+
+ # most methods can be called two ways:
+ $PortObj->is_handshake("xoff"); # set parameter
+ $flowcontrol = $PortObj->is_handshake; # current value (scalar)
+
+ # similar
+ $PortObj->is_baudrate(9600);
+ $PortObj->is_parity("odd");
+ $PortObj->is_databits(8);
+ $PortObj->is_stopbits(1);
+ $PortObj->debug_comm(0);
+ $PortObj->is_xon_limit(100); # bytes left in buffer
+ $PortObj->is_xoff_limit(100); # space left in buffer
+ $PortObj->is_xon_char(0x11);
+ $PortObj->is_xoff_char(0x13);
+ $PortObj->is_eof_char(0x0);
+ $PortObj->is_event_char(0x0);
+ $PortObj->is_error_char(0); # for parity errors
+
+ $rbuf = $PortObj->is_read_buf; # read_only except internal use
+ $wbuf = $PortObj->is_write_buf;
+ $size = $PortObj->internal_buffer;
+
+ $PortObj->is_buffers(4096, 4096); # read, write
+ # returns current in list context
+
+ $PortObj->is_read_interval(100); # max time between read char (millisec)
+ $PortObj->is_read_char_time(5); # avg time between read char
+ $PortObj->is_read_const_time(100); # total = (avg * bytes) + const
+ $PortObj->is_write_char_time(5);
+ $PortObj->is_write_const_time(100);
+
+ $PortObj->is_binary(T); # just say Yes (Win 3.x option)
+ $PortObj->is_parity_enable(F); # faults during input
+
+=head2 Operating Methods
+
+ ($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->is_status
+ || warn "could not get port status\n";
+
+ $ClearedErrorFlags = $PortObj->reset_error;
+ # The API resets errors when reading status, $LatchErrorFlags
+ # is all $ErrorFlags since they were last explicitly cleared
+
+ if ($BlockingFlags) { warn "Port is blocked"; }
+ if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; }
+ if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; }
+
+Additional useful constants may be exported eventually.
+
+ $count_in = $PortObj->read_bg($InBytes);
+ ($done, $count_in, $string_in) = $PortObj->read_done(1);
+ # background read with wait until done
+
+ $count_out = $PortObj->write_bg($output_string); # background write
+ ($done, $count_out) = $PortObj->write_done(0);
+
+ $PortObj->suspend_tx; # output from write buffer
+ $PortObj->resume_tx;
+ $PortObj->xmit_imm_char(0x03); # bypass buffer (and suspend)
+
+ $PortObj->xoff_active; # simulate received xoff
+ $PortObj->xon_active; # simulate received xon
+
+ $PortObj->purge_all;
+ $PortObj->purge_rx;
+ $PortObj->purge_tx;
+
+ # controlling outputs from the port
+ $PortObj->dtr_active(T); # sends outputs direct to hardware
+ $PortObj->rts_active(Yes); # returns status of API call
+ $PortObj->break_active(N); # NOT state of bit
+
+ $PortObj->pulse_break_on($milliseconds); # off version is implausible
+ $PortObj->pulse_rts_on($milliseconds);
+ $PortObj->pulse_rts_off($milliseconds);
+ $PortObj->pulse_dtr_on($milliseconds);
+ $PortObj->pulse_dtr_off($milliseconds);
+ # sets_bit, delays, resets_bit, delays
+ # pulse_xxx methods not supported on Perl 5.004
+
+ $ModemStatus = $PortObj->is_modemlines;
+ if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; }
+
+ $PortObj->close || die;
+ # "undef $PortObj" preferred unless reopening port
+ # "close" should precede "undef" if both used
+
+=head1 DESCRIPTION
+
+This provides fairly low-level access to the Win32 System API calls
+dealing with serial ports.
+
+Uses features of the Win32 API to implement non-blocking I/O, serial
+parameter setting, event-loop operation, and enhanced error handling.
+
+To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>.
+This is expected to change to an empty list reference, C<[]>, when Perl
+supports that form in this usage.
+
+Beyond raw access to the API calls and related constants, this module
+will eventually handle smart buffer allocation and translation of return
+codes.
+
+=head2 Initialization
+
+The constructor is B<new> with a F<PortName> (as the Registry
+knows it) specified. This will do a B<CreateFile>, get the available
+options and capabilities via the Win32 API, and create the object.
+The port is not yet ready for read/write access. First, the desired
+I<parameter settings> must be established. Since these are tuning
+constants for an underlying hardware driver in the Operating System,
+they should all checked for validity by the method calls that set them.
+The B<initialize> method takes a list of required parameters and confirms
+they have been set. For others, it will attempt to deduce defaults from
+the hardware or from other parameters. The B<initialize> method returns
+the number of faults (zero if the port is setup ok). The B<update_DCB>
+method writes a new I<Device Control Block> to complete the startup and
+allow the port to be used. Ports are opened for binary transfers. A
+separate C<binmode> is not needed. The USER must release the object
+if B<initialize> or B<update_DCB> does not succeed.
+
+Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure
+to open a port prints a error message to STDOUT by default. Since only
+one application at a time can "own" the port, one source of failure was
+"port in use". There was previously no way to check this without getting
+a "fail message". Setting C<$quiet> disables this built-in message. It
+also returns 0 instead of C<undef> if the port is unavailable (still FALSE,
+used for testing this condition - other faults may still return C<undef>).
+Use of C<$quiet> only applies to B<new>.
+
+The fault checking in B<initialize> consists in verifying an I<_N_$item>
+internal variable exists for each I<$item> in the input list. The
+I<_N_$item> is created for each parameter that is set either directly
+or by default. A derived class must create the I<_N_$items> for any
+varibles it adds to the base class if it wants B<initialize> to check
+them. Win32API::CommPort supports the following:
+
+ $item _N_$item setting method
+ ------ --------- --------------
+ BAUD "_N_BAUD" is_baudrate
+ BINARY "_N_BINARY" is_binary
+ DATA "_N_DATA" is_databits
+ EOFCHAR "_N_EOFCHAR" is_eof_char
+ ERRCHAR "_N_ERRCHAR" is_error_char
+ EVTCHAR "_N_EVTCHAR" is_event_char
+ HSHAKE "_N_HSHAKE" is_handshake
+ PARITY "_N_PARITY" is_parity
+ PARITY_EN "_N_PARITY_EN" is_parity_enable
+ RCONST "_N_RCONST" is_read_const_time
+ READBUF "_N_READBUF" is_read_buf
+ RINT "_N_RINT" is_read_interval
+ RTOT "_N_RTOT" is_read_char_time
+ STOP "_N_STOP" is_stopbits
+ WCONST "_N_WCONST" is_write_const_time
+ WRITEBUF "_N_WRITEBUF" is_write_buf
+ WTOT "_N_WTOT" is_write_char_time
+ XOFFCHAR "_N_XOFFCHAR" is_xoff_char
+ XOFFLIM "_N_XOFFLIM" is_xoff_limit
+ XONCHAR "_N_XONCHAR" is_xon_char
+ XONLIM "_N_XONLIM" is_xon_limit
+
+Some individual parameters (eg. baudrate) can be changed after the
+initialization is completed. These will automatically update the
+I<Device Control Block> as required. The I<init_done> method indicates
+when I<initialize> has completed successfully.
+
+
+ $PortObj = new Win32API::CommPort ($PortName, $quiet)
+ || die "Can't open $PortName: $^E\n"; # $quiet is optional
+
+ if $PortObj->can_databits { $PortObj->is_databits(8) };
+ $PortObj->is_baudrate(9600);
+ $PortObj->is_parity("none");
+ $PortObj->is_stopbits(1);
+ $PortObj->is_handshake("rts");
+ $PortObj->is_buffers(4096, 4096);
+ $PortObj->dtr_active(T);
+
+ @required = qw( BAUD DATA STOP PARITY );
+ $PortObj->initialize(@required) || undef $PortObj;
+
+ $PortObj->dtr_active(f);
+ $PortObj->is_baudrate(300);
+
+ $PortObj->close || die;
+ # "undef $PortObj" preferred unless reopening port
+ # "close" should precede "undef" if both used
+
+ undef $PortObj; # closes port AND frees memory in perl
+
+The F<PortName> maps to both the Registry I<Device Name> and the
+I<Properties> associated with that device. A single I<Physical> port
+can be accessed using two or more I<Device Names>. But the options
+and setup data will differ significantly in the two cases. A typical
+example is a Modem on port "COM2". Both of these F<PortNames> open
+the same I<Physical> hardware:
+
+ $P1 = new Win32API::CommPort ("COM2");
+
+ $P2 = new Win32API::CommPort ("\\\\.\\Nanohertz Modem model K-9");
+
+$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety
+of modem-specific added options and features. The "raw" API calls return
+different size configuration structures in the two cases. Win32 uses the
+"\\.\" prefix to identify "named" devices. Since both names use the same
+I<Physical> hardware, they can not both be used at the same time. The OS
+will complain. Consider this A Good Thing.
+
+Version 0.16 adds B<pulse> methods for the I<RTS, BREAK, and DTR> bits. The
+B<pulse> methods assume the bit is in the opposite state when the method
+is called. They set the requested state, delay the specified number of
+milliseconds, set the opposite state, and again delay the specified time.
+These methods are designed to support devices, such as the X10 "FireCracker"
+control and some modems, which require pulses on these lines to signal
+specific events or data. Since the 5.00402 Perl distribution from CPAN does
+not support sub-second time delays readily, these methods are not supported
+on that version of Perl.
+
+ $PortObj->pulse_break_on($milliseconds);
+ $PortObj->pulse_rts_on($milliseconds);
+ $PortObj->pulse_rts_off($milliseconds);
+ $PortObj->pulse_dtr_on($milliseconds);
+ $PortObj->pulse_dtr_off($milliseconds);
+
+Version 0.16 also adds I<experimental> support for the rest of the option bits
+available through the I<Device Control Block>. They have not been extensively
+tested and these settings are NOT saved in the B<configuration file> by
+I<Win32::SerialPort>. Please let me know if one does not work as advertised.
+[Win32 API bit designation]
+
+ $PortObj->ignore_null(0); # discard \000 bytes on input [fNull]
+
+ $PortObj->ignore_no_dsr(0); # discard input bytes unless DSR
+ # [fDsrSensitivity]
+
+ $PortObj->subst_pe_char(0); # replace parity errors with B<is_error_char>
+ # when B<is_parity_enable> [fErrorChar]
+
+ $PortObj->abort_on_error(0); # cancel read/write [fAbortOnError]
+
+ # next one set by $PortObj->is_handshake("dtr");
+ $PortObj->output_dsr(0); # use DSR handshake on output [fOutxDsrFlow]
+
+ # next one set by $PortObj->is_handshake("rts");
+ $PortObj->output_cts(0); # use CTS handshake on output [fOutxCtsFlow]
+
+ # next two set by $PortObj->is_handshake("xoff");
+ $PortObj->input_xoff(0); # use Xon/Xoff handshake on input [fInX]
+ $PortObj->output_xoff(0); # use Xon/Xoff handshake on output [fOutX]
+
+ $PortObj->tx_on_xoff(0); # continue output even after input xoff sent
+ # [fTXContinueOnXoff]
+
+The B<get_tick_count> method is a wrapper around the I<Win32::GetTickCount()>
+function. It matches a corresponding method in I<Device::SerialPort> which
+does not have access to the I<Win32::> namespace. It still returns time
+in milliseconds - but can be used in cross-platform scripts.
+
+=head2 Configuration and Capability Methods
+
+The Win32 Serial Comm API provides extensive information concerning
+the capabilities and options available for a specific port (and
+instance). "Modem" ports have different capabilties than "RS-232"
+ports - even if they share the same Hardware. Many traditional modem
+actions are handled via TAPI. "Fax" ports have another set of options -
+and are accessed via MAPI. Yet many of the same low-level API commands
+and data structures are "common" to each type ("Modem" is implemented
+as an "RS-232" superset). In addition, Win95 supports a variety of
+legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN,
+16-data-bit paths, and 256Kbaud.
+
+=over 8
+
+Binary selections will accept as I<true> any of the following:
+C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case)
+Anything else is I<false>.
+
+There are a large number of possible configuration and option parameters.
+To facilitate checking option validity in scripts, most configuration
+methods can be used in two different ways:
+
+=item method called with an argument
+
+The parameter is set to the argument, if valid. An invalid argument
+returns I<false> (undef) and the parameter is unchanged. After B<init_done>,
+the port will be updated immediately if allowed. Otherwise, the value
+will be applied when B<update_DCB> is called.
+
+=item method called with no argument in scalar context
+
+The current value is returned. If the value is not initialized either
+directly or by default, return "undef" which will parse to I<false>.
+For binary selections (true/false), return the current value. All
+current values from "multivalue" selections will parse to I<true>.
+Current values may differ from requested values until B<init_done>.
+There is no way to see requests which have not yet been applied.
+Setting the same parameter again overwrites the first request. Test
+the return value of the setting method to check "success".
+
+=item Asynchronous (Background) I/O
+
+This version now handles Polling (do if Ready), Synchronous (block until
+Ready), and Asynchronous Modes (begin and test if Ready) with the timeout
+choices provided by the API. No effort has yet been made to interact with
+Windows events. But background I/O has been used successfully with the
+Perl Tk modules and callbacks from the event loop.
+
+=item Timeouts
+
+The API provides two timing models. The first applies only to reading and
+essentially determines I<Read Not Ready> by checking the time between
+consecutive characters. The B<ReadFile> operation returns if that time
+exceeds the value set by B<is_read_interval>. It does this by timestamping
+each character. It appears that at least one character must by received in
+I<every> B<read> I<call to the API> to initialize the mechanism. The timer
+is then reset by each succeeding character. If no characters are received,
+the read will block indefinitely.
+
+Setting B<is_read_interval> to C<0xffffffff> will do a non-blocking read.
+The B<ReadFile> returns immediately whether or not any characters are
+actually read. This replicates the behavior of the API.
+
+The other model defines the total time allowed to complete the operation.
+A fixed overhead time is added to the product of bytes and per_byte_time.
+A wide variety of timeout options can be defined by selecting the three
+parameters: fixed, each, and size.
+
+Read_Total = B<is_read_const_time> + (B<is_read_char_time> * bytes_to_read)
+
+Write_Total = B<is_write_const_time> + (B<is_write_char_time> * bytes_to_write)
+
+When reading a known number of characters, the I<Read_Total> mechanism is
+recommended. This mechanism I<MUST> be used with
+I<Win32::SerialPort tied FileHandles> because the tie methods can make
+multiple internal API calls. The I<Read_Interval> mechanism is suitable for
+a B<read_bg> method that expects a response of variable or unknown size. You
+should then also set a long I<Read_Total> timeout as a "backup" in case
+no bytes are received.
+
+=back
+
+=head2 Exports
+
+Nothing is exported by default. The following tags can be used to have
+large sets of symbols exported:
+
+=over 4
+
+=item :PARAM
+
+Utility subroutines and constants for parameter setting and test:
+
+ LONGsize SHORTsize nocarp yes_true
+ OS_Error internal_buffer
+
+=item :STAT
+
+Serial communications status constants. Included are the constants for
+ascertaining why a transmission is blocked:
+
+ BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold
+ BM_fXoffSent BM_fEof BM_fTxim BM_AllBits
+
+Which incoming bits are active:
+
+ MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON
+
+What hardware errors have been detected:
+
+ CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME
+ CE_BREAK CE_TXFULL CE_MODE
+
+Offsets into the array returned by B<status:>
+
+ ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR
+
+=item :RAW
+
+The constants and wrapper methods for low-level API calls. Details of
+these methods may change with testing. Some may be inherited from
+Win32API::File when that becomes available.
+
+ $result=ClearCommError($handle, $Error_BitMask_p, $CommStatus);
+ $result=ClearCommBreak($handle);
+ $result=SetCommBreak($handle);
+ $result=GetCommModemStatus($handle, $ModemStatus);
+ $result=GetCommProperties($handle, $CommProperties);
+ $result=GetCommState($handle, $DCB_Buffer);
+ $result=SetCommState($handle, $DCB_Buffer);
+ $result=SetupComm($handle, $in_buf_size, $out_buf_size);
+ $result=ReadFile($handle, $buffer, $wanted, $got, $template);
+ $result=WriteFile($handle, $buffer, $size, $count, $template);
+
+ $result=GetCommTimeouts($handle, $CommTimeOuts);
+ $result=SetCommTimeouts($handle, $CommTimeOuts);
+ $result=EscapeCommFunction($handle, $Func_ID);
+ $result=GetCommConfig($handle, $CommConfig, $Size);
+ $result=SetCommConfig($handle, $CommConfig, $Size);
+ $result=PurgeComm($handle, $flags);
+
+ $result=GetCommMask($handle, $Event_Bitmask);
+ $result=SetCommMask($handle, $Event_Bitmask);
+ $hEvent=CreateEvent($security, $reset_req, $initial, $name);
+ $handle=CreateFile($file, $access, $share, $security,
+ $creation, $flags, $template);
+ $result=CloseHandle($handle);
+ $result=ResetEvent($hEvent);
+ $result=TransmitCommChar($handle, $char);
+ $result=WaitCommEvent($handle, $Event_Bitmask, $lpOverlapped);
+ $result=GetOverlappedResult($handle, $lpOverlapped, $count, $bool);
+
+Flags used by B<PurgeComm:>
+
+ PURGE_TXABORT PURGE_RXABORT PURGE_TXCLEAR PURGE_RXCLEAR
+
+Function IDs used by EscapeCommFunction:
+
+ SETXOFF SETXON SETRTS CLRRTS
+ SETDTR CLRDTR SETBREAK CLRBREAK
+
+Events used by B<WaitCommEvent:>
+
+ EV_RXCHAR EV_RXFLAG EV_TXEMPTY EV_CTS
+ EV_DSR EV_RLSD EV_BREAK EV_ERR
+ EV_RING EV_PERR EV_RX80FULL EV_EVENT1
+ EV_EVENT2
+
+Errors specific to B<GetOverlappedResult:>
+
+ ERROR_IO_INCOMPLETE ERROR_IO_PENDING
+
+=item :COMMPROP
+
+The constants for the I<CommProperties structure> returned by
+B<GetCommProperties>. Included mostly for completeness.
+
+ BAUD_USER BAUD_075 BAUD_110 BAUD_134_5
+ BAUD_150 BAUD_300 BAUD_600 BAUD_1200
+ BAUD_1800 BAUD_2400 BAUD_4800 BAUD_7200
+ BAUD_9600 BAUD_14400 BAUD_19200 BAUD_38400
+ BAUD_56K BAUD_57600 BAUD_115200 BAUD_128K
+
+ PST_FAX PST_LAT PST_MODEM PST_PARALLELPORT
+ PST_RS232 PST_RS422 PST_X25 PST_NETWORK_BRIDGE
+ PST_RS423 PST_RS449 PST_SCANNER PST_TCPIP_TELNET
+ PST_UNSPECIFIED
+
+ PCF_INTTIMEOUTS PCF_PARITY_CHECK PCF_16BITMODE
+ PCF_DTRDSR PCF_SPECIALCHARS PCF_RLSD
+ PCF_RTSCTS PCF_SETXCHAR PCF_TOTALTIMEOUTS
+ PCF_XONXOFF
+
+ SP_BAUD SP_DATABITS SP_HANDSHAKING SP_PARITY
+ SP_RLSD SP_STOPBITS SP_SERIALCOMM SP_PARITY_CHECK
+
+ DATABITS_5 DATABITS_6 DATABITS_7 DATABITS_8
+ DATABITS_16 DATABITS_16X
+
+ STOPBITS_10 STOPBITS_15 STOPBITS_20
+
+ PARITY_SPACE PARITY_NONE PARITY_ODD PARITY_EVEN
+ PARITY_MARK
+
+ COMMPROP_INITIALIZED
+
+=item :DCB
+
+The constants for the I<Device Control Block> returned by B<GetCommState>
+and updated by B<SetCommState>. Again, included mostly for completeness.
+But there are some combinations of "FM_f" settings which are not currently
+supported by high-level commands. If you need one of those, please report
+the lack as a bug.
+
+ CBR_110 CBR_300 CBR_600 CBR_1200
+ CBR_2400 CBR_4800 CBR_9600 CBR_14400
+ CBR_19200 CBR_38400 CBR_56000 CBR_57600
+ CBR_115200 CBR_128000 CBR_256000
+
+ DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE DTR_CONTROL_HANDSHAKE
+ RTS_CONTROL_DISABLE RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE
+ RTS_CONTROL_TOGGLE
+
+ EVENPARITY MARKPARITY NOPARITY ODDPARITY
+ SPACEPARITY
+
+ ONESTOPBIT ONE5STOPBITS TWOSTOPBITS
+
+ FM_fBinary FM_fParity FM_fOutxCtsFlow
+ FM_fOutxDsrFlow FM_fDtrControl FM_fDsrSensitivity
+ FM_fTXContinueOnXoff FM_fOutX FM_fInX
+ FM_fErrorChar FM_fNull FM_fRtsControl
+ FM_fAbortOnError FM_fDummy2
+
+=item :ALL
+
+All of the above. Except for the I<test suite>, there is not really a good
+reason to do this.
+
+=back
+
+=head1 NOTES
+
+The object returned by B<new> is NOT a I<Filehandle>. You
+will be disappointed if you try to use it as one.
+
+e.g. the following is WRONG!!____C<print $PortObj "some text";>
+
+I<Win32::SerialPort> supports accessing ports via I<Tied Filehandles>.
+
+An important note about Win32 filenames. The reserved device names such
+as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence
+I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>.
+
+This module uses Win32::API extensively. The raw API calls are B<very>
+unforgiving. You will certainly want to start perl with the B<-w> switch.
+If you can, B<use strict> as well. Try to ferret out all the syntax and
+usage problems BEFORE issuing the API calls (many of which modify tuning
+constants in hardware device drivers....not where you want to look for bugs).
+
+Thanks to Ken White for testing on NT.
+
+=head1 KNOWN LIMITATIONS
+
+The current version of the module has been designed for testing using
+the ActiveState and Core (GS 5.004_02) ports of Perl for Win32 without
+requiring a compiler or using XS. In every case, compatibility has been
+selected over performance. Since everything is (sometimes convoluted but
+still pure) Perl, you can fix flaws and change limits if required. But
+please file a bug report if you do. This module has been tested with
+each of the binary perl versions for which Win32::API is supported: AS
+builds 315, 316, and 500-509 and GS 5.004_02. It has only been tested on
+Intel hardware.
+
+=over 4
+
+=item Tutorial
+
+With all the options, this module needs a good tutorial. It doesn't
+have a complete one yet. A I<"How to get started"> tutorial appeared
+B<The Perl Journal #13> (March 1999). The demo programs are a good
+starting point for additional examples.
+
+=item Buffers
+
+The size of the Win32 buffers are selectable with B<is_buffers>. But each read
+method currently uses a fixed internal buffer of 4096 bytes. This can be
+changed in the module source. The read-only B<internal_buffer> method will
+give the current size. There are other fixed internal buffers as well. But
+no one has needed to change those. The XS version will support dynamic buffer
+sizing.
+
+=item Modems
+
+Lots of modem-specific options are not supported. The same is true of
+TAPI, MAPI. I<API Wizards> are welcome to contribute.
+
+=item API Options
+
+Lots of options are just "passed through from the API". Some probably
+shouldn't be used together. The module validates the obvious choices when
+possible. For something really fancy, you may need additional API
+documentation. Available from I<Micro$oft Pre$$>.
+
+=back
+
+=head1 BUGS
+
+ActiveState ports of Perl for Win32 before build 500 do not support the
+tools for building extensions and so will not support later versions of
+this extension. In particular, the automated install and test scripts in
+this distribution work differently with ActiveState builds 3xx.
+
+There is no parameter checking on the "raw" API calls. You probably should
+be familiar with using the calls in "C" before doing much experimenting.
+
+On Win32, a port must B<close> before it can be reopened again by the same
+process. If a physical port can be accessed using more than one name (see
+above), all names are treated as one. The perl script can also be run
+multiple times within a single batch file or shell script. The I<Makefile.PL>
+spawns subshells with backticks to run the test suite on Perl 5.003 - ugly,
+but it works.
+
+On NT, a B<read_done> or B<write_done> returns I<False> if a background
+operation is aborted by a purge. Win95 returns I<True>.
+
+EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005.
+It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV.
+
+A few NT systems seem to set B<can_parity_enable> true, but do not actually
+support setting B<is_parity_enable>. This may be a characteristic of certain
+third-party serial drivers. Or a Microsoft bug. I have not been able to
+reproduce it on my system.
+
+__Please send comments and bug reports to wcbirthisel@alum.mit.edu.
+
+=head1 AUTHORS
+
+Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/.
+
+Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/.
+
+=head1 SEE ALSO
+
+Wi32::SerialPort - High-level user interface/front-end for this module
+
+Win32API::File I<when available>
+
+Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/
+
+Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial
+
+=head1 COPYRIGHT
+
+Copyright (C) 1999, Bill Birthisel. All rights reserved.
+
+This module is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=head2 COMPATIBILITY
+
+Most of the code in this module has been stable since version 0.12.
+Except for items indicated as I<Experimental>, I do not expect functional
+changes which are not fully backwards compatible. However, Version 0.16
+removes the "dummy (0, 1) list" which was returned by many binary methods
+in case they were called in list context. I do not know of any use outside
+the test suite for that feature.
+
+Version 0.12 added an I<Install.PL> script to put modules into the documented
+Namespaces. The script uses I<MakeMaker> tools not available in
+ActiveState 3xx builds. Users of those builds will need to install
+differently (see README). Programs in the test suite are modified for
+the current version. Additions to the configurtion files generated by
+B<save> prevent those created by Version 0.15 from being used by earlier
+Versions. 4 November 1999.
+
+=cut
Index: tags/V0.5.1/perl/lib/Win32/SerialPort.pm
===================================================================
--- tags/V0.5.1/perl/lib/Win32/SerialPort.pm (revision 0)
+++ tags/V0.5.1/perl/lib/Win32/SerialPort.pm (revision 810)
@@ -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
Index: tags/V0.5.1/perl/InstallPackages.bat
===================================================================
--- tags/V0.5.1/perl/InstallPackages.bat (revision 0)
+++ tags/V0.5.1/perl/InstallPackages.bat (revision 810)
@@ -0,0 +1,25 @@
+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
+rem eall ppm install Image::Size
+call ppm install Win32::MultiMedia::Joystick
+call ppm install Image-ExifTool
+
+echo done
Index: tags/V0.5.1/translate.pl
===================================================================
--- tags/V0.5.1/translate.pl (revision 0)
+++ tags/V0.5.1/translate.pl (revision 810)
@@ -0,0 +1,815 @@
+#!/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
+# 2009-10-24 0.3.0 rw NC 0.17
+# 2010-02-10 0.4.0 rw Grid, Stick, SerialChannel, ExternControl, Event engine
+# 2010-02-15 0.4.1 rw FctKey, RC-Channel
+# 2010-03-20 0.4.2 rw Servo configuration
+# 2010-09-09 0.4.3 rw GeoMaptool
+#
+###############################################################################
+
+$Version{'translate.pl'} = "0.4.3 - 2010-09-09";
+
+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_07" => "Nick Servo",
+ "Analog_08" => "Roll Servo",
+ "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",