WebSVN - Projects - Path Comparison - /MissionCockpit/ Rev 462 and /MissionCockpit/ Rev 463

Ignore whitespace Rev 462 → Rev 463

 /MissionCockpit/tags/V0.2.0/INSTALL.TXT
 ,0 → 1,280
+. Allemeine Hinweise
+Bevor Mission Cockpit verwendet werden kann müssen einige Vorbereitungen gewissenhaft durchgeführt werden.
+Das kann einige Zeit in Anspruch nehmen. Nehmt euch die Zeit oder lasst es gleich bleiben ;-)
+Aber glaubt mir, der Zeitaufwand ist es wert!
+Also bitte die folgenden Punkte unbedingt durchlesen, verstehen und gewissenhaft umsetzen!
+Beachte die Regeln für den Betrieb von ferngesteuerten Flugmodellen!
+. Update von früheren Programm-Versionen
+Einstellungen werden in der Datei mkcockpit.xml gespeichert.
+Mit neueren Programmversionen sind neue Konfigurationseinträge dazugekommen, für die es
+momentan keine Default-Einstellungen gibt, die aber vom Programm unbedingt benötigt werden.
+Deswegen muss eine vorhandene mkcockpit.xml mit der bei der jeweiligen Programmversion beiliegenden
+mkcockpit.xml manuell gemerged werden. Das kann mit einem beliebigen Editor erfolgen,
+komfortabel geht es mit WinMerge (www.winmerge.org).
+. Perl Interpreter
+Mission Cockpit ist in der Scriptsprache Perl/Tk programmiert.
+Zur Ausführung des Programms wird Perl Version 5.10.0 benoetigt.
+Mit Version 5.8. hat das Packet "thread::Queue" nicht richtig funktioniert.
+Mission Cockpit ist nicht als EXE-File verfuegbar.
+Den Perl Interpreter fuer Windows bekommt man z.B. hier: http://www.activestate.com/activeperl
+Mission Cockpit benoetigt folgende Perl-Packete:
+        Tk
+        Tk::Balloon
+        Tk::Dialog
+        Tk::Notebook;
+        Math::Trig
+        XML::Simple        # http://search.cpan.org/dist/XML-Simple-2.18
+        Geo::Ellipsoid     # http://search.cpan.org/dist/Geo-Ellipsoid-1.12
+        threads            # http://search.cpan.org/~jdhedden/threads-1.72
+        threads::shared    # http://search.cpan.org/~jdhedden/threads-shared-1.28
+        Thread::Queue      # http://search.cpan.org/dist/Thread-Queue-2.11
+        Time::HiRes        # http://search.cpan.org/~jhi/Time-HiRes-1.9719
+        Win32::SerialPort  # http://search.cpan.org/dist/Win32-SerialPort
+Die Packete liegen, bis auf Tk, in der Mission Cockpit Umgebung im Verzeichnis "perl"
+Sie werden verwendet, falls sie im standard Perl-Verzeichnis nicht existieren.
+Die Packete kann man sich alternativ auch aus dem CPAN beschaffen.
+Tk kann man mit dem Perl-Packet-Manager PPM.EXE installieren, z.B. "ppm install Tk"
+. Unterstuetzte Betriebssysteme
+Das Programm wurde unter Windows Vista und Windows XP entwickelt.
+Bis auf das verwendete Packet "Win32::SerialPort" sollte das Mission Cockpit auch unter Linux funktionieren.
+Fuer Linux gibt es das Packet "Device::Serialport" mit der gleichen Schnittstelle.
+mkcomm.pl und track.pl sind fuer "Device::Serialport" vorbereitet, sollte theoretisch
+auch unter Linux laufen. Ausprobiert habe ich das allerdings nicht!!
+. Programmstart
+mkcockpit.pl   bzw.  perl mkcockpit.pl
+. Voraussetzung Flight-Ctr und Navi-Ctrl
+Entwickelt wurde mit FC 0.73d und NC 0.15c
+NC-Versionen kleiner als 0.15c funktionieren nicht, wegen der ständig inkompatiblen Änderungen
+des Debug- und Navidata-Datensatzes der NC.
+. Karte fuer das Flugfeld definieren
+Die Karte fuer das Flugfeld muss als GIF-Datei vorliegen. Sie kann eine beliebige Größe haben.
+Die Karten werden im Verzeichnis "map" abgelegt.
+Die Karte kann eine beliebige Ausrichtung haben. Norden muss nicht oben sein.
+Als Quelle eignet sich z.B. ein Screenschot von Google Earth.
+In map/map.pl koennen ein oder mehrere Karten definiert werden.
+Die Auswahl der gewuenschten Karte erfolgt im Konfigurations-Dialog, Reiter "Karte"
+Fuer jede Karte wird in map.pl eine Sektion angelegt, z.B.:
+    Hemhofen => {
+        'Name' => "Hemhofen",
+        'Size_X' => '800',
+        'Size_Y' => '600',
+        'File' => 'hemhofen-800.gif',
+        'P1_x' => '66',               # calibration P1, P2
+        'P1_y' => '62',
+        'P2_x' => '778',
+        'P2_y' => '488',
+        'P1_Lat' => '49.685333',
+        'P1_Lon' => '10.950134',
+        'P2_Lat' => '49.682949',
+        'P2_Lon' => '10.944580',
+        'Border' => [ 555, 430,       # airfield border
+, 555,
+, 555,
+, 300,
+, 260,
+, 94,
+, 130,
+, 300,
+, 400,
+, 470,
+, 515,
+, 420,
+                    ],
+        },
+Unbedingt auf die richtige Syntax achten (Kommata, geschweifte Klammern, eckige Klammern),
+sonst gibt es Syntax-Fehler beim Programmstart.
+'Border' ist ein Polygon, der als Flugfeldbegrenzung auf der Karte angezeigt wird.
+Die Koordinaten sind Pixel-Koordinaten bezogen auf das GIF-Hintergrundbild.
+Der Ursprung 0/0 ist links oben.
+Der Border-Polygon kann auch komplett weggelassen werden.
+Später möchte ich noch eine Logik programmieren, die das Setzen der Wegpunkte nur innerhalb
+des Polygons erlaubt.
+. Kalibirieren der Karte
+Die Karte muss gewissenhaft kalibiriert werden!
+Dazu werden bei der zu kalibrierenden Karte in "map/map.pl" fuer zwei
+markante Punkte P1, P2 die Pixel-Koordinaten und die dazugehoerigen GPS-Koordinaten eingetragen.
+P1 und P2 sollten moeglichst weit auseinader liegen, z.B. P1 links oben und P2 rechts unten.
+Man kann zunaechst beliebige Werte eintragen und dann das Programm starten.
+Die Pixel-Koordinaten werden in der Statuszeile angezeigt, wenn man mit der linken Maustaste auf
+die Karte klickt. Die entsprechnden GPS-Koordinaten kann man z.B. im Google Earth ermitteln.
+Anmerkung:
+Da ist scheinbar ein kleiner Bug in der Kalibrierung. Der Punkt P1 muss oberhalb und links von P2 liegen.
+. Daten-Link zum MK
+Das Programm benoetigt unbedingt einen stabilen Daten-Link zum Debug-Port der Navi-Ctrl.
+Das WI.232 Modul hat sich bei mir auch bei grosser Entfernung (250 m) als zuverlaessig erwiesen.
+Kommuniziert wird ausschliesslich mit der Navi-Ctrl.
+Es werden OSD- und Debug-Datensatz von der NC, Target- und Waypoint-Datensatz zur NC verwendet.
+. Konfiguration
+Die Konfiguration wird in mkcockpit.xml gespeichert.
+Konfigurieren kann man im Mission Cockpit, Menu "Datei -> Einstellungen".
+ALternativ kann man die XML-Datei auch direkt editieren.
+Bei Konfiguration im Mission Cockpit ist zu beachten, dass die meisten Einstellungen erst bei
+Programm-Neustart wirksam werden!
+Um einen guten Kontrast zwischen der Karte und den auf die Karte gezeichneten Objekte zu erhalten
+kann es erforderlich sein, die Farbe der Objekte umzudefinieren.
+Die Farben koennen im Konfigurations-Dialog eingestellt werden. Gueltige Werte sind:
+- Namen, z.B. red, green, blue, ...
+- RGB Hex-Werte, z.B. #ff0000  (= rot)
+. Waypoint-Fliegen - Klassische Art von der NC gesteuert
+Waypoints werden per rechter Maustaste gesetzt und sofort an den MK uebertragen.
+Waypoints kann man per Drag/Drop mit der linken Maustaste verschieben. Die Waypoint-Verbindungslinien
+werden dann rot angezeigt. Das bedeutet, dass die angezeigten Wegpunkte nicht mehr mit den bereits zum
+MK uebertragenen Wegpunkten uebereistimmen. Die Waypoints muessen dann per rechtem Maustaste-Menue
+"Alle Wegpunkte erneut senden" an den MK uebertragen werden.
+Der MK beginnt die Waypoints abzufliegen, wenn per RC-Fernsteuerung der "Coming Home" Modus aktiviert wird.
+Nach dem letzten Wegpunkt fliegt der MK automatisch zur Home-Position zurueck.
+Die Navi-Ctrl kann max. 20 Wegpunkte aufnehmen.
+Das Wegpunkt-Fliegen kann unterbrochen werden, indem per RC von "Coming Home" auf "Position Hold"
+geschaltet wird. Wenn dann wieder auf Coming Home" geschaltet wird faengt der MK wieder von vorne mit
+dem ersten Waypoint an.
+. Waypoint Player - Die innovative Art vom Mission Cockpit gesteuert
+Das klassische vom NC gesteuerte Waypoint-Fliegen ist relativ unflexibel und wird relativ schnell langweilig.
+Deswegen habe ich einen vom Mission Cockpit gesteuerten Waypoint-Player implementiert.
+Der Waypoint-Player sendet ständig Target-Datensätze an den MK, ähnlich wie beim Follow-Me oder Follow-Bär.
+Damit hat man wesentlich mehr Möglichkeiten:
+- Beliebig viele Waypoints
+- Die Steuerung  des Wp-Players erfolgt wie bei einem CD-Player:
+     >    Starten des Waypoint-Players
+          Key: Leertaste
+     ||   Pause - Der MK bleibt an der momentanen Position stehen. Mit ">" kann der WP-Flug fortgesetzt werden
+          Key: Leertaste
+     >>   Anfliegen des nächsten Wegpunktes
+          Key: n
+     <<   Anfliegen des vorherigen Wegpunktes
+          Key: p
+     |<<  Anfliegen des ersten Wegpunktes
+          Key: f
+     >>|  Anfliegen des letzten Wegpunktes
+          Key: l
+     Home Anfliegen der Home-Position
+          Key: h
+     Stop Beenden des Waypoint-Players. Der klassische Waypoint-Modus wird wieder aktiviert.
+          Key: s
+  Die Steuerung erfolgt entweder mit:
+  - Maus und die am unteren Bildschirmrand eingeblendeten Symbole
+  - Tastatur - Tastenbelegung siehe oben
+  - Einer programmierbaren PC-Fernbedienung, die Tastatureingaben simuliert.
+    Ich verwende z.B. eine X10-Fernbedienung, die oft Medion-PCs zur Steuerung des MediaCenter beiliegt,
+    in Verbindung mit EventGhost (www.eventghost.org).
+Zum Fliegen mit dem Waypoint-Player muss sich der MK im "Coming Home"-Modus befinden, so
+wie auch beim normalen WP-Fliegen, und zusätzlich mit  ">" gestartet werden.
+Der Waypoint-Player arbeitet, wenn in der Modus-Anzeige "Play" oder "Pause" angezeigt wird.
+Der Waypoint-Player kann bereits im PH-Modus mit ">" gestartet werden.
+Nach Umschalten auf CH fängt der Waypoint-Player an die Zielkoordinaten zu senden und abzufliegen.
+Da der Waypoint-Player immer nur den nächsten Waypoint an den MK überträgt kann die Waypoint-Liste noch
+geändert werden oder neue Waypoints hinzugefügt werden, während der MK bereits die Liste abfliegt.
+Eine erneute Übertragung der WP-Liste an den MK wie beim "normalen" WP-Fliegen ist nicht erforderlich.
+Ärgerlich ist, dass der MK bei Empfang eines Target-Datensatzes kurz piept. Da die Target-Datensätze
+x pro Sekunde übertragen werden ist das sehr nervig. Ich habe deswegen den Piepser mit einem Stück
+Klebeband abgeklebt. Er ist dadurch im Flug zwar nicht mehr zu höhren, aber eigentlich braucht man
+das auch nicht, weil die relevanten Daten im Mission Cockpit angezeigt werden.
+Da der MK im Waypoint-Player Modus die Zielkoordinaten ständig neu gesendet bekommt ist eine stabile
+Datenübertragung umso wichtiger! Falls der Daten-Link doch einmal versagen sollte kehrt der MK nach 60 sec
+Holdtime automatiosch zur Home-Position zurück.
+Der Waypoint-Player verwendet die gleichen Waypoint-Listen wie beim normalen WP-Fliegen.
+. Wegpunkte von Datei Laden/Speichern
+Wegpunkte können als XML-Datei gespeichert und wieder geladen werden.
+Die x/y Pixelkoordinaten werden nun relativ bezogen auf die Größe des Bildes als Fließkommazahlen im
+Bereich 0..1 gespeichert. Damit ist es möglich, eine Waypoint-Liste auch auf einer größeren oder kleineren
+Karte zu laden.
+Beim Laden werden die GPS-Koordinaten für die aktuelle Karte aus den x/y Pixelkoordinaten neu berechnet.
+Somit kann man die für eine Karte erstellten Wegpunkte auch auf einer anderen Karte laden, ohne die
+GPS-Koordinaten der Wegpunkte anpassen zu müssen.
+. Follow "Bär"
+Das "Bärchen" kann per Drag/Drop mit der linken Maustaste auf der Karte rumgeschoben werden.
+Der MK fliegt hinterher, wenn er per RC in den "Coming-Home" Modus geschaltet ist.
+Solange der Bär verschoben wird, wird ein mal pro Sekunde ein Target-Datensatz zum MK geschickt.
+. Tracking Antenne
+Im Mission Cockpit ist die Ansteuerung fuer eine horizontale 180 Grad Antennennachfuehrung implementiert.
+Damit kann z.B. die Richtantenne einer Video-Uebertragungsstecke nachgefuehrt werden.
+Dazu wird benoetigt:
+- Pololu Mikro-Servoboard, z.B. http://www.shop.robotikhardware.de/shop/catalog/product_info.php?cPath=65&products_id=118
+  Das Board wird an eine serielle Schnittstelle am PC angeschlossen.
+- Ein Servo, welches mechanisch einen 180 Grad Drehwinkel zulaesst, z.B. MPX Polo Digi 4 / Hitec HS85 oder aehnlich.
+  Das Servo wird ausserhalb der ueblichen Impulslängen angesteuert, um den 180 Grad Drehwinkel zu erreichen.
+Momentan ist lediglich eine horizontale Nachfuehrung implementiert.
+Die Tracking-Antenne wird im Konfgurations-Dialog, Reiter "Tracking Antenne", aktiviert: (Yes/No).
+Bei aktivierter Tracking-Antenne wird links unten ein Richtungsanzeiger der Antenne eingeblendet.
+Mission Cockpit benötigt die GPS-Koordinaten und Kompass-Richtung fuer die Mittelstellung der Antenne.
+Dazu stellt man den MK vor die Antenne, der MK zeigt dabei in die gleiche Richtung wie die Antenne.
+Beim Start der MK-Motore werden die GPS- und Kompass-Daten vom MK als Koordinaten der Groundstation übernommen.
+. Hinweise zum Waypoint Fliegen
+Der MK muss im Free-Modus einwandfrei fliegen. Bei wenig Wind und eingeschaltetem Höhensensor darf
+der MK nur ganz wenig abdriften.
+Der MK muss im Free-Modus sicher beherrscht werden, bevor man sich ans WP-Fliegen wagt.
+Der MK fliegt zwar (fast) von selber, aber in brenzligen Situationen muss man sicher eingreifen können und den
+MK evtl. auch aus großen Entfernungen sicher zurückholen können.
+Meine Erfahrung zeigt, dass 6 Satelliten für einen stabilen PositionHold oder Waypoint-Flug nicht ausreichen.
+Es sollten schon 8 oder mehr Satelliten empfangen werden.
+. Mikrokopter Forum
+http://forum.mikrokopter.de/topic-8404.html
+Feedback könnt ihr gerne ins Form schreiben.
+Viel Spass mit dem Mission Cockpit
+Rainer

 /MissionCockpit/tags/V0.2.0/LICENSE.TXT
 ,0 → 1,36
+Creative Commons Lizenz mit den Zusaetzen (by, nc, sa)
+======================================================
+Es ist Ihnen gestattet:
+    * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen
+    * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen
+Zu den folgenden Bedingungen:
+    * Namensnennung.
+      Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen.
+    * Keine kommerzielle Nutzung.
+      Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden.
+    * Weitergabe unter gleichen Bedingungen.
+      Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten,
+      verändern oder als Grundlage für einen anderen Inhalt verwenden,
+      dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen
+      weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind.
+Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses
+Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden.
+Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung
+des Rechteinhabers dazu erhalten.
+Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt.
+Weitere Details zur Lizenzbestimmung gibt es hier:
+   Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/
+   Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode

 /MissionCockpit/tags/V0.2.0/geserver.pl
 ,0 → 1,208
+#!/usr/bin/perl
+#!/usr/bin/perl -d:ptkdb
+###############################################################################
+#
+# geserver.pl -  Google Earth Server for MK Mission Cockpit
+#
+# Copyright (C) 2009  Rainer Walther  (rainerwalther-mail@web.de)
+#
+# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa)
+#
+# Es ist Ihnen gestattet:
+#     * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen
+#     * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen
+#
+# Zu den folgenden Bedingungen:
+#     * Namensnennung.
+#       Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen.
+#     * Keine kommerzielle Nutzung.
+#       Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden.
+#     * Weitergabe unter gleichen Bedingungen.
+#       Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten,
+#       verändern oder als Grundlage für einen anderen Inhalt verwenden,
+#       dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen
+#       weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind.
+#
+# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses
+# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden.
+#
+# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung
+# des Rechteinhabers dazu erhalten.
+#
+# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt.
+#
+# Weitere Details zur Lizenzbestimmung gibt es hier:
+#   Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/
+#   Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode
+#
+###############################################################################
+#
+# 20090317 0.0.1 rw created
+# 20090401 0.1.0 rw RC1
+#
+###############################################################################
+$Version{'geserver.pl'} = "0.1.0 - 2009-04-01";
+#
+# Parameter
+#
+$port_listen = $Cfg->{'geserver'}->{'HttpPort'};
+use Socket;
+use IO::Select;
+use threads;
+use threads::shared;
+$|  = 1;
+# "Lon, Lat, Alt"
+share (@GeCoords);
+sub GeServer()
+    {
+    local *S;
+    socket     (S, PF_INET   , SOCK_STREAM , getprotobyname('tcp')) or die "couldn't open socket: $!";
+    setsockopt (S, SOL_SOCKET, SO_REUSEADDR, 1);
+    bind       (S, sockaddr_in($port_listen, INADDR_ANY));
+    listen     (S, 5)                                               or die "don't hear anything:  $!";
+    my $ss = IO::Select->new();
+    $ss -> add (*S);
+    while(1)
+        {
+        my @connections_pending = $ss->can_read();
+        foreach (@connections_pending)
+            {
+            my $fh;
+            my $remote = accept($fh, $_);
+            my($port,$iaddr) = sockaddr_in($remote);
+            my $peeraddress = inet_ntoa($iaddr);
+            # memory-leak in threads!!!  Process only one request in parallel
+            # my $t = threads->create(\&new_connection, $fh);
+            &new_connection ($fh);
+            }
+        }
+    }
+sub new_connection
+    {
+    my $fh = shift;
+    binmode $fh;
+    my %req;
+    $req{HEADER}={};
+    my $request_line = <$fh>;
+    my $first_line = "";
+    while ($request_line ne "\r\n")
+        {
+        unless ($request_line)
+            {
+            close $fh;
+            }
+        chomp $request_line;
+        unless ($first_line)
+            {
+            $first_line = $request_line;
+            my @parts = split(" ", $first_line);
+            if (@parts != 3)
+                {
+                close $fh;
+                }
+            $req{METHOD} = $parts[0];
+            $req{OBJECT} = $parts[1];
+            }
+         else
+            {
+            my ($name, $value) = split(": ", $request_line);
+            $name       = lc $name;
+            $req{HEADER}{$name} = $value;
+            }
+        $request_line = <$fh>;
+        }
+    &http_request_handler($fh, \%req);
+    close $fh;
+    }
+sub http_request_handler
+    {
+    my $fh     =   shift;
+    my $req_   =   shift;
+    my %req    =   %$req_;
+    my %header = %{$req{HEADER}};
+    print $fh "HTTP/1.0 200 OK\n";
+    print $fh "Content-Type: application/vnd.google-earth.kml+xml; charset=iso-8859-1\n";
+    print $fh "Connection: close\n\n";
+    # KML Header
+    print $fh <<EOF;
+<?xml version="1.0" encoding="UTF-8"?>
+<kml xmlns="http://earth.google.com/kml/2.2">
+  <Document>
+    <name>Mikrokopter GPS logging</name>
+    <Style id="MK_gps-style">
+      <LineStyle>
+        <color>ff0000ff</color>
+        <width>2</width>
+      </LineStyle>
+    </Style>
+    <Placemark>
+      <name>Flight live</name>
+      <styleUrl>MK_gps-style</styleUrl>
+      <LineString>
+        <tessellate>1</tessellate>
+        <altitudeMode>relativeToGround</altitudeMode>
+        <coordinates>
+EOF
+    # send all KML Coords for each request
+    for $i (0 .. $#GeCoords)
+        {
+        print $fh "$GeCoords[$i]\n";
+        }
+    # KML Trailler
+    print $fh <<EOF;
+        </coordinates>
+      </LineString>
+    </Placemark>
+  </Document>
+</kml>
+EOF
+    # Debug:
+    # print  "Method: $req{METHOD}\n";
+    # print  "Object: $req{OBJECT}\n>";
+    # foreach my $r (keys %header)
+    #    {
+    #    print  $r, " = ", $header{$r} , "\n";
+    #    }
+    }
+;
+__END__

/MissionCockpit/tags/V0.2.0/icon/WpFirst.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpHome.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpLast.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpNext.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpPause.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpPlay.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpPrev.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/WpStop.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/bear_48.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/heart_32.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/heart_48.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/satellite_64.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/target_48.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/icon/waypoint_48.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

 /MissionCockpit/tags/V0.2.0/libmap.pl
 ,0 → 1,189
+#!/usr/bin/perl
+#!/usr/bin/perl -d:ptkdb
+###############################################################################
+#
+# libmap.pl -  Conversion GPS and Map-X/Y Coordinates
+#
+# Copyright (C) 2009  Rainer Walther  (rainerwalther-mail@web.de)
+#
+# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa)
+#
+# Es ist Ihnen gestattet:
+#     * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen
+#     * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen
+#
+# Zu den folgenden Bedingungen:
+#     * Namensnennung.
+#       Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen.
+#     * Keine kommerzielle Nutzung.
+#       Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden.
+#     * Weitergabe unter gleichen Bedingungen.
+#       Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten,
+#       verändern oder als Grundlage für einen anderen Inhalt verwenden,
+#       dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen
+#       weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind.
+#
+# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses
+# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden.
+#
+# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung
+# des Rechteinhabers dazu erhalten.
+#
+# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt.
+#
+# Weitere Details zur Lizenzbestimmung gibt es hier:
+#   Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/
+#   Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode
+#
+###############################################################################
+#
+# 2009-03-06 0.0.1 rw created
+# 2009-04-01 0.1.0 rw RC1
+# 2009-05-13 0.1.1 rw MapGpsAt() added
+#
+###############################################################################
+$Version{'libmap.pl'} = "0.1.1 - 2009-05-13";
+use Geo::Ellipsoid;     # http://search.cpan.org/dist/Geo-Ellipsoid-1.12/lib/Geo/Ellipsoid.pm
+require "$Cfg->{'map'}->{'MapDir'}/map.pl";   # Landkarte
+#
+# Convert GPS (Lat,Lon) to pixel coordinates in map
+#
+sub MapGps2XY ()
+    {
+    my ($Lat, $Lon, $Bearing) = @_;
+    # Aktuell gültige Karte
+    my %Map = %{$Maps{'Current'}};
+    my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees',
+                                       'distance_units' => 'meter',
+                                       'ellipsoid' => 'WGS84',
+                                                                     );
+    # P1 -> P2: Entfernung und Richtung
+    my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} );
+    my $dx_p = $Map{'P2_x'} - $Map{'P1_x'};
+    my $dy_p = $Map{'P2_y'} - $Map{'P1_y'};
+    my $P1P2_Dist_p = sqrt($dx_p*$dx_p + $dy_p*$dy_p);
+    my $PixRes = $P1P2_Dist_m / $P1P2_Dist_p ;        # 1 Pixel = $PixRes Meter
+    my $Phi = rad2deg atan ($dy_p / $dx_p);
+    my $PhiRef = $P1P2_Bearing - $Phi;                # Winkel zwischen N und Bild-Horizont
+    # P1 -> Target: Entfernung und Richtung
+    my ($T_Dist_m, $T_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Lat, $Lon );
+    my $Alpha = deg2rad($T_Bearing - $PhiRef);        # Winkel zw. Bild-Horizont und Target
+    my $T_dx_p = cos($Alpha) * $T_Dist_m / $PixRes;
+    my $T_dy_p = sin($Alpha) * $T_Dist_m / $PixRes;
+    my $X_p = $Map{'P1_x'} + $T_dx_p;
+    my $Y_p = $Map{'P1_y'} + $T_dy_p;
+    $Angel = $Bearing - $PhiRef;
+    return ($X_p, $Y_p, $Angel);
+    }
+#
+# Convert pixel coordinates in map to GPS (Lat,Lon)
+#
+sub MapXY2Gps ()
+    {
+    my ($X, $Y) = @_;
+    # Aktuell gültige Karte
+    my %Map = %{$Maps{'Current'}};
+    my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees',
+                                       'distance_units' => 'meter',
+                                       'ellipsoid' => 'WGS84',
+                                     );
+    # P1 -> P2: Entfernung und Richtung
+    my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} );
+    my $dx_p = $Map{'P2_x'} - $Map{'P1_x'};
+    my $dy_p = $Map{'P2_y'} - $Map{'P1_y'};
+    my $P1P2_Dist_p = sqrt($dx_p*$dx_p + $dy_p*$dy_p);
+    my $PixRes = $P1P2_Dist_m / $P1P2_Dist_p ;        # 1 Pixel = $PixRes Meter
+    my $Phi = rad2deg atan ($dy_p / $dx_p);
+    my $PhiRef = $P1P2_Bearing - $Phi;                # Winkel zwischen N und Bild-Horizont
+    my $dx = $X - $Map{'P1_x'};
+    my $dy = $Y - $Map{'P1_y'};
+    my $Phi = rad2deg atan ($dy / $dx);
+    my $Bearing = $PhiRef + $Phi;
+    my $Dist = $PixRes * sqrt($dx*$dx + $dy*$dy);
+    my ($Lat, $Lon) = $Map_Geo->at( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Dist, $Bearing );
+    return ($Lat, $Lon);
+    }
+#
+# Get Bearing, Distance from 2 GPS Points
+#
+sub MapGpsTo()
+    {
+    my ($Lat1, $Lon1, $Lat2, $Lon2) = @_;
+    my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees',
+                                       'distance_units' => 'meter',
+                                       'ellipsoid' => 'WGS84',
+                                     );
+    my ($Dist, $Bearing) = $Map_Geo->to( $Lat1, $Lon1, $Lat2, $Lon2);
+    return ($Dist, $Bearing);
+    }
+#
+# Get Target from GPS-Point, Bearing, Distance
+#
+sub MapGpsAt()
+    {
+    my ($Lat, $Lon, $Dist, $Bearing) = @_;
+    my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees',
+                                       'distance_units' => 'meter',
+                                       'ellipsoid' => 'WGS84',
+                                     );
+    my ($Target_Lat, $Target_Lon) = $Map_Geo->at( $Lat, $Lon, $Dist, $Bearing);
+    return ($Target_Lat, $Target_Lon);
+    }
+# Angel geographic North to Map Horizont
+sub MapAngel()
+    {
+    # Aktuell gültige Karte
+    my %Map = %{$Maps{'Current'}};
+    my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees',
+                                       'distance_units' => 'meter',
+                                       'ellipsoid' => 'WGS84',
+                                     );
+    # P1 -> P2: Entfernung und Richtung
+    my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} );
+    my $dx_p = $Map{'P2_x'} - $Map{'P1_x'};
+    my $dy_p = $Map{'P2_y'} - $Map{'P1_y'};
+    my $Phi = rad2deg atan ($dy_p / $dx_p);
+    my $PhiRef = $P1P2_Bearing - $Phi;                # Winkel zwischen N und Bild-Horizont
+    return ($PhiRef);
+    }
+;
+__END__

 /MissionCockpit/tags/V0.2.0/logging.pl
 ,0 → 1,421
+#!/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 intervav
+#
+###############################################################################
+$Version{'logging.pl'} = "0.1.0 - 2009-04-01";
+#
+# Parameter
+#
+my $LoopTime = $Cfg->{'logging'}->{'Intervall'} || 1;  # in s
+$LoopTime *= 1000000;      # in us
+# Packages
+use threads;
+use threads::shared;
+use Time::HiRes qw(usleep);
+require "mkcomm.pl";     # MK communication
+require "geserver.pl";   # Google Earth Server
+require "translate.pl";  # Übersetzungstable
+#
+# Signal handler
+#
+$SIG{'INT'}  = 'LogSigHandler';
+$SIG{'KILL'} = 'LogSigHandler';
+sub SigHandler()
+    {
+    if ( defined threads->self() )
+        {
+        threads->exit();
+        }
+    exit;
+    }
+my $LogCsvIsOpen = 0;
+my $LogKmlIsOpen = 0;
+my $LogGpxIsOpen = 0;
+my $GeServerIsRunning = 0;
+#
+# CSV
+#
+# Open CSV logfile
+sub LogCsvOpen()
+    {
+    if ( ! $LogCsvIsOpen )
+        {
+        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
+        my $Filename = sprintf ("mk-%04d%02d%02d-%02d%02d%02d.csv", $year+1900, $mon+1, $mday, $hour, $min, $sec);
+        open LOGCSV, ">$Cfg->{'logging'}->{'CsvLogDir'}/$Filename";
+        $LogCsvIsOpen = 1;
+        # print labes at first line
+        # NC OSD
+        my $Sep = "";
+        foreach $Label (sort keys %MkOsd)
+            {
+            if ( $Translate{$Label} ne "" )
+                {
+                $Label = $Translate{$Label};
+                }
+            print LOGCSV "$Sep" . "$Label";
+            $Sep = ",";
+            }
+        # NC Debug
+        foreach $Label (sort keys %MkNcDebug)
+            {
+            if ( $Translate{$Label} ne "" )
+                {
+                $Label = $Translate{$Label};
+                }
+            print LOGCSV "$Sep" . "$Label";
+            }
+        print LOGCSV "\n";
+        }
+    return 0;
+    }
+# Close CSV
+sub LogCsvClose()
+    {
+    if ( $LogCsvIsOpen )
+        {
+        close LOGCSV;
+        $LogCsvIsOpen = 0;
+        }
+    return 0;
+    }
+# Log CSV
+sub LogCsv()
+    {
+    lock %MkOsd;      # until end of Block
+    lock %MkNcDebug;  # until end of Block
+    if ( $MkOsd{'_Timestamp'} >= time-2 )
+        {
+        # active connection to MK
+        &LogCsvOpen();
+        # NC OSD
+        my $Sep = "";
+        foreach $Label (sort keys %MkOsd)
+            {
+            print LOGCSV "$Sep" . "$MkOsd{$Label}";
+            $Sep = ",";
+            }
+        # NC Debug
+        foreach $Label (sort keys %MkNcDebug)
+            {
+            print LOGCSV "$Sep" . "$MkNcDebug{$Label}";
+            }
+        print LOGCSV "\n";
+        }
+    else
+        {
+        # connection to MK lost, close Logfile
+        &LogCsvClose();
+        }
+    return 0;
+    }
+#
+# GPX
+# http://www.topografix.com/gpx_manual.asp
+#
+# Open GPX logfile
+sub LogGpxOpen()
+    {
+    if ( ! $LogGpxIsOpen )
+        {
+        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
+        my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec);
+        my $Filename = "mk-" . $TimeStamp . ".gpx";
+        open LOGGPX, ">$Cfg->{'logging'}->{'GpxLogDir'}/$Filename";
+        $LogGpxIsOpen = 1;
+        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
+        my $UtcTimeStamp = sprintf ("%04d-%02d-%02dT%02d:%02d:%02dZ", $year+1900, $mon+1, $mday, $hour, $min, $sec);
+        # print GPX-Header
+        print LOGGPX <<EOF;
+<?xml version="1.0" encoding="UTF-8"?>
+<gpx
+  version="1.0"
+  creator="MK Mission Cockpit"
+  xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+  xmlns="http://www.topografix.com/GPX/1/0"
+  xsi:schemaLocation="http://www.topografix.com/GPX/1/0 http://www.topografix.com/GPX/1/0/gpx.xsd">
+  <time>${UtcTimeStamp}</time>
+  <trk>
+    <name>Mikrokopter GPS logging</name>
+        <desc>Flight ${TimeStamp}</desc>
+    <trkseg>
+EOF
+        }
+    return 0;
+    }
+# Close GPX
+sub LogGpxClose()
+    {
+    if ( $LogGpxIsOpen )
+        {
+        # print GPX-Trailer
+        print LOGGPX <<EOF;
+    </trkseg>
+  </trk>
+</gpx>
+EOF
+        close LOGGPX;
+        $LogGpxIsOpen = 0;
+        }
+    return 0;
+    }
+# Log GPX
+sub LogGpx()
+    {
+    lock %MkOsd;   # until end of Block
+    if ( $MkOsd{'_Timestamp'} >= time-2  and
+         $MkOsd{'MKFlags'} & 0x02  and  $MkOsd{'CurPos_Stat'} == 1 )
+        {
+        # active connection to MK, MK is flying, valid GPS
+        &LogGpxOpen();
+        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
+        my $UtcTimeStamp = sprintf ("%04d-%02d-%02dT%02d:%02d:%02dZ", $year+1900, $mon+1, $mday, $hour, $min, $sec);
+        my $Speed = $MkOsd{'GroundSpeed'} / 100;  # m/s
+        printf LOGGPX <<EOF;
+      <trkpt lat="$MkOsd{'CurPos_Lat'}" lon="$MkOsd{'CurPos_Lon'}">
+        <ele>$MkOsd{'CurPos_Alt'}</ele>
+        <time>${UtcTimeStamp}</time>
+        <sat>$MkOsd{'SatsInUse'}</sat>
+        <course>$MkOsd{'CompassHeading'}</course>
+        <speed>$Speed</speed>
+        <extensions>
+          <Target-Lat>$MkOsd{'TargetPos_Lat'}</Target-Lat>
+          <Target-Lon>$MkOsd{'TargetPos_Lon'}</Target-Lon>
+          <Target-Alt>$MkOsd{'TargetPos_Alt'}</Target-Alt>
+          <Target-Bearing>$MkOsd{'TargetPosDev_Bearing'}</Target-Bearing>
+          <Target-Dist>$MkOsd{'TargetPosDev_Dist'}</Target-Dist>
+          <Waypoint>$MkOsd{'WaypointIndex'} / $MkOsd{'WaypointNumber'}</Waypoint>
+          <Altimeter>$MkOsd{'Altimeter'}</Altimeter>
+          <Variometer>$MkOsd{'Variometer'}</Variometer>
+          <UBat>$MkOsd{'UBat'}</UBat>
+          <AngleNick>$MkOsd{'AngleNick'}</AngleNick>
+          <AngleRoll>$MkOsd{'AngleRoll'}</AngleRoll>
+          <MKFlags>$MkOsd{'MKFlags'}</MKFlags>
+          <NCFlags>$MkOsd{'NCFlags'}</NCFlags>
+        </extensions>
+      </trkpt>
+EOF
+        }
+    else
+        {
+        &LogGpxClose();
+        }
+    }
+#
+# KML
+# http://code.google.com/intl/de-DE/apis/kml/documentation/kml_tut.html
+#
+# Open KML logfile
+sub LogKmlOpen()
+    {
+    if ( ! $LogKmlIsOpen )
+        {
+        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
+        my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec);
+        my $Filename = "mk-" . $TimeStamp . ".kml";
+        open LOGKML, ">$Cfg->{'logging'}->{'KmlLogDir'}/$Filename";
+        $LogKmlIsOpen = 1;
+        # print KML-Header
+        print LOGKML <<EOF;
+<?xml version="1.0" encoding="UTF-8"?>
+<kml xmlns="http://earth.google.com/kml/2.2">
+  <Document>
+    <name>Mikrokopter GPS logging</name>
+    <Style id="MK_gps-style">
+      <LineStyle>
+        <color>ff0000ff</color>
+        <width>2</width>
+      </LineStyle>
+    </Style>
+    <Placemark>
+      <name>Flight ${TimeStamp}</name>
+      <styleUrl>MK_gps-style</styleUrl>
+      <LineString>
+        <tessellate>1</tessellate>
+        <altitudeMode>relativeToGround</altitudeMode>
+        <coordinates>
+EOF
+        }
+    return 0;
+    }
+# Close KML
+sub LogKmlClose()
+    {
+    if ( $LogKmlIsOpen )
+        {
+        # print KML-Trailer
+        print LOGKML <<EOF;
+        </coordinates>
+      </LineString>
+    </Placemark>
+  </Document>
+</kml>
+EOF
+        close LOGKML;
+        $LogKmlIsOpen = 0;
+        }
+    return 0;
+    }
+# Log KML
+sub LogKml()
+    {
+    lock %MkOsd;   # until end of Block
+    if ( $MkOsd{'_Timestamp'} >= time-2  and
+         $MkOsd{'MKFlags'} & 0x02  and  $MkOsd{'CurPos_Stat'} == 1 )
+        {
+        # active connection to MK, MK is flying, valid GPS
+        &LogKmlOpen();
+        my $AltRel = $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'};
+        if ( $AltRel < 0 ) { $AltRel = 0; }
+        printf LOGKML "          %f, %f, %f\n", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $AltRel;
+        }
+    else
+        {
+        &LogKmlClose();
+        }
+    }
+# Send Coords to GoogleEarth server
+sub Send2GeServer()
+    {
+    lock %MkOsd;   # until end of Block
+    if ( $MkOsd{'_Timestamp'} >= time-2  and
+         $MkOsd{'MKFlags'} & 0x02  and  $MkOsd{'CurPos_Stat'} == 1 )
+        {
+        # active connection to MK, MK is flying, valid GPS
+        my $AltRel = $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'};
+        if ( $AltRel < 0 ) { $AltRel = 0; }
+        push @GeCoords, sprintf "%f, %f, %f", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $AltRel;
+        }
+    }
+sub MkLogLoop()
+    {
+    while (1)
+        {
+        &LogCsv();
+        &LogKml();
+        &LogGpx();
+        &Send2GeServer();  # Google Earth
+        # kurz schlafen legen
+        usleep $LoopTime;
+        }
+    }
+#
+# Hauptprgramm
+#
+if ( $0 =~ /logging.pl$/i )
+    {
+    # Program wurde direkt aufgerufen
+    # Kommunikation zum MK herstellen
+    $mk_thr = threads->create (\&MkCommLoop) -> detach();
+    &MkLogLoop();
+    # should never exit
+    }
+;
+__END__

/MissionCockpit/tags/V0.2.0/map/default-800.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

/MissionCockpit/tags/V0.2.0/map/hemhofen-800.gif
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property

 /MissionCockpit/tags/V0.2.0/map/map.pl
 ,0 → 1,105
+###############################################################################
+#
+# map.pl -  Map definition
+#
+## Copyright (C) 2009  Rainer Walther  (rainerwalther-mail@web.de)
+#
+# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa)
+#
+# Es ist Ihnen gestattet:
+#     * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen
+#     * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen
+#
+# Zu den folgenden Bedingungen:
+#     * Namensnennung.
+#       Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen.
+#     * Keine kommerzielle Nutzung.
+#       Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden.
+#     * Weitergabe unter gleichen Bedingungen.
+#       Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten,
+#       verändern oder als Grundlage für einen anderen Inhalt verwenden,
+#       dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen
+#       weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind.
+#
+# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses
+# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden.
+#
+# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung
+# des Rechteinhabers dazu erhalten.
+#
+# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt.
+#
+# Weitere Details zur Lizenzbestimmung gibt es hier:
+#   Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/
+#   Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode
+#
+###############################################################################
+##
+# 2009-03-06 0.0.1 rw created
+# 2009-04-01 0.1.0 rw RC1
+#
+###############################################################################
+$Version{'map/map.pl'} = "0.1.0 - 2009-04-01";
+%Maps =
+    (
+    Hemhofen => {
+        'Name' => "Hemhofen",
+        'Size_X' => '800',
+        'Size_Y' => '600',
+        'File' => 'hemhofen-800.gif',
+        'P1_x' => '66',               # calibration P1, P2
+        'P1_y' => '62',
+        'P2_x' => '778',
+        'P2_y' => '488',
+        'P1_Lat' => '49.685333',
+        'P1_Lon' => '10.950134',
+        'P2_Lat' => '49.682949',
+        'P2_Lon' => '10.944580',
+        'Border' => [ 555, 430,       # airfield border
+, 555,
+, 555,
+, 300,
+, 260,
+, 94,
+, 130,
+, 300,
+, 400,
+, 470,
+, 515,
+, 420,
+                    ],
+        },
+    Default => {
+        'Name' => "Default",
+        'Size_X' => '800',
+        'Size_Y' => '600',
+        'File' => 'default-800.gif',
+        'P1_x' => '71',               # calibration P1, P2
+        'P1_y' => '472',
+        'P2_x' => '500',
+        'P2_y' => '103',
+        'P1_Lat' => '48.856253',
+        'P1_Lon' => '2.3500000',
+        'P2_Lat' => '54.090153',
+        'P2_Lon' => '12.133249',
+        },
+    );
+# Die verwendete Karte
+my $MapDefault = $Cfg->{'map'}->{'MapDefault'};
+$Maps{'Current'} = $Maps{$MapDefault};
+#
+# Todo: Karte automatisch anhand der aktuellen GPS Position auswählen
+#
+;
+__END__

 /MissionCockpit/tags/V0.2.0/mkcockpit.pl
 ,0 → 1,2131
+#!/usr/bin/perl
+#y!/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
+#
+###############################################################################
+$Version = "0.2.0 - 2009-05-14";
+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 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
+# 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", $Cwd . "perl/site/lib";
+# Version setting
+share (%Version);
+$Version{'mkcockpit.pl'}  = $Version;
+# Read configuration
+$XmlConfigFile = "mkcockpit.xml";
+$Cfg = XMLin($XmlConfigFile);
+require "track.pl";     # Tracking antenna
+require "mkcomm.pl";    # MK communication
+require "logging.pl";   # CSV and GPX Logging
+require "geserver.pl";  # Google Earth Server
+require "$Cfg->{'map'}->{'MapDir'}/map.pl";   # Landkarte
+require "libmap.pl";    # map subs
+require "translate.pl"; # Übersetzungstable
+# 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();
+# Aktuell gültige Karte
+my %Map = %{$Maps{'Current'}};
+# Hauptfenster
+my $main = new MainWindow;
+$main->title ("MK Mission Cockpit");
+#-----------------------------------------------------------------
+# Menu
+#-----------------------------------------------------------------
+# Menu bar
+my $menu_bar = $main->Menu;
+$main->optionAdd("*tearOff", "false");
+$main->configure ('-menu' => $menu_bar);
+my $menu_file = $menu_bar->cascade('-label' => "~Datei");
+    $menu_file->command('-label' => 'Einstellungen',
+                        '-command' => [\&Configure],
+                       );
+    $menu_file->separator;
+    $menu_file->command('-label' => 'Ende',
+                        '-command' => sub{exit(0)},
+                        );
+my $menu_debug = $menu_bar->cascade(-label => "D~ebug");
+    $menu_debug->command('-label' => 'NC ~OSD Datensatz (O)',
+                         '-command' => [\&DisplayHash, \%MkOsd, "NC OSD Datensatz (O)", "Display Refresh Heartbeat"],
+                        );
+    $menu_debug->command('-label' => 'NC ~Target Datensatz (s)',
+                         '-command' => [\&DisplayHash, \%MkTarget, "NC Target Datensatz (s)", "Display Refresh Heartbeat"],
+                        );
+    $menu_debug->command('-label' => 'NC ~Debug Datensatz (D)',
+                         '-command' => [\&DisplayHash, \%MkNcDebug, "NC Debug Datensatz (D)", "Display Refresh Heartbeat"],
+                                        );
+    $menu_debug->command('-label' => 'NC ~Sonstiges',
+                         '-command' => [\&DisplayHash, \%Mk, "NC Sonstiges", "Display Refresh Heartbeat"],
+                                        );
+    $menu_debug->separator;
+    $menu_debug->command('-label' => 'Tracking ~Antenne Debug Datensatz',
+                         '-command' => [\&DisplayHash, \%MkTrack, "Tracking Antenne Debug Datensatz", "Display Refresh Heartbeat"],
+                        );
+my $menu_help = $menu_bar->cascade(-label => "~Hilfe");
+    $menu_help->command('-label' => 'Version',
+                        '-command' => [\&DisplayHash, \%Version, "Version", "Display"],
+                       );
+    $menu_help->separator;
+    $menu_help->command('-label' => 'Über',
+                        '-command' => sub
+        {
+        my $License = <<EOF;
+Copyright (C) 2009  Rainer Walther (rainerwalther-mail\@web.de)
+Creative Commons Lizenz mit den Zusaetzen (by, nc, sa)
+Siehe LICENSE.TXT
+EOF
+        my $DlgAbout = $frame_map->Dialog('-title' => 'Über MK Mission Cockpit',
+                                          '-text' => "$License",
+                                          '-buttons' => ['OK'],
+                                          '-bitmap' => 'info',
+                                         );
+        $DlgAbout->Show;
+        });
+# Hauptfenster Statuszeile
+$frame_status = $main->Frame( '-background' => 'lightgray',
+                         ) -> pack('-side' => 'bottom',
+                                   '-anchor' => 'w',
+                                   '-fill' => 'none',
+                                   '-expand' => 'y',
+                                    );
+$status_line = $frame_status->Label ('-text' => 'Statuszeile',
+                                    ) -> pack ('-side' => 'bottom',
+                                               );
+#-----------------------------------------------------------------
+# Frames
+#-----------------------------------------------------------------
+#
+# Frame: Map
+#
+$frame_map = $main->Frame( '-background' => 'lightgray',
+                           '-relief' => 'sunken',
+                           '-borderwidth' => 5,
+                          ) -> pack('-side' => 'top',
+                                    '-fill' => 'x',
+                                    );
+# Map Überschrift
+$frame_map_top = $frame_map->Frame() -> pack( '-side' => 'top',
+                                              '-expand' => 'x',
+                                              '-anchor' => 'w',
+                                            );
+$frame_map_top->Label ('-text' => "Karte: $Map{'Name'} ($Map{'File'})",
+                       '-background' => 'lightgray',
+                       '-relief' => 'flat',
+                       ) -> pack( '-side' => 'left' );
+# Map Statuszeile
+$map_status = $frame_map->Frame( '-background' => 'lightgray',
+                               ) -> pack('-side' => 'bottom',
+                                         '-anchor' => 'w',
+                                         '-fill' => 'none',
+                                         '-expand' => 'y',
+                                        );
+$map_status_line = $map_status->Label ( '-text' => 'Statuszeile',
+                                        '-background' => 'lightgray',
+                                       ) -> pack ('-side' => 'bottom',);
+# Map Canvas
+# Canvas size
+$MapSizeX  = $Map{'Size_X'};
+$MapSizeY  = $Map{'Size_Y'};
+$map_canvas = $frame_map->Canvas( '-width'  => $MapSizeX,
+                                  '-height' => $MapSizeY,
+                                  '-cursor' => 'cross',
+                                ) -> pack();
+# load Map photo
+$map_canvas->Photo( 'Map',
+                    '-file' => "$Cfg->{'map'}->{'MapDir'}/$Map{'File'}",
+                  );
+$map_canvas->createImage( 0, 0,
+                          '-tags' => 'Map',
+                          '-anchor' => 'nw',
+                          '-image'  => 'Map',
+                        );
+# border polygon
+$map_canvas->createPolygon( @Map{'Border'},
+                           '-tags' => 'Map-Border',
+                           '-fill' => '',
+                           '-outline' => $Cfg->{'mkcockpit'}->{'ColorAirfield'}, '-width' => 2,
+                          );
+# load Heartbeat icon
+$map_canvas->Photo( 'HeartbeatSmall',
+                    '-file' => "$Cfg->{'mkcockpit'}->{'IconHeartSmall'}",
+                  );
+$map_canvas->Photo( 'HeartbeatLarge',
+                    '-file' => "$Cfg->{'mkcockpit'}->{'IconHeartLarge'}",
+                  );
+$map_canvas->createImage( $MapSizeX/4, 10,
+                          '-tags' => 'Heartbeat',
+                          '-anchor' => 'nw',
+                          '-image'  => 'HeartbeatSmall',
+                        );
+# load Satellite icon
+$map_canvas->Photo( 'Satellite-Photo',
+                    '-file' => "$Cfg->{'mkcockpit'}->{'IconSatellite'}",
+                               );
+$map_canvas->createImage($MapSizeX-190, -100,   # hide photo
+                         '-tags' => 'Satellite',
+                         '-anchor' => 'nw',
+                         '-image'  => 'Satellite-Photo',
+                        );
+# load Waypoint icon
+$map_canvas->Photo( 'Waypoint-Photo',
+                    '-file' => "$Cfg->{'mkcockpit'}->{'IconWaypoint'}",
+                  );
+# load Target icon
+$map_canvas->Photo( 'Target-Photo',
+                    '-file' => "$Cfg->{'mkcockpit'}->{'IconTarget'}",
+                  );
+$map_canvas->createImage(0, -100,   # hide photo
+                         '-tags' => 'Target',
+                         '-anchor' => 'nw',
+                         '-image'  => 'Target-Photo',
+                        );
+# load Fox icon
+$map_canvas->Photo( 'Fox-Photo',
+                    '-file' => "$Cfg->{'mkcockpit'}->{'IconFox'}",
+                  );
+$map_canvas->createImage($MapSizeX/2+50, $MapSizeY/2,
+                         '-tags' => 'Fox',
+                         '-anchor' => 'nw',
+                         '-image'  => 'Fox-Photo',
+                        );
+# load WP-Player icons
+$map_canvas->Photo( 'WpPlay-Foto',  '-file' => "$Cfg->{'waypoint'}->{'IconPlay'}");
+$map_canvas->Photo( 'WpStop-Foto',  '-file' => "$Cfg->{'waypoint'}->{'IconStop'}");
+$map_canvas->Photo( 'WpPause-Foto', '-file' => "$Cfg->{'waypoint'}->{'IconPause'}");
+$map_canvas->Photo( 'WpNext-Foto',  '-file' => "$Cfg->{'waypoint'}->{'IconNext'}");
+$map_canvas->Photo( 'WpPrev-Foto',  '-file' => "$Cfg->{'waypoint'}->{'IconPrev'}");
+$map_canvas->Photo( 'WpFirst-Foto', '-file' => "$Cfg->{'waypoint'}->{'IconFirst'}");
+$map_canvas->Photo( 'WpLast-Foto',  '-file' => "$Cfg->{'waypoint'}->{'IconLast'}");
+$map_canvas->Photo( 'WpHome-Foto',  '-file' => "$Cfg->{'waypoint'}->{'IconHome'}");
+$map_canvas->createImage($MapSizeX/2+100, $MapSizeY-48,
+                         '-tags' => 'Wp-PlayPause',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpPlay-Foto',
+                        );
+$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48,
+                         '-tags' => 'Wp-Stop',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpStop-Foto',
+                        );
+$map_canvas->createImage($MapSizeX/2, $MapSizeY-48,
+                         '-tags' => 'Wp-Next',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpNext-Foto',
+                        );
+$map_canvas->createImage($MapSizeX/2-50, $MapSizeY-48,
+                         '-tags' => 'Wp-Prev',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpPrev-Foto',
+                        );
+$map_canvas->createImage($MapSizeX/2-100, $MapSizeY-48,
+                         '-tags' => 'Wp-First',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpFirst-Foto',
+                        );
+$map_canvas->createImage($MapSizeX/2+50, $MapSizeY-48,
+                         '-tags' => 'Wp-Last',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpLast-Foto',
+                        );
+$map_canvas->createImage($MapSizeX/2-150, $MapSizeY-48,
+                         '-tags' => 'Wp-Home',
+                         '-anchor' => 'nw',
+                         '-image'  => 'WpHome-Foto',
+                        );
+# Balloon attached to Canvas
+$map_balloon = $frame_map->Balloon('-statusbar' => $status_line, );
+$map_balloon->attach($map_canvas,
+                     '-balloonposition' => 'mouse',
+                     '-state' => 'balloon',
+                     '-msg' => { 'MK-Arrow' => "MikroKopter",
+                                 'MK-Home-Line' => "Hier gehts nach Hause",
+                                 'MK-Home-Dist' => "Entfernung nach Hause",
+                                 'MK-Target-Line' => "Hier gehts zum Ziel",
+                                 'MK-Target-Dist' => "Entfernung zum Ziel",
+                                 'MK-Speed' => 'Geschwindigkeits-Vektor',
+                                 'Map-Variometer' => 'Variometer',
+                                 'Map-Variometer-Pointer' => 'Variometer',
+                                 'Map-Variometer-Skala' => 'Variometer',
+                                 'Fox' => 'Ziel für Fuchsjagd',
+                                 'Heartbeat' => 'Aktivität Datenübertragung zum MK',
+                                 'Satellite' => 'Guter Satelliten-Empfang',
+                                 'Waypoint' => 'Wegpunkt',
+                                 'Map-Border' => 'Flugplatz',
+                                 'Waypoint-Connector' => 'Verbinder Wegpunkte',
+                                 'Wp-PlayPause' => 'Play/Pause',
+                                 'Wp-Stop' => 'Stop',
+                                 'Wp-First' => 'Zum ersten Waypoint',
+                                 'Wp-Last' => 'Zum letzten Waypoint',
+                                 'Wp-Next' => 'Zum nächsten Waypoint',
+                                 'Wp-Prev' => 'Zum vorgerigen Waypoint',
+                                 'Wp-Home' => 'Zur Home-Position',
+                               },
+                    );
+#
+# Mouse buttons
+#
+# general Mouse button 1
+$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");
+    });
+# Mouse button 1 for Fox
+my $FoxOldx = 0;
+my $FoxOldy = 0;
+# 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;
+        my ($Lat, $Lon) = &MapXY2Gps($x, $y);
+        &MkFlyTo ( '-lat' => $Lat,
+                   '-lon' => $Lon,
+                   '-mode' => "Target",
+                 );
+        $FoxTime = time;
+        $map_status_line->configure ('-text' => "Ziel-Koordinaten gesendet -> Lat: $Lat  Lon: $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;
+    my ($Lat, $Lon) = &MapXY2Gps($x, $y);
+    &MkFlyTo ( '-lat' => $Lat,
+               '-lon' => $Lon,
+               '-mode' => "Target",
+             );
+    # Show user that Waypoints in MK are cleared
+    $WaypointsModified = 1;
+    &WpRedrawLines();
+    $map_status_line->configure ('-text' => "Ziel-Koordinaten gesendet -> Lat: $Lat  Lon: $Lon     x: $x  y: $y");
+    });
+# Pick Waypoint
+$map_canvas->bind('Waypoint' => '<Button-1>' => sub
+    {
+    # prepare to move
+    my ($x, $y) = ($Tk::event->x, $Tk::event->y);
+    $WpOldx = $x;
+    $WpOldy = $y;
+    });
+# Move Waypoint
+$map_canvas->bind('Waypoint' => '<Button1-Motion>' => sub
+    {
+    my ($x, $y) = ($Tk::event->x, $Tk::event->y);
+    my $id      = $map_canvas->find('withtag', 'current');
+    # move icon and Wp-Number
+    my $WpIndex = &WpGetIndexFromId($id);
+    if ( $WpIndex >= 0 )
+        {
+        my $Tag = $Waypoints[$WpIndex]{'Tag'};
+        $map_canvas->move($Tag => $x - $WpOldx, $y - $WpOldy);
+        }
+    $WpOldx = $x;
+    $WpOldy = $y;
+    });
+# Release Wp
+$map_canvas->bind('Waypoint' => '<Button1-ButtonRelease>' => sub
+    {
+    my ($x, $y) = ($Tk::event->x, $Tk::event->y);
+    my $id      = $map_canvas->find('withtag', 'current');
+    # take coords from lower/middle icon position
+    my ($x0, $y0, $x1, $y1) = $map_canvas->bbox ($id);
+    $x = $x0 + ($x1 - $x0)/2;
+    $y = $y1;
+    # update Waypoint-Array
+    my $WpIndex = &WpGetIndexFromId($id);
+    if ( $WpIndex >= 0 )
+            {
+        # got it: set new coords
+        my ($Lat, $Lon) = &MapXY2Gps($x, $y);
+        my $Wp = $Waypoints[$WpIndex];
+        $Wp->{'MapX'} = $x;
+        $Wp->{'MapY'} = $y;
+        $Wp->{'Pos_Lat'} = $Lat;
+        $Wp->{'Pos_Lon'} = $Lon;
+        # redraw connector-lines
+        &WpRedrawLines();
+        # red connectors: Wp still have to be sent to MK
+        $map_canvas->itemconfigure('Waypoint-Connector',
+                                       '-fill' => $Cfg->{'mkcockpit'}->{'ColorWpResend'},
+                                      );
+        $WaypointsModified = 1;
+        my $WpNum = $WpIndex + 1;
+        $map_status_line->configure ('-text' => "Wegpunkt $WpNum verschoben  Lat: $Lat  Lon: $Lon     x: $x  y: $y");
+        }
+    });
+#
+# Waypoint-Player - uses Waypoint-List: @Waypoints
+#
+# WP Player state machine
+$WpPlayerMode = 'Stop';     # Start, Stop, Pause
+$WpPlayerIndex = 0;
+$WpPlayerHoldtime = -1;
+# Mouse bindings
+$map_canvas->bind('Wp-PlayPause' => '<Button-1>' => \&CbWpPlayerPlayPause );
+$map_canvas->bind('Wp-Next'      => '<Button-1>' => \&CbWpPlayerNext );
+$map_canvas->bind('Wp-Prev'      => '<Button-1>' => \&CbWpPlayerPrev );
+$map_canvas->bind('Wp-First'     => '<Button-1>' => \&CbWpPlayerFirst );
+$map_canvas->bind('Wp-Last'      => '<Button-1>' => \&CbWpPlayerLast );
+$map_canvas->bind('Wp-Home'      => '<Button-1>' => \&CbWpPlayerHome );
+$map_canvas->bind('Wp-Stop'      => '<Button-1>' => \&CbWpPlayerStop );
+# Focus Canvas, if any key pressed. Needed for the following key-bindings
+$main->bind('<Any-Enter>' => sub { $map_canvas->Tk::focus });
+# Disable default bindings on canvas
+$main->bind('Tk::Canvas',"<$_>",undef)for qw /Left Right Up Down/;
+# keyboard bindings
+$map_canvas->Tk::bind( '<Key-space>', \&CbWpPlayerPlayPause );
+$map_canvas->Tk::bind( '<Key-n>'    , \&CbWpPlayerNext );
+$map_canvas->Tk::bind( '<Key-p>'    , \&CbWpPlayerPrev );
+$map_canvas->Tk::bind( '<Key-f>'    , \&CbWpPlayerFirst );
+$map_canvas->Tk::bind( '<Key-l>'    , \&CbWpPlayerLast );
+$map_canvas->Tk::bind( '<Key-h>'    , \&CbWpPlayerHome );
+$map_canvas->Tk::bind( '<Key-s>'    , \&CbWpPlayerStop );
+# Mouse button 3 context menu
+my $map_menu = $map_canvas->Menu('-tearoff' => 0,
+                                 '-title' =>'None',
+                                 '-menuitems' =>
+    [
+     [Button => "Wegpunkt hinzufügen und senden",  -command => sub
+        {
+        my $Tag = sprintf "Waypoint-%d.%d", time, int (rand(9)) ;   # kind of unique Tag for this Wp
+        # Waypoint Icon
+        my $IconHeight = 48;
+        my $IconWidth = 48;
+        $map_canvas->createImage($MapCanvasX-$IconWidth/2, $MapCanvasY-$IconHeight,
+                                 '-tags' => ['Waypoint', $Tag],
+                                 '-anchor' => 'nw',
+                                 '-image'  => 'Waypoint-Photo',
+                                );
+        # Waypoint Number
+        my $WpNumber = scalar @Waypoints + 1;
+        $map_canvas->createText ( $MapCanvasX+3, $MapCanvasY-$IconHeight/2+12,
+                                  '-tags' => ['WaypointNumber', $Tag],
+                                  '-text' => $WpNumber,
+                                  '-font' => '-*-Arial-Bold-R-Normal--*-100-*',
+                                  '-fill' => $Cfg->{'mkcockpit'}->{'ColorWpNumber'},
+                                  '-anchor' => 'w',
+                                 );
+        $map_canvas->lower('Waypoint', 'Fox');            # waypoint below Fox
+        $map_canvas->lower('WaypointNumber', 'Waypoint'); # Nr below waypoint
+        # send Wp to MK
+        ($Lat, $Lon) = &MapXY2Gps($MapCanvasX, $MapCanvasY);
+        &MkFlyTo ( '-lat' => $Lat,
+                   '-lon' => $Lon,
+                   '-mode' => "Waypoint"
+                 );
+        # save Wp-Hash in Waypoint-Array
+        my $Wp = {};
+        $Wp->{'Tag'} = $Tag;
+        $Wp->{'MapX'} = $MapCanvasX;
+        $Wp->{'MapY'} = $MapCanvasY;
+        $Wp->{'Pos_Lat'} = $Lat;
+        $Wp->{'Pos_Lon'} = $Lon;
+        $Wp->{'Pos_Alt'} = $MkOsd{'CurPos_Alt'};
+        $Wp->{'Heading'}         = $Cfg->{'waypoint'}->{'DefaultHeading'};
+        $Wp->{'ToleranceRadius'} = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'};
+        $Wp->{'Holdtime'}        = $Cfg->{'waypoint'}->{'DefaultHoldtime'};
+        $Wp->{'Event_Flag'}      = $Cfg->{'waypoint'}->{'DefaultEventFlag'};
+        push @Waypoints, $Wp;
+        # redraw connector-lines
+        &WpRedrawLines();
+        $map_status_line->configure ('-text' => "Wegpunkt gespeichert und gesendet -> Lat: $Lat Lon: $Lon");
+        }],
+     [Button => "Wegpunkt Eigenschaften",  -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, "Eigenschaften Wegpunkt $WpNum", "Edit Waypoint Refresh");
+            $map_status_line->configure ('-text' => "Wegpunkt $WpNum Eigenschaften");
+            }
+        }],
+     [Button => "Alle Wegpunkte erneut senden",  -command => sub
+        {
+        &WpSendAll();
+        $map_status_line->configure ('-text' => "Alle Wegpunkte gesendet");
+        }],
+      '',   # Separator
+     [Button => "Wegpunkte laden und senden",  -command => sub
+        {
+        $WpFile = $main->getOpenFile('-defaultextension' => ".xml",
+                                     '-filetypes'        =>
+                                         [['Waypoints',     '.xml' ],
+                                          ['All Files',     '*', ],
+                                         ],
+                                     '-initialdir' => $Cfg->{'waypoint'}->{'WpDir'},
+                                     '-title' => "Wegpunkte laden",
+                                    );
+        if ( -f $WpFile )
+            {
+            # XML in Hash-Ref lesen
+            my $Wp = XMLin($WpFile, ForceArray => 1);
+            # XML Hash-Ref in Wp-Array umkopieren
+            undef @Waypoints;
+            foreach $key (sort keys %$Wp)
+                {
+                my $Point = $Wp->{$key}->[0];
+                # relative Pixelkoordinaten auf Bildgroesse umrechnen
+                if ( $Point->{'MapX'} <= 1  and  $Point->{'MapY'} <= 1 )
+                    {
+                    $Point->{'MapX'} = int ( $Point->{'MapX'} * $MapSizeX + 0.5 );
+                    $Point->{'MapY'} = int ( $Point->{'MapY'} * $MapSizeY + 0.5 );
+                    }
+                # GPS Koordinaten für die aktuelle Karte neu aus Map x/y berechnen
+                my ($Lat, $Lon) = &MapXY2Gps($Point->{'MapX'}, $Point->{'MapY'});
+                $Point->{'Pos_Lat'} = $Lat;
+                $Point->{'Pos_Lon'} = $Lon;
+                push @Waypoints, $Point;
+                }
+            &WpSendAll();
+            &WpRedrawLines();
+            &WpRedrawIcons();
+            $map_status_line->configure ('-text' => "Wegpunkte aus $WpFile geladen und gesendet");
+            }
+        }],
+     [Button => "Wegpunkte speichern",  -command => sub
+        {
+        $WpFile = $main->getSaveFile('-defaultextension' => ".xml",
+                                     '-filetypes'        =>
+                                       [['Waypoints',     '.xml' ],
+                                        ['All Files',     '*', ],
+                                       ],
+                                     '-initialdir' => $Cfg->{'waypoint'}->{'WpDir'},
+                                     '-title' => "Wegpunkte speichern",
+                                    );
+        # Waypoint-Array in Hash umkopieren
+        my %Wp;
+        for  $i ( 0 .. $#Waypoints )
+            {
+            my $key = sprintf ("WP-%04d", $i);
+            $Wp{$key} = $Waypoints[$i];
+            # Pixelkoordinaten relativ zur Bildgroesse speichern
+            $Wp{$key}{'MapX'} /= $MapSizeX;
+            $Wp{$key}{'MapY'} /= $MapSizeY;
+            }
+        # WP-Hash als XML speichern
+        &XMLout (\%Wp,
+                 'OutputFile' => $WpFile,
+                 'AttrIndent' => '1',
+                 'RootName' => 'Waypoints',
+                );
+        $map_status_line->configure ('-text' => "Wegpunkte in $WpFile gespeichert");
+        }],
+     '',   # Separator
+     [Button => "Wegpunkt löschen",  -command => sub
+        {
+        # find Wp-Hash for selected icon/tag
+        my $WpIndex = &WpGetIndexFromId($MapCanvasId);
+        if ( $WpIndex >= 0 )
+            {
+            my $Wp = $Waypoints[$WpIndex];
+            # remove icon and Wp-Number on canvas;
+            $map_canvas->delete($Wp->{'Tag'});
+            # delete Wp in Waypoint-Array
+            splice @Waypoints, $WpIndex, 1;
+            # redraw connector-lines
+            $WaypointsModified = 1;
+            &WpRedrawLines();
+            &WpRedrawIcons();  # wg. Wp-Nummern
+            $WpNum = $WpIndex + 1;
+            $map_status_line->configure ('-text' => "Wegpunkt $WpNum gelöscht");
+            }
+        }],
+     [Button => "Alle Wegpunkte löschen und senden",  -command => sub
+        {
+        undef @Waypoints;
+        # remove all Wp-Icons and Wp-Number on canvas
+        $map_canvas->delete('Waypoint');
+        $map_canvas->delete('WaypointNumber');
+        # redraw connector-lines
+        &WpRedrawLines();
+        &WpSendAll();
+        $map_status_line->configure ('-text' => "Alle Wegpunkte $WpIndex gelöscht");
+        }],
+    '',   # Separator
+     [Button => "Ziel sofort anfliegen",  -command => sub
+        {
+        &MkFlyTo ( '-x' => $MapCanvasX,
+                   '-y' => $MapCanvasY,
+                   '-mode' => "Target"
+                 );
+        # redraw connector-lines
+        $WaypointsModified = 1;
+        &WpRedrawLines();
+        $map_status_line->configure ('-text' => "Ziel-Koordinaten gesendet -> Lat: $Lat  Lon: $Lon     x: $x  y: $y");
+        }],
+    ]
+                                    );
+$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') ] );
+#
+# Objects on canvas
+#
+# Line from MK to Home
+$map_canvas->createLine ( $MapSizeX/2, $MapSizeY/2, $MapSizeX/2, $MapSizeY/2,
+                          '-tags' => 'MK-Home-Line',
+                          '-arrow' => 'none',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeLine'},
+                          '-width' => 3,
+                         );
+# Text Entfernung positioniert an der Home-Linie
+$map_canvas->createText ( $MapSizeX/2 + 8, $MapSizeY/2 - 8,
+                          '-tags' => 'MK-Home-Dist',
+                          '-text' => '0 m',
+                          '-anchor' => 'w',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-200-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeDist'},
+                          );
+# Line from MK to Target, draw invisible out of sight
+$map_canvas->createLine ( 0, -100, 0, -100,
+                          '-tags' => 'MK-Target-Line',
+                          '-arrow' => 'none',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetLine'},
+                          '-width' => 3,
+                         );
+# Text Entfernung positioniert an der Target-Linie
+$map_canvas->createText ( 0, -100,
+                          '-tags' => 'MK-Target-Dist',
+                          '-text' => '0 m',
+                          '-anchor' => 'w',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-200-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetDist'},
+                          );
+# MK Geschwindigkeits-Vektor
+$MapMkSpeedLen = 60;    # Länge Speed-Zeiger
+my $x0 = $MapSizeX/2;
+my $y0 = $MapSizeY/2;
+my $x1 = $MapSizeX/2;
+my $y1 = $MapSizeY/2 - $MapMkSpeedLen;
+$map_canvas->createLine ( $x0, $y0, $x1, $y1,
+                          '-tags' => 'MK-Speed',
+                          '-arrow' => 'last',
+                          '-arrowshape' => [10, 10, 3 ],
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorSpeedVector'},
+                          '-width' => 4,
+                         );
+# MK als Pfeilspitze einer Linie darstellen
+$MapMkLen = 25;
+my $x0 = $MapSizeX/2;
+my $y0 = $MapSizeY/2 + $MapMkLen/2;
+my $x1 = $MapSizeX/2;
+my $y1 = $MapSizeY/2 - $MapMkLen/2;
+$map_canvas->createLine ( $x0, $y0, $x1, $y1,
+                          '-tags' => 'MK-Arrow',
+                          '-arrow' => 'last',
+                          '-arrowshape' => [25, 30, 10 ],
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorMkSatNo'},
+                          '-width' => 1
+                         );
+# OSD Daten auf Karte anzeigen
+# Flugzeit
+$map_canvas->createText ( $MapSizeX/2 - 40, 20,
+                          '-tags' => 'MK-OSD-Tim-Label',
+                          '-text' => 'TIM',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( $MapSizeX/2, 20,
+                          '-tags' => 'MK-OSD-Tim-Value',
+                          '-text' => $MkFlyingTime,            # $MkOsd{'FlyingTime'},
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Batterie Spannung
+$map_canvas->createText ( $MapSizeX/2 - 40, 50,
+                          '-tags' => 'MK-OSD-Bat-Label',
+                          '-text' => 'BAT',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( $MapSizeX/2, 50,
+                          '-tags' => 'MK-OSD-Bat-Value',
+                          '-text' => sprintf ("%3.1f V", $MkOsd{'UBat'}),
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Ground speed
+$map_canvas->createText ( 10,  20,
+                          '-tags' => 'MK-OSD-Spd-Label',
+                          '-text' => 'SPD',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( 50,  20,
+                          '-tags' => 'MK-OSD-Spd-Value',
+                          '-text' => sprintf ("%3d km/h", $MkOsd{'GroundSpeed'} * 0.036),
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Hoehe (Luftdruck)
+$map_canvas->createText ( 10,  50,
+                          '-tags' => 'MK-OSD-Alt-Label',
+                          '-text' => 'ALT',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( 50,  50,
+                          '-tags' => 'MK-OSD-Alt-Value',
+                          '-text' => sprintf ("%3d m", $MkOsd{'Altimeter'}/$Cfg->{'mkcockpit'}->{'AltFactor'}),
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Variometer
+$map_canvas->createText ( 10,  80,
+                          '-tags' => 'MK-OSD-Vsi-Label',
+                          '-text' => 'VSI',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( 50,  80,
+                          '-tags' => 'MK-OSD-Vsi-Value',
+                          '-text' => sprintf ("%3d", $MkOsd{'Variometer'}),
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Anzahl Satelitten
+$map_canvas->createText ( $MapSizeX - 130, 20,
+                          '-tags' => 'MK-OSD-Sat-Label',
+                          '-text' => 'SAT',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( $MapSizeX - 80, 20,
+                          '-tags' => 'MK-OSD-Sat-Value',
+                          '-text' => "$MkOsd{'SatsInUse'}",
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Wegpunkte
+$map_canvas->createText ( $MapSizeX - 130, 50,
+                          '-tags' => 'MK-OSD-Wp-Label',
+                          '-text' => 'WPT',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( $MapSizeX - 80, 50,
+                          '-tags' => 'MK-OSD-Wp-Value',
+                          '-text' => $MkOsd{'WaypointIndex'} . "/" . $MkOsd{'WaypointNumber'} ,
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Navigation Mode
+$map_canvas->createText ( $MapSizeX - 130, 80,
+                          '-tags' => 'MK-OSD-Mode-Label',
+                          '-text' => 'MOD',
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( $MapSizeX - 80, 80,
+                          '-tags' => 'MK-OSD-Mode-Value',
+                          '-text' => '' ,
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Waypoint Holdtime count down
+$map_canvas->createText ( $MapSizeX - 130, -110,
+                          '-tags' => 'MK-OSD-Holdtime-Label',
+                          '-text' => 'HLD',                             # Holdtime Count Down
+                          '-font' => '-*-Arial-Bold-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+$map_canvas->createText ( $MapSizeX - 80, -110,
+                          '-tags' => 'MK-OSD-Holdtime-Value',
+                          '-text' => '--' ,
+                          '-font' => '-*-Arial-Bold-R-Normal--*-270-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'},
+                          '-anchor' => 'w',
+                         );
+# Variometer on canvas
+my @Polygon;
+for ( $y = -100; $y <= 100; $y += 10)
+    {
+    my $Len = 5;
+    if ( ($y % 50) == 0 )
+        {
+        $Len = 10;
+        $map_canvas->createText ( $Len+5, $MapSizeY/2 + $y,
+                                  '-tags' => 'Map-Variometer-Skala',
+                                  '-text' => sprintf ("%3d", -$y / 10),
+                                  '-anchor' => 'w',
+                                  '-font' => '-*-Arial-Normal-R-Normal--*-150-*',
+                          '-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'},
+                          );
+        }
+    push @Polygon, (   0, $MapSizeY/2 + $y);
+    push @Polygon, ($Len, $MapSizeY/2 + $y);
+    push @Polygon, (   0, $MapSizeY/2 + $y);
+    }
+$map_canvas->createLine(@Polygon,
+                        '-tags' => 'Map-Variometer',
+                        '-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'},
+                        '-width' => 2,
+                        '-arrow' => 'none',
+                       );
+# Vario Pointer
+$map_canvas->createPolygon( 5, $MapSizeY/2, 20, $MapSizeY/2+10, 20, $MapSizeY/2-10,
+                           '-tags' => 'Map-Variometer-Pointer',
+                           '-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometerPointer'},
+                           '-outline' => 'black', '-width' => 1,
+                          );
+# Tracking Canvas
+if ( $Cfg->{'track'}->{'Active'} =~ /y/i )
+    {
+    # Canvas size
+    $TrackSizeX  = 125;
+    $TrackSizeY  = 100;
+    $TrackOffY   = $TrackSizeY - $MapSizeY + 20;
+    $TrackPtrLen = 50;    # Länge Zeiger
+    # draw in map-canvas
+    $track_canvas = $map_canvas;
+    # Ziffernblatt
+    my $x0 = $TrackSizeX/2 - $TrackPtrLen;
+    my $y0 = $TrackSizeY + $TrackPtrLen - $TrackOffY;
+    my $x1 = $TrackSizeX/2 + $TrackPtrLen;
+    my $y1 = $TrackSizeY   - $TrackPtrLen - $TrackOffY;
+    $track_canvas->createArc ( $x0, $y0, $x1, $y1,
+                               '-extent' => '200',
+                               '-start' => '-10',
+                               '-style' => 'chord',
+                               '-outline' => 'gray', '-width' => '1',
+                             );
+    # Skala Ziffernblatt
+    for ($i=0; $i<=180; $i+=15)
+        {
+        my $pi = 3.14159265358979;
+        my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 20) * cos($i / 180 * $pi);
+        my $y0 = $TrackSizeY   - ($TrackPtrLen - 20) * sin($i / 180 * $pi) - $TrackOffY;
+        my $x1 = $TrackSizeX/2 - ($TrackPtrLen - 28) * cos($i / 180 * $pi);
+        my $y1 = $TrackSizeY   - ($TrackPtrLen - 28) * sin($i / 180 * $pi) - $TrackOffY;
+        $track_canvas->createLine ( $x0, $y0, $x1, $y1,
+                                   '-fill' => 'white',
+                                   '-width' => 1,
+                                  );
+        }
+    # Skala Beschriftung Ziffernblatt
+    for ($i=0; $i<=180; $i+=45)
+        {
+        my $pi = 3.14159265358979;
+        my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 12) * cos($i / 180 * $pi);
+        my $y0 = $TrackSizeY   - ($TrackPtrLen - 12) * sin($i / 180 * $pi) - $TrackOffY;
+        $track_canvas->createText ( $x0, $y0,
+                                   '-text' => $i - 90,
+                                   '-fill' => 'white',
+                                  );
+        }
+    # Ziffernblatt Beschriftung Einheit
+    my $x0 = $TrackSizeX/2;
+    my $y0 = $MapSizeY -6;
+    $track_canvas->createText ( $x0, $y0,
+                                '-text' => "Antenne Winkel",
+                                '-justify' => 'center',
+                                '-fill' => 'white',
+                                );
+    # Zeiger
+    my $x0 = $TrackSizeX/2;
+    my $y0 = $TrackSizeY - 0 - $TrackOffY;
+    my $x1 = $TrackSizeX/2;
+    my $y1 = $TrackSizeY - ($TrackPtrLen - 22) - $TrackOffY;
+    $track_ptr_id= $track_canvas->createLine ( $x0, $y0, $x1, $y1,
+                                               '-tags' => 'Track-Ptr',
+                                               '-arrow' => 'last',
+                                               '-arrowshape' => [20, 30, 5 ],
+                                               '-fill' => 'red',
+                                               '-width' => 8,
+                                              );
+    # Zeiger Center
+    my $Dia = 7;
+    my $x0 = $TrackSizeX/2 - $Dia;
+    my $y0 = $TrackSizeY + $Dia - $TrackOffY;
+    my $x1 = $TrackSizeX/2 + $Dia;
+    my $y1 = $TrackSizeY   - $Dia - $TrackOffY;
+    $track_canvas->createArc ( $x0, $y0, $x1, $y1,
+                               '-extent' => '359',
+                               '-outline' => 'gray', '-width' => 1,
+                               '-fill' => 'gray',
+                             );
+    }
+#-----------------------------------------------------------------
+# Timer
+#-----------------------------------------------------------------
+#
+# Timer: 5s
+#
+$main->repeat (5000, sub
+    {
+    if ( ! $MkSendWp )
+        {
+        # Abfragefrequenz OSD und Debug regelmäßig neu einstellen, falls Übertragungsfehler
+        $MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 10) );   # Frequenz OSD Datensatz, * 10ms
+        $MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 10) );   # Frequenz MK Debug Datensatz, * 10ms
+        $MkSendQueue->enqueue( "v", "$AddrNC", "");   # Version
+        $MkSendQueue->enqueue( "e", "$AddrNC", "");   # Error Text Request
+        }
+    });
+#
+# Timer: 0.1s - Map Overlay aktualisieren
+#
+$frame_map_top->repeat (100, sub
+    {
+    lock (%MkOsd);              # until end of block
+    # Aktuell gültige Karte
+    my %Map = %{$Maps{'Current'}};
+    if ( $MkOsd{'_Timestamp'} >= time-2 )
+        {
+        # Gueltige OSD Daten
+        my $SatsInUse = $MkOsd{'SatsInUse'};
+        if ( $SatsInUse > 0  and  $MkOsd{'CurPos_Stat'} == 1 and $MkOsd{'HomePos_Stat'} == 1 )
+            {
+            # ausreichender GPS Empfang
+            # get x,y map coords of current position
+            my ($C_x, $C_y, $C_Angel) = &MapGps2XY($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, $MkOsd{'CompassHeading'});
+            # rotate MK arrow
+            my $dy = sin (deg2rad $C_Angel) * ($MapMkLen/2);
+            my $dx = cos (deg2rad $C_Angel) * ($MapMkLen/2);
+            my $x0 = $C_x - $dx;
+            my $y0 = $C_y - $dy;
+            my $x1 = $C_x + $dx;
+            my $y1 = $C_y + $dy;
+            $map_canvas->coords ('MK-Arrow', $x0, $y0, $x1, $y1);
+            # Update speed vector
+            my $MapAngel = &MapAngel();   # Norh to Map-Horizont
+            my $GpsSpeedNorth = $MkNcDebug{'Analog_21'};
+            my $GpsSpeedEast  = $MkNcDebug{'Analog_22'};
+            my $PhiGpsSpeed = rad2deg atan2 ( $GpsSpeedEast, $GpsSpeedNorth );
+            $PhiMapSpeed = $PhiGpsSpeed - $MapAngel;
+            # 555 cm/s ~ 20 km/h -> Zeigerlänge = $MkSpeedLen bei 20 km/h
+            my $dy = sin (deg2rad $PhiMapSpeed) * $MapMkSpeedLen * $MkOsd{'GroundSpeed'} / 555;
+            my $dx = cos (deg2rad $PhiMapSpeed) * $MapMkSpeedLen * $MkOsd{'GroundSpeed'} / 555;
+            my $x0 = $C_x;
+            my $y0 = $C_y;
+            my $x1 = $C_x + $dx;
+            my $y1 = $C_y + $dy;
+            $map_canvas->coords ('MK-Speed', $x0, $y0, $x1, $y1);
+            # Update Line between Home and MK
+            my ($H_x, $H_y) = &MapGps2XY($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'});
+            $map_canvas->coords ('MK-Home-Line', $H_x, $H_y, $C_x, $C_y);
+            # Update Distance between Home and MK
+            my ($Dist, $Bearing) = MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'},
+                                                   $MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'} );
+            my $x = ($C_x - $H_x) / 2 + $H_x + 8;
+            my $y = ($C_y - $H_y) / 2 + $H_y + 8;
+            $map_canvas->coords ('MK-Home-Dist', $x, $y);
+            $map_canvas->itemconfigure ('MK-Home-Dist',
+                                        '-text' => sprintf ("%4d m", $Dist),
+                                       );
+            # Update OSD - Sat dependent values
+            $map_canvas->itemconfigure ('MK-OSD-Spd-Value', '-text' => sprintf ("%3d km/h", $MkOsd{'GroundSpeed'} * 0.036) );
+            # Alt = average Luftdruck und Sat
+            my $Alt = int ( ($MkOsd{'Altimeter'} / $Cfg->{'mkcockpit'}->{'AltFactor'} +
+                             $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'} + 0.5) / 2 );
+            $map_canvas->itemconfigure ('MK-OSD-Alt-Value', '-text' => sprintf ("%d m", $Alt) );
+            if ( $MkOsd{'TargetPos_Stat'} == 1 )
+                {
+                # Valid Target
+                # Update Line between Target and MK
+                my ($T_x, $T_y) = &MapGps2XY($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'});
+                $map_canvas->coords ('MK-Target-Line', $C_x, $C_y, $T_x, $T_y);
+                # Update Distance between Target and MK
+                my ($Dist, $Bearing) = MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'},
+                                                        $MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'} );
+                my $x = ($C_x - $T_x) / 2 + $T_x - 8;
+                my $y = ($C_y - $T_y) / 2 + $T_y + 8;
+                $map_canvas->coords ('MK-Target-Dist', $x, $y);
+                $map_canvas->itemconfigure ('MK-Target-Dist',
+                                            '-text' => sprintf ("%4d m", $Dist),
+                                           );
+                # show target icon
+                my $IconHeight = 48;
+                my $IconWidth = 48;
+                $map_canvas->coords('Target', $T_x - $IconWidth/2, $T_y - $IconHeight );
+                }
+            else
+                {
+                # No valid Target, move target line out of sight/canvas
+                $map_canvas->coords ('MK-Target-Line', 0, -100, 0, -100);
+                $map_canvas->coords ('MK-Home-Dist', 0, -100);
+                # hide target icon
+                $map_canvas->coords('Target', 0, -100, );
+                }
+            }
+        else
+            {
+            # kein ausreichender Sat-Empfang
+            $map_canvas->itemconfigure ('MK-OSD-Spd-Value', '-text' => sprintf ("%3d km/h", 0 ) );
+            }
+        # Update OSD - non Sat dependent values
+        $map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-text' => sprintf ("%3.1f V", $MkOsd{'UBat'}) );
+        $map_canvas->itemconfigure ('MK-OSD-Vsi-Value', '-text' => sprintf ("%3d", $MkOsd{'Variometer'}) );
+        $map_canvas->itemconfigure ('MK-OSD-Tim-Value', '-text' => sprintf ("%02d:%02d", $MkFlyingTime / 60, $MkFlyingTime % 60) );
+        $map_canvas->itemconfigure ('MK-OSD-Sat-Value', '-text' => $MkOsd{'SatsInUse'} );
+        # Waypoints abhaengig vom Modus NC/Player
+        my $WpValue = "--/--";
+        if ( $MkOsd{'WaypointNumber'} > 0)
+            {
+            $WpValue = sprintf ("%d/%d", $MkOsd{'WaypointIndex'} +1, $MkOsd{'WaypointNumber'});
+            }
+        if ($WpPlayerMode ne "Stop")
+            {
+            $WpValue = sprintf ("%d/%d", $WpPlayerIndex +1, scalar @Waypoints);
+            }
+        $map_canvas->itemconfigure ('MK-OSD-Wp-Value',  '-text' => "$WpValue");
+        # blink battery warning
+        $map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'});
+        if ( $MkOsd{'UBat'}  <  $Cfg->{'mkcockpit'}->{'UBatWarning'} )
+            {
+            if ( time %2 )
+                {
+                $map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-fill' => 'red');
+                }
+            }
+        my $Mode = "";
+        if ($MkOsd{'NCFlags'} & 0x04) { $Mode = "WPT"};
+        if ($WpPlayerMode eq "Play")  { $Mode = "Play" };
+        if ($WpPlayerMode eq "Pause") { $Mode = "Paus" };
+        if ($WpPlayerMode eq "Home")  { $Mode = "Home" };
+        if ($MkOsd{'NCFlags'} & 0x01) { $Mode = "Free"};
+        if ($MkOsd{'NCFlags'} & 0x02) { $Mode = "PH"};
+        if ($MkOsd{'NCFlags'} & 0x08) { $Mode = "$Mode" . " !"};  # Range Warning
+        $map_canvas->itemconfigure ('MK-OSD-Mode-Value', '-text' => "$Mode" );
+        # Holdtime count down
+        if ( $WpPlayerHoldtime >= 0 )
+            {
+            my $Holdtime = int ($WpPlayerHoldtime / 2  + 0.5);
+            $map_canvas->itemconfigure ('MK-OSD-Holdtime-Value', '-text' => sprintf ("%d s", $Holdtime) );
+            $map_canvas->coords ('MK-OSD-Holdtime-Label', $MapSizeX - 130, 110);
+            $map_canvas->coords ('MK-OSD-Holdtime-Value', $MapSizeX - 80, 110);
+            }
+        else
+            {
+            # move out of sight
+            $map_canvas->coords ('MK-OSD-Holdtime-Label', $MapSizeX - 130, -110);
+            $map_canvas->coords ('MK-OSD-Holdtime-Value', $MapSizeX - 80, -110);
+            }
+        # Farbe MK-Zeiger abhängig vom GPS Empfang
+        my $MkCol= $Cfg->{'mkcockpit'}->{'ColorMkSatNo'};
+        if ( $SatsInUse >= 1 ) { $MkCol = $Cfg->{'mkcockpit'}->{'ColorMkSatLow'} ; }
+        if ( $SatsInUse >= 6 ) { $MkCol = $Cfg->{'mkcockpit'}->{'ColorMkSatGood'}; }
+        $map_canvas->itemconfigure ('MK-Arrow', '-fill' => $MkCol);
+        # Variometer Pointer
+        my $dy = -$MkOsd{'Variometer'} * 10;
+        $map_canvas->coords('Map-Variometer-Pointer', 5, $MapSizeY/2+$dy, 20, $MapSizeY/2+10+$dy, 20, $MapSizeY/2-10+$dy);
+        # Show/Hide SatFix Icon
+        if ($MkOsd{'SatsInUse'} >= 6 )
+            {
+            $map_canvas->coords('Satellite', $MapSizeX-190, 10, );
+            }
+        else
+            {
+            # move icon out of sight
+            $map_canvas->coords('Satellite', 0, -100, );
+            }
+        }
+    else
+        {
+        # keine aktuellen OSD Daten vom MK verfügbar
+        }
+    });
+#
+# Timer: 0.1s - Tracking Anzeige aktualisieren
+#
+if ( $Cfg->{'track'}->{'Active'} =~ /y/i )
+    {
+    $frame_map_top->repeat (100, sub
+        {
+        # Aktuell gültige Karte
+        my %Map = %{$Maps{'Current'}};
+        # Zeiger neu zeichnen
+        my $ServoPan = @ServoPos[$MkTrack{'ServoPan'}];
+        if ( $ServoPan ne ""  )
+            {
+            my $x0 = $TrackSizeX/2;
+            my $y0 = $TrackSizeY - 0 - $TrackOffY;
+            my $x1 = $TrackSizeX/2 - ($TrackPtrLen-22) * cos( deg2rad $ServoPan);
+            my $y1 = $TrackSizeY   - ($TrackPtrLen-22) * sin (deg2rad $ServoPan) - $TrackOffY;
+            $track_canvas->coords ('Track-Ptr', $x0, $y0, $x1, $y1);
+            }
+        # Farbe Zeiger abhängig vom GPS Empfang
+        my $SatsInUse = $MkOsd{'SatsInUse'};
+        my $TrackPtrCol= 'red';
+        if ( $SatsInUse >= 1 ) { $TrackPtrCol = 'orange'; }
+        if ( $SatsInUse >= 6 ) { $TrackPtrCol = 'green'; }
+        $track_canvas->itemconfigure ('Track-Ptr', '-fill' => $TrackPtrCol);
+        });
+    }
+#
+# Timer: 0.5s - Waypoint Player
+#
+$frame_map_top->repeat (500, sub
+    {
+    if ($MkOsd{'NCFlags'} & 0x04)
+        {
+        # NC is in WPT Mode
+        if ( $WpPlayerMode eq "Pause" )
+            {
+            if ( $WpPlayerPause_Lat ne ""  and  $WpPlayerPause_Lon ne "" )
+                {
+                # Gespeicherte Pausen-Pos senden
+                &MkFlyTo ( '-lat'  => $WpPlayerPause_Lat,
+                           '-lon'  => $WpPlayerPause_Lon,
+                           '-holdtime' => "60",
+                           '-mode' => "Target",
+                         );
+                }
+            }
+        if ( $WpPlayerMode eq "Home" )
+            {
+            lock (%MkOsd);              # until end of block
+            if ( $MkOsd{'HomePos_Stat'} == 1 )
+                {
+                &MkFlyTo ( '-lat'  => $MkOsd{'HomePos_Lat'},
+                           '-lon'  => $MkOsd{'HomePos_Lon'},
+                           '-holdtime' => "60",
+                           '-mode' => "Target",
+                         );
+                }
+            }
+        my $WpCnt = scalar @Waypoints;
+        if ( $WpPlayerMode eq "Play"  and  $WpCnt > 0  and  $WpPlayerIndex < $WpCnt )
+            {
+            # Target WP-Pos senden
+            my $Wp_Lon = $Waypoints[$WpPlayerIndex]{'Pos_Lon'};
+            my $Wp_Lat = $Waypoints[$WpPlayerIndex]{'Pos_Lat'};
+            if ( $Wp_Lat ne ""  and  $Wp_Lon ne "" )
+                {
+                &MkFlyTo ( '-lat'  => $Wp_Lat,
+                           '-lon'  => $Wp_Lon,
+                           '-holdtime' => "60",
+                           '-mode' => "Target",
+                         );
+                }
+            }
+        if ( $WpPlayerMode eq "Play" )
+            {
+            # Ziel erreicht?
+            if ( &WpCheckTargetReached() )
+                {
+                &WpTargetNext();
+                }
+            }
+        }
+    # WP Player Holdtime count down
+    if ( $WpPlayerHoldtime > 0  )
+        {
+        $WpPlayerHoldtime --;
+        }
+    });
+#
+# Timer: 1s
+#
+$frame_map_top->repeat (1000, sub
+    {
+    # Aktuell gültige Karte
+    my %Map = %{$Maps{'Current'}};
+    if ( $MkOsd{'_Timestamp'} >= time -2 )
+        {
+        # Heartbeat MK Datenübertragung
+        if ( time %2 )
+            {
+            $map_canvas->itemconfigure('Heartbeat', '-image' => 'HeartbeatLarge', );
+            }
+        else
+            {
+            $map_canvas->itemconfigure('Heartbeat', '-image' => 'HeartbeatSmall', );
+            }
+        # Flugzeit aktualisieren
+        # Flugzeit selber mitzählen, da $MkOsd{'FlyingTime'} immer 0 (0.14b)
+        if ( $MkOsd{'MKFlags'} & 0x02 )
+            {
+            $MkFlyingTime += 1;
+            }
+        # Footprint
+        if ( $Cfg->{'mkcockpit'}->{'FootprintLength'} > 0 )
+            {
+            if ( $MkOsd{'SatsInUse'} > 0  and  $MkOsd{'CurPos_Stat'} == 1 )
+                {
+                # neuen Footprint hinten anhaengen
+                my ($x, $y) = &MapGps2XY($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'});
+                push @Footprint, $x, $y;
+                }
+            while ( $#Footprint / 2  >  $Cfg->{'mkcockpit'}->{'FootprintLength'} )
+                {
+                # alte Footprints entfernen
+                splice @Footprint, 0, 2;
+                }
+            &FootprintRedraw();
+            }
+        # tracking antenne
+        if ( $MkOsd{'MKFlags'} & 0x01  and  ! $MkTrack{'IsRunning'} and
+             $Cfg->{'track'}->{'Active'} =~ /y/i )
+            {
+            # start track at 1st motor start
+            $track_thr = threads->create (\&TrackAntennaGps)->detach();
+            $MkTrack{'IsRunning'} = "Running";
+            }
+        }
+    });
+MainLoop();   # should never end
+#-----------------------------------------------------------------
+# Subroutines
+#-----------------------------------------------------------------
+# Get Wp Index from Canvas Id
+sub WpGetIndexFromId()
+    {
+    my ($id) = @_;
+    my @Tags = $map_canvas->gettags($id);
+    my $WpTag = $Tags[1];
+    for $i (0 .. $#Waypoints)
+        {
+        my $Wp = $Waypoints[$i];
+        if ( $Wp->{'Tag'} eq $WpTag )
+            {
+            # got it
+            return $i;
+            }
+        }
+    return -1;
+    }
+# Resend all Waypoints to MK
+sub WpSendAll()
+    {
+    # OSD/Debug Abfragefrequenz verringern, sonst kommen nicht alle Wp im MK an
+    # Sicherheitshalber doppelt senden
+    $MkSendWp = 1;       # verhindert ueberschreiben im Timer
+    $MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 1000) );   # Frequenz OSD Datensatz, * 10ms
+    $MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 1000) );   # Frequenz MK Debug Datensatz, * 10ms
+    usleep (200000);
+    $MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 1000) );   # Frequenz OSD Datensatz, * 10ms
+    $MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 1000) );   # Frequenz MK Debug Datensatz, * 10ms
+    usleep (200000);
+    # Alte WP-Liste im MK löschen
+    my $Wp = $Waypoints[0];
+    &MkFlyTo ( '-lat'  => $Wp->{'Pos_Lat'},
+               '-lon'  => Wp->{'Pos_Lon'},
+               '-mode' => "Waypoint Delete"
+             );
+    for $i (0 .. $#Waypoints)
+        {
+        my $Wp = $Waypoints[$i];
+        &MkFlyTo ( '-lat'             => $Wp->{'Pos_Lat'},
+                   '-lon'             => $Wp->{'Pos_Lon'},
+                   '-alt'             => $Wp->{'Pos_Alt'},
+                   '-heading'         => $Wp->{'Heading'},
+                   '-toleranceradius' => $Wp->{'ToleranceRadius'},
+                   '-holdtime'        => $Wp->{'Holdtime'},
+                   '-eventflag'       => $Wp->{'Event_Flag'},
+                   '-mode'            => "Waypoint"
+                 );
+        usleep (150000)  # NC Zeit zum Verarbeiten geben
+        }
+    $MkSendWp = 0;  # normale OSD/Debug Abfragefrequenz wird automatisch im 5s Timer wieder eingestellt
+    # gray connectors: Wp are sent to MK
+    $map_canvas->itemconfigure('Waypoint-Connector',
+                               '-fill' => $Cfg->{'mkcockpit'}->{'ColorWpConnector'},
+                              );
+    # MK ist nun synchron mit @Waypoints
+    $WaypointsModified = 0;
+    }
+# Redraw Waypoint Icons
+sub WpRedrawIcons()
+    {
+    # delete old icons and Wp-Number from canvas
+    $map_canvas->delete('Waypoint');
+    $map_canvas->delete('WaypointNumber');
+    # create new icons
+    for $i (0 .. $#Waypoints)
+        {
+        my $Wp = $Waypoints[$i];
+        my $x = $Wp->{'MapX'};
+        my $y = $Wp->{'MapY'};
+        my $Tag = $Wp->{'Tag'};
+        # Waypoint Icon
+        my $IconHeight = 48;
+        my $IconWidth = 48;
+        $map_canvas->createImage($x-$IconWidth/2, $y-$IconHeight,
+                                 '-tags' => ['Waypoint', $Tag],
+                                 '-anchor' => 'nw',
+                                 '-image'  => 'Waypoint-Photo',
+                                );
+        # Waypoint Number
+        my $WpNumber = $i + 1;
+        $map_canvas->createText ( $x+3, $y-$IconHeight/2+12,
+                                  '-tags' => ['WaypointNumber', $Tag],
+                                  '-text' => $WpNumber,
+                                  '-font' => '-*-Arial-Bold-R-Normal--*-100-*',
+                                  '-fill' => $Cfg->{'mkcockpit'}->{'ColorWpNumber'},
+                                  '-anchor' => 'w',
+                                 );
+        }
+    $map_canvas->lower('Waypoint', 'Fox');              # waypoint below Fox
+    $map_canvas->lower('WaypointNumber', 'Waypoint');   # waypoint-number below waypoint
+    }
+# Redraw Waypoint connectors
+sub WpRedrawLines()
+    {
+    # delete old connectors from canvas
+    $map_canvas->delete('Waypoint-Connector');
+    my $Color = $Cfg->{'mkcockpit'}->{'ColorWpConnector'};
+    if ( $WaypointsModified )
+        {
+        $Color = $Cfg->{'mkcockpit'}->{'ColorWpResend'};
+        }
+    my $Wp = $Waypoints[0];
+    my $x_last = $Wp->{'MapX'};
+    my $y_last = $Wp->{'MapY'};
+    for $i (1 .. $#Waypoints)
+        {
+        my $Wp = $Waypoints[$i];
+        my $x = $Wp->{'MapX'};
+        my $y = $Wp->{'MapY'};
+        $map_canvas->createLine ( $x_last, $y_last, $x, $y,
+                                  '-tags' => 'Waypoint-Connector',
+                                  '-arrow' => 'last',
+                                  '-arrowshape' => [10, 10, 3 ],
+                                  '-fill' => $Color,
+                                  '-width' => 1,
+                                );
+        $x_last = $x;
+        $y_last = $y;
+        }
+    $map_canvas->lower('Waypoint-Connector', 'Waypoint');   # connector below waypoint
+    }
+# Redraw Footprint
+sub FootprintRedraw()
+    {
+    # delete old Footprint fom canvas
+    $map_canvas->delete('Footprint');
+    if ( scalar @Footprint >= 4 )  # at least 2 Koordinaten-Paare
+        {
+        $map_canvas->createLine ( @Footprint,
+                                  '-tags' => 'Footprint',
+                                  '-fill' => $Cfg->{'mkcockpit'}->{'ColorFootprint'},
+                                  '-width' => 1,
+                                );
+        }
+    $map_canvas->lower('Footprint', 'Fox');
+    }
+# Display or Modify Hash
+sub DisplayHash()
+    {
+    my ($hrefData, $Titel, $Mode) = @_;
+    # $Mode: Display, Edit, Waypoint, Refresh
+    my %Id;
+    my $Label;
+    my $Value;
+    # Neues Fenster aufmachen
+    my $popup = $main->Toplevel();
+    $popup->title($Titel);
+    # Buttons
+    my $popup_button = $popup->Frame() -> pack('-side' => 'bottom',
+                                               '-expand' => 'y',
+                                               '-anchor' => 's',
+                                               '-padx' => 5,
+                                               '-pady' => 5,
+                                               );
+    $popup_button->Button('-text'    => 'Schließen',
+                          '-command' => sub
+        {
+        if ( $Mode =~ /edit/i  and  $Mode =~ /waypoint/i )
+            {
+            $WaypointsModified = 1;
+            &WpRedrawLines();
+            &WpRedrawIcons();
+            }
+        $popup->destroy()
+        })->pack;
+    # Frame mit den Labels
+    my $popup_label = $popup->Frame() -> pack('-side' => 'left',
+                                              '-expand' => 'y',
+                                              '-anchor' => 'w',
+                                              '-padx' => 10,
+                                              '-pady' => 10,
+                                              );
+    # Labels anzeigen
+    foreach $Label ( sort keys %{$hrefData})
+        {
+        if ( $Translate{$Label} ne "" )
+            {
+            $Label = $Translate{$Label};
+            }
+        $popup_label->Label ('-text' => $Label,
+                             '-width' => 25,
+                             '-anchor' => 'w',
+                             ) -> pack();
+        }
+    # Frame mit den Daten
+    my $popup_values = $popup->Frame() -> pack('-side' => 'left',
+                                               '-expand' => 'y',
+                                               '-anchor' => 'w',
+                                               '-padx' => 10,
+                                               '-pady' => 10,
+                                               );
+    # Daten anzeigen
+    foreach $Value ( sort keys %{$hrefData})
+        {
+        if ( $Mode =~ /display/i )
+            {
+            # Display
+            $Id{$Value} = $popup_values->Label ('-text' => ${$hrefData}{$Value},
+                                                '-width' => 20,
+                                                '-anchor' => 'e',
+                                                '-relief' => 'sunken',
+                                                ) -> pack();
+            }
+        if ( $Mode =~ /edit/i )
+            {
+            # Edit
+            $Id{$Value} = $popup_values->Entry ('-textvariable' => \${$hrefData}{$Value},
+                                                '-exportselection' => '1',
+                                                '-width' => 20,
+                                                '-relief' => 'sunken',
+                                               ) -> pack();
+            if ( $Mode =~ /waypoint/i )
+                {
+                # einige Waypoint-Felder nicht aenderbar einstellen
+                if ( "MapX MapY Pos_Lat Pos_Lon Tag" =~ /$Value/i )
+                    {
+                    $Id{$Value}->configure('-state' => 'disabled', );
+                    }
+                }
+            }
+        }
+    if ( $Mode =~ /refresh/i )
+        {
+        # Timer: 0.1s
+        $popup_values->repeat (100, sub
+            {
+            # Datenfelder alle 100ms aktualisieren
+            my $BgColor = 'white';
+            if ( $Mode =~ /heartbeat/i )
+                {
+                $BgColor = 'red';
+                if ( $MkOsd{'_Timestamp'} >= time-2 )
+                    {
+                    # gültige daten vom MK
+                    $BgColor = 'white';
+                    }
+                }
+            foreach $Value ( sort keys %{$hrefData} )
+                {
+                $Id{$Value}->configure('-text' => ${$hrefData}{$Value},
+                                       '-background' => "$BgColor",
+                                      );
+                }
+            });
+        }
+    return 0;
+    }
+# Konfigurationsdatei mkcockpit.xml im Popup-Fenster editieren
+sub Configure()
+    {
+    # Copy Cfg-Hash for editing
+    my $CfgEdit = {%{$Cfg}};
+    foreach $key (keys %{$Cfg})
+        {
+        if ( ref $Cfg->{$key} )
+            {
+            $CfgEdit->{$key} = {%{$Cfg->{$key}}};
+            }
+        }
+    # Neues Fenster aufmachen
+    my $popup = $main->Toplevel();
+    $popup->title("Einstellungen - $XmlConfigFile");
+    # jede Sektion in einem Tab anzeigen
+    my $book = $popup->NoteBook()->pack( -fill=>'both', -expand=>1 );
+    foreach $key (sort keys %{$CfgEdit})
+        {
+        if ( ! ref $CfgEdit->{$key} )
+            {
+            next;
+            }
+        my $TabLabel = "$key";
+        if ( $Translate{$key} ne "" )
+                {
+                $TabLabel = $Translate{$key};
+                }
+        my $Tab = $book->add( "$key", -label=>"$TabLabel", );
+        # Frame fuer Buttons
+        my $book_button = $Tab->Frame() -> pack('-side' => 'bottom',
+                                                '-expand' => 'y',
+                                                '-anchor' => 's',
+                                                '-padx' => 5,
+                                                '-pady' => 5,
+                                                );
+        $book_button->Button('-text'    => 'OK',
+                             '-width' => '10',
+                             '-command' => sub
+            {
+            # Copy back CfgEdit-Hash
+            $Cfg = {%{$CfgEdit}};
+            foreach $key (keys %{$CfgEdit})
+                {
+                if ( ref $CfgEdit->{$key} )
+                    {
+                    $Cfg->{$key} = {%{$CfgEdit->{$key}}};
+                    }
+                }
+            # set new timestamp
+            my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
+            my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec);
+            $Cfg->{'CreationDate'} = $TimeStamp;
+            # Cfg in mkcockpit.xml speichern
+            &XMLout ($Cfg,
+                     'OutputFile' => $XmlConfigFile,
+                     'AttrIndent' => '1',
+                     'RootName' => 'mkcockpit-Config',
+                    );
+            $popup->destroy();
+            } )->pack ('-side' => 'left',
+                       '-expand' => 'y',
+                       '-anchor' => 's',
+                       '-padx' => 5,
+                       '-pady' => 5,
+                      );
+        $book_button->Button('-text'    => 'Abbruch',
+                             '-width' => '10',
+                             '-command' => sub { $popup->destroy() },
+                            )->pack ('-side' => 'left',
+                                     '-expand' => 'y',
+                                     '-anchor' => 's',
+                                     '-padx' => 5,
+                                     '-pady' => 5,
+                                     );
+        $book_button->Label ('-text' => "*) Aenderungen werden erst nach Programm-Neustart wirksam!",
+                             '-anchor' => 'w',
+                             '-foreground' => 'red',
+                            ) ->pack ('-side' => 'left',
+                                      '-expand' => 'y',
+                                      '-anchor' => 's',
+                                      '-padx' => 10,
+                                      '-pady' => 5,
+                                      );
+        # Frame mit den Labels
+        my $popup_label = $Tab->Frame() -> pack('-side' => 'left',
+                                                '-expand' => 'y',
+                                                '-anchor' => 'w',
+                                                '-padx' => 10,
+                                                '-pady' => 10,
+                                                );
+        # Labels anzeigen
+        foreach $Label ( sort keys %{$CfgEdit->{$key}})
+            {
+            if ( $Translate{$Label} ne "" )
+                {
+                $Label = $Translate{$Label};
+                }
+            $popup_label->Label ('-text' => $Label,
+                                 '-width' => 30,
+                                 '-anchor' => 'w',
+                                ) -> pack();
+            }
+        # Frame mit den Daten
+        my $popup_values = $Tab->Frame() -> pack('-side' => 'left',
+                                                 '-expand' => 'y',
+                                                 '-anchor' => 'w',
+                                                 '-padx' => 10,
+                                                 '-pady' => 10,
+                                                 );
+        # Eingabefelder mit Daten anzeigen
+        foreach $Value ( sort keys %{$CfgEdit->{$key}})
+            {
+            $popup_values->Entry ('-textvariable' => \$CfgEdit->{$key}->{$Value},
+                                  '-exportselection' => '1',
+                                  '-width' => 30,
+                                  '-relief' => 'sunken',
+                                 ) -> pack();
+            }
+        }
+    }
+# Waypoint Player: Goto next Waypoint
+sub WpTargetNext()
+    {
+    $WpPlayerIndex ++;
+    if ( $WpPlayerIndex > $#Waypoints )
+        {
+        # Restart with 1st Wp
+        $WpPlayerIndex = 0;
+        }
+    $WpPlayerHoldtime = -1;
+    }
+# Waypoint Player: Goto previous Waypoint
+sub WpTargetPrev()
+    {
+    $WpPlayerIndex --;
+    if ( $WpPlayerIndex < 0 )
+        {
+        # Restart with last Wp
+        $WpPlayerIndex = $#Waypoints;
+        }
+    $WpPlayerHoldtime = -1;
+    }
+# Waypoint Player: Goto first Waypoint
+sub WpTargetFirst()
+    {
+    $WpPlayerIndex = 0;
+    $WpPlayerHoldtime = -1;
+    }
+# Waypoint Player: Goto last Waypoint
+sub WpTargetLast()
+    {
+    $WpPlayerIndex = $#Waypoints;
+    $WpPlayerHoldtime = -1;
+    }
+# Waypoint Player: Waypoint Target reached?
+sub WpCheckTargetReached()
+    {
+    if ( $WpPlayerHoldtime == -1 )
+        {
+        lock (%MkOsd);              # until end of block
+        if ( $MkOsd{'_Timestamp'} >= time-2  and   # Gueltige OSD Daten
+             $MkOsd{'NCFlags'} & 0x04  and         # WPT-Mode
+             $MkOsd{'SatsInUse'} >= 6  and  $MkOsd{'CurPos_Stat'} == 1 and  $MkOsd{'HomePos_Stat'} == 1)
+            {
+            # Gueltige SAT Daten
+            my $WpTarget_Lat = $Waypoints[$WpPlayerIndex]{'Pos_Lat'};
+            my $WpTarget_Lon = $Waypoints[$WpPlayerIndex]{'Pos_Lon'};
+            my $WpTolerance  = $Waypoints[$WpPlayerIndex]{'ToleranceRadius'};
+            my $WpHoldtime   = $Waypoints[$WpPlayerIndex]{'Holdtime'};
+            # Operation Radius pruefen
+            my ($HomeDist, $HomeBearing) = &MapGpsTo($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, $WpTarget_Lat, $WpTarget_Lon );
+            if ( $HomeDist > $MkOsd{'OperatingRadius'} )
+                {
+                # Target entsprechend Operation Radius neu berechnen
+                $HomeDist = $MkOsd{'OperatingRadius'};
+                ($WpTarget_Lat, $WpTarget_Lon) = &MapGpsAt($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, $HomeDist, $HomeBearing);
+                }
+            # Abstand zum Ziel pruefen
+            my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, $WpTarget_Lat, $WpTarget_Lon );
+            if ( $Dist <= $WpTolerance )
+                {
+                # Target reached - count down Holdtime
+                $WpPlayerHoldtime = 2 * $WpHoldtime;      # 0..2n - decrement im 0.5s timer
+                }
+            }
+        }
+    if ( $WpPlayerHoldtime == 0 )  # wird im 0.5s timer runtergezaehlt
+        {
+        # Target reached - Holdtime is over
+        $WpPlayerHoldtime = -1;
+        return 1;
+        }
+    # Target NOT reached
+    return 0;
+    }
+#
+# Call Back
+#
+# Wp-Player CallBack: Play/Pause button
+sub CbWpPlayerPlayPause()
+    {
+    # Play/Pause-Icon loeschen und neu anzeigen
+    $map_canvas->delete('Wp-PlayPause');
+    if ( ($WpPlayerMode eq "Pause") or  ($WpPlayerMode eq "Stop") or  ($WpPlayerMode eq "Home") )
+        {
+        $WpPlayerMode = 'Play';
+        $WpPlayerHoldtime = -1;
+        $map_canvas->createImage($MapSizeX/2+100, $MapSizeY-48,
+                                 '-tags' => 'Wp-PlayPause',
+                                 '-anchor' => 'nw',
+                                 '-image'  => 'WpPause-Foto',
+                                 );
+        }
+    else
+        {
+        $WpPlayerMode = 'Pause';
+        $WpPlayerHoldtime = -1;
+        $map_canvas->createImage($MapSizeX/2+100, $MapSizeY-48,
+                                 '-tags' => 'Wp-PlayPause',
+                                 '-anchor' => 'nw',
+                                 '-image'  => 'WpPlay-Foto',
+                                 );
+        # momentane Position merken und im Wp-Timer dauernd senden
+        $WpPlayerPause_Lon = "";
+        $WpPlayerPause_Lat = "";
+        lock (%MkOsd);              # until end of block
+        if ( $MkOsd{'_Timestamp'} >= time-2 )
+            {
+            # Gueltige OSD Daten
+            if ( $MkOsd{'SatsInUse'} >= 6  and  $MkOsd{'CurPos_Stat'} == 1 )
+                {
+                $WpPlayerPause_Lon = $MkOsd{'CurPos_Lon'};
+                $WpPlayerPause_Lat = $MkOsd{'CurPos_Lat'};
+                }
+            }
+        }
+    }
+# Wp-Player CallBack: Next
+sub CbWpPlayerNext()
+    {
+    if ( $WpPlayerMode ne 'Stop' )
+        {
+        &WpTargetNext();
+        }
+    }
+# Wp-Player CallBack: Prev
+sub CbWpPlayerPrev()
+    {
+    if ( $WpPlayerMode ne 'Stop' )
+        {
+        &WpTargetPrev();
+        }
+    }
+# Wp-Player CallBack: First
+sub CbWpPlayerFirst()
+    {
+    if ( $WpPlayerMode ne 'Stop' )
+        {
+        &WpTargetFirst();
+        }
+    }
+# Wp-Player CallBack: Last
+sub CbWpPlayerLast()
+    {
+    if ( $WpPlayerMode ne 'Stop' )
+        {
+        &WpTargetLast();
+        }
+    }
+# Wp-Player CallBack: Home
+sub CbWpPlayerHome()
+    {
+    if ( $WpPlayerMode ne 'Stop' )
+        {
+        $WpPlayerMode = 'Home';
+        &WpTargetFirst();
+        $map_canvas->delete('Wp-PlayPause');
+        $map_canvas->createImage($MapSizeX/2+100, $MapSizeY-48,
+                                 '-tags' => 'Wp-PlayPause',
+                                 '-anchor' => 'nw',
+                                 '-image'  => 'WpPlay-Foto',
+                                 );
+        }
+    }
+# Wp-Player CallBack: Stop
+sub CbWpPlayerStop()
+    {
+    if ( $WpPlayerMode ne 'Stop' )
+        {
+        $WpPlayerMode = 'Stop';
+        &WpFirstFirst();
+        $map_canvas->delete('Wp-PlayPause');
+        $map_canvas->createImage($MapSizeX/2+100, $MapSizeY-48,
+                                 '-tags' => 'Wp-PlayPause',
+                                 '-anchor' => 'nw',
+                                 '-image'  => 'WpPlay-Foto',
+                                 );
+        # Show user that Waypoints in MK are cleared
+        $WaypointsModified = 1;
+        &WpRedrawLines();
+        }
+    }
+;
+__END__

 /MissionCockpit/tags/V0.2.0/mkcockpit.xml
 ,0 → 1,50
+<mkcockpit-Config CreationDate="20090515-182103">
+  <geserver HttpPort="8080" />
+  <logging CsvLogDir="log"
+           GpxLogDir="log"
+           Intervall="1.0"
+           KmlLogDir="log" />
+  <map MapDefault="Hemhofen"
+       MapDir="map" />
+  <mkcockpit AltFactor="25"
+             ColorAirfield="blue"
+             ColorFootprint="magenta"
+             ColorHomeDist="white"
+             ColorHomeLine="red"
+             ColorMkSatGood="yellow"
+             ColorMkSatLow="orange"
+             ColorMkSatNo="red"
+             ColorOsd="white"
+             ColorSpeedVector="white"
+             ColorTargetDist="black"
+             ColorTargetLine="green"
+             ColorVariometer="white"
+             ColorVariometerPointer="yellow"
+             ColorWpConnector="gray"
+             ColorWpNumber="gray"
+             ColorWpResend="red"
+             FootprintLength="120"
+             IconFox="icon/bear_48.gif"
+             IconHeartLarge="icon/heart_48.gif"
+             IconHeartSmall="icon/heart_32.gif"
+             IconSatellite="icon/satellite_64.gif"
+             IconTarget="icon/target_48.gif"
+             IconWaypoint="icon/waypoint_48.gif"
+             UBatWarning="10.0" />
+  <mkcomm Port="COM1" />
+  <track Active="No"
+         Port="COM8" />
+  <waypoint DefaultEventFlag="0"
+            DefaultHeading="0"
+            DefaultHoldtime="10"
+            DefaultToleranceRadius="5"
+            IconFirst="icon/WpFirst.gif"
+            IconHome="icon/WpHome.gif"
+            IconLast="icon/WpLast.gif"
+            IconNext="icon/WpNext.gif"
+            IconPause="icon/WpPause.gif"
+            IconPlay="icon/WpPlay.gif"
+            IconPrev="icon/WpPrev.gif"
+            IconStop="icon/WpStop.gif"
+            WpDir="waypoints" />
+</mkcockpit-Config>

 /MissionCockpit/tags/V0.2.0/mkcomm.pl
 ,0 → 1,702
+#!/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
+#
+###############################################################################
+$Version{'mkcomm.pl'} = "0.1.1 - 2009-04-06";
+# 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";
+# 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);
+# Queue for Sending to MK
+$MkSendQueue = Thread::Queue->new();
+#
+# Signal handler
+#
+$SIG{'INT'}  = 'SigHandler';
+$SIG{'KILL'} = 'SigHandler';
+sub SigHandler()
+    {
+    # 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'};
+    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";
+        }
+    # Set COM parameters
+    $MkPort->baudrate(57600);
+    $MkPort->parity("none");
+    $MkPort->databits(8);
+    $MkPort->stopbits(1);
+    $MkPort->handshake('none');
+    $MkPort->write_settings;
+    $MkPort->read_const_time(100); # total = (avg * bytes) + const (ms)
+    }
+# Read one line from MK
+# Check send-queue
+sub MkIOLine()
+    {
+    # Init serial port
+    &MkInit();
+    my $RxLine = "";
+    while ( 1 )
+        {
+        # Check Send-Queue
+        my $Items = $MkSendQueue->pending();
+        if ( $Items >= 3 )  # Cmd, Addr, Data
+            {
+            my ($Id, $Addr, $Data) = $MkSendQueue->dequeue(3);
+            &MkSend ($Id, $Addr, $Data);
+            }
+        # Zeichenweise lesen, blockierend mit Timeout
+        my ($RxLen, $RxChar) = $MkPort->read(1);
+          if ( $RxLen == 1 )
+              {
+            if ( "$RxChar" eq "#" )       # 1st char of line
+                {
+                $RxLine = "#";
+                }
+            elsif ( "$RxChar" eq "\r" )   # last char of line
+                {
+                return ($RxLine);
+                }
+            else
+                {
+                $RxLine = "$RxLine" . "$RxChar";    # collect char
+                }
+            }
+        }
+    }
+# Read and decode a command from MK
+# process send queue in &MkIOLine()
+sub MkIO()
+    {
+    my $RxData = &MkIOLine();     # Blocking Read for complete line
+    # Zeile decodieren
+    if ( substr ($RxData, 0, 1) eq '#' )
+        {
+        # Zeile decodieren
+        $Header = substr($RxData, 0, 3);
+        $Chksum = substr($RxData, -2);
+        $Data = substr($RxData, 3, length ($RxData) -5);
+        # CRC prüfen
+        if ( &CrcCheck ("$Header" . "$Data", $Chksum ) )
+            {
+            # Base64 decodieren
+            $Data = &Decode64($Data);
+            # Daten auswerten und in shared Hash schreiben
+            if ( &ProcessRx($Header, $Data) )
+                {
+                return 1;    # alles OK
+                }
+            }
+        }
+    return 0;  # keine Daten empfangen
+    }
+# Send a command to MK
+sub MkSend()
+    {
+    my ($Id, $Addr, $Data) = @_;
+    # Init serial port
+    &MkInit();
+    my $Base64Data = &Encode64($Data);
+    my $TxData = "#" . "$Addr" . "$Id" . "$Base64Data";
+    my $Crc = &Crc($TxData);
+    my $TxSend  = "$TxData" . "$Crc" . "\r";
+    $MkPort->write($TxSend);
+    }
+# close COM-Port
+sub MkClose()
+    {
+    undef $MkPort;
+    }
+# CRC Prüfung
+sub CrcCheck ()
+    {
+    my ($Data, $Crc) = @_;
+    my $Check = &Crc($Data);
+    if ( $Check ne $Crc )
+        {
+        return 0;   # CRC passt nicht
+        }
+    return (1);    # CRC OK
+    }
+# CRC berechnen
+sub Crc ()
+    {
+    my ($Data) = @_;
+    my $TmpCrc = 0;
+    my $Len = length $Data;
+    for ($i=0; $i<$Len; $i++)
+        {
+        $TmpCrc += ord(substr($Data, $i, 1));
+        }
+    $TmpCrc %= 4096;
+    my $Crc1 = ord ("=") + $TmpCrc / 64;
+    my $Crc2 = ord ("=") + $TmpCrc % 64;
+    $Crc = pack("CC", $Crc1, $Crc2);
+    return ($Crc);
+    }
+# Empfangene Daten decodieren, modifiziertes Base64
+sub Decode64()
+    {
+    my ($DataIn) = @_;
+    my $ptrIn  = 0;
+    my $DataOut  = "";
+    my $len = length ($DataIn);
+    while ( $len > 0 )
+        {
+        $a = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("=");
+        $b = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("=");
+        $c = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("=");
+        $d = ord (substr ($DataIn, $ptrIn ++, 1)) - ord ("=");
+        $x = ($a << 2) | ($b >> 4);
+        $y = (($b & 0x0f) << 4) | ($c >> 2);
+        $z = (($c & 0x03) << 6) | $d;
+        foreach $i ( $x, $y, $z )
+            {
+            if ( $len--)
+                {
+                my $Tmp = pack ('C1', $i);
+                $DataOut = "$DataOut" . "$Tmp";
+                }
+            else
+                {
+                last;
+                }
+            }
+        }
+    return ($DataOut);
+    }
+# zu sendende Daten codieren, modifiziertes Base64
+sub Encode64()
+    {
+    my ($Data) = @_;
+    my $Length = length $Data;
+    my $TxBuf = "";
+    my $ptr = 0;
+    while( $Length > 0 )
+        {
+        my $a = 0;
+        my $b = 0;
+        my $c = 0;
+        if ($Length) {$a = ord(substr ($Data, $ptr++, $Length--));}
+        if ($Length) {$b = ord(substr ($Data, $ptr++, $Length--));}
+        if ($Length) {$c = ord(substr ($Data, $ptr++, $Length--));}
+        my $ac = ord("=") +    ($a >> 2);
+        my $bc = ord("=") + ( (($a & 0x03) << 4) | (($b & 0xf0) >> 4) );
+        my $cc = ord("=") + ( (($b & 0x0f) << 2) | (($c & 0xc0) >> 6) );
+        my $dc = ord("=") +    ($c & 0x3f);
+        $TxBuf = "$TxBuf" . pack ("C4", $ac, $bc, $cc, $dc);
+        }
+    return ($TxBuf);
+    }
+# Empfangenen Datensatz verarbeiten
+sub ProcessRx()
+    {
+    my ($Header, $Data) = @_;
+    my $Adr = substr ($Header, 1, 1);    # b=FC, c=NC, d=MK3MAG
+    my $Id  = substr ($Header, 2, 1);
+    if ( $Id eq "O" )
+        {
+        #
+        # OSD-Daten nach %MkOsd einlesen
+        #
+        # Struktur Datensatz:
+        #     u8  Version                                     // version of the data structure
+        #     GPS_Pos_t CurrentPosition;
+        #     GPS_Pos_t TargetPosition;
+        #     GPS_PosDev_t TargetPositionDeviation;
+        #     GPS_Pos_t HomePosition;
+        #     GPS_PosDev_t HomePositionDeviation;
+        #     u8  WaypointIndex;                              // index of current waypoints running from 0 to WaypointNumber-1
+        #     u8  WaypointNumber;                             // number of stored waypoints
+        #     u8  SatsInUse;                                  // no of satellites used for position solution
+        #     s16 Altimeter;                                  // hight according to air pressure
+        #     s16 Variometer;                                 // climb(+) and sink(-) rate
+        #     u16 FlyingTime;                                 // in seconds
+        #     u8  UBat;                                       // Battery Voltage in 0.1 Volts
+        #     u16 GroundSpeed;                                // speed over ground in cm/s (2D)
+        #     s16 Heading;                                    // current flight direction in deg as angle to north
+        #     s16 CompassHeading;                             // current compass value
+        #     s8  AngleNick;                                  // current Nick angle in 1°
+        #     s8  AngleRoll;                                  // current Rick angle in 1°
+        #     u8  RC_Quality;                                 // RC_Quality
+        #     u8  MKFlags;                                    // Flags from FC
+        #     u8  NCFlags;                                    // Flags from NC
+        #     u8  Errorcode;                                  // 0 --> okay
+        #     u8  OperatingRadius                             // current operation radius around the Home Position in m
+        #     s16 TopSpeed;                                   // velocity in vertical direction in cm/s
+        #     u8  TargetHoldTime;                             // time in s to stay at the given target, counts down to 0 if target has been reached
+        #     u8  Reserve[4];                                 // for future use
+        # GPS_Pos_t:
+        #     s32 Longitude;   // in 1E-7 deg
+        #     s32 Latitude;    // in 1E-7 deg
+        #     s32 Altitude;    // in mm
+        #     u8  Status;      // validity of data
+        # GPS_PosDev_t:
+        #     s16 Distance;                                   // distance to target in dm
+        #     s16 Bearing;                                    // course to target in deg
+        # Status:
+        #     INVALID         = 0
+        #     NEWDATA         = 1
+        #     PROCESSED       = 2
+        # MKFlags  0x01: MOTOR_RUN, 0x02 FLY, 0x04: CALIBRATE, 0x08: START, 0x10: EMERGENCY_LANDING
+        # NCFlags  0x01: FLAG_FREE, 0x02: FLAG_PH, 0x04: FLAG_CH, 0x08: FLAG_RANGE_LIMIT
+        #          0x10: FLAG_NOSERIALLINK, 0x20: FLAG_TARGET_REACHED, FLAG_MANUAL_CONTROL: 0x40
+        #          0x80: FLAG_8
+        lock (%MkOsd);  # until end of Block
+        (
+        $MkOsd{'Version'},
+        $MkOsd{'CurPos_Lon'},
+        $MkOsd{'CurPos_Lat'},
+        $MkOsd{'CurPos_Alt'},
+        $MkOsd{'CurPos_Stat'},
+        $MkOsd{'TargetPos_Lon'},
+        $MkOsd{'TargetPos_Lat'},
+        $MkOsd{'TargetPos_Alt'},
+        $MkOsd{'TargetPos_Stat'},
+        $MkOsd{'TargetPosDev_Dist'},
+        $MkOsd{'TargetPosDev_Bearing'},
+        $MkOsd{'HomePos_Lon'},
+        $MkOsd{'HomePos_Lat'},
+        $MkOsd{'HomePos_Alt'},
+        $MkOsd{'HomePos_Stat'},
+        $MkOsd{'HomePosDev_Dist'},
+        $MkOsd{'HomePosDev_Bearing'},
+        $MkOsd{'WaypointIndex'},
+        $MkOsd{'WaypointNumber'},
+        $MkOsd{'SatsInUse'},
+        $MkOsd{'Altimeter'},
+        $MkOsd{'Variometer'},
+        $MkOsd{'FlyingTime'},
+        $MkOsd{'UBat'},
+        $MkOsd{'GroundSpeed'},
+        $MkOsd{'Heading'},
+        $MkOsd{'CompassHeading'},
+        $MkOsd{'AngleNick'},
+        $MkOsd{'AngleRoll'},
+        $MkOsd{'RC_Quality'},
+        $MkOsd{'MKFlags'},
+        $MkOsd{'NCFlags'},
+        $MkOsd{'Errorcode'},
+        $MkOsd{'OperatingRadius'},
+        $MkOsd{'TopSpeed'},
+        $MkOsd{'TargetHoldTime'},
+        ) = unpack ('ClllClllCsslllCssCCCssSCSssccCCCCCsC', $Data);
+        $MkOsd{'CurPos_Lon'}     = sprintf("%.7f", $MkOsd{'CurPos_Lon'} / 10000000);
+        $MkOsd{'CurPos_Lat'}     = sprintf("%.7f", $MkOsd{'CurPos_Lat'} / 10000000);
+        $MkOsd{'CurPos_Alt'}     = sprintf("%.3f", $MkOsd{'CurPos_Alt'} / 1000);
+        $MkOsd{'TargetPos_Lon'}  = sprintf("%.7f", $MkOsd{'TargetPos_Lon'} / 10000000);
+        $MkOsd{'TargetPos_Lat'}  = sprintf("%.7f", $MkOsd{'TargetPos_Lat'} / 10000000);
+        $MkOsd{'TargetPos_Alt'}  = sprintf("%.3f", $MkOsd{'TargetPos_Alt'} / 1000);
+        $MkOsd{'HomePos_Lon'}    = sprintf("%.7f", $MkOsd{'HomePos_Lon'} / 10000000);
+        $MkOsd{'HomePos_Lat'}    = sprintf("%.7f", $MkOsd{'HomePos_Lat'} / 10000000);
+        $MkOsd{'HomePos_Alt'}    = sprintf("%.3f", $MkOsd{'HomePos_Alt'} / 1000);
+        $MkOsd{'UBat'}           = sprintf("%.1f", $MkOsd{'UBat'} / 10);
+        # Timestamp, wann der Datensatz geschtieben wurde
+        $MkOsd{'_Timestamp'} = time;
+        }
+    elsif ( $Id eq "s" )
+        {
+        #
+        # NC Target position in %MkTarget
+        #
+        # Datenstruktur:
+        #    GPS_Pos_t Position;     // the gps position of the waypoint, see ubx.h for details
+        #    s16 Heading;            // orientation, future implementation
+        #    u8  ToleranceRadius;    // in meters, if the MK is within that range around the target, then the next target is
+        #    u8  HoldTime;           // in seconds, if the MK was once in the tolerance area around a WP,
+        #                            // this time defines the delay before the next WP is triggered
+        #    u8  Event_Flag;         // future emplementation
+        #    u8  reserve[12];        // reserved
+        lock (%MkTarget);  # until end of block
+        (
+        $MkTarget{'Pos_Lon'},
+        $MkTarget{'Pos_Lat'},
+        $MkTarget{'Pos_Alt'},
+        $MkTarget{'Pos_Stat'},
+        $MkTarget{'Heading'},
+        $MkTarget{'ToleranceRadius'},
+        $MkTarget{'HoldTime'},
+        $MkTarget{'EventFlag'},
+        ) = unpack ('lllCsCCC', $Data);
+        $MkTarget{'Pos_Lon'} = sprintf("%.7f", $MkTarget{'Pos_Lon'} / 10000000);
+        $MkTarget{'Pos_Lat'} = sprintf("%.7f", $MkTarget{'Pos_Lat'} / 10000000);
+        $MkTarget{'Pos_Alt'} = sprintf("%.3f", $MkTarget{'Pos_Alt'} / 1000);
+        # Timestamp, wann der Datensatz geschtieben wurdw
+        $MkTarget{'_Timestamp'} = time;
+        }
+    elsif ( $Id eq "W" )
+        {
+        #
+        # Request new waypoint
+        #
+        # Datenstruktur:
+        #    u8 Number of waypoint
+        ($WpNumber) = unpack ('C', $Data);
+        # keine Ahnung wofuer das gut sein soll
+        # print "Request new Waypoint Number: $WpNumber\n";
+        }
+    elsif ( $Id eq "V" )
+        {
+        #
+        # Version
+        #
+        # Datenstruktur:
+        #    u8 SWMajor
+        #    u8 SWMinor
+        #    u8 ProtoMajor
+        #    u8 ProtoMinor
+        #    u8 SWPatch
+        #    u8 Reserved[5]
+        (
+        $Mk{'SWMajor'},
+        $Mk{'SWMinor'},
+        $Mk{'ProtoMajor'},
+        $Mk{'ProtoMinor'},
+        $Mk{'SWPatch'},
+        ) = unpack ('C5', $Data);
+        $Mk{'_Timestamp'} = time;
+        }
+    elsif ( $Id eq "E" )
+        {
+        #
+        # Error Text
+        #
+        # Datenstruktur:
+        #    s8 ErrorMsg[25]
+        $Mk{'ErrorMsg'} = unpack ('Z25', $Data);
+        }
+    elsif ( $Id eq "D" )
+        {
+        #
+        # NC Debug %MkNcDebug
+        #
+        # Datenstruktur:
+        #    u8 Digital[2];
+        #    u16 Analog[32];
+        lock (%MkNcDebug);    # until end of block
+        (
+        $MkNcDebug{'Digital_00'},
+        $MkNcDebug{'Digital_01'},
+        $MkNcDebug{'Analog_00'},
+        $MkNcDebug{'Analog_01'},
+        $MkNcDebug{'Analog_02'},
+        $MkNcDebug{'Analog_03'},
+        $MkNcDebug{'Analog_04'},
+        $MkNcDebug{'Analog_05'},
+        $MkNcDebug{'Analog_06'},
+        $MkNcDebug{'Analog_07'},
+        $MkNcDebug{'Analog_08'},
+        $MkNcDebug{'Analog_09'},
+        $MkNcDebug{'Analog_10'},
+        $MkNcDebug{'Analog_11'},
+        $MkNcDebug{'Analog_12'},
+        $MkNcDebug{'Analog_13'},
+        $MkNcDebug{'Analog_14'},
+        $MkNcDebug{'Analog_15'},
+        $MkNcDebug{'Analog_16'},
+        $MkNcDebug{'Analog_17'},
+        $MkNcDebug{'Analog_18'},
+        $MkNcDebug{'Analog_19'},
+        $MkNcDebug{'Analog_20'},
+        $MkNcDebug{'Analog_21'},
+        $MkNcDebug{'Analog_22'},
+        $MkNcDebug{'Analog_23'},
+        $MkNcDebug{'Analog_24'},
+        $MkNcDebug{'Analog_25'},
+        $MkNcDebug{'Analog_26'},
+        $MkNcDebug{'Analog_27'},
+        $MkNcDebug{'Analog_28'},
+        $MkNcDebug{'Analog_29'},
+        $MkNcDebug{'Analog_30'},
+        $MkNcDebug{'Analog_31'},
+        ) = unpack ('C2s32', $Data);
+        # Timestamp, wann der Datensatz geschrieben wurde
+        $MkNcDebug{'_Timestamp'} = time;
+        }
+    else
+        {
+        print "Unknown Command: $Header $Data\n";
+        }
+    }
+# send Target or Waypoint to MK
+sub MkFlyTo()
+    {
+    my %Param = @_;
+    my $x               = $Param{'-x'};
+    my $y               = $Param{'-y'};
+    my $Lat             = $Param{'-lat'};
+    my $Lon             = $Param{'-lon'};
+    my $Alt             = $Param{'-alt'};
+    my $Heading         = $Param{'-heading'};
+    my $ToleranceRadius = $Param{'-toleranceradius'};
+    my $Holdtime        = $Param{'-holdtime'};
+    my $EventFlag       = $Param{'-eventflag'};
+    my $Mode            = $Param{'-mode'};
+    if ( $x ne ""  and  $y ne ""  and  $Lat eq ""  and  $Lon eq "" )
+        {
+        ($Lat, $Lon) = &MapXY2Gps($x, $y);
+        }
+    if ( $Alt eq "" )             { $Alt = $MkOsd{'CurPos_Alt'}; }
+    if ( $Heading eq "" )         { $Heading         = $Cfg->{'waypoint'}->{'DefaultHeading'}; }
+    if ( $ToleranceRadius eq "" ) { $ToleranceRadius = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; }
+    if ( $Holdtime eq "" )        { $Holdtime        = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; }
+    if ( $EventFlag eq "" )       { $EventFlag       = $Cfg->{'waypoint'}->{'DefaultEventFlag'}; }
+    my $Status = 1;     # valid
+    if ( $Mode =~ /delete/i )
+        {
+        $Status = 0;    # invalid -> delete NC WP-List
+        }
+    my $Lat_i = sprintf "%d", $Lat * 10000000;
+    my $Lon_i = sprintf "%d", $Lon * 10000000;
+    my $Alt_i = sprintf "%d", $Alt * 1000;
+    # Datenstruktur:
+    #    GPS_Pos_t Position;     // the gps position of the waypoint, see ubx.h for details
+    #    s16 Heading;            // orientation, future implementation
+    #    u8  ToleranceRadius;    // in meters, if the MK is within that range around the target, then the next target is
+    #    u8  HoldTime;           // in seconds, if the MK was once in the tolerance area around a WP,
+    #                            // this time defines the delay before the next WP is triggered
+    #    u8  Event_Flag;         // future emplementation
+    #    u8  reserve[12];        // reserved
+    my $Wp = pack ('lllCsC15',
+                   $Lon_i,
+                   $Lat_i,
+                   $Alt_i,
+                   $Status,
+                   $Heading,
+                   $ToleranceRadius,
+                   $Holdtime,
+                   $EventFlag,
+,0,0,0,0,0,0,0,0,0,0,0,
+                  );
+    if ( $Mode =~ /waypoint/i )
+        {
+        $MkSendQueue->enqueue( "w", "$AddrNC", $Wp );
+        # &MkSend( "w", "$AddrNC", $Wp );
+        }
+    elsif ( $Mode =~ /target/i )
+        {
+        $MkSendQueue->enqueue( "s", "$AddrNC", $Wp );
+        # &MkSend( "w", "$AddrNC", $Wp );
+        }
+    else
+        {
+        # ignore
+        }
+    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
+    }
+;
+__END__

 /MissionCockpit/tags/V0.2.0/perl/lib/Thread/Queue.pm
 ,0 → 1,481
+package Thread::Queue;
+use strict;
+use warnings;
+our $VERSION = '2.11';
+use threads::shared 1.21;
+use Scalar::Util 1.10 qw(looks_like_number blessed reftype refaddr);
+# Carp errors from threads::shared calls should complain about caller
+our @CARP_NOT = ("threads::shared");
+# Predeclarations for internal functions
+my ($validate_count, $validate_index);
+# Create a new queue possibly pre-populated with items
+sub new
+{
+    my $class = shift;
+    my @queue :shared = map { shared_clone($_) } @_;
+    return bless(\@queue, $class);
+}
+# Add items to the tail of a queue
+sub enqueue
+{
+    my $queue = shift;
+    lock(@$queue);
+    push(@$queue, map { shared_clone($_) } @_)
+        and cond_signal(@$queue);
+}
+# Return a count of the number of items on a queue
+sub pending
+{
+    my $queue = shift;
+    lock(@$queue);
+    return scalar(@$queue);
+}
+# Return 1 or more items from the head of a queue, blocking if needed
+sub dequeue
+{
+    my $queue = shift;
+    lock(@$queue);
+    my $count = @_ ? $validate_count->(shift) : 1;
+    # Wait for requisite number of items
+    cond_wait(@$queue) until (@$queue >= $count);
+    cond_signal(@$queue) if (@$queue > $count);
+    # Return single item
+    return shift(@$queue) if ($count == 1);
+    # Return multiple items
+    my @items;
+    push(@items, shift(@$queue)) for (1..$count);
+    return @items;
+}
+# Return items from the head of a queue with no blocking
+sub dequeue_nb
+{
+    my $queue = shift;
+    lock(@$queue);
+    my $count = @_ ? $validate_count->(shift) : 1;
+    # Return single item
+    return shift(@$queue) if ($count == 1);
+    # Return multiple items
+    my @items;
+    for (1..$count) {
+        last if (! @$queue);
+        push(@items, shift(@$queue));
+    }
+    return @items;
+}
+# Return an item without removing it from a queue
+sub peek
+{
+    my $queue = shift;
+    lock(@$queue);
+    my $index = @_ ? $validate_index->(shift) : 0;
+    return $$queue[$index];
+}
+# Insert items anywhere into a queue
+sub insert
+{
+    my $queue = shift;
+    lock(@$queue);
+    my $index = $validate_index->(shift);
+    return if (! @_);   # Nothing to insert
+    # Support negative indices
+    if ($index < 0) {
+        $index += @$queue;
+        if ($index < 0) {
+            $index = 0;
+        }
+    }
+    # Dequeue items from $index onward
+    my @tmp;
+    while (@$queue > $index) {
+        unshift(@tmp, pop(@$queue))
+    }
+    # Add new items to the queue
+    push(@$queue, map { shared_clone($_) } @_);
+    # Add previous items back onto the queue
+    push(@$queue, @tmp);
+    # Soup's up
+    cond_signal(@$queue);
+}
+# Remove items from anywhere in a queue
+sub extract
+{
+    my $queue = shift;
+    lock(@$queue);
+    my $index = @_ ? $validate_index->(shift) : 0;
+    my $count = @_ ? $validate_count->(shift) : 1;
+    # Support negative indices
+    if ($index < 0) {
+        $index += @$queue;
+        if ($index < 0) {
+            $count += $index;
+            return if ($count <= 0);            # Beyond the head of the queue
+            return $queue->dequeue_nb($count);  # Extract from the head
+        }
+    }
+    # Dequeue items from $index+$count onward
+    my @tmp;
+    while (@$queue > ($index+$count)) {
+        unshift(@tmp, pop(@$queue))
+    }
+    # Extract desired items
+    my @items;
+    unshift(@items, pop(@$queue)) while (@$queue > $index);
+    # Add back any removed items
+    push(@$queue, @tmp);
+    # Return single item
+    return $items[0] if ($count == 1);
+    # Return multiple items
+    return @items;
+}
+### Internal Functions ###
+# Check value of the requested index
+$validate_index = sub {
+    my $index = shift;
+    if (! defined($index) ||
+        ! looks_like_number($index) ||
+        (int($index) != $index))
+    {
+        require Carp;
+        my ($method) = (caller(1))[3];
+        $method =~ s/Thread::Queue:://;
+        $index = 'undef' if (! defined($index));
+        Carp::croak("Invalid 'index' argument ($index) to '$method' method");
+    }
+    return $index;
+};
+# Check value of the requested count
+$validate_count = sub {
+    my $count = shift;
+    if (! defined($count) ||
+        ! looks_like_number($count) ||
+        (int($count) != $count) ||
+        ($count < 1))
+    {
+        require Carp;
+        my ($method) = (caller(1))[3];
+        $method =~ s/Thread::Queue:://;
+        $count = 'undef' if (! defined($count));
+        Carp::croak("Invalid 'count' argument ($count) to '$method' method");
+    }
+    return $count;
+};
+;
+=head1 NAME
+Thread::Queue - Thread-safe queues
+=head1 VERSION
+This document describes Thread::Queue version 2.11
+=head1 SYNOPSIS
+    use strict;
+    use warnings;
+    use threads;
+    use Thread::Queue;
+    my $q = Thread::Queue->new();    # A new empty queue
+    # Worker thread
+    my $thr = threads->create(sub {
+                                while (my $item = $q->dequeue()) {
+                                    # Do work on $item
+                                }
+                             })->detach();
+    # Send work to the thread
+    $q->enqueue($item1, ...);
+    # Count of items in the queue
+    my $left = $q->pending();
+    # Non-blocking dequeue
+    if (defined(my $item = $q->dequeue_nb())) {
+        # Work on $item
+    }
+    # Get the second item in the queue without dequeuing anything
+    my $item = $q->peek(1);
+    # Insert two items into the queue just behind the head
+    $q->insert(1, $item1, $item2);
+    # Extract the last two items on the queue
+    my ($item1, $item2) = $q->extract(-2, 2);
+=head1 DESCRIPTION
+This module provides thread-safe FIFO queues that can be accessed safely by
+any number of threads.
+Any data types supported by L<threads::shared> can be passed via queues:
+=over
+=item Ordinary scalars
+=item Array refs
+=item Hash refs
+=item Scalar refs
+=item Objects based on the above
+=back
+Ordinary scalars are added to queues as they are.
+If not already thread-shared, the other complex data types will be cloned
+(recursively, if needed, and including any C<bless>ings and read-only
+settings) into thread-shared structures before being placed onto a queue.
+For example, the following would cause L<Thread::Queue> to create a empty,
+shared array reference via C<&shared([])>, copy the elements 'foo', 'bar'
+and 'baz' from C<@ary> into it, and then place that shared reference onto
+the queue:
+    my @ary = qw/foo bar baz/;
+    $q->enqueue(\@ary);
+However, for the following, the items are already shared, so their references
+are added directly to the queue, and no cloning takes place:
+    my @ary :shared = qw/foo bar baz/;
+    $q->enqueue(\@ary);
+    my $obj = &shared({});
+    $$obj{'foo'} = 'bar';
+    $$obj{'qux'} = 99;
+    bless($obj, 'My::Class');
+    $q->enqueue($obj);
+See L</"LIMITATIONS"> for caveats related to passing objects via queues.
+=head1 QUEUE CREATION
+=over
+=item ->new()
+Creates a new empty queue.
+=item ->new(LIST)
+Creates a new queue pre-populated with the provided list of items.
+=back
+=head1 BASIC METHODS
+The following methods deal with queues on a FIFO basis.
+=over
+=item ->enqueue(LIST)
+Adds a list of items onto the end of the queue.
+=item ->dequeue()
+=item ->dequeue(COUNT)
+Removes the requested number of items (default is 1) from the head of the
+queue, and returns them.  If the queue contains fewer than the requested
+number of items, then the thread will be blocked until the requisite number
+of items are available (i.e., until other threads <enqueue> more items).
+=item ->dequeue_nb()
+=item ->dequeue_nb(COUNT)
+Removes the requested number of items (default is 1) from the head of the
+queue, and returns them.  If the queue contains fewer than the requested
+number of items, then it immediately (i.e., non-blocking) returns whatever
+items there are on the queue.  If the queue is empty, then C<undef> is
+returned.
+=item ->pending()
+Returns the number of items still in the queue.
+=back
+=head1 ADVANCED METHODS
+The following methods can be used to manipulate items anywhere in a queue.
+To prevent the contents of a queue from being modified by another thread
+while it is being examined and/or changed, L<lock|threads::shared/"lock
+VARIABLE"> the queue inside a local block:
+    {
+        lock($q);   # Keep other threads from changing the queue's contents
+        my $item = $q->peek();
+        if ($item ...) {
+            ...
+        }
+    }
+    # Queue is now unlocked
+=over
+=item ->peek()
+=item ->peek(INDEX)
+Returns an item from the queue without dequeuing anything.  Defaults to the
+the head of queue (at index position 0) if no index is specified.  Negative
+index values are supported as with L<arrays|perldata/"Subscripts"> (i.e., -1
+is the end of the queue, -2 is next to last, and so on).
+If no items exists at the specified index (i.e., the queue is empty, or the
+index is beyond the number of items on the queue), then C<undef> is returned.
+Remember, the returned item is not removed from the queue, so manipulating a
+C<peek>ed at reference affects the item on the queue.
+=item ->insert(INDEX, LIST)
+Adds the list of items to the queue at the specified index position (0
+is the head of the list).  Any existing items at and beyond that position are
+pushed back past the newly added items:
+    $q->enqueue(1, 2, 3, 4);
+    $q->insert(1, qw/foo bar/);
+    # Queue now contains:  1, foo, bar, 2, 3, 4
+Specifying an index position greater than the number of items in the queue
+just adds the list to the end.
+Negative index positions are supported:
+    $q->enqueue(1, 2, 3, 4);
+    $q->insert(-2, qw/foo bar/);
+    # Queue now contains:  1, 2, foo, bar, 3, 4
+Specifying a negative index position greater than the number of items in the
+queue adds the list to the head of the queue.
+=item ->extract()
+=item ->extract(INDEX)
+=item ->extract(INDEX, COUNT)
+Removes and returns the specified number of items (defaults to 1) from the
+specified index position in the queue (0 is the head of the queue).  When
+called with no arguments, C<extract> operates the same as C<dequeue_nb>.
+This method is non-blocking, and will return only as many items as are
+available to fulfill the request:
+    $q->enqueue(1, 2, 3, 4);
+    my $item  = $q->extract(2)     # Returns 3
+                                   # Queue now contains:  1, 2, 4
+    my @items = $q->extract(1, 3)  # Returns (2, 4)
+                                   # Queue now contains:  1
+Specifying an index position greater than the number of items in the
+queue results in C<undef> or an empty list being returned.
+    $q->enqueue('foo');
+    my $nada = $q->extract(3)      # Returns undef
+    my @nada = $q->extract(1, 3)   # Returns ()
+Negative index positions are supported.  Specifying a negative index position
+greater than the number of items in the queue may return items from the head
+of the queue (similar to C<dequeue_nb>) if the count overlaps the head of the
+queue from the specified position (i.e. if queue size + index + count is
+greater than zero):
+    $q->enqueue(qw/foo bar baz/);
+    my @nada = $q->extract(-6, 2);   # Returns ()         - (3+(-6)+2) <= 0
+    my @some = $q->extract(-6, 4);   # Returns (foo)      - (3+(-6)+4) > 0
+                                     # Queue now contains:  bar, baz
+    my @rest = $q->extract(-3, 4);   # Returns (bar, baz) - (2+(-3)+4) > 0
+=back
+=head1 NOTES
+Queues created by L<Thread::Queue> can be used in both threaded and
+non-threaded applications.
+=head1 LIMITATIONS
+Passing objects on queues may not work if the objects' classes do not support
+sharing.  See L<threads::shared/"BUGS AND LIMITATIONS"> for more.
+Passing array/hash refs that contain objects may not work for Perl prior to
+.10.0.
+=head1 SEE ALSO
+Thread::Queue Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/Thread-Queue>
+Annotated POD for Thread::Queue:
+L<http://annocpan.org/~JDHEDDEN/Thread-Queue-2.11/lib/Thread/Queue.pm>
+Source repository:
+L<http://code.google.com/p/thread-queue/>
+L<threads>, L<threads::shared>
+=head1 MAINTAINER
+Jerry D. Hedden, S<E<lt>jdhedden AT cpan DOT orgE<gt>>
+=head1 LICENSE
+This program is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+=cut

 /MissionCockpit/tags/V0.2.0/perl/lib/XML/Simple.pm
 ,0 → 1,3284
+# $Id: Simple.pm,v 1.40 2007/08/15 10:36:48 grantm Exp $
+package XML::Simple;
+=head1 NAME
+XML::Simple - Easy API to maintain XML (esp config files)
+=head1 SYNOPSIS
+    use XML::Simple;
+    my $ref = XMLin([<xml file or string>] [, <options>]);
+    my $xml = XMLout($hashref [, <options>]);
+Or the object oriented way:
+    require XML::Simple;
+    my $xs = XML::Simple->new(options);
+    my $ref = $xs->XMLin([<xml file or string>] [, <options>]);
+    my $xml = $xs->XMLout($hashref [, <options>]);
+(or see L<"SAX SUPPORT"> for 'the SAX way').
+To catch common errors:
+    use XML::Simple qw(:strict);
+(see L<"STRICT MODE"> for more details).
+=cut
+# See after __END__ for more POD documentation
+# Load essentials here, other modules loaded on demand later
+use strict;
+use Carp;
+require Exporter;
+##############################################################################
+# Define some constants
+#
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $PREFERRED_PARSER);
+@ISA               = qw(Exporter);
+@EXPORT            = qw(XMLin XMLout);
+@EXPORT_OK         = qw(xml_in xml_out);
+$VERSION           = '2.18';
+$PREFERRED_PARSER  = undef;
+my $StrictMode     = 0;
+my @KnownOptIn     = qw(keyattr keeproot forcecontent contentkey noattr
+                        searchpath forcearray cache suppressempty parseropts
+                        grouptags nsexpand datahandler varattr variables
+                        normalisespace normalizespace valueattr);
+my @KnownOptOut    = qw(keyattr keeproot contentkey noattr
+                        rootname xmldecl outputfile noescape suppressempty
+                        grouptags nsexpand handler noindent attrindent nosort
+                        valueattr numericescape);
+my @DefKeyAttr     = qw(name key id);
+my $DefRootName    = qq(opt);
+my $DefContentKey  = qq(content);
+my $DefXmlDecl     = qq(<?xml version='1.0' standalone='yes'?>);
+my $xmlns_ns       = 'http://www.w3.org/2000/xmlns/';
+my $bad_def_ns_jcn = '{' . $xmlns_ns . '}';     # LibXML::SAX workaround
+##############################################################################
+# Globals for use by caching routines
+#
+my %MemShareCache  = ();
+my %MemCopyCache   = ();
+##############################################################################
+# Wrapper for Exporter - handles ':strict'
+#
+sub import {
+  # Handle the :strict tag
+  $StrictMode = 1 if grep(/^:strict$/, @_);
+  # Pass everything else to Exporter.pm
+  @_ = grep(!/^:strict$/, @_);
+  goto &Exporter::import;
+}
+##############################################################################
+# Constructor for optional object interface.
+#
+sub new {
+  my $class = shift;
+  if(@_ % 2) {
+    croak "Default options must be name=>value pairs (odd number supplied)";
+  }
+  my %known_opt;
+  @known_opt{@KnownOptIn, @KnownOptOut} = (undef) x 100;
+  my %raw_opt = @_;
+  my %def_opt;
+  while(my($key, $val) = each %raw_opt) {
+    my $lkey = lc($key);
+    $lkey =~ s/_//g;
+    croak "Unrecognised option: $key" unless(exists($known_opt{$lkey}));
+    $def_opt{$lkey} = $val;
+  }
+  my $self = { def_opt => \%def_opt };
+  return(bless($self, $class));
+}
+##############################################################################
+# Sub: _get_object()
+#
+# Helper routine called from XMLin() and XMLout() to create an object if none
+# was provided.  Note, this routine does mess with the caller's @_ array.
+#
+sub _get_object {
+  my $self;
+  if($_[0]  and  UNIVERSAL::isa($_[0], 'XML::Simple')) {
+    $self = shift;
+  }
+  else {
+    $self = XML::Simple->new();
+  }
+  return $self;
+}
+##############################################################################
+# Sub/Method: XMLin()
+#
+# Exported routine for slurping XML into a hashref - see pod for info.
+#
+# May be called as object method or as a plain function.
+#
+# Expects one arg for the source XML, optionally followed by a number of
+# name => value option pairs.
+#
+sub XMLin {
+  my $self = &_get_object;      # note, @_ is passed implicitly
+  my $target = shift;
+  # Work out whether to parse a string, a file or a filehandle
+  if(not defined $target) {
+    return $self->parse_file(undef, @_);
+  }
+  elsif($target eq '-') {
+    local($/) = undef;
+    $target = <STDIN>;
+    return $self->parse_string(\$target, @_);
+  }
+  elsif(my $type = ref($target)) {
+    if($type eq 'SCALAR') {
+      return $self->parse_string($target, @_);
+    }
+    else {
+      return $self->parse_fh($target, @_);
+    }
+  }
+  elsif($target =~ m{<.*?>}s) {
+    return $self->parse_string(\$target, @_);
+  }
+  else {
+    return $self->parse_file($target, @_);
+  }
+}
+##############################################################################
+# Sub/Method: parse_file()
+#
+# Same as XMLin, but only parses from a named file.
+#
+sub parse_file {
+  my $self = &_get_object;      # note, @_ is passed implicitly
+  my $filename = shift;
+  $self->handle_options('in', @_);
+  $filename = $self->default_config_file if not defined $filename;
+  $filename = $self->find_xml_file($filename, @{$self->{opt}->{searchpath}});
+  # Check cache for previous parse
+  if($self->{opt}->{cache}) {
+    foreach my $scheme (@{$self->{opt}->{cache}}) {
+      my $method = 'cache_read_' . $scheme;
+      my $opt = $self->$method($filename);
+      return($opt) if($opt);
+    }
+  }
+  my $ref = $self->build_simple_tree($filename, undef);
+  if($self->{opt}->{cache}) {
+    my $method = 'cache_write_' . $self->{opt}->{cache}->[0];
+    $self->$method($ref, $filename);
+  }
+  return $ref;
+}
+##############################################################################
+# Sub/Method: parse_fh()
+#
+# Same as XMLin, but only parses from a filehandle.
+#
+sub parse_fh {
+  my $self = &_get_object;      # note, @_ is passed implicitly
+  my $fh = shift;
+  croak "Can't use " . (defined $fh ? qq{string ("$fh")} : 'undef') .
+        " as a filehandle" unless ref $fh;
+  $self->handle_options('in', @_);
+  return $self->build_simple_tree(undef, $fh);
+}
+##############################################################################
+# Sub/Method: parse_string()
+#
+# Same as XMLin, but only parses from a string or a reference to a string.
+#
+sub parse_string {
+  my $self = &_get_object;      # note, @_ is passed implicitly
+  my $string = shift;
+  $self->handle_options('in', @_);
+  return $self->build_simple_tree(undef, ref $string ? $string : \$string);
+}
+##############################################################################
+# Method: default_config_file()
+#
+# Returns the name of the XML file to parse if no filename (or XML string)
+# was provided.
+#
+sub default_config_file {
+  my $self = shift;
+  require File::Basename;
+  my($basename, $script_dir, $ext) = File::Basename::fileparse($0, '\.[^\.]+');
+  # Add script directory to searchpath
+  if($script_dir) {
+    unshift(@{$self->{opt}->{searchpath}}, $script_dir);
+  }
+  return $basename . '.xml';
+}
+##############################################################################
+# Method: build_simple_tree()
+#
+# Builds a 'tree' data structure as provided by XML::Parser and then
+# 'simplifies' it as specified by the various options in effect.
+#
+sub build_simple_tree {
+  my $self = shift;
+  my $tree = $self->build_tree(@_);
+  return $self->{opt}->{keeproot}
+         ? $self->collapse({}, @$tree)
+         : $self->collapse(@{$tree->[1]});
+}
+##############################################################################
+# Method: build_tree()
+#
+# This routine will be called if there is no suitable pre-parsed tree in a
+# cache.  It parses the XML and returns an XML::Parser 'Tree' style data
+# structure (summarised in the comments for the collapse() routine below).
+#
+# XML::Simple requires the services of another module that knows how to parse
+# XML.  If XML::SAX is installed, the default SAX parser will be used,
+# otherwise XML::Parser will be used.
+#
+# This routine expects to be passed a filename as argument 1 or a 'string' as
+# argument 2.  The 'string' might be a string of XML (passed by reference to
+# save memory) or it might be a reference to an IO::Handle.  (This
+# non-intuitive mess results in part from the way XML::Parser works but that's
+# really no excuse).
+#
+sub build_tree {
+  my $self     = shift;
+  my $filename = shift;
+  my $string   = shift;
+  my $preferred_parser = $PREFERRED_PARSER;
+  unless(defined($preferred_parser)) {
+    $preferred_parser = $ENV{XML_SIMPLE_PREFERRED_PARSER} || '';
+  }
+  if($preferred_parser eq 'XML::Parser') {
+    return($self->build_tree_xml_parser($filename, $string));
+  }
+  eval { require XML::SAX; };      # We didn't need it until now
+  if($@) {                         # No XML::SAX - fall back to XML::Parser
+    if($preferred_parser) {        # unless a SAX parser was expressly requested
+      croak "XMLin() could not load XML::SAX";
+    }
+    return($self->build_tree_xml_parser($filename, $string));
+  }
+  $XML::SAX::ParserPackage = $preferred_parser if($preferred_parser);
+  my $sp = XML::SAX::ParserFactory->parser(Handler => $self);
+  $self->{nocollapse} = 1;
+  my($tree);
+  if($filename) {
+    $tree = $sp->parse_uri($filename);
+  }
+  else {
+    if(ref($string) && ref($string) ne 'SCALAR') {
+      $tree = $sp->parse_file($string);
+    }
+    else {
+      $tree = $sp->parse_string($$string);
+    }
+  }
+  return($tree);
+}
+##############################################################################
+# Method: build_tree_xml_parser()
+#
+# This routine will be called if XML::SAX is not installed, or if XML::Parser
+# was specifically requested.  It takes the same arguments as build_tree() and
+# returns the same data structure (XML::Parser 'Tree' style).
+#
+sub build_tree_xml_parser {
+  my $self     = shift;
+  my $filename = shift;
+  my $string   = shift;
+  eval {
+    local($^W) = 0;      # Suppress warning from Expat.pm re File::Spec::load()
+    require XML::Parser; # We didn't need it until now
+  };
+  if($@) {
+    croak "XMLin() requires either XML::SAX or XML::Parser";
+  }
+  if($self->{opt}->{nsexpand}) {
+    carp "'nsexpand' option requires XML::SAX";
+  }
+  my $xp = XML::Parser->new(Style => 'Tree', @{$self->{opt}->{parseropts}});
+  my($tree);
+  if($filename) {
+    # $tree = $xp->parsefile($filename);  # Changed due to prob w/mod_perl
+    local(*XML_FILE);
+    open(XML_FILE, '<', $filename) || croak qq($filename - $!);
+    $tree = $xp->parse(*XML_FILE);
+    close(XML_FILE);
+  }
+  else {
+    $tree = $xp->parse($$string);
+  }
+  return($tree);
+}
+##############################################################################
+# Method: cache_write_storable()
+#
+# Wrapper routine for invoking Storable::nstore() to cache a parsed data
+# structure.
+#
+sub cache_write_storable {
+  my($self, $data, $filename) = @_;
+  my $cachefile = $self->storable_filename($filename);
+  require Storable;           # We didn't need it until now
+  if ('VMS' eq $^O) {
+    Storable::nstore($data, $cachefile);
+  }
+  else {
+    # If the following line fails for you, your Storable.pm is old - upgrade
+    Storable::lock_nstore($data, $cachefile);
+  }
+}
+##############################################################################
+# Method: cache_read_storable()
+#
+# Wrapper routine for invoking Storable::retrieve() to read a cached parsed
+# data structure.  Only returns cached data if the cache file exists and is
+# newer than the source XML file.
+#
+sub cache_read_storable {
+  my($self, $filename) = @_;
+  my $cachefile = $self->storable_filename($filename);
+  return unless(-r $cachefile);
+  return unless((stat($cachefile))[9] > (stat($filename))[9]);
+  require Storable;           # We didn't need it until now
+  if ('VMS' eq $^O) {
+    return(Storable::retrieve($cachefile));
+  }
+  else {
+    return(Storable::lock_retrieve($cachefile));
+  }
+}
+##############################################################################
+# Method: storable_filename()
+#
+# Translates the supplied source XML filename into a filename for the storable
+# cached data.  A '.stor' suffix is added after stripping an optional '.xml'
+# suffix.
+#
+sub storable_filename {
+  my($self, $cachefile) = @_;
+  $cachefile =~ s{(\.xml)?$}{.stor};
+  return $cachefile;
+}
+##############################################################################
+# Method: cache_write_memshare()
+#
+# Takes the supplied data structure reference and stores it away in a global
+# hash structure.
+#
+sub cache_write_memshare {
+  my($self, $data, $filename) = @_;
+  $MemShareCache{$filename} = [time(), $data];
+}
+##############################################################################
+# Method: cache_read_memshare()
+#
+# Takes a filename and looks in a global hash for a cached parsed version.
+#
+sub cache_read_memshare {
+  my($self, $filename) = @_;
+  return unless($MemShareCache{$filename});
+  return unless($MemShareCache{$filename}->[0] > (stat($filename))[9]);
+  return($MemShareCache{$filename}->[1]);
+}
+##############################################################################
+# Method: cache_write_memcopy()
+#
+# Takes the supplied data structure and stores a copy of it in a global hash
+# structure.
+#
+sub cache_write_memcopy {
+  my($self, $data, $filename) = @_;
+  require Storable;           # We didn't need it until now
+  $MemCopyCache{$filename} = [time(), Storable::dclone($data)];
+}
+##############################################################################
+# Method: cache_read_memcopy()
+#
+# Takes a filename and looks in a global hash for a cached parsed version.
+# Returns a reference to a copy of that data structure.
+#
+sub cache_read_memcopy {
+  my($self, $filename) = @_;
+  return unless($MemCopyCache{$filename});
+  return unless($MemCopyCache{$filename}->[0] > (stat($filename))[9]);
+  return(Storable::dclone($MemCopyCache{$filename}->[1]));
+}
+##############################################################################
+# Sub/Method: XMLout()
+#
+# Exported routine for 'unslurping' a data structure out to XML.
+#
+# Expects a reference to a data structure and an optional list of option
+# name => value pairs.
+#
+sub XMLout {
+  my $self = &_get_object;      # note, @_ is passed implicitly
+  croak "XMLout() requires at least one argument" unless(@_);
+  my $ref = shift;
+  $self->handle_options('out', @_);
+  # If namespace expansion is set, XML::NamespaceSupport is required
+  if($self->{opt}->{nsexpand}) {
+    require XML::NamespaceSupport;
+    $self->{nsup} = XML::NamespaceSupport->new();
+    $self->{ns_prefix} = 'aaa';
+  }
+  # Wrap top level arrayref in a hash
+  if(UNIVERSAL::isa($ref, 'ARRAY')) {
+    $ref = { anon => $ref };
+  }
+  # Extract rootname from top level hash if keeproot enabled
+  if($self->{opt}->{keeproot}) {
+    my(@keys) = keys(%$ref);
+    if(@keys == 1) {
+      $ref = $ref->{$keys[0]};
+      $self->{opt}->{rootname} = $keys[0];
+    }
+  }
+  # Ensure there are no top level attributes if we're not adding root elements
+  elsif($self->{opt}->{rootname} eq '') {
+    if(UNIVERSAL::isa($ref, 'HASH')) {
+      my $refsave = $ref;
+      $ref = {};
+      foreach (keys(%$refsave)) {
+        if(ref($refsave->{$_})) {
+          $ref->{$_} = $refsave->{$_};
+        }
+        else {
+          $ref->{$_} = [ $refsave->{$_} ];
+        }
+      }
+    }
+  }
+  # Encode the hashref and write to file if necessary
+  $self->{_ancestors} = [];
+  my $xml = $self->value_to_xml($ref, $self->{opt}->{rootname}, '');
+  delete $self->{_ancestors};
+  if($self->{opt}->{xmldecl}) {
+    $xml = $self->{opt}->{xmldecl} . "\n" . $xml;
+  }
+  if($self->{opt}->{outputfile}) {
+    if(ref($self->{opt}->{outputfile})) {
+      my $fh = $self->{opt}->{outputfile};
+      if(UNIVERSAL::isa($fh, 'GLOB') and !UNIVERSAL::can($fh, 'print')) {
+        eval { require IO::Handle; };
+        croak $@ if $@;
+      }
+      return($fh->print($xml));
+    }
+    else {
+      local(*OUT);
+      open(OUT, '>', "$self->{opt}->{outputfile}") ||
+        croak "open($self->{opt}->{outputfile}): $!";
+      binmode(OUT, ':utf8') if($] >= 5.008);
+      print OUT $xml || croak "print: $!";
+      close(OUT);
+    }
+  }
+  elsif($self->{opt}->{handler}) {
+    require XML::SAX;
+    my $sp = XML::SAX::ParserFactory->parser(
+               Handler => $self->{opt}->{handler}
+             );
+    return($sp->parse_string($xml));
+  }
+  else {
+    return($xml);
+  }
+}
+##############################################################################
+# Method: handle_options()
+#
+# Helper routine for both XMLin() and XMLout().  Both routines handle their
+# first argument and assume all other args are options handled by this routine.
+# Saves a hash of options in $self->{opt}.
+#
+# If default options were passed to the constructor, they will be retrieved
+# here and merged with options supplied to the method call.
+#
+# First argument should be the string 'in' or the string 'out'.
+#
+# Remaining arguments should be name=>value pairs.  Sets up default values
+# for options not supplied.  Unrecognised options are a fatal error.
+#
+sub handle_options  {
+  my $self = shift;
+  my $dirn = shift;
+  # Determine valid options based on context
+  my %known_opt;
+  if($dirn eq 'in') {
+    @known_opt{@KnownOptIn} = @KnownOptIn;
+  }
+  else {
+    @known_opt{@KnownOptOut} = @KnownOptOut;
+  }
+  # Store supplied options in hashref and weed out invalid ones
+  if(@_ % 2) {
+    croak "Options must be name=>value pairs (odd number supplied)";
+  }
+  my %raw_opt  = @_;
+  my $opt      = {};
+  $self->{opt} = $opt;
+  while(my($key, $val) = each %raw_opt) {
+    my $lkey = lc($key);
+    $lkey =~ s/_//g;
+    croak "Unrecognised option: $key" unless($known_opt{$lkey});
+    $opt->{$lkey} = $val;
+  }
+  # Merge in options passed to constructor
+  foreach (keys(%known_opt)) {
+    unless(exists($opt->{$_})) {
+      if(exists($self->{def_opt}->{$_})) {
+        $opt->{$_} = $self->{def_opt}->{$_};
+      }
+    }
+  }
+  # Set sensible defaults if not supplied
+  if(exists($opt->{rootname})) {
+    unless(defined($opt->{rootname})) {
+      $opt->{rootname} = '';
+    }
+  }
+  else {
+    $opt->{rootname} = $DefRootName;
+  }
+  if($opt->{xmldecl}  and  $opt->{xmldecl} eq '1') {
+    $opt->{xmldecl} = $DefXmlDecl;
+  }
+  if(exists($opt->{contentkey})) {
+    if($opt->{contentkey} =~ m{^-(.*)$}) {
+      $opt->{contentkey} = $1;
+      $opt->{collapseagain} = 1;
+    }
+  }
+  else {
+    $opt->{contentkey} = $DefContentKey;
+  }
+  unless(exists($opt->{normalisespace})) {
+    $opt->{normalisespace} = $opt->{normalizespace};
+  }
+  $opt->{normalisespace} = 0 unless(defined($opt->{normalisespace}));
+  # Cleanups for values assumed to be arrays later
+  if($opt->{searchpath}) {
+    unless(ref($opt->{searchpath})) {
+      $opt->{searchpath} = [ $opt->{searchpath} ];
+    }
+  }
+  else  {
+    $opt->{searchpath} = [ ];
+  }
+  if($opt->{cache}  and !ref($opt->{cache})) {
+    $opt->{cache} = [ $opt->{cache} ];
+  }
+  if($opt->{cache}) {
+    $_ = lc($_) foreach (@{$opt->{cache}});
+    foreach my $scheme (@{$opt->{cache}}) {
+      my $method = 'cache_read_' . $scheme;
+      croak "Unsupported caching scheme: $scheme"
+        unless($self->can($method));
+    }
+  }
+  if(exists($opt->{parseropts})) {
+    if($^W) {
+      carp "Warning: " .
+           "'ParserOpts' is deprecated, contact the author if you need it";
+    }
+  }
+  else {
+    $opt->{parseropts} = [ ];
+  }
+  # Special cleanup for {forcearray} which could be regex, arrayref or boolean
+  # or left to default to 0
+  if(exists($opt->{forcearray})) {
+    if(ref($opt->{forcearray}) eq 'Regexp') {
+      $opt->{forcearray} = [ $opt->{forcearray} ];
+    }
+    if(ref($opt->{forcearray}) eq 'ARRAY') {
+      my @force_list = @{$opt->{forcearray}};
+      if(@force_list) {
+        $opt->{forcearray} = {};
+        foreach my $tag (@force_list) {
+          if(ref($tag) eq 'Regexp') {
+            push @{$opt->{forcearray}->{_regex}}, $tag;
+          }
+          else {
+            $opt->{forcearray}->{$tag} = 1;
+          }
+        }
+      }
+      else {
+        $opt->{forcearray} = 0;
+      }
+    }
+    else {
+      $opt->{forcearray} = ( $opt->{forcearray} ? 1 : 0 );
+    }
+  }
+  else {
+    if($StrictMode  and  $dirn eq 'in') {
+      croak "No value specified for 'ForceArray' option in call to XML$dirn()";
+    }
+    $opt->{forcearray} = 0;
+  }
+  # Special cleanup for {keyattr} which could be arrayref or hashref or left
+  # to default to arrayref
+  if(exists($opt->{keyattr}))  {
+    if(ref($opt->{keyattr})) {
+      if(ref($opt->{keyattr}) eq 'HASH') {
+        # Make a copy so we can mess with it
+        $opt->{keyattr} = { %{$opt->{keyattr}} };
+        # Convert keyattr => { elem => '+attr' }
+        # to keyattr => { elem => [ 'attr', '+' ] }
+        foreach my $el (keys(%{$opt->{keyattr}})) {
+          if($opt->{keyattr}->{$el} =~ /^(\+|-)?(.*)$/) {
+            $opt->{keyattr}->{$el} = [ $2, ($1 ? $1 : '') ];
+            if($StrictMode  and  $dirn eq 'in') {
+              next if($opt->{forcearray} == 1);
+              next if(ref($opt->{forcearray}) eq 'HASH'
+                      and $opt->{forcearray}->{$el});
+              croak "<$el> set in KeyAttr but not in ForceArray";
+            }
+          }
+          else {
+            delete($opt->{keyattr}->{$el}); # Never reached (famous last words?)
+          }
+        }
+      }
+      else {
+        if(@{$opt->{keyattr}} == 0) {
+          delete($opt->{keyattr});
+        }
+      }
+    }
+    else {
+      $opt->{keyattr} = [ $opt->{keyattr} ];
+    }
+  }
+  else  {
+    if($StrictMode) {
+      croak "No value specified for 'KeyAttr' option in call to XML$dirn()";
+    }
+    $opt->{keyattr} = [ @DefKeyAttr ];
+  }
+  # Special cleanup for {valueattr} which could be arrayref or hashref
+  if(exists($opt->{valueattr})) {
+    if(ref($opt->{valueattr}) eq 'ARRAY') {
+      $opt->{valueattrlist} = {};
+      $opt->{valueattrlist}->{$_} = 1 foreach(@{ delete $opt->{valueattr} });
+    }
+  }
+  # make sure there's nothing weird in {grouptags}
+  if($opt->{grouptags}) {
+    croak "Illegal value for 'GroupTags' option - expected a hashref"
+      unless UNIVERSAL::isa($opt->{grouptags}, 'HASH');
+    while(my($key, $val) = each %{$opt->{grouptags}}) {
+      next if $key ne $val;
+      croak "Bad value in GroupTags: '$key' => '$val'";
+    }
+  }
+  # Check the {variables} option is valid and initialise variables hash
+  if($opt->{variables} and !UNIVERSAL::isa($opt->{variables}, 'HASH')) {
+    croak "Illegal value for 'Variables' option - expected a hashref";
+  }
+  if($opt->{variables}) {
+    $self->{_var_values} = { %{$opt->{variables}} };
+  }
+  elsif($opt->{varattr}) {
+    $self->{_var_values} = {};
+  }
+}
+##############################################################################
+# Method: find_xml_file()
+#
+# Helper routine for XMLin().
+# Takes a filename, and a list of directories, attempts to locate the file in
+# the directories listed.
+# Returns a full pathname on success; croaks on failure.
+#
+sub find_xml_file  {
+  my $self = shift;
+  my $file = shift;
+  my @search_path = @_;
+  require File::Basename;
+  require File::Spec;
+  my($filename, $filedir) = File::Basename::fileparse($file);
+  if($filename ne $file) {        # Ignore searchpath if dir component
+    return($file) if(-e $file);
+  }
+  else {
+    my($path);
+    foreach $path (@search_path)  {
+      my $fullpath = File::Spec->catfile($path, $file);
+      return($fullpath) if(-e $fullpath);
+    }
+  }
+  # If user did not supply a search path, default to current directory
+  if(!@search_path) {
+    return($file) if(-e $file);
+    croak "File does not exist: $file";
+  }
+  croak "Could not find $file in ", join(':', @search_path);
+}
+##############################################################################
+# Method: collapse()
+#
+# Helper routine for XMLin().  This routine really comprises the 'smarts' (or
+# value add) of this module.
+#
+# Takes the parse tree that XML::Parser produced from the supplied XML and
+# recurses through it 'collapsing' unnecessary levels of indirection (nested
+# arrays etc) to produce a data structure that is easier to work with.
+#
+# Elements in the original parser tree are represented as an element name
+# followed by an arrayref.  The first element of the array is a hashref
+# containing the attributes.  The rest of the array contains a list of any
+# nested elements as name+arrayref pairs:
+#
+#  <element name>, [ { <attribute hashref> }, <element name>, [ ... ], ... ]
+#
+# The special element name '0' (zero) flags text content.
+#
+# This routine cuts down the noise by discarding any text content consisting of
+# only whitespace and then moves the nested elements into the attribute hash
+# using the name of the nested element as the hash key and the collapsed
+# version of the nested element as the value.  Multiple nested elements with
+# the same name will initially be represented as an arrayref, but this may be
+# 'folded' into a hashref depending on the value of the keyattr option.
+#
+sub collapse {
+  my $self = shift;
+  # Start with the hash of attributes
+  my $attr  = shift;
+  if($self->{opt}->{noattr}) {                    # Discard if 'noattr' set
+    $attr = {};
+  }
+  elsif($self->{opt}->{normalisespace} == 2) {
+    while(my($key, $value) = each %$attr) {
+      $attr->{$key} = $self->normalise_space($value)
+    }
+  }
+  # Do variable substitutions
+  if(my $var = $self->{_var_values}) {
+    while(my($key, $val) = each(%$attr)) {
+      $val =~ s{\$\{([\w.]+)\}}{ $self->get_var($1) }ge;
+      $attr->{$key} = $val;
+    }
+  }
+  # Roll up 'value' attributes (but only if no nested elements)
+  if(!@_  and  keys %$attr == 1) {
+    my($k) = keys %$attr;
+    if($self->{opt}->{valueattrlist}  and $self->{opt}->{valueattrlist}->{$k}) {
+      return $attr->{$k};
+    }
+  }
+  # Add any nested elements
+  my($key, $val);
+  while(@_) {
+    $key = shift;
+    $val = shift;
+    if(ref($val)) {
+      $val = $self->collapse(@$val);
+      next if(!defined($val)  and  $self->{opt}->{suppressempty});
+    }
+    elsif($key eq '0') {
+      next if($val =~ m{^\s*$}s);  # Skip all whitespace content
+      $val = $self->normalise_space($val)
+        if($self->{opt}->{normalisespace} == 2);
+      # do variable substitutions
+      if(my $var = $self->{_var_values}) {
+        $val =~ s{\$\{(\w+)\}}{ $self->get_var($1) }ge;
+      }
+      # look for variable definitions
+      if(my $var = $self->{opt}->{varattr}) {
+        if(exists $attr->{$var}) {
+          $self->set_var($attr->{$var}, $val);
+        }
+      }
+      # Collapse text content in element with no attributes to a string
+      if(!%$attr  and  !@_) {
+        return($self->{opt}->{forcecontent} ?
+          { $self->{opt}->{contentkey} => $val } : $val
+        );
+      }
+      $key = $self->{opt}->{contentkey};
+    }
+    # Combine duplicate attributes into arrayref if required
+    if(exists($attr->{$key})) {
+      if(UNIVERSAL::isa($attr->{$key}, 'ARRAY')) {
+        push(@{$attr->{$key}}, $val);
+      }
+      else {
+        $attr->{$key} = [ $attr->{$key}, $val ];
+      }
+    }
+    elsif(defined($val)  and  UNIVERSAL::isa($val, 'ARRAY')) {
+      $attr->{$key} = [ $val ];
+    }
+    else {
+      if( $key ne $self->{opt}->{contentkey}
+          and (
+            ($self->{opt}->{forcearray} == 1)
+            or (
+              (ref($self->{opt}->{forcearray}) eq 'HASH')
+              and (
+                $self->{opt}->{forcearray}->{$key}
+                or (grep $key =~ $_, @{$self->{opt}->{forcearray}->{_regex}})
+              )
+            )
+          )
+        ) {
+        $attr->{$key} = [ $val ];
+      }
+      else {
+        $attr->{$key} = $val;
+      }
+    }
+  }
+  # Turn arrayrefs into hashrefs if key fields present
+  if($self->{opt}->{keyattr}) {
+    while(($key,$val) = each %$attr) {
+      if(defined($val)  and  UNIVERSAL::isa($val, 'ARRAY')) {
+        $attr->{$key} = $self->array_to_hash($key, $val);
+      }
+    }
+  }
+  # disintermediate grouped tags
+  if($self->{opt}->{grouptags}) {
+    while(my($key, $val) = each(%$attr)) {
+      next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
+      next unless(exists($self->{opt}->{grouptags}->{$key}));
+      my($child_key, $child_val) =  %$val;
+      if($self->{opt}->{grouptags}->{$key} eq $child_key) {
+        $attr->{$key}= $child_val;
+      }
+    }
+  }
+  # Fold hashes containing a single anonymous array up into just the array
+  my $count = scalar keys %$attr;
+  if($count == 1
+     and  exists $attr->{anon}
+     and  UNIVERSAL::isa($attr->{anon}, 'ARRAY')
+  ) {
+    return($attr->{anon});
+  }
+  # Do the right thing if hash is empty, otherwise just return it
+  if(!%$attr  and  exists($self->{opt}->{suppressempty})) {
+    if(defined($self->{opt}->{suppressempty})  and
+       $self->{opt}->{suppressempty} eq '') {
+      return('');
+    }
+    return(undef);
+  }
+  # Roll up named elements with named nested 'value' attributes
+  if($self->{opt}->{valueattr}) {
+    while(my($key, $val) = each(%$attr)) {
+      next unless($self->{opt}->{valueattr}->{$key});
+      next unless(UNIVERSAL::isa($val, 'HASH') and (keys %$val == 1));
+      my($k) = keys %$val;
+      next unless($k eq $self->{opt}->{valueattr}->{$key});
+      $attr->{$key} = $val->{$k};
+    }
+  }
+  return($attr)
+}
+##############################################################################
+# Method: set_var()
+#
+# Called when a variable definition is encountered in the XML.  (A variable
+# definition looks like <element attrname="name">value</element> where attrname
+# matches the varattr setting).
+#
+sub set_var {
+  my($self, $name, $value) = @_;
+  $self->{_var_values}->{$name} = $value;
+}
+##############################################################################
+# Method: get_var()
+#
+# Called during variable substitution to get the value for the named variable.
+#
+sub get_var {
+  my($self, $name) = @_;
+  my $value = $self->{_var_values}->{$name};
+  return $value if(defined($value));
+  return '${' . $name . '}';
+}
+##############################################################################
+# Method: normalise_space()
+#
+# Strips leading and trailing whitespace and collapses sequences of whitespace
+# characters to a single space.
+#
+sub normalise_space {
+  my($self, $text) = @_;
+  $text =~ s/^\s+//s;
+  $text =~ s/\s+$//s;
+  $text =~ s/\s\s+/ /sg;
+  return $text;
+}
+##############################################################################
+# Method: array_to_hash()
+#
+# Helper routine for collapse().
+# Attempts to 'fold' an array of hashes into an hash of hashes.  Returns a
+# reference to the hash on success or the original array if folding is
+# not possible.  Behaviour is controlled by 'keyattr' option.
+#
+sub array_to_hash {
+  my $self     = shift;
+  my $name     = shift;
+  my $arrayref = shift;
+  my $hashref  = $self->new_hashref;
+  my($i, $key, $val, $flag);
+  # Handle keyattr => { .... }
+  if(ref($self->{opt}->{keyattr}) eq 'HASH') {
+    return($arrayref) unless(exists($self->{opt}->{keyattr}->{$name}));
+    ($key, $flag) = @{$self->{opt}->{keyattr}->{$name}};
+    for($i = 0; $i < @$arrayref; $i++)  {
+      if(UNIVERSAL::isa($arrayref->[$i], 'HASH') and
+         exists($arrayref->[$i]->{$key})
+      ) {
+        $val = $arrayref->[$i]->{$key};
+        if(ref($val)) {
+          $self->die_or_warn("<$name> element has non-scalar '$key' key attribute");
+          return($arrayref);
+        }
+        $val = $self->normalise_space($val)
+          if($self->{opt}->{normalisespace} == 1);
+        $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
+          if(exists($hashref->{$val}));
+        $hashref->{$val} = { %{$arrayref->[$i]} };
+        $hashref->{$val}->{"-$key"} = $hashref->{$val}->{$key} if($flag eq '-');
+        delete $hashref->{$val}->{$key} unless($flag eq '+');
+      }
+      else {
+        $self->die_or_warn("<$name> element has no '$key' key attribute");
+        return($arrayref);
+      }
+    }
+  }
+  # Or assume keyattr => [ .... ]
+  else {
+    my $default_keys =
+      join(',', @DefKeyAttr) eq join(',', @{$self->{opt}->{keyattr}});
+    ELEMENT: for($i = 0; $i < @$arrayref; $i++)  {
+      return($arrayref) unless(UNIVERSAL::isa($arrayref->[$i], 'HASH'));
+      foreach $key (@{$self->{opt}->{keyattr}}) {
+        if(defined($arrayref->[$i]->{$key}))  {
+          $val = $arrayref->[$i]->{$key};
+          if(ref($val)) {
+            $self->die_or_warn("<$name> element has non-scalar '$key' key attribute")
+              if not $default_keys;
+            return($arrayref);
+          }
+          $val = $self->normalise_space($val)
+            if($self->{opt}->{normalisespace} == 1);
+          $self->die_or_warn("<$name> element has non-unique value in '$key' key attribute: $val")
+            if(exists($hashref->{$val}));
+          $hashref->{$val} = { %{$arrayref->[$i]} };
+          delete $hashref->{$val}->{$key};
+          next ELEMENT;
+        }
+      }
+      return($arrayref);    # No keyfield matched
+    }
+  }
+  # collapse any hashes which now only have a 'content' key
+  if($self->{opt}->{collapseagain}) {
+    $hashref = $self->collapse_content($hashref);
+  }
+  return($hashref);
+}
+##############################################################################
+# Method: die_or_warn()
+#
+# Takes a diagnostic message and does one of three things:
+# 1. dies if strict mode is enabled
+# 2. warns if warnings are enabled but strict mode is not
+# 3. ignores message and resturns silently if neither strict mode nor warnings
+#    are enabled
+#
+sub die_or_warn {
+  my $self = shift;
+  my $msg  = shift;
+  croak $msg if($StrictMode);
+  carp "Warning: $msg" if($^W);
+}
+##############################################################################
+# Method: new_hashref()
+#
+# This is a hook routine for overriding in a sub-class.  Some people believe
+# that using Tie::IxHash here will solve order-loss problems.
+#
+sub new_hashref {
+  my $self = shift;
+  return { @_ };
+}
+##############################################################################
+# Method: collapse_content()
+#
+# Helper routine for array_to_hash
+#
+# Arguments expected are:
+# - an XML::Simple object
+# - a hasref
+# the hashref is a former array, turned into a hash by array_to_hash because
+# of the presence of key attributes
+# at this point collapse_content avoids over-complicated structures like
+# dir => { libexecdir    => { content => '$exec_prefix/libexec' },
+#          localstatedir => { content => '$prefix' },
+#        }
+# into
+# dir => { libexecdir    => '$exec_prefix/libexec',
+#          localstatedir => '$prefix',
+#        }
+sub collapse_content {
+  my $self       = shift;
+  my $hashref    = shift;
+  my $contentkey = $self->{opt}->{contentkey};
+  # first go through the values,checking that they are fit to collapse
+  foreach my $val (values %$hashref) {
+    return $hashref unless (     (ref($val) eq 'HASH')
+                             and (keys %$val == 1)
+                             and (exists $val->{$contentkey})
+                           );
+  }
+  # now collapse them
+  foreach my $key (keys %$hashref) {
+    $hashref->{$key}=  $hashref->{$key}->{$contentkey};
+  }
+  return $hashref;
+}
+##############################################################################
+# Method: value_to_xml()
+#
+# Helper routine for XMLout() - recurses through a data structure building up
+# and returning an XML representation of that structure as a string.
+#
+# Arguments expected are:
+# - the data structure to be encoded (usually a reference)
+# - the XML tag name to use for this item
+# - a string of spaces for use as the current indent level
+#
+sub value_to_xml {
+  my $self = shift;;
+  # Grab the other arguments
+  my($ref, $name, $indent) = @_;
+  my $named = (defined($name) and $name ne '' ? 1 : 0);
+  my $nl = "\n";
+  my $is_root = $indent eq '' ? 1 : 0;   # Warning, dirty hack!
+  if($self->{opt}->{noindent}) {
+    $indent = '';
+    $nl     = '';
+  }
+  # Convert to XML
+  if(ref($ref)) {
+    croak "circular data structures not supported"
+      if(grep($_ == $ref, @{$self->{_ancestors}}));
+    push @{$self->{_ancestors}}, $ref;
+  }
+  else {
+    if($named) {
+      return(join('',
+              $indent, '<', $name, '>',
+              ($self->{opt}->{noescape} ? $ref : $self->escape_value($ref)),
+              '</', $name, ">", $nl
+            ));
+    }
+    else {
+      return("$ref$nl");
+    }
+  }
+  # Unfold hash to array if possible
+  if(UNIVERSAL::isa($ref, 'HASH')      # It is a hash
+     and keys %$ref                    # and it's not empty
+     and $self->{opt}->{keyattr}       # and folding is enabled
+     and !$is_root                     # and its not the root element
+  ) {
+    $ref = $self->hash_to_array($name, $ref);
+  }
+  my @result = ();
+  my($key, $value);
+  # Handle hashrefs
+  if(UNIVERSAL::isa($ref, 'HASH')) {
+    # Reintermediate grouped values if applicable
+    if($self->{opt}->{grouptags}) {
+      $ref = $self->copy_hash($ref);
+      while(my($key, $val) = each %$ref) {
+        if($self->{opt}->{grouptags}->{$key}) {
+          $ref->{$key} = { $self->{opt}->{grouptags}->{$key} => $val };
+        }
+      }
+    }
+    # Scan for namespace declaration attributes
+    my $nsdecls = '';
+    my $default_ns_uri;
+    if($self->{nsup}) {
+      $ref = $self->copy_hash($ref);
+      $self->{nsup}->push_context();
+      # Look for default namespace declaration first
+      if(exists($ref->{xmlns})) {
+        $self->{nsup}->declare_prefix('', $ref->{xmlns});
+        $nsdecls .= qq( xmlns="$ref->{xmlns}");
+        delete($ref->{xmlns});
+      }
+      $default_ns_uri = $self->{nsup}->get_uri('');
+      # Then check all the other keys
+      foreach my $qname (keys(%$ref)) {
+        my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
+        if($uri) {
+          if($uri eq $xmlns_ns) {
+            $self->{nsup}->declare_prefix($lname, $ref->{$qname});
+            $nsdecls .= qq( xmlns:$lname="$ref->{$qname}");
+            delete($ref->{$qname});
+          }
+        }
+      }
+      # Translate any remaining Clarkian names
+      foreach my $qname (keys(%$ref)) {
+        my($uri, $lname) = $self->{nsup}->parse_jclark_notation($qname);
+        if($uri) {
+          if($default_ns_uri  and  $uri eq $default_ns_uri) {
+            $ref->{$lname} = $ref->{$qname};
+            delete($ref->{$qname});
+          }
+          else {
+            my $prefix = $self->{nsup}->get_prefix($uri);
+            unless($prefix) {
+              # $self->{nsup}->declare_prefix(undef, $uri);
+              # $prefix = $self->{nsup}->get_prefix($uri);
+              $prefix = $self->{ns_prefix}++;
+              $self->{nsup}->declare_prefix($prefix, $uri);
+              $nsdecls .= qq( xmlns:$prefix="$uri");
+            }
+            $ref->{"$prefix:$lname"} = $ref->{$qname};
+            delete($ref->{$qname});
+          }
+        }
+      }
+    }
+    my @nested = ();
+    my $text_content = undef;
+    if($named) {
+      push @result, $indent, '<', $name, $nsdecls;
+    }
+    if(keys %$ref) {
+      my $first_arg = 1;
+      foreach my $key ($self->sorted_keys($name, $ref)) {
+        my $value = $ref->{$key};
+        next if(substr($key, 0, 1) eq '-');
+        if(!defined($value)) {
+          next if $self->{opt}->{suppressempty};
+          unless(exists($self->{opt}->{suppressempty})
+             and !defined($self->{opt}->{suppressempty})
+          ) {
+            carp 'Use of uninitialized value' if($^W);
+          }
+          if($key eq $self->{opt}->{contentkey}) {
+            $text_content = '';
+          }
+          else {
+            $value = exists($self->{opt}->{suppressempty}) ? {} : '';
+          }
+        }
+        if(!ref($value)
+           and $self->{opt}->{valueattr}
+           and $self->{opt}->{valueattr}->{$key}
+        ) {
+          $value = { $self->{opt}->{valueattr}->{$key} => $value };
+        }
+        if(ref($value)  or  $self->{opt}->{noattr}) {
+          push @nested,
+            $self->value_to_xml($value, $key, "$indent  ");
+        }
+        else {
+          $value = $self->escape_value($value) unless($self->{opt}->{noescape});
+          if($key eq $self->{opt}->{contentkey}) {
+            $text_content = $value;
+          }
+          else {
+            push @result, "\n$indent " . ' ' x length($name)
+              if($self->{opt}->{attrindent}  and  !$first_arg);
+            push @result, ' ', $key, '="', $value , '"';
+            $first_arg = 0;
+          }
+        }
+      }
+    }
+    else {
+      $text_content = '';
+    }
+    if(@nested  or  defined($text_content)) {
+      if($named) {
+        push @result, ">";
+        if(defined($text_content)) {
+          push @result, $text_content;
+          $nested[0] =~ s/^\s+// if(@nested);
+        }
+        else {
+          push @result, $nl;
+        }
+        if(@nested) {
+          push @result, @nested, $indent;
+        }
+        push @result, '</', $name, ">", $nl;
+      }
+      else {
+        push @result, @nested;             # Special case if no root elements
+      }
+    }
+    else {
+      push @result, " />", $nl;
+    }
+    $self->{nsup}->pop_context() if($self->{nsup});
+  }
+  # Handle arrayrefs
+  elsif(UNIVERSAL::isa($ref, 'ARRAY')) {
+    foreach $value (@$ref) {
+      next if !defined($value) and $self->{opt}->{suppressempty};
+      if(!ref($value)) {
+        push @result,
+             $indent, '<', $name, '>',
+             ($self->{opt}->{noescape} ? $value : $self->escape_value($value)),
+             '</', $name, ">$nl";
+      }
+      elsif(UNIVERSAL::isa($value, 'HASH')) {
+        push @result, $self->value_to_xml($value, $name, $indent);
+      }
+      else {
+        push @result,
+               $indent, '<', $name, ">$nl",
+               $self->value_to_xml($value, 'anon', "$indent  "),
+               $indent, '</', $name, ">$nl";
+      }
+    }
+  }
+  else {
+    croak "Can't encode a value of type: " . ref($ref);
+  }
+  pop @{$self->{_ancestors}} if(ref($ref));
+  return(join('', @result));
+}
+##############################################################################
+# Method: sorted_keys()
+#
+# Returns the keys of the referenced hash sorted into alphabetical order, but
+# with the 'key' key (as in KeyAttr) first, if there is one.
+#
+sub sorted_keys {
+  my($self, $name, $ref) = @_;
+  return keys %$ref if $self->{opt}->{nosort};
+  my %hash = %$ref;
+  my $keyattr = $self->{opt}->{keyattr};
+  my @key;
+  if(ref $keyattr eq 'HASH') {
+    if(exists $keyattr->{$name} and exists $hash{$keyattr->{$name}->[0]}) {
+      push @key, $keyattr->{$name}->[0];
+      delete $hash{$keyattr->{$name}->[0]};
+    }
+  }
+  elsif(ref $keyattr eq 'ARRAY') {
+    foreach (@{$keyattr}) {
+      if(exists $hash{$_}) {
+        push @key, $_;
+        delete $hash{$_};
+        last;
+      }
+    }
+  }
+  return(@key, sort keys %hash);
+}
+##############################################################################
+# Method: escape_value()
+#
+# Helper routine for automatically escaping values for XMLout().
+# Expects a scalar data value.  Returns escaped version.
+#
+sub escape_value {
+  my($self, $data) = @_;
+  return '' unless(defined($data));
+  $data =~ s/&/&amp;/sg;
+  $data =~ s/</&lt;/sg;
+  $data =~ s/>/&gt;/sg;
+  $data =~ s/"/&quot;/sg;
+  my $level = $self->{opt}->{numericescape} or return $data;
+  return $self->numeric_escape($data, $level);
+}
+sub numeric_escape {
+  my($self, $data, $level) = @_;
+  use utf8; # required for 5.6
+  if($self->{opt}->{numericescape} eq '2') {
+    $data =~ s/([^\x00-\x7F])/'&#' . ord($1) . ';'/gse;
+  }
+  else {
+    $data =~ s/([^\x00-\xFF])/'&#' . ord($1) . ';'/gse;
+  }
+  return $data;
+}
+##############################################################################
+# Method: hash_to_array()
+#
+# Helper routine for value_to_xml().
+# Attempts to 'unfold' a hash of hashes into an array of hashes.  Returns a
+# reference to the array on success or the original hash if unfolding is
+# not possible.
+#
+sub hash_to_array {
+  my $self    = shift;
+  my $parent  = shift;
+  my $hashref = shift;
+  my $arrayref = [];
+  my($key, $value);
+  my @keys = $self->{opt}->{nosort} ? keys %$hashref : sort keys %$hashref;
+  foreach $key (@keys) {
+    $value = $hashref->{$key};
+    return($hashref) unless(UNIVERSAL::isa($value, 'HASH'));
+    if(ref($self->{opt}->{keyattr}) eq 'HASH') {
+      return($hashref) unless(defined($self->{opt}->{keyattr}->{$parent}));
+      push @$arrayref, $self->copy_hash(
+        $value, $self->{opt}->{keyattr}->{$parent}->[0] => $key
+      );
+    }
+    else {
+      push(@$arrayref, { $self->{opt}->{keyattr}->[0] => $key, %$value });
+    }
+  }
+  return($arrayref);
+}
+##############################################################################
+# Method: copy_hash()
+#
+# Helper routine for hash_to_array().  When unfolding a hash of hashes into
+# an array of hashes, we need to copy the key from the outer hash into the
+# inner hash.  This routine makes a copy of the original hash so we don't
+# destroy the original data structure.  You might wish to override this
+# method if you're using tied hashes and don't want them to get untied.
+#
+sub copy_hash {
+  my($self, $orig, @extra) = @_;
+  return { @extra, %$orig };
+}
+##############################################################################
+# Methods required for building trees from SAX events
+##############################################################################
+sub start_document {
+  my $self = shift;
+  $self->handle_options('in') unless($self->{opt});
+  $self->{lists} = [];
+  $self->{curlist} = $self->{tree} = [];
+}
+sub start_element {
+  my $self    = shift;
+  my $element = shift;
+  my $name = $element->{Name};
+  if($self->{opt}->{nsexpand}) {
+    $name = $element->{LocalName} || '';
+    if($element->{NamespaceURI}) {
+      $name = '{' . $element->{NamespaceURI} . '}' . $name;
+    }
+  }
+  my $attributes = {};
+  if($element->{Attributes}) {  # Might be undef
+    foreach my $attr (values %{$element->{Attributes}}) {
+      if($self->{opt}->{nsexpand}) {
+        my $name = $attr->{LocalName} || '';
+        if($attr->{NamespaceURI}) {
+          $name = '{' . $attr->{NamespaceURI} . '}' . $name
+        }
+        $name = 'xmlns' if($name eq $bad_def_ns_jcn);
+        $attributes->{$name} = $attr->{Value};
+      }
+      else {
+        $attributes->{$attr->{Name}} = $attr->{Value};
+      }
+    }
+  }
+  my $newlist = [ $attributes ];
+  push @{ $self->{lists} }, $self->{curlist};
+  push @{ $self->{curlist} }, $name => $newlist;
+  $self->{curlist} = $newlist;
+}
+sub characters {
+  my $self  = shift;
+  my $chars = shift;
+  my $text  = $chars->{Data};
+  my $clist = $self->{curlist};
+  my $pos = $#$clist;
+  if ($pos > 0 and $clist->[$pos - 1] eq '0') {
+    $clist->[$pos] .= $text;
+  }
+  else {
+    push @$clist, 0 => $text;
+  }
+}
+sub end_element {
+  my $self    = shift;
+  $self->{curlist} = pop @{ $self->{lists} };
+}
+sub end_document {
+  my $self = shift;
+  delete($self->{curlist});
+  delete($self->{lists});
+  my $tree = $self->{tree};
+  delete($self->{tree});
+  # Return tree as-is to XMLin()
+  return($tree) if($self->{nocollapse});
+  # Or collapse it before returning it to SAX parser class
+  if($self->{opt}->{keeproot}) {
+    $tree = $self->collapse({}, @$tree);
+  }
+  else {
+    $tree = $self->collapse(@{$tree->[1]});
+  }
+  if($self->{opt}->{datahandler}) {
+    return($self->{opt}->{datahandler}->($self, $tree));
+  }
+  return($tree);
+}
+*xml_in  = \&XMLin;
+*xml_out = \&XMLout;
+;
+__END__
+=head1 QUICK START
+Say you have a script called B<foo> and a file of configuration options
+called B<foo.xml> containing this:
+  <config logdir="/var/log/foo/" debugfile="/tmp/foo.debug">
+    <server name="sahara" osname="solaris" osversion="2.6">
+      <address>10.0.0.101</address>
+      <address>10.0.1.101</address>
+    </server>
+    <server name="gobi" osname="irix" osversion="6.5">
+      <address>10.0.0.102</address>
+    </server>
+    <server name="kalahari" osname="linux" osversion="2.0.34">
+      <address>10.0.0.103</address>
+      <address>10.0.1.103</address>
+    </server>
+  </config>
+The following lines of code in B<foo>:
+  use XML::Simple;
+  my $config = XMLin();
+will 'slurp' the configuration options into the hashref $config (because no
+arguments are passed to C<XMLin()> the name and location of the XML file will
+be inferred from name and location of the script).  You can dump out the
+contents of the hashref using Data::Dumper:
+  use Data::Dumper;
+  print Dumper($config);
+which will produce something like this (formatting has been adjusted for
+brevity):
+  {
+      'logdir'        => '/var/log/foo/',
+      'debugfile'     => '/tmp/foo.debug',
+      'server'        => {
+          'sahara'        => {
+              'osversion'     => '2.6',
+              'osname'        => 'solaris',
+              'address'       => [ '10.0.0.101', '10.0.1.101' ]
+          },
+          'gobi'          => {
+              'osversion'     => '6.5',
+              'osname'        => 'irix',
+              'address'       => '10.0.0.102'
+          },
+          'kalahari'      => {
+              'osversion'     => '2.0.34',
+              'osname'        => 'linux',
+              'address'       => [ '10.0.0.103', '10.0.1.103' ]
+          }
+      }
+  }
+Your script could then access the name of the log directory like this:
+  print $config->{logdir};
+similarly, the second address on the server 'kalahari' could be referenced as:
+  print $config->{server}->{kalahari}->{address}->[1];
+What could be simpler?  (Rhetorical).
+For simple requirements, that's really all there is to it.  If you want to
+store your XML in a different directory or file, or pass it in as a string or
+even pass it in via some derivative of an IO::Handle, you'll need to check out
+L<"OPTIONS">.  If you want to turn off or tweak the array folding feature (that
+neat little transformation that produced $config->{server}) you'll find options
+for that as well.
+If you want to generate XML (for example to write a modified version of
+$config back out as XML), check out C<XMLout()>.
+If your needs are not so simple, this may not be the module for you.  In that
+case, you might want to read L<"WHERE TO FROM HERE?">.
+=head1 DESCRIPTION
+The XML::Simple module provides a simple API layer on top of an underlying XML
+parsing module (either XML::Parser or one of the SAX2 parser modules).  Two
+functions are exported: C<XMLin()> and C<XMLout()>.  Note: you can explicity
+request the lower case versions of the function names: C<xml_in()> and
+C<xml_out()>.
+The simplest approach is to call these two functions directly, but an
+optional object oriented interface (see L<"OPTIONAL OO INTERFACE"> below)
+allows them to be called as methods of an B<XML::Simple> object.  The object
+interface can also be used at either end of a SAX pipeline.
+=head2 XMLin()
+Parses XML formatted data and returns a reference to a data structure which
+contains the same information in a more readily accessible form.  (Skip
+down to L<"EXAMPLES"> below, for more sample code).
+C<XMLin()> accepts an optional XML specifier followed by zero or more 'name =>
+value' option pairs.  The XML specifier can be one of the following:
+=over 4
+=item A filename
+If the filename contains no directory components C<XMLin()> will look for the
+file in each directory in the SearchPath (see L<"OPTIONS"> below) or in the
+current directory if the SearchPath option is not defined.  eg:
+  $ref = XMLin('/etc/params.xml');
+Note, the filename '-' can be used to parse from STDIN.
+=item undef
+If there is no XML specifier, C<XMLin()> will check the script directory and
+each of the SearchPath directories for a file with the same name as the script
+but with the extension '.xml'.  Note: if you wish to specify options, you
+must specify the value 'undef'.  eg:
+  $ref = XMLin(undef, ForceArray => 1);
+=item A string of XML
+A string containing XML (recognised by the presence of '<' and '>' characters)
+will be parsed directly.  eg:
+  $ref = XMLin('<opt username="bob" password="flurp" />');
+=item An IO::Handle object
+An IO::Handle object will be read to EOF and its contents parsed. eg:
+  $fh = IO::File->new('/etc/params.xml');
+  $ref = XMLin($fh);
+=back
+=head2 XMLout()
+Takes a data structure (generally a hashref) and returns an XML encoding of
+that structure.  If the resulting XML is parsed using C<XMLin()>, it should
+return a data structure equivalent to the original (see caveats below).
+The C<XMLout()> function can also be used to output the XML as SAX events
+see the C<Handler> option and L<"SAX SUPPORT"> for more details).
+When translating hashes to XML, hash keys which have a leading '-' will be
+silently skipped.  This is the approved method for marking elements of a
+data structure which should be ignored by C<XMLout>.  (Note: If these items
+were not skipped the key names would be emitted as element or attribute names
+with a leading '-' which would not be valid XML).
+=head2 Caveats
+Some care is required in creating data structures which will be passed to
+C<XMLout()>.  Hash keys from the data structure will be encoded as either XML
+element names or attribute names.  Therefore, you should use hash key names
+which conform to the relatively strict XML naming rules:
+Names in XML must begin with a letter.  The remaining characters may be
+letters, digits, hyphens (-), underscores (_) or full stops (.).  It is also
+allowable to include one colon (:) in an element name but this should only be
+used when working with namespaces (B<XML::Simple> can only usefully work with
+namespaces when teamed with a SAX Parser).
+You can use other punctuation characters in hash values (just not in hash
+keys) however B<XML::Simple> does not support dumping binary data.
+If you break these rules, the current implementation of C<XMLout()> will
+simply emit non-compliant XML which will be rejected if you try to read it
+back in.  (A later version of B<XML::Simple> might take a more proactive
+approach).
+Note also that although you can nest hashes and arrays to arbitrary levels,
+circular data structures are not supported and will cause C<XMLout()> to die.
+If you wish to 'round-trip' arbitrary data structures from Perl to XML and back
+to Perl, then you should probably disable array folding (using the KeyAttr
+option) both with C<XMLout()> and with C<XMLin()>.  If you still don't get the
+expected results, you may prefer to use L<XML::Dumper> which is designed for
+exactly that purpose.
+Refer to L<"WHERE TO FROM HERE?"> if C<XMLout()> is too simple for your needs.
+=head1 OPTIONS
+B<XML::Simple> supports a number of options (in fact as each release of
+B<XML::Simple> adds more options, the module's claim to the name 'Simple'
+becomes increasingly tenuous).  If you find yourself repeatedly having to
+specify the same options, you might like to investigate L<"OPTIONAL OO
+INTERFACE"> below.
+If you can't be bothered reading the documentation, refer to
+L<"STRICT MODE"> to automatically catch common mistakes.
+Because there are so many options, it's hard for new users to know which ones
+are important, so here are the two you really need to know about:
+=over 4
+=item *
+check out C<ForceArray> because you'll almost certainly want to turn it on
+=item *
+make sure you know what the C<KeyAttr> option does and what its default value is
+because it may surprise you otherwise (note in particular that 'KeyAttr'
+affects both C<XMLin> and C<XMLout>)
+=back
+The option name headings below have a trailing 'comment' - a hash followed by
+two pieces of metadata:
+=over 4
+=item *
+Options are marked with 'I<in>' if they are recognised by C<XMLin()> and
+'I<out>' if they are recognised by C<XMLout()>.
+=item *
+Each option is also flagged to indicate whether it is:
+ 'important'   - don't use the module until you understand this one
+ 'handy'       - you can skip this on the first time through
+ 'advanced'    - you can skip this on the second time through
+ 'SAX only'    - don't worry about this unless you're using SAX (or
+                 alternatively if you need this, you also need SAX)
+ 'seldom used' - you'll probably never use this unless you were the
+                 person that requested the feature
+=back
+The options are listed alphabetically:
+Note: option names are no longer case sensitive so you can use the mixed case
+versions shown here; all lower case as required by versions 2.03 and earlier;
+or you can add underscores between the words (eg: key_attr).
+=head2 AttrIndent => 1 I<# out - handy>
+When you are using C<XMLout()>, enable this option to have attributes printed
+one-per-line with sensible indentation rather than all on one line.
+=head2 Cache => [ cache schemes ] I<# in - advanced>
+Because loading the B<XML::Parser> module and parsing an XML file can consume a
+significant number of CPU cycles, it is often desirable to cache the output of
+C<XMLin()> for later reuse.
+When parsing from a named file, B<XML::Simple> supports a number of caching
+schemes.  The 'Cache' option may be used to specify one or more schemes (using
+an anonymous array).  Each scheme will be tried in turn in the hope of finding
+a cached pre-parsed representation of the XML file.  If no cached copy is
+found, the file will be parsed and the first cache scheme in the list will be
+used to save a copy of the results.  The following cache schemes have been
+implemented:
+=over 4
+=item storable
+Utilises B<Storable.pm> to read/write a cache file with the same name as the
+XML file but with the extension .stor
+=item memshare
+When a file is first parsed, a copy of the resulting data structure is retained
+in memory in the B<XML::Simple> module's namespace.  Subsequent calls to parse
+the same file will return a reference to this structure.  This cached version
+will persist only for the life of the Perl interpreter (which in the case of
+mod_perl for example, may be some significant time).
+Because each caller receives a reference to the same data structure, a change
+made by one caller will be visible to all.  For this reason, the reference
+returned should be treated as read-only.
+=item memcopy
+This scheme works identically to 'memshare' (above) except that each caller
+receives a reference to a new data structure which is a copy of the cached
+version.  Copying the data structure will add a little processing overhead,
+therefore this scheme should only be used where the caller intends to modify
+the data structure (or wishes to protect itself from others who might).  This
+scheme uses B<Storable.pm> to perform the copy.
+=back
+Warning! The memory-based caching schemes compare the timestamp on the file to
+the time when it was last parsed.  If the file is stored on an NFS filesystem
+(or other network share) and the clock on the file server is not exactly
+synchronised with the clock where your script is run, updates to the source XML
+file may appear to be ignored.
+=head2 ContentKey => 'keyname' I<# in+out - seldom used>
+When text content is parsed to a hash value, this option let's you specify a
+name for the hash key to override the default 'content'.  So for example:
+  XMLin('<opt one="1">Text</opt>', ContentKey => 'text')
+will parse to:
+  { 'one' => 1, 'text' => 'Text' }
+instead of:
+  { 'one' => 1, 'content' => 'Text' }
+C<XMLout()> will also honour the value of this option when converting a hashref
+to XML.
+You can also prefix your selected key name with a '-' character to have
+C<XMLin()> try a little harder to eliminate unnecessary 'content' keys after
+array folding.  For example:
+  XMLin(
+    '<opt><item name="one">First</item><item name="two">Second</item></opt>',
+    KeyAttr => {item => 'name'},
+    ForceArray => [ 'item' ],
+    ContentKey => '-content'
+  )
+will parse to:
+  {
+    'item' => {
+      'one' =>  'First'
+      'two' =>  'Second'
+    }
+  }
+rather than this (without the '-'):
+  {
+    'item' => {
+      'one' => { 'content' => 'First' }
+      'two' => { 'content' => 'Second' }
+    }
+  }
+=head2 DataHandler => code_ref I<# in - SAX only>
+When you use an B<XML::Simple> object as a SAX handler, it will return a
+'simple tree' data structure in the same format as C<XMLin()> would return.  If
+this option is set (to a subroutine reference), then when the tree is built the
+subroutine will be called and passed two arguments: a reference to the
+B<XML::Simple> object and a reference to the data tree.  The return value from
+the subroutine will be returned to the SAX driver.  (See L<"SAX SUPPORT"> for
+more details).
+=head2 ForceArray => 1 I<# in - important>
+This option should be set to '1' to force nested elements to be represented
+as arrays even when there is only one.  Eg, with ForceArray enabled, this
+XML:
+    <opt>
+      <name>value</name>
+    </opt>
+would parse to this:
+    {
+      'name' => [
+                  'value'
+                ]
+    }
+instead of this (the default):
+    {
+      'name' => 'value'
+    }
+This option is especially useful if the data structure is likely to be written
+back out as XML and the default behaviour of rolling single nested elements up
+into attributes is not desirable.
+If you are using the array folding feature, you should almost certainly enable
+this option.  If you do not, single nested elements will not be parsed to
+arrays and therefore will not be candidates for folding to a hash.  (Given that
+the default value of 'KeyAttr' enables array folding, the default value of this
+option should probably also have been enabled too - sorry).
+=head2 ForceArray => [ names ] I<# in - important>
+This alternative (and preferred) form of the 'ForceArray' option allows you to
+specify a list of element names which should always be forced into an array
+representation, rather than the 'all or nothing' approach above.
+It is also possible (since version 2.05) to include compiled regular
+expressions in the list - any element names which match the pattern will be
+forced to arrays.  If the list contains only a single regex, then it is not
+necessary to enclose it in an arrayref.  Eg:
+  ForceArray => qr/_list$/
+=head2 ForceContent => 1 I<# in - seldom used>
+When C<XMLin()> parses elements which have text content as well as attributes,
+the text content must be represented as a hash value rather than a simple
+scalar.  This option allows you to force text content to always parse to
+a hash value even when there are no attributes.  So for example:
+  XMLin('<opt><x>text1</x><y a="2">text2</y></opt>', ForceContent => 1)
+will parse to:
+  {
+    'x' => {           'content' => 'text1' },
+    'y' => { 'a' => 2, 'content' => 'text2' }
+  }
+instead of:
+  {
+    'x' => 'text1',
+    'y' => { 'a' => 2, 'content' => 'text2' }
+  }
+=head2 GroupTags => { grouping tag => grouped tag } I<# in+out - handy>
+You can use this option to eliminate extra levels of indirection in your Perl
+data structure.  For example this XML:
+  <opt>
+   <searchpath>
+     <dir>/usr/bin</dir>
+     <dir>/usr/local/bin</dir>
+     <dir>/usr/X11/bin</dir>
+   </searchpath>
+ </opt>
+Would normally be read into a structure like this:
+  {
+    searchpath => {
+                    dir => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
+                  }
+  }
+But when read in with the appropriate value for 'GroupTags':
+  my $opt = XMLin($xml, GroupTags => { searchpath => 'dir' });
+It will return this simpler structure:
+  {
+    searchpath => [ '/usr/bin', '/usr/local/bin', '/usr/X11/bin' ]
+  }
+The grouping element (C<< <searchpath> >> in the example) must not contain any
+attributes or elements other than the grouped element.
+You can specify multiple 'grouping element' to 'grouped element' mappings in
+the same hashref.  If this option is combined with C<KeyAttr>, the array
+folding will occur first and then the grouped element names will be eliminated.
+C<XMLout> will also use the grouptag mappings to re-introduce the tags around
+the grouped elements.  Beware though that this will occur in all places that
+the 'grouping tag' name occurs - you probably don't want to use the same name
+for elements as well as attributes.
+=head2 Handler => object_ref I<# out - SAX only>
+Use the 'Handler' option to have C<XMLout()> generate SAX events rather than
+returning a string of XML.  For more details see L<"SAX SUPPORT"> below.
+Note: the current implementation of this option generates a string of XML
+and uses a SAX parser to translate it into SAX events.  The normal encoding
+rules apply here - your data must be UTF8 encoded unless you specify an
+alternative encoding via the 'XMLDecl' option; and by the time the data reaches
+the handler object, it will be in UTF8 form regardless of the encoding you
+supply.  A future implementation of this option may generate the events
+directly.
+=head2 KeepRoot => 1 I<# in+out - handy>
+In its attempt to return a data structure free of superfluous detail and
+unnecessary levels of indirection, C<XMLin()> normally discards the root
+element name.  Setting the 'KeepRoot' option to '1' will cause the root element
+name to be retained.  So after executing this code:
+  $config = XMLin('<config tempdir="/tmp" />', KeepRoot => 1)
+You'll be able to reference the tempdir as
+C<$config-E<gt>{config}-E<gt>{tempdir}> instead of the default
+C<$config-E<gt>{tempdir}>.
+Similarly, setting the 'KeepRoot' option to '1' will tell C<XMLout()> that the
+data structure already contains a root element name and it is not necessary to
+add another.
+=head2 KeyAttr => [ list ] I<# in+out - important>
+This option controls the 'array folding' feature which translates nested
+elements from an array to a hash.  It also controls the 'unfolding' of hashes
+to arrays.
+For example, this XML:
+    <opt>
+      <user login="grep" fullname="Gary R Epstein" />
+      <user login="stty" fullname="Simon T Tyson" />
+    </opt>
+would, by default, parse to this:
+    {
+      'user' => [
+                  {
+                    'login' => 'grep',
+                    'fullname' => 'Gary R Epstein'
+                  },
+                  {
+                    'login' => 'stty',
+                    'fullname' => 'Simon T Tyson'
+                  }
+                ]
+    }
+If the option 'KeyAttr => "login"' were used to specify that the 'login'
+attribute is a key, the same XML would parse to:
+    {
+      'user' => {
+                  'stty' => {
+                              'fullname' => 'Simon T Tyson'
+                            },
+                  'grep' => {
+                              'fullname' => 'Gary R Epstein'
+                            }
+                }
+    }
+The key attribute names should be supplied in an arrayref if there is more
+than one.  C<XMLin()> will attempt to match attribute names in the order
+supplied.  C<XMLout()> will use the first attribute name supplied when
+'unfolding' a hash into an array.
+Note 1: The default value for 'KeyAttr' is ['name', 'key', 'id'].  If you do
+not want folding on input or unfolding on output you must setting this option
+to an empty list to disable the feature.
+Note 2: If you wish to use this option, you should also enable the
+C<ForceArray> option.  Without 'ForceArray', a single nested element will be
+rolled up into a scalar rather than an array and therefore will not be folded
+(since only arrays get folded).
+=head2 KeyAttr => { list } I<# in+out - important>
+This alternative (and preferred) method of specifiying the key attributes
+allows more fine grained control over which elements are folded and on which
+attributes.  For example the option 'KeyAttr => { package => 'id' } will cause
+any package elements to be folded on the 'id' attribute.  No other elements
+which have an 'id' attribute will be folded at all.
+Note: C<XMLin()> will generate a warning (or a fatal error in L<"STRICT MODE">)
+if this syntax is used and an element which does not have the specified key
+attribute is encountered (eg: a 'package' element without an 'id' attribute, to
+use the example above).  Warnings will only be generated if B<-w> is in force.
+Two further variations are made possible by prefixing a '+' or a '-' character
+to the attribute name:
+The option 'KeyAttr => { user => "+login" }' will cause this XML:
+    <opt>
+      <user login="grep" fullname="Gary R Epstein" />
+      <user login="stty" fullname="Simon T Tyson" />
+    </opt>
+to parse to this data structure:
+    {
+      'user' => {
+                  'stty' => {
+                              'fullname' => 'Simon T Tyson',
+                              'login'    => 'stty'
+                            },
+                  'grep' => {
+                              'fullname' => 'Gary R Epstein',
+                              'login'    => 'grep'
+                            }
+                }
+    }
+The '+' indicates that the value of the key attribute should be copied rather
+than moved to the folded hash key.
+A '-' prefix would produce this result:
+    {
+      'user' => {
+                  'stty' => {
+                              'fullname' => 'Simon T Tyson',
+                              '-login'    => 'stty'
+                            },
+                  'grep' => {
+                              'fullname' => 'Gary R Epstein',
+                              '-login'    => 'grep'
+                            }
+                }
+    }
+As described earlier, C<XMLout> will ignore hash keys starting with a '-'.
+=head2 NoAttr => 1 I<# in+out - handy>
+When used with C<XMLout()>, the generated XML will contain no attributes.
+All hash key/values will be represented as nested elements instead.
+When used with C<XMLin()>, any attributes in the XML will be ignored.
+=head2 NoEscape => 1 I<# out - seldom used>
+By default, C<XMLout()> will translate the characters 'E<lt>', 'E<gt>', '&' and
+'"' to '&lt;', '&gt;', '&amp;' and '&quot' respectively.  Use this option to
+suppress escaping (presumably because you've already escaped the data in some
+more sophisticated manner).
+=head2 NoIndent => 1 I<# out - seldom used>
+Set this option to 1 to disable C<XMLout()>'s default 'pretty printing' mode.
+With this option enabled, the XML output will all be on one line (unless there
+are newlines in the data) - this may be easier for downstream processing.
+=head2 NoSort => 1 I<# out - seldom used>
+Newer versions of XML::Simple sort elements and attributes alphabetically (*),
+by default.  Enable this option to suppress the sorting - possibly for
+backwards compatibility.
+* Actually, sorting is alphabetical but 'key' attribute or element names (as in
+'KeyAttr') sort first.  Also, when a hash of hashes is 'unfolded', the elements
+are sorted alphabetically by the value of the key field.
+=head2 NormaliseSpace => 0 | 1 | 2 I<# in - handy>
+This option controls how whitespace in text content is handled.  Recognised
+values for the option are:
+=over 4
+=item *
+= (default) whitespace is passed through unaltered (except of course for the
+normalisation of whitespace in attribute values which is mandated by the XML
+recommendation)
+=item *
+= whitespace is normalised in any value used as a hash key (normalising means
+removing leading and trailing whitespace and collapsing sequences of whitespace
+characters to a single space)
+=item *
+= whitespace is normalised in all text content
+=back
+Note: you can spell this option with a 'z' if that is more natural for you.
+=head2 NSExpand => 1 I<# in+out handy - SAX only>
+This option controls namespace expansion - the translation of element and
+attribute names of the form 'prefix:name' to '{uri}name'.  For example the
+element name 'xsl:template' might be expanded to:
+'{http://www.w3.org/1999/XSL/Transform}template'.
+By default, C<XMLin()> will return element names and attribute names exactly as
+they appear in the XML.  Setting this option to 1 will cause all element and
+attribute names to be expanded to include their namespace prefix.
+I<Note: You must be using a SAX parser for this option to work (ie: it does not
+work with XML::Parser)>.
+This option also controls whether C<XMLout()> performs the reverse translation
+from '{uri}name' back to 'prefix:name'.  The default is no translation.  If
+your data contains expanded names, you should set this option to 1 otherwise
+C<XMLout> will emit XML which is not well formed.
+I<Note: You must have the XML::NamespaceSupport module installed if you want
+C<XMLout()> to translate URIs back to prefixes>.
+=head2 NumericEscape => 0 | 1 | 2 I<# out - handy>
+Use this option to have 'high' (non-ASCII) characters in your Perl data
+structure converted to numeric entities (eg: &#8364;) in the XML output.  Three
+levels are possible:
+- default: no numeric escaping (OK if you're writing out UTF8)
+- only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output
+- all characters above 0x7F are escaped (good for plain ASCII output)
+=head2 OutputFile => <file specifier> I<# out - handy>
+The default behaviour of C<XMLout()> is to return the XML as a string.  If you
+wish to write the XML to a file, simply supply the filename using the
+'OutputFile' option.
+This option also accepts an IO handle object - especially useful in Perl 5.8.0
+and later for output using an encoding other than UTF-8, eg:
+  open my $fh, '>:encoding(iso-8859-1)', $path or die "open($path): $!";
+  XMLout($ref, OutputFile => $fh);
+Note, XML::Simple does not require that the object you pass in to the
+OutputFile option inherits from L<IO::Handle> - it simply assumes the object
+supports a C<print> method.
+=head2 ParserOpts => [ XML::Parser Options ] I<# in - don't use this>
+I<Note: This option is now officially deprecated.  If you find it useful, email
+the author with an example of what you use it for.  Do not use this option to
+set the ProtocolEncoding, that's just plain wrong - fix the XML>.
+This option allows you to pass parameters to the constructor of the underlying
+XML::Parser object (which of course assumes you're not using SAX).
+=head2 RootName => 'string' I<# out - handy>
+By default, when C<XMLout()> generates XML, the root element will be named
+'opt'.  This option allows you to specify an alternative name.
+Specifying either undef or the empty string for the RootName option will
+produce XML with no root elements.  In most cases the resulting XML fragment
+will not be 'well formed' and therefore could not be read back in by C<XMLin()>.
+Nevertheless, the option has been found to be useful in certain circumstances.
+=head2 SearchPath => [ list ] I<# in - handy>
+If you pass C<XMLin()> a filename, but the filename include no directory
+component, you can use this option to specify which directories should be
+searched to locate the file.  You might use this option to search first in the
+user's home directory, then in a global directory such as /etc.
+If a filename is provided to C<XMLin()> but SearchPath is not defined, the
+file is assumed to be in the current directory.
+If the first parameter to C<XMLin()> is undefined, the default SearchPath
+will contain only the directory in which the script itself is located.
+Otherwise the default SearchPath will be empty.
+=head2 SuppressEmpty => 1 | '' | undef I<# in+out - handy>
+This option controls what C<XMLin()> should do with empty elements (no
+attributes and no content).  The default behaviour is to represent them as
+empty hashes.  Setting this option to a true value (eg: 1) will cause empty
+elements to be skipped altogether.  Setting the option to 'undef' or the empty
+string will cause empty elements to be represented as the undefined value or
+the empty string respectively.  The latter two alternatives are a little
+easier to test for in your code than a hash with no keys.
+The option also controls what C<XMLout()> does with undefined values.  Setting
+the option to undef causes undefined values to be output as empty elements
+(rather than empty attributes), it also suppresses the generation of warnings
+about undefined values.  Setting the option to a true value (eg: 1) causes
+undefined values to be skipped altogether on output.
+=head2 ValueAttr => [ names ] I<# in - handy>
+Use this option to deal elements which always have a single attribute and no
+content.  Eg:
+  <opt>
+    <colour value="red" />
+    <size   value="XXL" />
+  </opt>
+Setting C<< ValueAttr => [ 'value' ] >> will cause the above XML to parse to:
+  {
+    colour => 'red',
+    size   => 'XXL'
+  }
+instead of this (the default):
+  {
+    colour => { value => 'red' },
+    size   => { value => 'XXL' }
+  }
+Note: This form of the ValueAttr option is not compatible with C<XMLout()> -
+since the attribute name is discarded at parse time, the original XML cannot be
+reconstructed.
+=head2 ValueAttr => { element => attribute, ... } I<# in+out - handy>
+This (preferred) form of the ValueAttr option requires you to specify both
+the element and the attribute names.  This is not only safer, it also allows
+the original XML to be reconstructed by C<XMLout()>.
+Note: You probably don't want to use this option and the NoAttr option at the
+same time.
+=head2 Variables => { name => value } I<# in - handy>
+This option allows variables in the XML to be expanded when the file is read.
+(there is no facility for putting the variable names back if you regenerate
+XML using C<XMLout>).
+A 'variable' is any text of the form C<${name}> which occurs in an attribute
+value or in the text content of an element.  If 'name' matches a key in the
+supplied hashref, C<${name}> will be replaced with the corresponding value from
+the hashref.  If no matching key is found, the variable will not be replaced.
+Names must match the regex: C<[\w.]+> (ie: only 'word' characters and dots are
+allowed).
+=head2 VarAttr => 'attr_name' I<# in - handy>
+In addition to the variables defined using C<Variables>, this option allows
+variables to be defined in the XML.  A variable definition consists of an
+element with an attribute called 'attr_name' (the value of the C<VarAttr>
+option).  The value of the attribute will be used as the variable name and the
+text content of the element will be used as the value.  A variable defined in
+this way will override a variable defined using the C<Variables> option.  For
+example:
+  XMLin( '<opt>
+            <dir name="prefix">/usr/local/apache</dir>
+            <dir name="exec_prefix">${prefix}</dir>
+            <dir name="bindir">${exec_prefix}/bin</dir>
+          </opt>',
+         VarAttr => 'name', ContentKey => '-content'
+        );
+produces the following data structure:
+  {
+    dir => {
+             prefix      => '/usr/local/apache',
+             exec_prefix => '/usr/local/apache',
+             bindir      => '/usr/local/apache/bin',
+           }
+  }
+=head2 XMLDecl => 1  or  XMLDecl => 'string'  I<# out - handy>
+If you want the output from C<XMLout()> to start with the optional XML
+declaration, simply set the option to '1'.  The default XML declaration is:
+        <?xml version='1.0' standalone='yes'?>
+If you want some other string (for example to declare an encoding value), set
+the value of this option to the complete string you require.
+=head1 OPTIONAL OO INTERFACE
+The procedural interface is both simple and convenient however there are a
+couple of reasons why you might prefer to use the object oriented (OO)
+interface:
+=over 4
+=item *
+to define a set of default values which should be used on all subsequent calls
+to C<XMLin()> or C<XMLout()>
+=item *
+to override methods in B<XML::Simple> to provide customised behaviour
+=back
+The default values for the options described above are unlikely to suit
+everyone.  The OO interface allows you to effectively override B<XML::Simple>'s
+defaults with your preferred values.  It works like this:
+First create an XML::Simple parser object with your preferred defaults:
+  my $xs = XML::Simple->new(ForceArray => 1, KeepRoot => 1);
+then call C<XMLin()> or C<XMLout()> as a method of that object:
+  my $ref = $xs->XMLin($xml);
+  my $xml = $xs->XMLout($ref);
+You can also specify options when you make the method calls and these values
+will be merged with the values specified when the object was created.  Values
+specified in a method call take precedence.
+Note: when called as methods, the C<XMLin()> and C<XMLout()> routines may be
+called as C<xml_in()> or C<xml_out()>.  The method names are aliased so the
+only difference is the aesthetics.
+=head2 Parsing Methods
+You can explicitly call one of the following methods rather than rely on the
+C<xml_in()> method automatically determining whether the target to be parsed is
+a string, a file or a filehandle:
+=over 4
+=item parse_string(text)
+Works exactly like the C<xml_in()> method but assumes the first argument is
+a string of XML (or a reference to a scalar containing a string of XML).
+=item parse_file(filename)
+Works exactly like the C<xml_in()> method but assumes the first argument is
+the name of a file containing XML.
+=item parse_fh(file_handle)
+Works exactly like the C<xml_in()> method but assumes the first argument is
+a filehandle which can be read to get XML.
+=back
+=head2 Hook Methods
+You can make your own class which inherits from XML::Simple and overrides
+certain behaviours.  The following methods may provide useful 'hooks' upon
+which to hang your modified behaviour.  You may find other undocumented methods
+by examining the source, but those may be subject to change in future releases.
+=over 4
+=item handle_options(direction, name => value ...)
+This method will be called when one of the parsing methods or the C<XMLout()>
+method is called.  The initial argument will be a string (either 'in' or 'out')
+and the remaining arguments will be name value pairs.
+=item default_config_file()
+Calculates and returns the name of the file which should be parsed if no
+filename is passed to C<XMLin()> (default: C<$0.xml>).
+=item build_simple_tree(filename, string)
+Called from C<XMLin()> or any of the parsing methods.  Takes either a file name
+as the first argument or C<undef> followed by a 'string' as the second
+argument.  Returns a simple tree data structure.  You could override this
+method to apply your own transformations before the data structure is returned
+to the caller.
+=item new_hashref()
+When the 'simple tree' data structure is being built, this method will be
+called to create any required anonymous hashrefs.
+=item sorted_keys(name, hashref)
+Called when C<XMLout()> is translating a hashref to XML.  This routine returns
+a list of hash keys in the order that the corresponding attributes/elements
+should appear in the output.
+=item escape_value(string)
+Called from C<XMLout()>, takes a string and returns a copy of the string with
+XML character escaping rules applied.
+=item numeric_escape(string)
+Called from C<escape_value()>, to handle non-ASCII characters (depending on the
+value of the NumericEscape option).
+=item copy_hash(hashref, extra_key => value, ...)
+Called from C<XMLout()>, when 'unfolding' a hash of hashes into an array of
+hashes.  You might wish to override this method if you're using tied hashes and
+don't want them to get untied.
+=back
+=head2 Cache Methods
+XML::Simple implements three caching schemes ('storable', 'memshare' and
+'memcopy').  You can implement a custom caching scheme by implementing
+two methods - one for reading from the cache and one for writing to it.
+For example, you might implement a new 'dbm' scheme that stores cached data
+structures using the L<MLDBM> module.  First, you would add a
+C<cache_read_dbm()> method which accepted a filename for use as a lookup key
+and returned a data structure on success, or undef on failure.  Then, you would
+implement a C<cache_read_dbm()> method which accepted a data structure and a
+filename.
+You would use this caching scheme by specifying the option:
+  Cache => [ 'dbm' ]
+=head1 STRICT MODE
+If you import the B<XML::Simple> routines like this:
+  use XML::Simple qw(:strict);
+the following common mistakes will be detected and treated as fatal errors
+=over 4
+=item *
+Failing to explicitly set the C<KeyAttr> option - if you can't be bothered
+reading about this option, turn it off with: KeyAttr => [ ]
+=item *
+Failing to explicitly set the C<ForceArray> option - if you can't be bothered
+reading about this option, set it to the safest mode with: ForceArray => 1
+=item *
+Setting ForceArray to an array, but failing to list all the elements from the
+KeyAttr hash.
+=item *
+Data error - KeyAttr is set to say { part => 'partnum' } but the XML contains
+one or more E<lt>partE<gt> elements without a 'partnum' attribute (or nested
+element).  Note: if strict mode is not set but -w is, this condition triggers a
+warning.
+=item *
+Data error - as above, but non-unique values are present in the key attribute
+(eg: more than one E<lt>partE<gt> element with the same partnum).  This will
+also trigger a warning if strict mode is not enabled.
+=item *
+Data error - as above, but value of key attribute (eg: partnum) is not a
+scalar string (due to nested elements etc).  This will also trigger a warning
+if strict mode is not enabled.
+=back
+=head1 SAX SUPPORT
+From version 1.08_01, B<XML::Simple> includes support for SAX (the Simple API
+for XML) - specifically SAX2.
+In a typical SAX application, an XML parser (or SAX 'driver') module generates
+SAX events (start of element, character data, end of element, etc) as it parses
+an XML document and a 'handler' module processes the events to extract the
+required data.  This simple model allows for some interesting and powerful
+possibilities:
+=over 4
+=item *
+Applications written to the SAX API can extract data from huge XML documents
+without the memory overheads of a DOM or tree API.
+=item *
+The SAX API allows for plug and play interchange of parser modules without
+having to change your code to fit a new module's API.  A number of SAX parsers
+are available with capabilities ranging from extreme portability to blazing
+performance.
+=item *
+A SAX 'filter' module can implement both a handler interface for receiving
+data and a generator interface for passing modified data on to a downstream
+handler.  Filters can be chained together in 'pipelines'.
+=item *
+One filter module might split a data stream to direct data to two or more
+downstream handlers.
+=item *
+Generating SAX events is not the exclusive preserve of XML parsing modules.
+For example, a module might extract data from a relational database using DBI
+and pass it on to a SAX pipeline for filtering and formatting.
+=back
+B<XML::Simple> can operate at either end of a SAX pipeline.  For example,
+you can take a data structure in the form of a hashref and pass it into a
+SAX pipeline using the 'Handler' option on C<XMLout()>:
+  use XML::Simple;
+  use Some::SAX::Filter;
+  use XML::SAX::Writer;
+  my $ref = {
+               ....   # your data here
+            };
+  my $writer = XML::SAX::Writer->new();
+  my $filter = Some::SAX::Filter->new(Handler => $writer);
+  my $simple = XML::Simple->new(Handler => $filter);
+  $simple->XMLout($ref);
+You can also put B<XML::Simple> at the opposite end of the pipeline to take
+advantage of the simple 'tree' data structure once the relevant data has been
+isolated through filtering:
+  use XML::SAX;
+  use Some::SAX::Filter;
+  use XML::Simple;
+  my $simple = XML::Simple->new(ForceArray => 1, KeyAttr => ['partnum']);
+  my $filter = Some::SAX::Filter->new(Handler => $simple);
+  my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);
+  my $ref = $parser->parse_uri('some_huge_file.xml');
+  print $ref->{part}->{'555-1234'};
+You can build a filter by using an XML::Simple object as a handler and setting
+its DataHandler option to point to a routine which takes the resulting tree,
+modifies it and sends it off as SAX events to a downstream handler:
+  my $writer = XML::SAX::Writer->new();
+  my $filter = XML::Simple->new(
+                 DataHandler => sub {
+                                  my $simple = shift;
+                                  my $data = shift;
+                                  # Modify $data here
+                                  $simple->XMLout($data, Handler => $writer);
+                                }
+               );
+  my $parser = XML::SAX::ParserFactory->parser(Handler => $filter);
+  $parser->parse_uri($filename);
+I<Note: In this last example, the 'Handler' option was specified in the call to
+C<XMLout()> but it could also have been specified in the constructor>.
+=head1 ENVIRONMENT
+If you don't care which parser module B<XML::Simple> uses then skip this
+section entirely (it looks more complicated than it really is).
+B<XML::Simple> will default to using a B<SAX> parser if one is available or
+B<XML::Parser> if SAX is not available.
+You can dictate which parser module is used by setting either the environment
+variable 'XML_SIMPLE_PREFERRED_PARSER' or the package variable
+$XML::Simple::PREFERRED_PARSER to contain the module name.  The following rules
+are used:
+=over 4
+=item *
+The package variable takes precedence over the environment variable if both are defined.  To force B<XML::Simple> to ignore the environment settings and use
+its default rules, you can set the package variable to an empty string.
+=item *
+If the 'preferred parser' is set to the string 'XML::Parser', then
+L<XML::Parser> will be used (or C<XMLin()> will die if L<XML::Parser> is not
+installed).
+=item *
+If the 'preferred parser' is set to some other value, then it is assumed to be
+the name of a SAX parser module and is passed to L<XML::SAX::ParserFactory.>
+If L<XML::SAX> is not installed, or the requested parser module is not
+installed, then C<XMLin()> will die.
+=item *
+If the 'preferred parser' is not defined at all (the normal default
+state), an attempt will be made to load L<XML::SAX>.  If L<XML::SAX> is
+installed, then a parser module will be selected according to
+L<XML::SAX::ParserFactory>'s normal rules (which typically means the last SAX
+parser installed).
+=item *
+if the 'preferred parser' is not defined and B<XML::SAX> is not
+installed, then B<XML::Parser> will be used.  C<XMLin()> will die if
+L<XML::Parser> is not installed.
+=back
+Note: The B<XML::SAX> distribution includes an XML parser written entirely in
+Perl.  It is very portable but it is not very fast.  You should consider
+installing L<XML::LibXML> or L<XML::SAX::Expat> if they are available for your
+platform.
+=head1 ERROR HANDLING
+The XML standard is very clear on the issue of non-compliant documents.  An
+error in parsing any single element (for example a missing end tag) must cause
+the whole document to be rejected.  B<XML::Simple> will die with an appropriate
+message if it encounters a parsing error.
+If dying is not appropriate for your application, you should arrange to call
+C<XMLin()> in an eval block and look for errors in $@.  eg:
+    my $config = eval { XMLin() };
+    PopUpMessage($@) if($@);
+Note, there is a common misconception that use of B<eval> will significantly
+slow down a script.  While that may be true when the code being eval'd is in a
+string, it is not true of code like the sample above.
+=head1 EXAMPLES
+When C<XMLin()> reads the following very simple piece of XML:
+    <opt username="testuser" password="frodo"></opt>
+it returns the following data structure:
+    {
+      'username' => 'testuser',
+      'password' => 'frodo'
+    }
+The identical result could have been produced with this alternative XML:
+    <opt username="testuser" password="frodo" />
+Or this (although see 'ForceArray' option for variations):
+    <opt>
+      <username>testuser</username>
+      <password>frodo</password>
+    </opt>
+Repeated nested elements are represented as anonymous arrays:
+    <opt>
+      <person firstname="Joe" lastname="Smith">
+        <email>joe@smith.com</email>
+        <email>jsmith@yahoo.com</email>
+      </person>
+      <person firstname="Bob" lastname="Smith">
+        <email>bob@smith.com</email>
+      </person>
+    </opt>
+    {
+      'person' => [
+                    {
+                      'email' => [
+                                   'joe@smith.com',
+                                   'jsmith@yahoo.com'
+                                 ],
+                      'firstname' => 'Joe',
+                      'lastname' => 'Smith'
+                    },
+                    {
+                      'email' => 'bob@smith.com',
+                      'firstname' => 'Bob',
+                      'lastname' => 'Smith'
+                    }
+                  ]
+    }
+Nested elements with a recognised key attribute are transformed (folded) from
+an array into a hash keyed on the value of that attribute (see the C<KeyAttr>
+option):
+    <opt>
+      <person key="jsmith" firstname="Joe" lastname="Smith" />
+      <person key="tsmith" firstname="Tom" lastname="Smith" />
+      <person key="jbloggs" firstname="Joe" lastname="Bloggs" />
+    </opt>
+    {
+      'person' => {
+                    'jbloggs' => {
+                                   'firstname' => 'Joe',
+                                   'lastname' => 'Bloggs'
+                                 },
+                    'tsmith' => {
+                                  'firstname' => 'Tom',
+                                  'lastname' => 'Smith'
+                                },
+                    'jsmith' => {
+                                  'firstname' => 'Joe',
+                                  'lastname' => 'Smith'
+                                }
+                  }
+    }
+The <anon> tag can be used to form anonymous arrays:
+    <opt>
+      <head><anon>Col 1</anon><anon>Col 2</anon><anon>Col 3</anon></head>
+      <data><anon>R1C1</anon><anon>R1C2</anon><anon>R1C3</anon></data>
+      <data><anon>R2C1</anon><anon>R2C2</anon><anon>R2C3</anon></data>
+      <data><anon>R3C1</anon><anon>R3C2</anon><anon>R3C3</anon></data>
+    </opt>
+    {
+      'head' => [
+                  [ 'Col 1', 'Col 2', 'Col 3' ]
+                ],
+      'data' => [
+                  [ 'R1C1', 'R1C2', 'R1C3' ],
+                  [ 'R2C1', 'R2C2', 'R2C3' ],
+                  [ 'R3C1', 'R3C2', 'R3C3' ]
+                ]
+    }
+Anonymous arrays can be nested to arbirtrary levels and as a special case, if
+the surrounding tags for an XML document contain only an anonymous array the
+arrayref will be returned directly rather than the usual hashref:
+    <opt>
+      <anon><anon>Col 1</anon><anon>Col 2</anon></anon>
+      <anon><anon>R1C1</anon><anon>R1C2</anon></anon>
+      <anon><anon>R2C1</anon><anon>R2C2</anon></anon>
+    </opt>
+    [
+      [ 'Col 1', 'Col 2' ],
+      [ 'R1C1', 'R1C2' ],
+      [ 'R2C1', 'R2C2' ]
+    ]
+Elements which only contain text content will simply be represented as a
+scalar.  Where an element has both attributes and text content, the element
+will be represented as a hashref with the text content in the 'content' key
+(see the C<ContentKey> option):
+  <opt>
+    <one>first</one>
+    <two attr="value">second</two>
+  </opt>
+  {
+    'one' => 'first',
+    'two' => { 'attr' => 'value', 'content' => 'second' }
+  }
+Mixed content (elements which contain both text content and nested elements)
+will be not be represented in a useful way - element order and significant
+whitespace will be lost.  If you need to work with mixed content, then
+XML::Simple is not the right tool for your job - check out the next section.
+=head1 WHERE TO FROM HERE?
+B<XML::Simple> is able to present a simple API because it makes some
+assumptions on your behalf.  These include:
+=over 4
+=item *
+You're not interested in text content consisting only of whitespace
+=item *
+You don't mind that when things get slurped into a hash the order is lost
+=item *
+You don't want fine-grained control of the formatting of generated XML
+=item *
+You would never use a hash key that was not a legal XML element name
+=item *
+You don't need help converting between different encodings
+=back
+In a serious XML project, you'll probably outgrow these assumptions fairly
+quickly.  This section of the document used to offer some advice on chosing a
+more powerful option.  That advice has now grown into the 'Perl-XML FAQ'
+document which you can find at: L<http://perl-xml.sourceforge.net/faq/>
+The advice in the FAQ boils down to a quick explanation of tree versus
+event based parsers and then recommends:
+For event based parsing, use SAX (do not set out to write any new code for
+XML::Parser's handler API - it is obselete).
+For tree-based parsing, you could choose between the 'Perlish' approach of
+L<XML::Twig> and more standards based DOM implementations - preferably one with
+XPath support.
+=head1 SEE ALSO
+B<XML::Simple> requires either L<XML::Parser> or L<XML::SAX>.
+To generate documents with namespaces, L<XML::NamespaceSupport> is required.
+The optional caching functions require L<Storable>.
+Answers to Frequently Asked Questions about XML::Simple are bundled with this
+distribution as: L<XML::Simple::FAQ>
+=head1 COPYRIGHT
+Copyright 1999-2004 Grant McLean E<lt>grantm@cpan.orgE<gt>
+This library is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+=cut

 /MissionCockpit/tags/V0.2.0/perl/lib/threads.pm
 ,0 → 1,1056
+package threads;
+use 5.008;
+use strict;
+use warnings;
+our $VERSION = '1.71';
+my $XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+# Verify this Perl supports threads
+require Config;
+if (! $Config::Config{useithreads}) {
+    die("This Perl not built to support threads\n");
+}
+# Complain if 'threads' is loaded after 'threads::shared'
+if ($threads::shared::threads_shared) {
+    warn <<'_MSG_';
+Warning, threads::shared has already been loaded.  To
+enable shared variables, 'use threads' must be called
+before threads::shared or any module that uses it.
+_MSG_
+}
+# Declare that we have been loaded
+$threads::threads = 1;
+# Load the XS code
+require XSLoader;
+XSLoader::load('threads', $XS_VERSION);
+### Export ###
+sub import
+{
+    my $class = shift;   # Not used
+    # Exported subroutines
+    my @EXPORT = qw(async);
+    # Handle args
+    while (my $sym = shift) {
+        if ($sym =~ /^(?:stack|exit)/i) {
+            if (defined(my $arg = shift)) {
+                if ($sym =~ /^stack/i) {
+                    threads->set_stack_size($arg);
+                } else {
+                    $threads::thread_exit_only = $arg =~ /^thread/i;
+                }
+            } else {
+                require Carp;
+                Carp::croak("threads: Missing argument for option: $sym");
+            }
+        } elsif ($sym =~ /^str/i) {
+            import overload ('""' => \&tid);
+        } elsif ($sym =~ /^(?::all|yield)$/) {
+            push(@EXPORT, qw(yield));
+        } else {
+            require Carp;
+            Carp::croak("threads: Unknown import option: $sym");
+        }
+    }
+    # Export subroutine names
+    my $caller = caller();
+    foreach my $sym (@EXPORT) {
+        no strict 'refs';
+        *{$caller.'::'.$sym} = \&{$sym};
+    }
+    # Set stack size via environment variable
+    if (exists($ENV{'PERL5_ITHREADS_STACK_SIZE'})) {
+        threads->set_stack_size($ENV{'PERL5_ITHREADS_STACK_SIZE'});
+    }
+}
+### Methods, etc. ###
+# Exit from a thread (only)
+sub exit
+{
+    my ($class, $status) = @_;
+    if (! defined($status)) {
+        $status = 0;
+    }
+    # Class method only
+    if (ref($class)) {
+        require Carp;
+        Carp::croak('Usage: threads->exit(status)');
+    }
+    $class->set_thread_exit_only(1);
+    CORE::exit($status);
+}
+# 'Constant' args for threads->list()
+sub threads::all      { }
+sub threads::running  { 1 }
+sub threads::joinable { 0 }
+# 'new' is an alias for 'create'
+*new = \&create;
+# 'async' is a function alias for the 'threads->create()' method
+sub async (&;@)
+{
+    unshift(@_, 'threads');
+    # Use "goto" trick to avoid pad problems from 5.8.1 (fixed in 5.8.2)
+    goto &create;
+}
+# Thread object equality checking
+use overload (
+    '==' => \&equal,
+    '!=' => sub { ! equal(@_) },
+    'fallback' => 1
+);
+;
+__END__
+=head1 NAME
+threads - Perl interpreter-based threads
+=head1 VERSION
+This document describes threads version 1.71
+=head1 SYNOPSIS
+    use threads ('yield',
+                 'stack_size' => 64*4096,
+                 'exit' => 'threads_only',
+                 'stringify');
+    sub start_thread {
+        my @args = @_;
+        print('Thread started: ', join(' ', @args), "\n");
+    }
+    my $thr = threads->create('start_thread', 'argument');
+    $thr->join();
+    threads->create(sub { print("I am a thread\n"); })->join();
+    my $thr2 = async { foreach (@files) { ... } };
+    $thr2->join();
+    if (my $err = $thr2->error()) {
+        warn("Thread error: $err\n");
+    }
+    # Invoke thread in list context (implicit) so it can return a list
+    my ($thr) = threads->create(sub { return (qw/a b c/); });
+    # or specify list context explicitly
+    my $thr = threads->create({'context' => 'list'},
+                              sub { return (qw/a b c/); });
+    my @results = $thr->join();
+    $thr->detach();
+    # Get a thread's object
+    $thr = threads->self();
+    $thr = threads->object($tid);
+    # Get a thread's ID
+    $tid = threads->tid();
+    $tid = $thr->tid();
+    $tid = "$thr";
+    # Give other threads a chance to run
+    threads->yield();
+    yield();
+    # Lists of non-detached threads
+    my @threads = threads->list();
+    my $thread_count = threads->list();
+    my @running = threads->list(threads::running);
+    my @joinable = threads->list(threads::joinable);
+    # Test thread objects
+    if ($thr1 == $thr2) {
+        ...
+    }
+    # Manage thread stack size
+    $stack_size = threads->get_stack_size();
+    $old_size = threads->set_stack_size(32*4096);
+    # Create a thread with a specific context and stack size
+    my $thr = threads->create({ 'context'    => 'list',
+                                'stack_size' => 32*4096,
+                                'exit'       => 'thread_only' },
+                              \&foo);
+    # Get thread's context
+    my $wantarray = $thr->wantarray();
+    # Check thread's state
+    if ($thr->is_running()) {
+        sleep(1);
+    }
+    if ($thr->is_joinable()) {
+        $thr->join();
+    }
+    # Send a signal to a thread
+    $thr->kill('SIGUSR1');
+    # Exit a thread
+    threads->exit();
+=head1 DESCRIPTION
+Perl 5.6 introduced something called interpreter threads.  Interpreter threads
+are different from I<5005threads> (the thread model of Perl 5.005) by creating
+a new Perl interpreter per thread, and not sharing any data or state between
+threads by default.
+Prior to Perl 5.8, this has only been available to people embedding Perl, and
+for emulating fork() on Windows.
+The I<threads> API is loosely based on the old Thread.pm API. It is very
+important to note that variables are not shared between threads, all variables
+are by default thread local.  To use shared variables one must also use
+L<threads::shared>:
+    use threads;
+    use threads::shared;
+It is also important to note that you must enable threads by doing C<use
+threads> as early as possible in the script itself, and that it is not
+possible to enable threading inside an C<eval "">, C<do>, C<require>, or
+C<use>.  In particular, if you are intending to share variables with
+L<threads::shared>, you must C<use threads> before you C<use threads::shared>.
+(C<threads> will emit a warning if you do it the other way around.)
+=over
+=item $thr = threads->create(FUNCTION, ARGS)
+This will create a new thread that will begin execution with the specified
+entry point function, and give it the I<ARGS> list as parameters.  It will
+return the corresponding threads object, or C<undef> if thread creation failed.
+I<FUNCTION> may either be the name of a function, an anonymous subroutine, or
+a code ref.
+    my $thr = threads->create('func_name', ...);
+        # or
+    my $thr = threads->create(sub { ... }, ...);
+        # or
+    my $thr = threads->create(\&func, ...);
+The C<-E<gt>new()> method is an alias for C<-E<gt>create()>.
+=item $thr->join()
+This will wait for the corresponding thread to complete its execution.  When
+the thread finishes, C<-E<gt>join()> will return the return value(s) of the
+entry point function.
+The context (void, scalar or list) for the return value(s) for C<-E<gt>join()>
+is determined at the time of thread creation.
+    # Create thread in list context (implicit)
+    my ($thr1) = threads->create(sub {
+                                    my @results = qw(a b c);
+                                    return (@results);
+                                 });
+    #   or (explicit)
+    my $thr1 = threads->create({'context' => 'list'},
+                               sub {
+                                    my @results = qw(a b c);
+                                    return (@results);
+                               });
+    # Retrieve list results from thread
+    my @res1 = $thr1->join();
+    # Create thread in scalar context (implicit)
+    my $thr2 = threads->create(sub {
+                                    my $result = 42;
+                                    return ($result);
+                                 });
+    # Retrieve scalar result from thread
+    my $res2 = $thr2->join();
+    # Create a thread in void context (explicit)
+    my $thr3 = threads->create({'void' => 1},
+                               sub { print("Hello, world\n"); });
+    # Join the thread in void context (i.e., no return value)
+    $thr3->join();
+See L</"THREAD CONTEXT"> for more details.
+If the program exits without all threads having either been joined or
+detached, then a warning will be issued.
+Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already joined thread will
+cause an error to be thrown.
+=item $thr->detach()
+Makes the thread unjoinable, and causes any eventual return value to be
+discarded.  When the program exits, any detached threads that are still
+running are silently terminated.
+If the program exits without all threads having either been joined or
+detached, then a warning will be issued.
+Calling C<-E<gt>join()> or C<-E<gt>detach()> on an already detached thread
+will cause an error to be thrown.
+=item threads->detach()
+Class method that allows a thread to detach itself.
+=item threads->self()
+Class method that allows a thread to obtain its own I<threads> object.
+=item $thr->tid()
+Returns the ID of the thread.  Thread IDs are unique integers with the main
+thread in a program being 0, and incrementing by 1 for every thread created.
+=item threads->tid()
+Class method that allows a thread to obtain its own ID.
+=item "$thr"
+If you add the C<stringify> import option to your C<use threads> declaration,
+then using a threads object in a string or a string context (e.g., as a hash
+key) will cause its ID to be used as the value:
+    use threads qw(stringify);
+    my $thr = threads->create(...);
+    print("Thread $thr started...\n");  # Prints out: Thread 1 started...
+=item threads->object($tid)
+This will return the I<threads> object for the I<active> thread associated
+with the specified thread ID.  Returns C<undef> if there is no thread
+associated with the TID, if the thread is joined or detached, if no TID is
+specified or if the specified TID is undef.
+=item threads->yield()
+This is a suggestion to the OS to let this thread yield CPU time to other
+threads.  What actually happens is highly dependent upon the underlying
+thread implementation.
+You may do C<use threads qw(yield)>, and then just use C<yield()> in your
+code.
+=item threads->list()
+=item threads->list(threads::all)
+=item threads->list(threads::running)
+=item threads->list(threads::joinable)
+With no arguments (or using C<threads::all>) and in a list context, returns a
+list of all non-joined, non-detached I<threads> objects.  In a scalar context,
+returns a count of the same.
+With a I<true> argument (using C<threads::running>), returns a list of all
+non-joined, non-detached I<threads> objects that are still running.
+With a I<false> argument (using C<threads::joinable>), returns a list of all
+non-joined, non-detached I<threads> objects that have finished running (i.e.,
+for which C<-E<gt>join()> will not I<block>).
+=item $thr1->equal($thr2)
+Tests if two threads objects are the same thread or not.  This is overloaded
+to the more natural forms:
+    if ($thr1 == $thr2) {
+        print("Threads are the same\n");
+    }
+    # or
+    if ($thr1 != $thr2) {
+        print("Threads differ\n");
+    }
+(Thread comparison is based on thread IDs.)
+=item async BLOCK;
+C<async> creates a thread to execute the block immediately following
+it.  This block is treated as an anonymous subroutine, and so must have a
+semicolon after the closing brace.  Like C<threads-E<gt>create()>, C<async>
+returns a I<threads> object.
+=item $thr->error()
+Threads are executed in an C<eval> context.  This method will return C<undef>
+if the thread terminates I<normally>.  Otherwise, it returns the value of
+C<$@> associated with the thread's execution status in its C<eval> context.
+=item $thr->_handle()
+This I<private> method returns the memory location of the internal thread
+structure associated with a threads object.  For Win32, this is a pointer to
+the C<HANDLE> value returned by C<CreateThread> (i.e., C<HANDLE *>); for other
+platforms, it is a pointer to the C<pthread_t> structure used in the
+C<pthread_create> call (i.e., C<pthread_t *>).
+This method is of no use for general Perl threads programming.  Its intent is
+to provide other (XS-based) thread modules with the capability to access, and
+possibly manipulate, the underlying thread structure associated with a Perl
+thread.
+=item threads->_handle()
+Class method that allows a thread to obtain its own I<handle>.
+=back
+=head1 EXITING A THREAD
+The usual method for terminating a thread is to
+L<return()|perlfunc/"return EXPR"> from the entry point function with the
+appropriate return value(s).
+=over
+=item threads->exit()
+If needed, a thread can be exited at any time by calling
+C<threads-E<gt>exit()>.  This will cause the thread to return C<undef> in a
+scalar context, or the empty list in a list context.
+When called from the I<main> thread, this behaves the same as C<exit(0)>.
+=item threads->exit(status)
+When called from a thread, this behaves like C<threads-E<gt>exit()> (i.e., the
+exit status code is ignored).
+When called from the I<main> thread, this behaves the same as C<exit(status)>.
+=item die()
+Calling C<die()> in a thread indicates an abnormal exit for the thread.  Any
+C<$SIG{__DIE__}> handler in the thread will be called first, and then the
+thread will exit with a warning message that will contain any arguments passed
+in the C<die()> call.
+=item exit(status)
+Calling L<exit()|perlfunc/"exit EXPR"> inside a thread causes the whole
+application to terminate.  Because of this, the use of C<exit()> inside
+threaded code, or in modules that might be used in threaded applications, is
+strongly discouraged.
+If C<exit()> really is needed, then consider using the following:
+    threads->exit() if threads->can('exit');   # Thread friendly
+    exit(status);
+=item use threads 'exit' => 'threads_only'
+This globally overrides the default behavior of calling C<exit()> inside a
+thread, and effectively causes such calls to behave the same as
+C<threads-E<gt>exit()>.  In other words, with this setting, calling C<exit()>
+causes only the thread to terminate.
+Because of its global effect, this setting should not be used inside modules
+or the like.
+The I<main> thread is unaffected by this setting.
+=item threads->create({'exit' => 'thread_only'}, ...)
+This overrides the default behavior of C<exit()> inside the newly created
+thread only.
+=item $thr->set_thread_exit_only(boolean)
+This can be used to change the I<exit thread only> behavior for a thread after
+it has been created.  With a I<true> argument, C<exit()> will cause only the
+thread to exit.  With a I<false> argument, C<exit()> will terminate the
+application.
+The I<main> thread is unaffected by this call.
+=item threads->set_thread_exit_only(boolean)
+Class method for use inside a thread to change its own behavior for C<exit()>.
+The I<main> thread is unaffected by this call.
+=back
+=head1 THREAD STATE
+The following boolean methods are useful in determining the I<state> of a
+thread.
+=over
+=item $thr->is_running()
+Returns true if a thread is still running (i.e., if its entry point function
+has not yet finished or exited).
+=item $thr->is_joinable()
+Returns true if the thread has finished running, is not detached and has not
+yet been joined.  In other words, the thread is ready to be joined, and a call
+to C<$thr-E<gt>join()> will not I<block>.
+=item $thr->is_detached()
+Returns true if the thread has been detached.
+=item threads->is_detached()
+Class method that allows a thread to determine whether or not it is detached.
+=back
+=head1 THREAD CONTEXT
+As with subroutines, the type of value returned from a thread's entry point
+function may be determined by the thread's I<context>:  list, scalar or void.
+The thread's context is determined at thread creation.  This is necessary so
+that the context is available to the entry point function via
+L<wantarray()|perlfunc/"wantarray">.  The thread may then specify a value of
+the appropriate type to be returned from C<-E<gt>join()>.
+=head2 Explicit context
+Because thread creation and thread joining may occur in different contexts, it
+may be desirable to state the context explicitly to the thread's entry point
+function.  This may be done by calling C<-E<gt>create()> with a hash reference
+as the first argument:
+    my $thr = threads->create({'context' => 'list'}, \&foo);
+    ...
+    my @results = $thr->join();
+In the above, the threads object is returned to the parent thread in scalar
+context, and the thread's entry point function C<foo> will be called in list
+(array) context such that the parent thread can receive a list (array) from
+the C<-E<gt>join()> call.  (C<'array'> is synonymous with C<'list'>.)
+Similarly, if you need the threads object, but your thread will not be
+returning a value (i.e., I<void> context), you would do the following:
+    my $thr = threads->create({'context' => 'void'}, \&foo);
+    ...
+    $thr->join();
+The context type may also be used as the I<key> in the hash reference followed
+by a I<true> value:
+    threads->create({'scalar' => 1}, \&foo);
+    ...
+    my ($thr) = threads->list();
+    my $result = $thr->join();
+=head2 Implicit context
+If not explicitly stated, the thread's context is implied from the context
+of the C<-E<gt>create()> call:
+    # Create thread in list context
+    my ($thr) = threads->create(...);
+    # Create thread in scalar context
+    my $thr = threads->create(...);
+    # Create thread in void context
+    threads->create(...);
+=head2 $thr->wantarray()
+This returns the thread's context in the same manner as
+L<wantarray()|perlfunc/"wantarray">.
+=head2 threads->wantarray()
+Class method to return the current thread's context.  This returns the same
+value as running L<wantarray()|perlfunc/"wantarray"> inside the current
+thread's entry point function.
+=head1 THREAD STACK SIZE
+The default per-thread stack size for different platforms varies
+significantly, and is almost always far more than is needed for most
+applications.  On Win32, Perl's makefile explicitly sets the default stack to
+MB; on most other platforms, the system default is used, which again may be
+much larger than is needed.
+By tuning the stack size to more accurately reflect your application's needs,
+you may significantly reduce your application's memory usage, and increase the
+number of simultaneously running threads.
+Note that on Windows, address space allocation granularity is 64 KB,
+therefore, setting the stack smaller than that on Win32 Perl will not save any
+more memory.
+=over
+=item threads->get_stack_size();
+Returns the current default per-thread stack size.  The default is zero, which
+means the system default stack size is currently in use.
+=item $size = $thr->get_stack_size();
+Returns the stack size for a particular thread.  A return value of zero
+indicates the system default stack size was used for the thread.
+=item $old_size = threads->set_stack_size($new_size);
+Sets a new default per-thread stack size, and returns the previous setting.
+Some platforms have a minimum thread stack size.  Trying to set the stack size
+below this value will result in a warning, and the minimum stack size will be
+used.
+Some Linux platforms have a maximum stack size.  Setting too large of a stack
+size will cause thread creation to fail.
+If needed, C<$new_size> will be rounded up to the next multiple of the memory
+page size (usually 4096 or 8192).
+Threads created after the stack size is set will then either call
+C<pthread_attr_setstacksize()> I<(for pthreads platforms)>, or supply the
+stack size to C<CreateThread()> I<(for Win32 Perl)>.
+(Obviously, this call does not affect any currently extant threads.)
+=item use threads ('stack_size' => VALUE);
+This sets the default per-thread stack size at the start of the application.
+=item $ENV{'PERL5_ITHREADS_STACK_SIZE'}
+The default per-thread stack size may be set at the start of the application
+through the use of the environment variable C<PERL5_ITHREADS_STACK_SIZE>:
+    PERL5_ITHREADS_STACK_SIZE=1048576
+    export PERL5_ITHREADS_STACK_SIZE
+    perl -e'use threads; print(threads->get_stack_size(), "\n")'
+This value overrides any C<stack_size> parameter given to C<use threads>.  Its
+primary purpose is to permit setting the per-thread stack size for legacy
+threaded applications.
+=item threads->create({'stack_size' => VALUE}, FUNCTION, ARGS)
+To specify a particular stack size for any individual thread, call
+C<-E<gt>create()> with a hash reference as the first argument:
+    my $thr = threads->create({'stack_size' => 32*4096}, \&foo, @args);
+=item $thr2 = $thr1->create(FUNCTION, ARGS)
+This creates a new thread (C<$thr2>) that inherits the stack size from an
+existing thread (C<$thr1>).  This is shorthand for the following:
+    my $stack_size = $thr1->get_stack_size();
+    my $thr2 = threads->create({'stack_size' => $stack_size}, FUNCTION, ARGS);
+=back
+=head1 THREAD SIGNALLING
+When safe signals is in effect (the default behavior - see L</"Unsafe signals">
+for more details), then signals may be sent and acted upon by individual
+threads.
+=over 4
+=item $thr->kill('SIG...');
+Sends the specified signal to the thread.  Signal names and (positive) signal
+numbers are the same as those supported by
+L<kill()|perlfunc/"kill SIGNAL, LIST">.  For example, 'SIGTERM', 'TERM' and
+(depending on the OS) 15 are all valid arguments to C<-E<gt>kill()>.
+Returns the thread object to allow for method chaining:
+    $thr->kill('SIG...')->join();
+=back
+Signal handlers need to be set up in the threads for the signals they are
+expected to act upon.  Here's an example for I<cancelling> a thread:
+    use threads;
+    sub thr_func
+    {
+        # Thread 'cancellation' signal handler
+        $SIG{'KILL'} = sub { threads->exit(); };
+        ...
+    }
+    # Create a thread
+    my $thr = threads->create('thr_func');
+    ...
+    # Signal the thread to terminate, and then detach
+    # it so that it will get cleaned up automatically
+    $thr->kill('KILL')->detach();
+Here's another simplistic example that illustrates the use of thread
+signalling in conjunction with a semaphore to provide rudimentary I<suspend>
+and I<resume> capabilities:
+    use threads;
+    use Thread::Semaphore;
+    sub thr_func
+    {
+        my $sema = shift;
+        # Thread 'suspend/resume' signal handler
+        $SIG{'STOP'} = sub {
+            $sema->down();      # Thread suspended
+            $sema->up();        # Thread resumes
+        };
+        ...
+    }
+    # Create a semaphore and pass it to a thread
+    my $sema = Thread::Semaphore->new();
+    my $thr = threads->create('thr_func', $sema);
+    # Suspend the thread
+    $sema->down();
+    $thr->kill('STOP');
+    ...
+    # Allow the thread to continue
+    $sema->up();
+CAVEAT:  The thread signalling capability provided by this module does not
+actually send signals via the OS.  It I<emulates> signals at the Perl-level
+such that signal handlers are called in the appropriate thread.  For example,
+sending C<$thr-E<gt>kill('STOP')> does not actually suspend a thread (or the
+whole process), but does cause a C<$SIG{'STOP'}> handler to be called in that
+thread (as illustrated above).
+As such, signals that would normally not be appropriate to use in the
+C<kill()> command (e.g., C<kill('KILL', $$)>) are okay to use with the
+C<-E<gt>kill()> method (again, as illustrated above).
+Correspondingly, sending a signal to a thread does not disrupt the operation
+the thread is currently working on:  The signal will be acted upon after the
+current operation has completed.  For instance, if the thread is I<stuck> on
+an I/O call, sending it a signal will not cause the I/O call to be interrupted
+such that the signal is acted up immediately.
+Sending a signal to a terminated thread is ignored.
+=head1 WARNINGS
+=over 4
+=item Perl exited with active threads:
+If the program exits without all threads having either been joined or
+detached, then this warning will be issued.
+NOTE:  If the I<main> thread exits, then this warning cannot be suppressed
+using C<no warnings 'threads';> as suggested below.
+=item Thread creation failed: pthread_create returned #
+See the appropriate I<man> page for C<pthread_create> to determine the actual
+cause for the failure.
+=item Thread # terminated abnormally: ...
+A thread terminated in some manner other than just returning from its entry
+point function, or by using C<threads-E<gt>exit()>.  For example, the thread
+may have terminated because of an error, or by using C<die>.
+=item Using minimum thread stack size of #
+Some platforms have a minimum thread stack size.  Trying to set the stack size
+below this value will result in the above warning, and the stack size will be
+set to the minimum.
+=item Thread creation failed: pthread_attr_setstacksize(I<SIZE>) returned 22
+The specified I<SIZE> exceeds the system's maximum stack size.  Use a smaller
+value for the stack size.
+=back
+If needed, thread warnings can be suppressed by using:
+    no warnings 'threads';
+in the appropriate scope.
+=head1 ERRORS
+=over 4
+=item This Perl not built to support threads
+The particular copy of Perl that you're trying to use was not built using the
+C<useithreads> configuration option.
+Having threads support requires all of Perl and all of the XS modules in the
+Perl installation to be rebuilt; it is not just a question of adding the
+L<threads> module (i.e., threaded and non-threaded Perls are binary
+incompatible.)
+=item Cannot change stack size of an existing thread
+The stack size of currently extant threads cannot be changed, therefore, the
+following results in the above error:
+    $thr->set_stack_size($size);
+=item Cannot signal threads without safe signals
+Safe signals must be in effect to use the C<-E<gt>kill()> signalling method.
+See L</"Unsafe signals"> for more details.
+=item Unrecognized signal name: ...
+The particular copy of Perl that you're trying to use does not support the
+specified signal being used in a C<-E<gt>kill()> call.
+=back
+=head1 BUGS AND LIMITATIONS
+Before you consider posting a bug report, please consult, and possibly post a
+message to the discussion forum to see if what you've encountered is a known
+problem.
+=over
+=item Thread-safe modules
+See L<perlmod/"Making your module threadsafe"> when creating modules that may
+be used in threaded applications, especially if those modules use non-Perl
+data, or XS code.
+=item Using non-thread-safe modules
+Unfortunately, you may encounter Perl modules that are not I<thread-safe>.
+For example, they may crash the Perl interpreter during execution, or may dump
+core on termination.  Depending on the module and the requirements of your
+application, it may be possible to work around such difficulties.
+If the module will only be used inside a thread, you can try loading the
+module from inside the thread entry point function using C<require> (and
+C<import> if needed):
+    sub thr_func
+    {
+        require Unsafe::Module
+        # Unsafe::Module->import(...);
+        ....
+    }
+If the module is needed inside the I<main> thread, try modifying your
+application so that the module is loaded (again using C<require> and
+C<-E<gt>import()>) after any threads are started, and in such a way that no
+other threads are started afterwards.
+If the above does not work, or is not adequate for your application, then file
+a bug report on L<http://rt.cpan.org/Public/> against the problematic module.
+=item Current working directory
+On all platforms except MSWin32, the setting for the current working directory
+is shared among all threads such that changing it in one thread (e.g., using
+C<chdir()>) will affect all the threads in the application.
+On MSWin32, each thread maintains its own the current working directory
+setting.
+=item Environment variables
+Currently, on all platforms except MSWin32, all I<system> calls (e.g., using
+C<system()> or back-ticks) made from threads use the environment variable
+settings from the I<main> thread.  In other words, changes made to C<%ENV> in
+a thread will not be visible in I<system> calls made by that thread.
+To work around this, set environment variables as part of the I<system> call.
+For example:
+    my $msg = 'hello';
+    system("FOO=$msg; echo \$FOO");   # Outputs 'hello' to STDOUT
+On MSWin32, each thread maintains its own set of environment variables.
+=item Parent-child threads
+On some platforms, it might not be possible to destroy I<parent> threads while
+there are still existing I<child> threads.
+=item Creating threads inside special blocks
+Creating threads inside C<BEGIN>, C<CHECK> or C<INIT> blocks should not be
+relied upon.  Depending on the Perl version and the application code, results
+may range from success, to (apparently harmless) warnings of leaked scalar, or
+all the way up to crashing of the Perl interpreter.
+=item Unsafe signals
+Since Perl 5.8.0, signals have been made safer in Perl by postponing their
+handling until the interpreter is in a I<safe> state.  See
+L<perl58delta/"Safe Signals"> and L<perlipc/"Deferred Signals (Safe Signals)">
+for more details.
+Safe signals is the default behavior, and the old, immediate, unsafe
+signalling behavior is only in effect in the following situations:
+=over 4
+=item * Perl has been built with C<PERL_OLD_SIGNALS> (see C<perl -V>).
+=item * The environment variable C<PERL_SIGNALS> is set to C<unsafe> (see L<perlrun/"PERL_SIGNALS">).
+=item * The module L<Perl::Unsafe::Signals> is used.
+=back
+If unsafe signals is in effect, then signal handling is not thread-safe, and
+the C<-E<gt>kill()> signalling method cannot be used.
+=item Returning closures from threads
+Returning closures from threads should not be relied upon.  Depending of the
+Perl version and the application code, results may range from success, to
+(apparently harmless) warnings of leaked scalar, or all the way up to crashing
+of the Perl interpreter.
+=item Returning objects from threads
+Returning objects from threads does not work.  Depending on the classes
+involved, you may be able to work around this by returning a serialized
+version of the object (e.g., using L<Data::Dumper> or L<Storable>), and then
+reconstituting it in the joining thread.  If you're using Perl 5.10.0 or
+later, and if the class supports L<shared objects|threads::shared/"OBJECTS">,
+you can pass them via L<shared queues| Thread::Queue>.
+=item END blocks in threads
+It is possible to add L<END blocks|perlmod/"BEGIN, UNITCHECK, CHECK, INIT and
+END"> to threads by using L<require|perlfunc/"require VERSION"> or
+L<eval|perlfunc/"eval EXPR"> with the appropriate code.  These C<END> blocks
+will then be executed when the thread's interpreter is destroyed (i.e., either
+during a C<-E<gt>join()> call, or at program termination).
+However, calling any L<threads> methods in such an C<END> block will most
+likely I<fail> (e.g., the application may hang, or generate an error) due to
+mutexes that are needed to control functionality within the L<threads> module.
+For this reason, the use of C<END> blocks in threads is B<strongly>
+discouraged.
+=item Perl Bugs and the CPAN Version of L<threads>
+Support for threads extends beyond the code in this module (i.e.,
+F<threads.pm> and F<threads.xs>), and into the Perl interpreter itself.  Older
+versions of Perl contain bugs that may manifest themselves despite using the
+latest version of L<threads> from CPAN.  There is no workaround for this other
+than upgrading to the latest version of Perl.
+Even with the latest version of Perl, it is known that certain constructs
+with threads may result in warning messages concerning leaked scalars or
+unreferenced scalars.  However, such warnings are harmless, and may safely be
+ignored.
+You can search for L<threads> related bug reports at
+L<http://rt.cpan.org/Public/>.  If needed submit any new bugs, problems,
+patches, etc. to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads>
+=back
+=head1 REQUIREMENTS
+Perl 5.8.0 or later
+=head1 SEE ALSO
+L<threads> Discussion Forum on CPAN:
+L<http://www.cpanforum.com/dist/threads>
+Annotated POD for L<threads>:
+L<http://annocpan.org/~JDHEDDEN/threads-1.71/threads.pm>
+Source repository:
+L<http://code.google.com/p/threads-shared/>
+L<threads::shared>, L<perlthrtut>
+L<http://www.perl.com/pub/a/2002/06/11/threads.html> and
+L<http://www.perl.com/pub/a/2002/09/04/threads.html>
+Perl threads mailing list:
+L<http://lists.cpan.org/showlist.cgi?name=iThreads>
+Stack size discussion:
+L<http://www.perlmonks.org/?node_id=532956>
+=head1 AUTHOR
+Artur Bergman E<lt>sky AT crucially DOT netE<gt>
+CPAN version produced by Jerry D. Hedden <jdhedden AT cpan DOT org>
+=head1 LICENSE
+threads is released under the same license as Perl.
+=head1 ACKNOWLEDGEMENTS
+Richard Soderberg E<lt>perl AT crystalflame DOT netE<gt> -
+Helping me out tons, trying to find reasons for races and other weird bugs!
+Simon Cozens E<lt>simon AT brecon DOT co DOT ukE<gt> -
+Being there to answer zillions of annoying questions
+Rocco Caputo E<lt>troc AT netrus DOT netE<gt>
+Vipul Ved Prakash E<lt>mail AT vipul DOT netE<gt> -
+Helping with debugging
+Dean Arnold E<lt>darnold AT presicient DOT comE<gt> -
+Stack size API
+=cut

 /MissionCockpit/tags/V0.2.0/perl/site/lib/Geo/Ellipsoid.pm
 ,0 → 1,950
+#       Geo::Ellipsoid
+#
+#       This package implements an Ellipsoid class to perform latitude
+#       and longitude calculations on the surface of an ellipsoid.
+#
+#       This is a Perl conversion of existing Fortran code (see
+#       ACKNOWLEDGEMENTS) and the author of this class makes no
+#       claims of originality. Nor can he even vouch for the
+#       results of the calculations, although they do seem to
+#       work for him and have been tested against other methods.
+package Geo::Ellipsoid;
+use warnings;
+use strict;
+use 5.006_00;
+use Scalar::Util 'looks_like_number';
+use Math::Trig;
+use Carp;
+=head1 NAME
+Geo::Ellipsoid - Longitude and latitude calculations using an ellipsoid model.
+=head1 VERSION
+Version 1.12, released July 4, 2008.
+=cut
+our $VERSION = '1.12';
+our $DEBUG = 0;
+=head1 SYNOPSIS
+  use Geo::Ellipsoid;
+  $geo = Geo::Ellipsoid->new(ellipsoid=>'NAD27', units=>'degrees');
+  @origin = ( 37.619002, -122.374843 );    # SFO
+  @dest = ( 33.942536, -118.408074 );      # LAX
+  ( $range, $bearing ) = $geo->to( @origin, @dest );
+  ($lat,$lon) = $geo->at( @origin, 2000, 45.0 );
+  ( $x, $y ) = $geo->displacement( @origin, $lat, $lon );
+  @pos = $geo->location( $lat, $lon, $x, $y );
+=head1 DESCRIPTION
+Geo::Ellipsoid performs geometrical calculations on the surface of
+an ellipsoid. An ellipsoid is a three-dimension object formed from
+the rotation of an ellipse about one of its axes. The approximate
+shape of the earth is an ellipsoid, so Geo::Ellipsoid can accurately
+calculate distance and bearing between two widely-separated locations
+on the earth's surface.
+The shape of an ellipsoid is defined by the lengths of its
+semi-major and semi-minor axes. The shape may also be specifed by
+the flattening ratio C<f> as:
+    f = ( semi-major - semi-minor ) / semi-major
+which, since f is a small number, is normally given as the reciprocal
+of the flattening C<1/f>.
+The shape of the earth has been surveyed and estimated differently
+at different times over the years. The two most common sets of values
+used to describe the size and shape of the earth in the United States
+are 'NAD27', dating from 1927, and 'WGS84', from 1984. United States
+Geological Survey topographical maps, for example, use one or the
+other of these values, and commonly-available Global Positioning
+System (GPS) units can be set to use one or the other.
+See L<"DEFINED ELLIPSOIDS"> below for the ellipsoid survey values
+that may be selected for use by Geo::Ellipsoid.
+=cut
+# class data and constants
+our $degrees_per_radian = 180/pi;
+our $eps = 1.0e-23;
+our $max_loop_count = 20;
+our $twopi = 2 * pi;
+our $halfpi = pi/2;
+our %defaults = (
+  ellipsoid => 'WGS84',
+  units => 'radians',
+  distance_units => 'meter',
+  longitude => 0,
+  latitude => 1,        # allows use of _normalize_output
+  bearing => 0,
+);
+our %distance = (
+  'foot'      => 0.3048,
+  'kilometer' => 1_000,
+  'meter'     => 1.0,
+  'mile'      => 1_609.344,
+  'nm'        => 1_852,
+);
+# set of ellipsoids that can be used.
+# values are
+#  1) a = semi-major (equatorial) radius of Ellipsoid
+#  2) 1/f = reciprocal of flattening (f), the ratio of the semi-minor
+#     (polar) radius to the semi-major (equatorial) axis, or
+#     polar radius = equatorial radius * ( 1 - f )
+our %ellipsoids = (
+    'AIRY'               => [ 6377563.396, 299.3249646     ],
+    'AIRY-MODIFIED'      => [ 6377340.189, 299.3249646     ],
+    'AUSTRALIAN'         => [ 6378160.0,   298.25          ],
+    'BESSEL-1841'        => [ 6377397.155, 299.1528128     ],
+    'CLARKE-1880'        => [ 6378249.145, 293.465         ],
+    'EVEREST-1830'       => [ 6377276.345, 300.8017        ],
+    'EVEREST-MODIFIED'   => [ 6377304.063, 300.8017        ],
+    'FISHER-1960'        => [ 6378166.0,   298.3           ],
+    'FISHER-1968'        => [ 6378150.0,   298.3           ],
+    'GRS80'              => [ 6378137.0,   298.25722210088 ],
+    'HOUGH-1956'         => [ 6378270.0,   297.0           ],
+    'HAYFORD'            => [ 6378388.0,   297.0           ],
+    'IAU76'              => [ 6378140.0,   298.257         ],
+    'KRASSOVSKY-1938'    => [ 6378245.0,   298.3           ],
+    'NAD27'              => [ 6378206.4,   294.9786982138  ],
+    'NWL-9D'             => [ 6378145.0,   298.25          ],
+    'SOUTHAMERICAN-1969' => [ 6378160.0,   298.25          ],
+    'SOVIET-1985'        => [ 6378136.0,   298.257         ],
+    'WGS72'              => [ 6378135.0,   298.26          ],
+    'WGS84'              => [ 6378137.0,   298.257223563   ],
+);
+=head1 CONSTRUCTOR
+=head2 new
+The new() constructor may be called with a hash list to set the value of the
+ellipsoid to be used, the value of the units to be used for angles and
+distances, and whether or not the output range of longitudes and bearing
+angles should be symmetric around zero or always greater than zero.
+The initial default constructor is equivalent to the following:
+    my $geo = Geo::Ellipsoid->new(
+      ellipsoid => 'WGS84',
+      units => 'radians' ,
+      distance_units => 'meter',
+      longitude => 0,
+      bearing => 0,
+    );
+The constructor arguments may be of any case and, with the exception of
+the ellipsoid value, abbreviated to their first three characters.
+Thus, ( UNI => 'DEG', DIS => 'FEE', Lon => 1, ell => 'NAD27', bEA => 0 )
+is valid.
+=cut
+sub new
+{
+  my( $class, %args ) = @_;
+  my $self = {%defaults};
+  print "new: @_\n" if $DEBUG;
+  foreach my $key ( keys %args ) {
+    my $val = $args{$key};
+    if( $key =~ /^ell/i ) {
+      $self->{ellipsoid} = uc $args{$key};
+    }elsif( $key =~ /^uni/i ) {
+      $self->{units} = $args{$key};
+    }elsif( $key =~ /^dis/i ) {
+      $self->{distance_units} = $args{$key};
+    }elsif( $key =~ /^lon/i ) {
+      $self->{longitude} = $args{$key};
+    }elsif( $key =~ /^bea/i ) {
+      $self->{bearing} = $args{$key};
+    }else{
+      carp("Unknown argument: $key => $args{$key}");
+    }
+  }
+  set_units($self,$self->{units});
+  set_ellipsoid($self,$self->{ellipsoid});
+  set_distance_unit($self,$self->{distance_units});
+  set_longitude_symmetric($self,$self->{longitude});
+  set_bearing_symmetric($self,$self->{bearing});
+  print
+    "Ellipsoid(units=>$self->{units},distance_units=>" .
+    "$self->{distance_units},ellipsoid=>$self->{ellipsoid}," .
+    "longitude=>$self->{longitude},bearing=>$self->{bearing})\n" if $DEBUG;
+  bless $self,$class;
+  return $self;
+}
+=head1 METHODS
+=head2 set_units
+Set the angle units used by the Geo::Ellipsoid object. The units may
+also be set in the constructor of the object. The allowable values are
+'degrees' or 'radians'. The default is 'radians'. The units value is
+not case sensitive and may be abbreviated to 3 letters. The units of
+angle apply to both input and output latitude, longitude, and bearing
+values.
+    $geo->set_units('degrees');
+=cut
+sub set_units
+{
+  my $self = shift;
+  my $units = shift;
+  if( $units =~ /deg/i ) {
+    $units = 'degrees';
+  }elsif( $units =~ /rad/i ) {
+    $units = 'radians';
+  }else{
+    croak("Invalid units specifier '$units' - please use either " .
+      "degrees or radians (the default)") unless $units =~ /rad/i;
+  }
+  $self->{units} = $units;
+}
+=head2 set_distance_unit
+Set the distance unit used by the Geo::Ellipsoid object. The unit of
+distance may also be set in the constructor of the object. The recognized
+values are 'meter', 'kilometer', 'mile', 'nm' (nautical mile), or 'foot'.
+The default is 'meter'. The value is not case sensitive and may be
+abbreviated to 3 letters.
+    $geo->set_distance_unit('kilometer');
+For any other unit of distance not recogized by this method, pass a
+numerical argument representing the length of the distance unit in
+meters. For example, to use units of furlongs, call
+    $geo->set_distance_unit(201.168);
+The distance conversion factors used by this module are as follows:
+  Unit          Units per meter
+  --------      ---------------
+  foot             0.3048
+  kilometer     1000.0
+  mile          1609.344
+  nm            1852.0
+=cut
+sub set_distance_unit
+{
+  my $self = shift;
+  my $unit = shift;
+  print "distance unit = $unit\n" if $DEBUG;
+  my $conversion = 0;
+  if( defined $unit ) {
+    my( $key, $val );
+    while( ($key,$val) = each %distance ) {
+      my $re = substr($key,0,3);
+      print "trying ($key,$re,$val)\n" if $DEBUG;
+      if( $unit =~ /^$re/i ) {
+        $self->{distance_units} = $unit;
+        $conversion = $val;
+        # finish iterating to reset 'each' function call
+        while( each %distance ) {}
+        last;
+      }
+    }
+    if( $conversion == 0 ) {
+      if( looks_like_number($unit) ) {
+        $conversion = $unit;
+      }else{
+        carp("Unknown argument to set_distance_unit: $unit\nAssuming meters");
+        $conversion = 1.0;
+      }
+    }
+  }else{
+    carp("Missing or undefined argument to set_distance_unit: ".
+      "$unit\nAssuming meters");
+    $conversion = 1.0;
+  }
+  $self->{conversion} = $conversion;
+}
+=head2 set_ellipsoid
+Set the ellipsoid to be used by the Geo::Ellipsoid object. See
+L<"DEFINED ELLIPSOIDS"> below for the allowable values. The value
+may also be set by the constructor. The default value is 'WGS84'.
+    $geo->set_ellipsoid('NAD27');
+=cut
+sub set_ellipsoid
+{
+  my $self = shift;
+  my $ellipsoid = uc shift || $defaults{ellipsoid};
+  print "  set ellipsoid to $ellipsoid\n" if $DEBUG;
+  unless( exists $ellipsoids{$ellipsoid} ) {
+    croak("Ellipsoid $ellipsoid does not exist - please use " .
+      "set_custom_ellipsoid to use an ellipsoid not in valid set");
+  }
+  $self->{ellipsoid} = $ellipsoid;
+  my( $major, $recip ) = @{$ellipsoids{$ellipsoid}};
+  $self->{equatorial} = $major;
+  if( $recip == 0 ) {
+    carp("Infinite flattening specified by ellipsoid -- assuming a sphere");
+    $self->{polar} = $self->{equatorial};
+    $self->{flattening} = 0;
+    $self->{eccentricity} = 0;
+  }else{
+    $self->{flattening} = ( 1.0 / $ellipsoids{$ellipsoid}[1]);
+    $self->{polar} = $self->{equatorial} * ( 1.0  - $self->{flattening} );
+    $self->{eccentricity} = sqrt( 2.0 * $self->{flattening} -
+      ( $self->{flattening} * $self->{flattening} ) );
+  }
+}
+=head2 set_custom_ellipsoid
+Sets the ellipsoid parameters to the specified ( major semiaxis and
+reciprocal flattening. A zero value for the reciprocal flattening
+will result in a sphere for the ellipsoid, and a warning message
+will be issued.
+    $geo->set_custom_ellipsoid( 'sphere', 6378137, 0 );
+=cut
+sub set_custom_ellipsoid
+{
+  my $self = shift;
+  my( $name, $major, $recip ) = @_;
+  $name = uc $name;
+  $recip = 0 unless defined $recip;
+  if( $major ) {
+    $ellipsoids{$name} = [ $major, $recip ];
+  }else{
+    croak("set_custom_ellipsoid called without semi-major radius parameter");
+  }
+  set_ellipsoid($self,$name);
+}
+=head2 set_longitude_symmetric
+If called with no argument or a true argument, sets the range of output
+values for longitude to be in the range [-pi,+pi) radians.  If called with
+a false or undefined argument, sets the output angle range to be
+[0,2*pi) radians.
+    $geo->set_longitude_symmetric(1);
+=cut
+sub set_longitude_symmetric
+{
+  my( $self, $sym ) = @_;
+  # see if argument passed
+  if( $#_ > 0 ) {
+    # yes -- use value passed
+    $self->{longitude} = $sym;
+  }else{
+    # no -- set to true
+    $self->{longitude} = 1;
+  }
+}
+=head2 set_bearing_symmetric
+If called with no argument or a true argument, sets the range of output
+values for bearing to be in the range [-pi,+pi) radians.  If called with
+a false or undefined argument, sets the output angle range to be
+[0,2*pi) radians.
+    $geo->set_bearing_symmetric(1);
+=cut
+sub set_bearing_symmetric
+{
+  my( $self, $sym ) = @_;
+  # see if argument passed
+  if( $#_ > 0 ) {
+    # yes -- use value passed
+    $self->{bearing} = $sym;
+  }else{
+    # no -- set to true
+    $self->{bearing} = 1;
+  }
+}
+=head2 set_defaults
+Sets the defaults for the new method. Call with key, value pairs similar to
+new.
+    $Geo::Ellipsoid->set_defaults(
+      units => 'degrees',
+      ellipsoid => 'GRS80',
+      distance_units => 'kilometer',
+      longitude => 1,
+      bearing => 0
+    );
+Keys and string values (except for the ellipsoid identifier) may be shortened
+to their first three letters and are case-insensitive:
+    $Geo::Ellipsoid->set_defaults(
+      uni => 'deg',
+      ell => 'GRS80',
+      dis => 'kil',
+      lon => 1,
+      bea => 0
+    );
+=cut
+sub set_defaults
+{
+  my $self = shift;
+  my %args = @_;
+  foreach my $key ( keys %args ) {
+    if( $key =~ /^ell/i ) {
+      $defaults{ellipsoid} = uc $args{$key};
+    }elsif( $key =~ /^uni/i ) {
+      $defaults{units} = $args{$key};
+    }elsif( $key =~ /^dis/i ) {
+      $defaults{distance_units} = $args{$key};
+    }elsif( $key =~ /^lon/i ) {
+      $defaults{longitude} = $args{$key};
+    }elsif( $key =~ /^bea/i ) {
+      $defaults{bearing} = $args{$key};
+    }else{
+      croak("Geo::Ellipsoid::set_defaults called with invalid key: $key");
+    }
+  }
+  print "Defaults set to ($defaults{ellipsoid},$defaults{units}\n"
+    if $DEBUG;
+}
+=head2 scales
+Returns a list consisting of the distance unit per angle of latitude
+and longitude (degrees or radians) at the specified latitude.
+These values may be used for fast approximations of distance
+calculations in the vicinity of some location.
+    ( $lat_scale, $lon_scale ) = $geo->scales($lat0);
+    $x = $lon_scale * ($lon - $lon0);
+    $y = $lat_scale * ($lat - $lat0);
+=cut
+sub scales
+{
+  my $self = shift;
+  my $units = $self->{units};
+  my $lat = $_[0];
+  if( defined $lat ) {
+    $lat /= $degrees_per_radian if( $units eq 'degrees' );
+  }else{
+    carp("scales() method requires latitude argument; assuming 0");
+    $lat = 0;
+  }
+  my $aa = $self->{equatorial};
+  my $bb = $self->{polar};
+  my $a2 = $aa*$aa;
+  my $b2 = $bb*$bb;
+  my $d1 = $aa * cos($lat);
+  my $d2 = $bb * sin($lat);
+  my $d3 = $d1*$d1 + $d2*$d2;
+  my $d4 = sqrt($d3);
+  my $n1 = $aa * $bb;
+  my $latscl = ( $n1 * $n1 ) / ( $d3 * $d4 * $self->{conversion} );
+  my $lonscl = ( $aa * $d1 ) / ( $d4 * $self->{conversion} );
+  if( $DEBUG ) {
+    print "lat=$lat, aa=$aa, bb=$bb\nd1=$d1, d2=$d2, d3=$d3, d4=$d4\n";
+    print "latscl=$latscl, lonscl=$lonscl\n";
+  }
+  if( $self->{units} eq 'degrees' ) {
+    $latscl /= $degrees_per_radian;
+    $lonscl /= $degrees_per_radian;
+  }
+  return ( $latscl, $lonscl );
+}
+=head2 range
+Returns the range in distance units between two specified locations given
+as latitude, longitude pairs.
+    my $dist = $geo->range( $lat1, $lon1, $lat2, $lon2 );
+    my $dist = $geo->range( @origin, @destination );
+=cut
+sub range
+{
+  my $self = shift;
+  my @args = _normalize_input($self->{units},@_);
+  my($range,$bearing) = _inverse($self,@args);
+  print "inverse(@_[1..4]) returns($range,$bearing)\n" if $DEBUG;
+  return $range;
+}
+=head2 bearing
+Returns the bearing in degrees or radians from the first location to
+the second. Zero bearing is true north.
+    my $bearing = $geo->bearing( $lat1, $lon1, $lat2, $lon2 );
+=cut
+sub bearing
+{
+  my $self = shift;
+  my $units = $self->{units};
+  my @args = _normalize_input($units,@_);
+  my($range,$bearing) = _inverse($self,@args);
+  print "inverse(@args) returns($range,$bearing)\n" if $DEBUG;
+  my $t = $bearing;
+  $self->_normalize_output('bearing',$bearing);
+  print "_normalize_output($t) returns($bearing)\n" if $DEBUG;
+  return $bearing;
+}
+=head2 at
+Returns the list (latitude,longitude) in degrees or radians that is a
+specified range and bearing from a given location.
+    my( $lat2, $lon2 ) = $geo->at( $lat1, $lon1, $range, $bearing );
+=cut
+sub at
+{
+  my $self = shift;
+  my $units = $self->{units};
+  my( $lat, $lon, $az ) = _normalize_input($units,@_[0,1,3]);
+  my $r = $_[2];
+  print "at($lat,$lon,$r,$az)\n" if $DEBUG;
+  my( $lat2, $lon2 ) = _forward($self,$lat,$lon,$r,$az);
+  print "_forward returns ($lat2,$lon2)\n" if $DEBUG;
+  $self->_normalize_output('longitude',$lon2);
+  $self->_normalize_output('latitude',$lat2);
+  return ( $lat2, $lon2 );
+}
+=head2 to
+In list context, returns (range, bearing) between two specified locations.
+In scalar context, returns just the range.
+    my( $dist, $theta ) = $geo->to( $lat1, $lon1, $lat2, $lon2 );
+    my $dist = $geo->to( $lat1, $lon1, $lat2, $lon2 );
+=cut
+sub to
+{
+  my $self = shift;
+  my $units = $self->{units};
+  my @args = _normalize_input($units,@_);
+  print "to($units,@args)\n" if $DEBUG;
+  my($range,$bearing) = _inverse($self,@args);
+  print "to: inverse(@args) returns($range,$bearing)\n" if $DEBUG;
+  #$bearing *= $degrees_per_radian if $units eq 'degrees';
+  $self->_normalize_output('bearing',$bearing);
+  if( wantarray() ) {
+    return ( $range, $bearing );
+  }else{
+    return $range;
+  }
+}
+=head2 displacement
+Returns the (x,y) displacement in distance units between the two specified
+locations.
+    my( $x, $y ) = $geo->displacement( $lat1, $lon1, $lat2, $lon2 );
+NOTE: The x and y displacements are only approximations and only valid
+between two locations that are fairly near to each other. Beyond 10 kilometers
+or more, the concept of X and Y on a curved surface loses its meaning.
+=cut
+sub displacement
+{
+  my $self = shift;
+  print "displacement(",join(',',@_),"\n" if $DEBUG;
+  my @args = _normalize_input($self->{units},@_);
+  print "call _inverse(@args)\n" if $DEBUG;
+  my( $range, $bearing ) = _inverse($self,@args);
+  print "disp: _inverse(@args) returns ($range,$bearing)\n" if $DEBUG;
+  my $x = $range * sin($bearing);
+  my $y = $range * cos($bearing);
+  return ($x,$y);
+}
+=head2 location
+Returns the list (latitude,longitude) of a location at a given (x,y)
+displacement from a given location.
+        my @loc = $geo->location( $lat, $lon, $x, $y );
+=cut
+sub location
+{
+  my $self = shift;
+  my $units = $self->{units};
+  my($lat,$lon,$x,$y) = @_;
+  my $range = sqrt( $x*$x+ $y*$y );
+  my $bearing = atan2($x,$y);
+  $bearing *= $degrees_per_radian if $units eq 'degrees';
+  print "location($lat,$lon,$x,$y,$range,$bearing)\n" if $DEBUG;
+  return $self->at($lat,$lon,$range,$bearing);
+}
+########################################################################
+#
+#      internal functions
+#
+#       inverse
+#
+#       Calculate the displacement from origin to destination.
+#       The input to this subroutine is
+#         ( latitude-1, longitude-1, latitude-2, longitude-2 ) in radians.
+#
+#       Return the results as the list (range,bearing) with range in the
+#       current specified distance unit and bearing in radians.
+sub _inverse()
+{
+  my $self = shift;
+  my( $lat1, $lon1, $lat2, $lon2 ) = (@_);
+  print "_inverse($lat1,$lon1,$lat2,$lon2)\n" if $DEBUG;
+  my $a = $self->{equatorial};
+  my $f = $self->{flattening};
+  my $r = 1.0 - $f;
+  my $tu1 = $r * sin($lat1) / cos($lat1);
+  my $tu2 = $r * sin($lat2) / cos($lat2);
+  my $cu1 = 1.0 / ( sqrt(($tu1*$tu1) + 1.0) );
+  my $su1 = $cu1 * $tu1;
+  my $cu2 = 1.0 / ( sqrt( ($tu2*$tu2) + 1.0 ));
+  my $s = $cu1 * $cu2;
+  my $baz = $s * $tu2;
+  my $faz = $baz * $tu1;
+  my $dlon = $lon2 - $lon1;
+  if( $DEBUG ) {
+    printf "lat1=%.8f, lon1=%.8f\n", $lat1, $lon1;
+    printf "lat2=%.8f, lon2=%.8f\n", $lat2, $lon2;
+    printf "r=%.8f, tu1=%.8f, tu2=%.8f\n", $r, $tu1, $tu2;
+    printf "faz=%.8f, dlon=%.8f\n", $faz, $dlon;
+  }
+  my $x = $dlon;
+  my $cnt = 0;
+  print "enter loop:\n" if $DEBUG;
+  my( $c2a, $c, $cx, $cy, $cz, $d, $del, $e, $sx, $sy, $y );
+  do {
+    printf "  x=%.8f\n", $x if $DEBUG;
+    $sx = sin($x);
+    $cx = cos($x);
+    $tu1 = $cu2*$sx;
+    $tu2 = $baz - ($su1*$cu2*$cx);
+    printf "    sx=%.8f, cx=%.8f, tu1=%.8f, tu2=%.8f\n",
+      $sx, $cx, $tu1, $tu2 if $DEBUG;
+    $sy = sqrt( $tu1*$tu1 + $tu2*$tu2 );
+    $cy = $s*$cx + $faz;
+    $y = atan2($sy,$cy);
+    my $sa;
+    if( $sy == 0.0 ) {
+      $sa = 1.0;
+    }else{
+      $sa = ($s*$sx) / $sy;
+    }
+    printf "    sy=%.8f, cy=%.8f, y=%.8f, sa=%.8f\n", $sy, $cy, $y, $sa
+      if $DEBUG;
+    $c2a = 1.0 - ($sa*$sa);
+    $cz = $faz + $faz;
+    if( $c2a > 0.0 ) {
+      $cz = ((-$cz)/$c2a) + $cy;
+    }
+    $e = ( 2.0 * $cz * $cz ) - 1.0;
+    $c = ( ((( (-3.0 * $c2a) + 4.0)*$f) + 4.0) * $c2a * $f )/16.0;
+    $d = $x;
+    $x = ( ($e * $cy * $c + $cz) * $sy * $c + $y) * $sa;
+    $x = ( 1.0 - $c ) * $x * $f + $dlon;
+    $del = $d - $x;
+    if( $DEBUG ) {
+      printf "    c2a=%.8f, cz=%.8f\n", $c2a, $cz;
+      printf "    e=%.8f, d=%.8f\n", $e, $d;
+      printf "    (d-x)=%.8g\n", $del;
+    }
+  }while( (abs($del) > $eps) && ( ++$cnt <= $max_loop_count ) );
+  $faz = atan2($tu1,$tu2);
+  $baz = atan2($cu1*$sx,($baz*$cx - $su1*$cu2)) + pi;
+  $x = sqrt( ((1.0/($r*$r)) -1.0 ) * $c2a+1.0 ) + 1.0;
+  $x = ($x-2.0)/$x;
+  $c = 1.0 - $x;
+  $c = (($x*$x)/4.0 + 1.0)/$c;
+  $d = ((0.375*$x*$x) - 1.0)*$x;
+  $x = $e*$cy;
+  if( $DEBUG ) {
+    printf "e=%.8f, cy=%.8f, x=%.8f\n", $e, $cy, $x;
+    printf "sy=%.8f, c=%.8f, d=%.8f\n", $sy, $c, $d;
+    printf "cz=%.8f, a=%.8f, r=%.8f\n", $cz, $a, $r;
+  }
+  $s = 1.0 - $e - $e;
+  $s = (((((((( $sy * $sy * 4.0 ) - 3.0) * $s * $cz * $d/6.0) - $x) *
+    $d /4.0) + $cz) * $sy * $d) + $y ) * $c * $a * $r;
+  printf "s=%.8f\n", $s if $DEBUG;
+  # adjust azimuth to (0,360) or (-180,180) as specified
+  if( $self->{symmetric} ) {
+    $faz += $twopi if $faz < -(pi);
+    $faz -= $twopi if $faz >= pi;
+  }else{
+    $faz += $twopi if $faz < 0;
+    $faz -= $twopi if $faz >= $twopi;
+  }
+  # return result
+  my @disp = ( ($s/$self->{conversion}), $faz );
+  print "disp = (@disp)\n" if $DEBUG;
+  return @disp;
+}
+#       _forward
+#
+#       Calculate the location (latitue,longitude) of a point
+#       given a starting point and a displacement from that
+#       point as (range,bearing)
+#
+sub _forward
+{
+  my $self = shift;
+  my( $lat1, $lon1, $range, $bearing ) = @_;
+  if( $DEBUG ) {
+    printf "_forward(lat1=%.8f,lon1=%.8f,range=%.8f,bearing=%.8f)\n",
+      $lat1, $lon1, $range, $bearing;
+  }
+  my $eps = 0.5e-13;
+  my $a = $self->{equatorial};
+  my $f = $self->{flattening};
+  my $r = 1.0 - $f;
+  my $tu = $r * sin($lat1) / cos($lat1);
+  my $faz = $bearing;
+  my $s = $self->{conversion} * $range;
+  my $sf = sin($faz);
+  my $cf = cos($faz);
+  my $baz = 0.0;
+  $baz = 2.0 * atan2($tu,$cf) if( $cf != 0.0 );
+  my $cu = 1.0 / sqrt(1.0 + $tu*$tu);
+  my $su = $tu * $cu;
+  my $sa = $cu * $sf;
+  my $c2a = 1.0 - ($sa*$sa);
+  my $x = 1.0 + sqrt( (((1.0/($r*$r)) - 1.0 )*$c2a) +1.0);
+  $x = ($x-2.0)/$x;
+  my $c = 1.0 - $x;
+  $c = ((($x*$x)/4.0) + 1.0)/$c;
+  my $d = $x * ((0.375*$x*$x)-1.0);
+  $tu = (($s/$r)/$a)/$c;
+  my $y = $tu;
+  if( $DEBUG ) {
+    printf "r=%.8f, tu=%.8f, faz=%.8f\n", $r, $tu, $faz;
+    printf "baz=%.8f, sf=%.8f, cf=%.8f\n", $baz, $sf, $cf;
+    printf "cu=%.8f, su=%.8f, sa=%.8f\n", $cu, $su, $sa;
+    printf "x=%.8f, c=%.8f, y=%.8f\n", $x, $c, $y;
+  }
+  my( $cy, $cz, $e, $sy );
+  do {
+    $sy = sin($y);
+    $cy = cos($y);
+    $cz = cos($baz+$y);
+    $e = (2.0*$cz*$cz)-1.0;
+    $c = $y;
+    $x = $e * $cy;
+    $y = (2.0 * $e) - 1.0;
+    $y = ((((((((($sy*$sy*4.0)-3.0)*$y*$cz*$d)/6.0)+$x)*$d)/4.0)-$cz)*$sy*$d) +
+      $tu;
+    } while( abs($y-$c) > $eps );
+  $baz = ($cu*$cy*$cf) - ($su*$sy);
+  $c = $r*sqrt(($sa*$sa) + ($baz*$baz));
+  $d = $su*$cy + $cu*$sy*$cf;
+  my $lat2 = atan2($d,$c);
+  $c = $cu*$cy - $su*$sy*$cf;
+  $x = atan2($sy*$sf,$c);
+  $c = (((((-3.0*$c2a)+4.0)*$f)+4.0)*$c2a*$f)/16.0;
+  $d = (((($e*$cy*$c) + $cz)*$sy*$c)+$y)*$sa;
+  my $lon2 = $lon1 + $x - (1.0-$c)*$d*$f;
+  #$baz = atan2($sa,$baz) + pi;
+  # return result
+  return ($lat2,$lon2);
+}
+#       _normalize_input
+#
+#       Normalize a set of input angle values by converting to
+#       radians if given in degrees and by converting to the
+#       range [0,2pi), i.e. greater than or equal to zero and
+#       less than two pi.
+#
+sub _normalize_input
+{
+  my $units = shift;
+  my @args = @_;
+  return map {
+    $_ = deg2rad($_) if $units eq 'degrees';
+    while( $_ < 0 ) { $_ += $twopi }
+    while( $_ >= $twopi ) { $_ -= $twopi }
+    $_
+  } @args;
+}
+#       _normalize_output
+#
+#       Normalize a set of output angle values by converting to
+#       degrees if needed and by converting to the range [-pi,+pi) or
+#       [0,2pi) as needed.
+#
+sub _normalize_output
+{
+  my $self = shift;
+  my $elem = shift;     # 'bearing' or 'longitude'
+  # adjust remaining input values by reference
+  for ( @_ ) {
+    if( $self->{$elem} ) {
+      # normalize to range [-pi,pi)
+      while( $_ < -(pi) ) { $_ += $twopi }
+      while( $_ >= pi ) { $_ -= $twopi }
+    }else{
+      # normalize to range [0,2*pi)
+      while( $_ < 0 ) { $_ += $twopi }
+      while( $_ >= $twopi ) { $_ -= $twopi }
+    }
+    $_ = rad2deg($_) if $self->{units} eq 'degrees';
+  }
+}
+=head1 DEFINED ELLIPSOIDS
+The following ellipsoids are defined in Geo::Ellipsoid, with the
+semi-major axis in meters and the reciprocal flattening as shown.
+The default ellipsoid is WGS84.
+    Ellipsoid        Semi-Major Axis (m.)     1/Flattening
+    ---------        -------------------     ---------------
+    AIRY                 6377563.396         299.3249646
+    AIRY-MODIFIED        6377340.189         299.3249646
+    AUSTRALIAN           6378160.0           298.25
+    BESSEL-1841          6377397.155         299.1528128
+    CLARKE-1880          6378249.145         293.465
+    EVEREST-1830         6377276.345         290.8017
+    EVEREST-MODIFIED     6377304.063         290.8017
+    FISHER-1960          6378166.0           298.3
+    FISHER-1968          6378150.0           298.3
+    GRS80                6378137.0           298.25722210088
+    HOUGH-1956           6378270.0           297.0
+    HAYFORD              6378388.0           297.0
+    IAU76                6378140.0           298.257
+    KRASSOVSKY-1938      6378245.0           298.3
+    NAD27                6378206.4           294.9786982138
+    NWL-9D               6378145.0           298.25
+    SOUTHAMERICAN-1969   6378160.0           298.25
+    SOVIET-1985          6378136.0           298.257
+    WGS72                6378135.0           298.26
+    WGS84                6378137.0           298.257223563
+=head1 LIMITATIONS
+The methods should not be used on points which are too near the poles
+(above or below 89 degrees), and should not be used on points which
+are antipodal, i.e., exactly on opposite sides of the ellipsoid. The
+methods will not return valid results in these cases.
+=head1 ACKNOWLEDGEMENTS
+The conversion algorithms used here are Perl translations of Fortran
+routines written by LCDR S<L. Pfeifer> NGS Rockville MD that implement
+S<T. Vincenty's> Modified Rainsford's method with Helmert's elliptical
+terms as published in "Direct and Inverse Solutions of Ellipsoid on
+the Ellipsoid with Application of Nested Equations", S<T. Vincenty,>
+Survey Review, April 1975.
+The Fortran source code files inverse.for and forward.for
+may be obtained from
+    ftp://ftp.ngs.noaa.gov/pub/pcsoft/for_inv.3d/source/
+=head1 AUTHOR
+Jim Gibson, C<< <Jim@Gibson.org> >>
+=head1 BUGS
+See LIMITATIONS, above.
+Please report any bugs or feature requests to
+C<bug-geo-ellipsoid@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Geo-Ellipsoid>.
+=head1 COPYRIGHT & LICENSE
+Copyright 2005-2008 Jim Gibson, all rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+=head1 SEE ALSO
+Geo::Distance, Geo::Ellipsoids
+=cut
+; # End of Geo::Ellipsoid

 /MissionCockpit/tags/V0.2.0/perl/site/lib/Time/HiRes.pm
 ,0 → 1,591
+package Time::HiRes;
+use strict;
+use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT = qw( );
+@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
+                 getitimer setitimer nanosleep clock_gettime clock_getres
+                 clock clock_nanosleep
+                 CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
+                 CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID
+                 CLOCK_TIMEOFDAY CLOCKS_PER_SEC
+                 ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
+                 TIMER_ABSTIME
+                 d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
+                 d_nanosleep d_clock_gettime d_clock_getres
+                 d_clock d_clock_nanosleep
+                 stat
+                );
+$VERSION = '1.9719';
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+sub AUTOLOAD {
+    my $constname;
+    ($constname = $AUTOLOAD) =~ s/.*:://;
+    # print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
+    die "&Time::HiRes::constant not defined" if $constname eq 'constant';
+    my ($error, $val) = constant($constname);
+    # print "AUTOLOAD: error = $error, val = $val\n";
+    if ($error) {
+        my (undef,$file,$line) = caller;
+        die "$error at $file line $line.\n";
+    }
+    {
+        no strict 'refs';
+        *$AUTOLOAD = sub { $val };
+    }
+    goto &$AUTOLOAD;
+}
+sub import {
+    my $this = shift;
+    for my $i (@_) {
+        if (($i eq 'clock_getres'    && !&d_clock_getres)    ||
+            ($i eq 'clock_gettime'   && !&d_clock_gettime)   ||
+            ($i eq 'clock_nanosleep' && !&d_clock_nanosleep) ||
+            ($i eq 'clock'           && !&d_clock)           ||
+            ($i eq 'nanosleep'       && !&d_nanosleep)       ||
+            ($i eq 'usleep'          && !&d_usleep)          ||
+            ($i eq 'ualarm'          && !&d_ualarm)) {
+            require Carp;
+            Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
+        }
+    }
+    Time::HiRes->export_to_level(1, $this, @_);
+}
+bootstrap Time::HiRes;
+# Preloaded methods go here.
+sub tv_interval {
+    # probably could have been done in C
+    my ($a, $b) = @_;
+    $b = [gettimeofday()] unless defined($b);
+    (${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
+}
+# Autoload methods go after =cut, and are processed by the autosplit program.
+;
+__END__
+=head1 NAME
+Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
+=head1 SYNOPSIS
+  use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
+                      clock_gettime clock_getres clock_nanosleep clock
+                      stat );
+  usleep ($microseconds);
+  nanosleep ($nanoseconds);
+  ualarm ($microseconds);
+  ualarm ($microseconds, $interval_microseconds);
+  $t0 = [gettimeofday];
+  ($seconds, $microseconds) = gettimeofday;
+  $elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
+  $elapsed = tv_interval ( $t0, [gettimeofday]);
+  $elapsed = tv_interval ( $t0 );
+  use Time::HiRes qw ( time alarm sleep );
+  $now_fractions = time;
+  sleep ($floating_seconds);
+  alarm ($floating_seconds);
+  alarm ($floating_seconds, $floating_interval);
+  use Time::HiRes qw( setitimer getitimer );
+  setitimer ($which, $floating_seconds, $floating_interval );
+  getitimer ($which);
+  use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep
+                      ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
+  $realtime   = clock_gettime(CLOCK_REALTIME);
+  $resolution = clock_getres(CLOCK_REALTIME);
+  clock_nanosleep(CLOCK_REALTIME, 1.5e9);
+  clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME);
+  my $ticktock = clock();
+  use Time::HiRes qw( stat );
+  my @stat = stat("file");
+  my @stat = stat(FH);
+=head1 DESCRIPTION
+The C<Time::HiRes> module implements a Perl interface to the
+C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and
+C<setitimer>/C<getitimer> system calls, in other words, high
+resolution time and timers. See the L</EXAMPLES> section below and the
+test scripts for usage; see your system documentation for the
+description of the underlying C<nanosleep> or C<usleep>, C<ualarm>,
+C<gettimeofday>, and C<setitimer>/C<getitimer> calls.
+If your system lacks C<gettimeofday()> or an emulation of it you don't
+get C<gettimeofday()> or the one-argument form of C<tv_interval()>.
+If your system lacks all of C<nanosleep()>, C<usleep()>,
+C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>,
+C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>.
+If your system lacks both C<ualarm()> and C<setitimer()> you don't get
+C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>.
+If you try to import an unimplemented function in the C<use> statement
+it will fail at compile time.
+If your subsecond sleeping is implemented with C<nanosleep()> instead
+of C<usleep()>, you can mix subsecond sleeping with signals since
+C<nanosleep()> does not use signals.  This, however, is not portable,
+and you should first check for the truth value of
+C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and
+then carefully read your C<nanosleep()> C API documentation for any
+peculiarities.
+If you are using C<nanosleep> for something else than mixing sleeping
+with signals, give some thought to whether Perl is the tool you should
+be using for work requiring nanosecond accuracies.
+Remember that unless you are working on a I<hard realtime> system,
+any clocks and timers will be imprecise, especially so if you are working
+in a pre-emptive multiuser system.  Understand the difference between
+I<wallclock time> and process time (in UNIX-like systems the sum of
+I<user> and I<system> times).  Any attempt to sleep for X seconds will
+most probably end up sleeping B<more> than that, but don't be surpised
+if you end up sleeping slightly B<less>.
+The following functions can be imported from this module.
+No functions are exported by default.
+=over 4
+=item gettimeofday ()
+In array context returns a two-element array with the seconds and
+microseconds since the epoch.  In scalar context returns floating
+seconds like C<Time::HiRes::time()> (see below).
+=item usleep ( $useconds )
+Sleeps for the number of microseconds (millionths of a second)
+specified.  Returns the number of microseconds actually slept.
+Can sleep for more than one second, unlike the C<usleep> system call.
+Can also sleep for zero seconds, which often works like a I<thread yield>.
+See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and
+C<Time::HiRes::clock_nanosleep()>.
+Do not expect usleep() to be exact down to one microsecond.
+=item nanosleep ( $nanoseconds )
+Sleeps for the number of nanoseconds (1e9ths of a second) specified.
+Returns the number of nanoseconds actually slept (accurate only to
+microseconds, the nearest thousand of them).  Can sleep for more than
+one second.  Can also sleep for zero seconds, which often works like
+a I<thread yield>.  See also C<Time::HiRes::sleep()>,
+C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>.
+Do not expect nanosleep() to be exact down to one nanosecond.
+Getting even accuracy of one thousand nanoseconds is good.
+=item ualarm ( $useconds [, $interval_useconds ] )
+Issues a C<ualarm> call; the C<$interval_useconds> is optional and
+will be zero if unspecified, resulting in C<alarm>-like behaviour.
+Returns the remaining time in the alarm in microseconds, or C<undef>
+if an error occurred.
+ualarm(0) will cancel an outstanding ualarm().
+Note that the interaction between alarms and sleeps is unspecified.
+=item tv_interval
+tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
+Returns the floating seconds between the two times, which should have
+been returned by C<gettimeofday()>. If the second argument is omitted,
+then the current time is used.
+=item time ()
+Returns a floating seconds since the epoch. This function can be
+imported, resulting in a nice drop-in replacement for the C<time>
+provided with core Perl; see the L</EXAMPLES> below.
+B<NOTE 1>: This higher resolution timer can return values either less
+or more than the core C<time()>, depending on whether your platform
+rounds the higher resolution timer values up, down, or to the nearest second
+to get the core C<time()>, but naturally the difference should be never
+more than half a second.  See also L</clock_getres>, if available
+in your system.
+B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
+the C<time()> seconds since epoch rolled over to 1_000_000_000, the
+default floating point format of Perl and the seconds since epoch have
+conspired to produce an apparent bug: if you print the value of
+C<Time::HiRes::time()> you seem to be getting only five decimals, not
+six as promised (microseconds).  Not to worry, the microseconds are
+there (assuming your platform supports such granularity in the first
+place).  What is going on is that the default floating point format of
+Perl only outputs 15 digits.  In this case that means ten digits
+before the decimal separator and five after.  To see the microseconds
+you can use either C<printf>/C<sprintf> with C<"%.6f">, or the
+C<gettimeofday()> function in list context, which will give you the
+seconds and microseconds as two separate values.
+=item sleep ( $floating_seconds )
+Sleeps for the specified amount of seconds.  Returns the number of
+seconds actually slept (a floating point value).  This function can
+be imported, resulting in a nice drop-in replacement for the C<sleep>
+provided with perl, see the L</EXAMPLES> below.
+Note that the interaction between alarms and sleeps is unspecified.
+=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
+The C<SIGALRM> signal is sent after the specified number of seconds.
+Implemented using C<setitimer()> if available, C<ualarm()> if not.
+The C<$interval_floating_seconds> argument is optional and will be
+zero if unspecified, resulting in C<alarm()>-like behaviour.  This
+function can be imported, resulting in a nice drop-in replacement for
+the C<alarm> provided with perl, see the L</EXAMPLES> below.
+Returns the remaining time in the alarm in seconds, or C<undef>
+if an error occurred.
+B<NOTE 1>: With some combinations of operating systems and Perl
+releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
+This means that an C<alarm()> followed by a C<select()> may together
+take the sum of the times specified for the the C<alarm()> and the
+C<select()>, not just the time of the C<alarm()>.
+Note that the interaction between alarms and sleeps is unspecified.
+=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
+Start up an interval timer: after a certain time, a signal ($which) arrives,
+and more signals may keep arriving at certain intervals.  To disable
+an "itimer", use C<$floating_seconds> of zero.  If the
+C<$interval_floating_seconds> is set to zero (or unspecified), the
+timer is disabled B<after> the next delivered signal.
+Use of interval timers may interfere with C<alarm()>, C<sleep()>,
+and C<usleep()>.  In standard-speak the "interaction is unspecified",
+which means that I<anything> may happen: it may work, it may not.
+In scalar context, the remaining time in the timer is returned.
+In list context, both the remaining time and the interval are returned.
+There are usually three or four interval timers (signals) available: the
+C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
+C<ITIMER_REALPROF>.  Note that which ones are available depends: true
+UNIX platforms usually have the first three, but only Solaris seems to
+have C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
+Win32 unfortunately does not haveinterval timers.
+C<ITIMER_REAL> results in C<alarm()>-like behaviour.  Time is counted in
+I<real time>; that is, wallclock time.  C<SIGALRM> is delivered when
+the timer expires.
+C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is,
+only when the process is running.  In multiprocessor/user/CPU systems
+this may be more or less than real or wallclock time.  (This time is
+also known as the I<user time>.)  C<SIGVTALRM> is delivered when the
+timer expires.
+C<ITIMER_PROF> counts time when either the process virtual time or when
+the operating system is running on behalf of the process (such as I/O).
+(This time is also known as the I<system time>.)  (The sum of user
+time and system time is known as the I<CPU time>.)  C<SIGPROF> is
+delivered when the timer expires.  C<SIGPROF> can interrupt system calls.
+The semantics of interval timers for multithreaded programs are
+system-specific, and some systems may support additional interval
+timers.  For example, it is unspecified which thread gets the signals.
+See your C<setitimer()> documentation.
+=item getitimer ( $which )
+Return the remaining time in the interval timer specified by C<$which>.
+In scalar context, the remaining time is returned.
+In list context, both the remaining time and the interval are returned.
+The interval is always what you put in using C<setitimer()>.
+=item clock_gettime ( $which )
+Return as seconds the current value of the POSIX high resolution timer
+specified by C<$which>.  All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, which is supposed to return results close to the
+results of C<gettimeofday>, or the number of seconds since 00:00:00:00
+January 1, 1970 Greenwich Mean Time (GMT).  Do not assume that
+CLOCK_REALTIME is zero, it might be one, or something else.
+Another potentially useful (but not available everywhere) value is
+C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
+value (unlike time() or gettimeofday(), which can be adjusted).
+See your system documentation for other possibly supported values.
+=item clock_getres ( $which )
+Return as seconds the resolution of the POSIX high resolution timer
+specified by C<$which>.  All implementations that support POSIX high
+resolution timers are supposed to support at least the C<$which> value
+of C<CLOCK_REALTIME>, see L</clock_gettime>.
+=item clock_nanosleep ( $which, $nanoseconds, $flags = 0)
+Sleeps for the number of nanoseconds (1e9ths of a second) specified.
+Returns the number of nanoseconds actually slept.  The $which is the
+"clock id", as with clock_gettime() and clock_getres().  The flags
+default to zero but C<TIMER_ABSTIME> can specified (must be exported
+explicitly) which means that C<$nanoseconds> is not a time interval
+(as is the default) but instead an absolute time.  Can sleep for more
+than one second.  Can also sleep for zero seconds, which often works
+like a I<thread yield>.  See also C<Time::HiRes::sleep()>,
+C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>.
+Do not expect clock_nanosleep() to be exact down to one nanosecond.
+Getting even accuracy of one thousand nanoseconds is good.
+=item clock()
+Return as seconds the I<process time> (user + system time) spent by
+the process since the first call to clock() (the definition is B<not>
+"since the start of the process", though if you are lucky these times
+may be quite close to each other, depending on the system).  What this
+means is that you probably need to store the result of your first call
+to clock(), and subtract that value from the following results of clock().
+The time returned also includes the process times of the terminated
+child processes for which wait() has been executed.  This value is
+somewhat like the second value returned by the times() of core Perl,
+but not necessarily identical.  Note that due to backward
+compatibility limitations the returned value may wrap around at about
+seconds or at about 36 minutes.
+=item stat
+=item stat FH
+=item stat EXPR
+As L<perlfunc/stat> but with the access/modify/change file timestamps
+in subsecond resolution, if the operating system and the filesystem
+both support such timestamps.  To override the standard stat():
+    use Time::HiRes qw(stat);
+Test for the value of &Time::HiRes::d_hires_stat to find out whether
+the operating system supports subsecond file timestamps: a value
+larger than zero means yes. There are unfortunately no easy
+ways to find out whether the filesystem supports such timestamps.
+UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp
+granularity is B<two> seconds).
+A zero return value of &Time::HiRes::d_hires_stat means that
+Time::HiRes::stat is a no-op passthrough for CORE::stat(),
+and therefore the timestamps will stay integers.  The same
+thing will happen if the filesystem does not do subsecond timestamps,
+even if the &Time::HiRes::d_hires_stat is non-zero.
+In any case do not expect nanosecond resolution, or even a microsecond
+resolution.  Also note that the modify/access timestamps might have
+different resolutions, and that they need not be synchronized, e.g.
+if the operations are
+    write
+    stat # t1
+    read
+    stat # t2
+the access time stamp from t2 need not be greater-than the modify
+time stamp from t1: it may be equal or I<less>.
+=back
+=head1 EXAMPLES
+  use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
+  $microseconds = 750_000;
+  usleep($microseconds);
+  # signal alarm in 2.5s & every .1s thereafter
+  ualarm(2_500_000, 100_000);
+  # cancel that ualarm
+  ualarm(0);
+  # get seconds and microseconds since the epoch
+  ($s, $usec) = gettimeofday();
+  # measure elapsed time
+  # (could also do by subtracting 2 gettimeofday return values)
+  $t0 = [gettimeofday];
+  # do bunch of stuff here
+  $t1 = [gettimeofday];
+  # do more stuff here
+  $t0_t1 = tv_interval $t0, $t1;
+  $elapsed = tv_interval ($t0, [gettimeofday]);
+  $elapsed = tv_interval ($t0); # equivalent code
+  #
+  # replacements for time, alarm and sleep that know about
+  # floating seconds
+  #
+  use Time::HiRes;
+  $now_fractions = Time::HiRes::time;
+  Time::HiRes::sleep (2.5);
+  Time::HiRes::alarm (10.6666666);
+  use Time::HiRes qw ( time alarm sleep );
+  $now_fractions = time;
+  sleep (2.5);
+  alarm (10.6666666);
+  # Arm an interval timer to go off first at 10 seconds and
+  # after that every 2.5 seconds, in process virtual time
+  use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
+  $SIG{VTALRM} = sub { print time, "\n" };
+  setitimer(ITIMER_VIRTUAL, 10, 2.5);
+  use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME );
+  # Read the POSIX high resolution timer.
+  my $high = clock_getres(CLOCK_REALTIME);
+  # But how accurate we can be, really?
+  my $reso = clock_getres(CLOCK_REALTIME);
+  use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME );
+  clock_nanosleep(CLOCK_REALTIME, 1e6);
+  clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME);
+  use Time::HiRes qw( clock );
+  my $clock0 = clock();
+  ... # Do something.
+  my $clock1 = clock();
+  my $clockd = $clock1 - $clock0;
+  use Time::HiRes qw( stat );
+  my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10];
+=head1 C API
+In addition to the perl API described above, a C API is available for
+extension writers.  The following C functions are available in the
+modglobal hash:
+  name             C prototype
+  ---------------  ----------------------
+  Time::NVtime     double (*)()
+  Time::U2time     void (*)(pTHX_ UV ret[2])
+Both functions return equivalent information (like C<gettimeofday>)
+but with different representations.  The names C<NVtime> and C<U2time>
+were selected mainly because they are operating system independent.
+(C<gettimeofday> is Unix-centric, though some platforms like Win32 and
+VMS have emulations for it.)
+Here is an example of using C<NVtime> from C:
+  double (*myNVtime)(); /* Returns -1 on failure. */
+  SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
+  if (!svp)         croak("Time::HiRes is required");
+  if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
+  myNVtime = INT2PTR(double(*)(), SvIV(*svp));
+  printf("The current time is: %f\n", (*myNVtime)());
+=head1 DIAGNOSTICS
+=head2 useconds or interval more than ...
+In ualarm() you tried to use number of microseconds or interval (also
+in microseconds) more than 1_000_000 and setitimer() is not available
+in your system to emulate that case.
+=head2 negative time not invented yet
+You tried to use a negative time argument.
+=head2 internal error: useconds < 0 (unsigned ... signed ...)
+Something went horribly wrong-- the number of microseconds that cannot
+become negative just became negative.  Maybe your compiler is broken?
+=head2 useconds or uinterval equal to or more than 1000000
+In some platforms it is not possible to get an alarm with subsecond
+resolution and later than one second.
+=head2 unimplemented in this platform
+Some calls simply aren't available, real or emulated, on every platform.
+=head1 CAVEATS
+Notice that the core C<time()> maybe rounding rather than truncating.
+What this means is that the core C<time()> may be reporting the time
+as one second later than C<gettimeofday()> and C<Time::HiRes::time()>.
+Adjusting the system clock (either manually or by services like ntp)
+may cause problems, especially for long running programs that assume
+a monotonously increasing time (note that all platforms do not adjust
+time as gracefully as UNIX ntp does).  For example in Win32 (and derived
+platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
+drift off from the system clock (and the original time())  by up to 0.5
+seconds. Time::HiRes will notice this eventually and recalibrate.
+Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
+might help in this (in case your system supports CLOCK_MONOTONIC).
+Some systems have APIs but not implementations: for example QNX and Haiku
+have the interval timer APIs but not the functionality.
+=head1 SEE ALSO
+Perl modules L<BSD::Resource>, L<Time::TAI64>.
+Your system documentation for C<clock>, C<clock_gettime>,
+C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>,
+C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>.
+=head1 AUTHORS
+D. Wegscheid <wegscd@whirlpool.com>
+R. Schertler <roderick@argon.org>
+J. Hietaniemi <jhi@iki.fi>
+G. Aas <gisle@aas.no>
+=head1 COPYRIGHT AND LICENSE
+Copyright (c) 1996-2002 Douglas E. Wegscheid.  All rights reserved.
+Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi.
+All rights reserved.
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+=cut

 /MissionCockpit/tags/V0.2.0/perl/site/lib/Win32/SerialPort.pm
 ,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;
+    }
+;
+}
+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";
+    }
+;
+}
+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";
+    }
+;
+}
+##### 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;
+;
+}
+# 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 (@_);
+;
+}
+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;
+}
+;  # 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,
+-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 AP

Subversion Repositories Projects

Compare Revisions

Ignore whitespace Rev 462 → Rev 463