/MissionCockpit/tags/V0.2.5/INSTALL.TXT |
---|
0,0 → 1,346 |
0. 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! |
1. 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). |
2. Perl Interpreter |
Mission Cockpit ist in der Scriptsprache Perl/Tk programmiert. |
Zur Ausführung des Programms wird Perl Version 5.10.0 benoetigt. |
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, betriebsbereit 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" |
3. 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!! |
4. Programmstart |
mkcockpit.pl bzw. perl mkcockpit.pl |
5. 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. |
6. Karte fuer das Flugfeld definieren |
Die Karte fuer das Flugfeld muss als JPEG, PNG oder 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. |
Im Verzeichnis "map" können mehrere Karten-Definitionen als XML-Dateien abgelegt werden. |
Eine XML-Datei kann eine oder mehrere Karten-Definitionen enthalten. |
Die Auswahl der gewuenschten Karte erfolgt im Konfigurations-Dialog, Reiter "Karte" |
Die XML-Datei muss momentan manuell angelegt und editiert werden. |
Eine XML-Datei hat folgenden Aufbau: |
<mkcockpit-Maps> |
<Hemhofen |
Name="Hemhofen" |
Size_X="800" |
Size_Y="600" |
File="hemhofen-800.png" |
P1_x="66" |
P1_y="62" |
P2_x="778" |
P2_y="488" |
P1_Lat="49.685333" |
P1_Lon="10.250134" |
P2_Lat="49.882949" |
P2_Lon="10.344580" |
Home_Lat="48.683734" |
Home_Lon="11.945960" |
Offset_x="5" |
Offset_y="5" |
Track_Lat="48.685333" |
Track_Lon="11.950134" |
Track_Alt="512" |
Track_Bearing="10" |
Border="555, 430, |
516, 555, |
258, 555, |
100, 300, |
580, 260, |
530, 94, |
627, 130, |
735, 300, |
680, 400, |
757, 470, |
720, 515, |
575, 420," |
/> |
</mkcockpit-Maps> |
Die XML-Datei muss dem gängigen XML-Syntax entsprechen. |
Folgende Werte sind optional und können entfallen: |
Home_Lat, Home_Lon: |
Home-Position für den Player. Wenn nicht angegeben wird die Home-Position vom MK verwendet. |
Offset_x, Offset_y: |
Für kleine Korrekturen der Kalibrierung. Die auf der Kart dargestellten Objekte wden um die |
Anzahl der angegeben Pixel verschoben. |
Track_Lat, Track_Lon, Track_Alt, Track_Bearing: |
Position und Blickrichtung der Tracking-Antenne, falls abweichend vom MK-Startpunkt |
Border: |
Polygon der Flugfeldbegrenzung |
Die Koordinaten sind Pixel-Koordinaten bezogen auf das Hintergrundbild. |
Der Ursprung 0/0 ist links oben. |
7. Kalibirieren der Karte |
Die Karte muss gewissenhaft kalibiriert werden! |
Dazu werden bei der zu kalibrierenden Karte in in der entsprechenden XML-Datei im "map"-Verzeichnis |
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. |
8. 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. |
9. 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) |
10. 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. |
11. 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). |
- Vista Sprachsteuerung kann Tastaureingaben simulieren. |
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 |
2x 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. |
12. Modi des Players |
Die Taste "R" (Random) schaltet folgende Modi durch: |
- Play WPT: Die Waypoints werden der Reihe nach abgeflogen |
- Rand WPT: Die Wegpunkte werden nach dem Zufallsprinzip abgeflogen |
- Rand MAP: Es wird nach dem Zufallsprinzip auf der Karte ein beliebiger Punkt gesucht und angeflogen |
Dabei werden 10% des Karten-Randes nicht angeflogen. |
Die Tasten "W" oder "K" schalten zwischen dem eventgesteuertem WPT-Mode und dem zeitgesteuerten KML-Mode um. |
Im Pause-Mode kann man den MK mit den Cursor-Tasten meterweise verschieben. |
Damit ist "Präzisions-Einparken" gut machbar. |
Die Taste "A" schaltet den Aufnahme-Modus ein oder aus. |
Damit kann man die Flugbahn des MK in beliebigen Modi aufzeichnen und dann im KML-Player-Modus wieder abspielen. |
13. Flugfeldbegrenzung |
In der Karten-Definition kann man eine Flugfeldbegrenzrun (Border) definieren. |
Der Player wird nur die Ziele anfliegen, die ohne Überquerung der Flugfeldbegrenzung erreichbar sind. |
Bei starkem Wid kann es jedoch passieren, dass der MK abgetrieben wird und trotzdem das Flugfeld verlässt. |
14. 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. |
15. KML Datei laden und abspielen. |
Es kann eine KML-Datei geladen werden, die der MK dann zeitgesteuert abfliegt. |
Im KML-File ist normalerweise keine Zeitbasis gespeichert. Die Punkte der KML-Datei werden mit dem |
in der "Logging"-Konfiguration eingetragenen Intervall abgespielt. |
16. Start Szenario |
Im Einstellungs-Dialog kann man im Reiter "Start Szenario" Voreinstellungen für den Player angeben. |
Damit kann der Player automatisch sofort nach dem Start des Programms in einen bestimmten Modus |
geschaltet werden und eine Waypoint- und/oder KML Datei geladen werden. |
17. 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. |
18. Tracking Antenne |
Im Mission Cockpit ist die Ansteuerung fuer eine Antennen-Nachfuehrung 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 oder zwei Servos, welche mechanisch einen 180 Grad Drehwinkel zulaesst |
Das Servo wird ausserhalb der ueblichen Impulslängen angesteuert, um den 180 Grad Drehwinkel zu erreichen. |
Es ist eine Pan- und Tilt Nachführung 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. |
Falls der Standort der Anatenne vom Startpunkt des MK abweicht können diese Werte auch optional in der |
Karten-Definition hinterlegt werden. |
Die Antenne kann auch nach "hinten" sehen. Das Pan- und Tilt-Serve "flippen" dabei um 180 Grad. |
19. Sprachausgabe |
Im Mission Cockpit ist eine Text To Speech (TTS) Sprachausgabe implementiert. |
Dazu muss das Programm eSpeak installiert werden. http://espeak.sourceforge.net |
Falls die Sprachausgabe auf die Nerven geht kann sie mit der Taste "M" (Mute) aus/ein geschaltet werden. |
ES werden regelmässig Flugzeit, Spannung, Höhe und Anzahl empfangener Satelliten ausgegeben. |
Wichtige Events (Akku-Warnung, Verlassen Flugfeld, Empfangsprobleme usw.) werden priorisiert angesagt. |
20. System-Meldungen |
Wichtige System-Meldungen werden in einer gelben "Sprechblase" direkt am MK-Symbol abgezeigt. |
Man muss also nicht ständig die OSD-Anzeigen kontrollieren und interpretieren. |
21. 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. |
22. 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.5/LICENSE.TXT |
---|
0,0 → 1,36 |
Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
====================================================== |
Es ist Ihnen gestattet: |
* das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
* Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
Zu den folgenden Bedingungen: |
* Namensnennung. |
Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
* Keine kommerzielle Nutzung. |
Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
* Weitergabe unter gleichen Bedingungen. |
Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
verändern oder als Grundlage für einen anderen Inhalt verwenden, |
dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
des Rechteinhabers dazu erhalten. |
Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
Weitere Details zur Lizenzbestimmung gibt es hier: |
Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
/MissionCockpit/tags/V0.2.5/MissionCockpit-V0.2.5.zip |
---|
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.5/geserver.pl |
---|
0,0 → 1,208 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# geserver.pl - Google Earth Server for MK Mission Cockpit |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 20090317 0.0.1 rw created |
# 20090401 0.1.0 rw RC1 |
# |
############################################################################### |
$Version{'geserver.pl'} = "0.1.0 - 2009-04-01"; |
# |
# Parameter |
# |
$port_listen = $Cfg->{'geserver'}->{'HttpPort'}; |
use Socket; |
use IO::Select; |
use threads; |
use threads::shared; |
$| = 1; |
# "Lon, Lat, Alt" |
share (@GeCoords); |
sub GeServer() |
{ |
local *S; |
socket (S, PF_INET , SOCK_STREAM , getprotobyname('tcp')) or die "couldn't open socket: $!"; |
setsockopt (S, SOL_SOCKET, SO_REUSEADDR, 1); |
bind (S, sockaddr_in($port_listen, INADDR_ANY)); |
listen (S, 5) or die "don't hear anything: $!"; |
my $ss = IO::Select->new(); |
$ss -> add (*S); |
while(1) |
{ |
my @connections_pending = $ss->can_read(); |
foreach (@connections_pending) |
{ |
my $fh; |
my $remote = accept($fh, $_); |
my($port,$iaddr) = sockaddr_in($remote); |
my $peeraddress = inet_ntoa($iaddr); |
# memory-leak in threads!!! Process only one request in parallel |
# my $t = threads->create(\&new_connection, $fh); |
&new_connection ($fh); |
} |
} |
} |
sub new_connection |
{ |
my $fh = shift; |
binmode $fh; |
my %req; |
$req{HEADER}={}; |
my $request_line = <$fh>; |
my $first_line = ""; |
while ($request_line ne "\r\n") |
{ |
unless ($request_line) |
{ |
close $fh; |
} |
chomp $request_line; |
unless ($first_line) |
{ |
$first_line = $request_line; |
my @parts = split(" ", $first_line); |
if (@parts != 3) |
{ |
close $fh; |
} |
$req{METHOD} = $parts[0]; |
$req{OBJECT} = $parts[1]; |
} |
else |
{ |
my ($name, $value) = split(": ", $request_line); |
$name = lc $name; |
$req{HEADER}{$name} = $value; |
} |
$request_line = <$fh>; |
} |
&http_request_handler($fh, \%req); |
close $fh; |
} |
sub http_request_handler |
{ |
my $fh = shift; |
my $req_ = shift; |
my %req = %$req_; |
my %header = %{$req{HEADER}}; |
print $fh "HTTP/1.0 200 OK\n"; |
print $fh "Content-Type: application/vnd.google-earth.kml+xml; charset=iso-8859-1\n"; |
print $fh "Connection: close\n\n"; |
# KML Header |
print $fh <<EOF; |
<?xml version="1.0" encoding="UTF-8"?> |
<kml xmlns="http://earth.google.com/kml/2.2"> |
<Document> |
<name>Mikrokopter GPS logging</name> |
<Style id="MK_gps-style"> |
<LineStyle> |
<color>ff0000ff</color> |
<width>2</width> |
</LineStyle> |
</Style> |
<Placemark> |
<name>Flight live</name> |
<styleUrl>MK_gps-style</styleUrl> |
<LineString> |
<tessellate>1</tessellate> |
<altitudeMode>relativeToGround</altitudeMode> |
<coordinates> |
EOF |
# send all KML Coords for each request |
for $i (0 .. $#GeCoords) |
{ |
print $fh "$GeCoords[$i]\n"; |
} |
# KML Trailler |
print $fh <<EOF; |
</coordinates> |
</LineString> |
</Placemark> |
</Document> |
</kml> |
EOF |
# Debug: |
# print "Method: $req{METHOD}\n"; |
# print "Object: $req{OBJECT}\n>"; |
# foreach my $r (keys %header) |
# { |
# print $r, " = ", $header{$r} , "\n"; |
# } |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/icon/ModeKml_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/icon/ModeWpt_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/icon/RandomMap_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/icon/RandomOff_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/icon/RandomOn_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/icon/RandomWpt_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/icon/Record_48.gif |
---|
Cannot display: file marked as a binary type. |
svn:mime-type = application/octet-stream |
Property changes: |
Added: svn:mime-type |
+application/octet-stream |
\ No newline at end of property |
/MissionCockpit/tags/V0.2.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/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.5/libmap.pl |
---|
0,0 → 1,207 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmap.pl - Conversion GPS and Map-X/Y Coordinates |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-03-06 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-05-13 0.1.1 rw MapGpsAt() added |
# 2009-05-22 0.1.2 rw add default Map dir |
# 2009-07-22 0.1.3 rw Map Offset_x, Offset_y added |
# 2009-08-08 0.1.4 rw atan -> atan2 |
# |
############################################################################### |
$Version{'libmap.pl'} = "0.1.4 - 2009-08-08"; |
use Geo::Ellipsoid; # http://search.cpan.org/dist/Geo-Ellipsoid-1.12/lib/Geo/Ellipsoid.pm |
use Math::Trig; |
if ( ! defined Cfg->{'map'}->{'MapDir'} ) |
{ |
# set default map directory |
$Cfg->{'map'}->{'MapDir'} = "map"; |
} |
require "$Cfg->{'map'}->{'MapDir'}/map.pl"; # Landkarte |
# |
# Convert GPS (Lat,Lon) to pixel coordinates in map |
# |
sub MapGps2XY () |
{ |
my ($Lat, $Lon, $Bearing) = @_; |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
# P1 -> P2: Entfernung und Richtung |
my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} ); |
my $dx_p = $Map{'P2_x'} - $Map{'P1_x'}; |
my $dy_p = $Map{'P2_y'} - $Map{'P1_y'}; |
my $P1P2_Dist_p = sqrt($dx_p*$dx_p + $dy_p*$dy_p); |
my $PixRes = $P1P2_Dist_m / $P1P2_Dist_p ; # 1 Pixel = $PixRes Meter |
my $Phi = rad2deg atan2 ($dy_p, $dx_p); |
my $PhiRef = $P1P2_Bearing - $Phi; # Winkel zwischen N und Bild-Horizont |
# P1 -> Target: Entfernung und Richtung |
my ($T_Dist_m, $T_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Lat, $Lon ); |
my $Alpha = deg2rad($T_Bearing - $PhiRef); # Winkel zw. Bild-Horizont und Target |
my $T_dx_p = cos($Alpha) * $T_Dist_m / $PixRes; |
my $T_dy_p = sin($Alpha) * $T_Dist_m / $PixRes; |
my $X_p = $Map{'P1_x'} + $T_dx_p + $Map{'Offset_x'}; |
my $Y_p = $Map{'P1_y'} + $T_dy_p - $Map{'Offset_y'}; |
# map calibration adjustment |
$X_p += $Map{'Offset_x'}; |
$Y_p -= $Map{'Offset_y'}; |
$Angel = $Bearing - $PhiRef; |
return ($X_p, $Y_p, $Angel); |
} |
# |
# Convert pixel coordinates in map to GPS (Lat,Lon) |
# |
sub MapXY2Gps () |
{ |
my ($X, $Y) = @_; |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
# map calibration adjustment |
$X -= $Map{'Offset_x'}; |
$Y += $Map{'Offset_y'}; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
# P1 -> P2: Entfernung und Richtung |
my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} ); |
my $dx_p = $Map{'P2_x'} - $Map{'P1_x'}; |
my $dy_p = $Map{'P2_y'} - $Map{'P1_y'}; |
my $P1P2_Dist_p = sqrt($dx_p*$dx_p + $dy_p*$dy_p); |
my $PixRes = $P1P2_Dist_m / $P1P2_Dist_p ; # 1 Pixel = $PixRes Meter |
my $Phi = rad2deg atan2 ($dy_p, $dx_p); |
my $PhiRef = $P1P2_Bearing - $Phi; # Winkel zwischen N und Bild-Horizont |
my $dx = $X - $Map{'P1_x'}; |
my $dy = $Y - $Map{'P1_y'}; |
my $Phi = rad2deg atan2 ($dy, $dx); |
my $Bearing = $PhiRef + $Phi; |
my $Dist = $PixRes * sqrt($dx*$dx + $dy*$dy); |
my ($Lat, $Lon) = $Map_Geo->at( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Dist, $Bearing ); |
return ($Lat, $Lon); |
} |
# |
# Get Bearing, Distance from 2 GPS Points |
# |
sub MapGpsTo() |
{ |
my ($Lat1, $Lon1, $Lat2, $Lon2) = @_; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
my ($Dist, $Bearing) = $Map_Geo->to( $Lat1, $Lon1, $Lat2, $Lon2); |
return ($Dist, $Bearing); |
} |
# |
# Get Target from GPS-Point, Bearing, Distance |
# |
sub MapGpsAt() |
{ |
my ($Lat, $Lon, $Dist, $Bearing) = @_; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
my ($Target_Lat, $Target_Lon) = $Map_Geo->at( $Lat, $Lon, $Dist, $Bearing); |
return ($Target_Lat, $Target_Lon); |
} |
# Angel geographic North to Map Horizont |
sub MapAngel() |
{ |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
my $Map_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
# P1 -> P2: Entfernung und Richtung |
my ($P1P2_Dist_m, $P1P2_Bearing) = $Map_Geo->to( $Map{'P1_Lat'}, $Map{'P1_Lon'}, $Map{'P2_Lat'}, $Map{'P2_Lon'} ); |
my $dx_p = $Map{'P2_x'} - $Map{'P1_x'}; |
my $dy_p = $Map{'P2_y'} - $Map{'P1_y'}; |
my $Phi = rad2deg atan2 ($dy_p, $dx_p); |
my $PhiRef = $P1P2_Bearing - $Phi; # Winkel zwischen N und Bild-Horizont |
return ($PhiRef); |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/libmkcockpit.pl |
---|
0,0 → 1,1611 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmkcockpit.pl - MK Mission Cockpit - Subroutined for GUI Frontend |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-08-09 0.2.5 rw subroutines moved from mkcockpit.pl |
# |
############################################################################### |
$Version{'libmkcockpit.pl'} = "0.2.5 - 2009-08-09"; |
# check, if %MkOsd is valid |
sub MkOsdIsValid() |
{ |
return ( $MkOsd{'_Timestamp'} >= time-2 ); |
} |
# check, if current GPS position is valid |
sub CurPosIsValid() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'CurPos_Stat'} == 1 ); |
} |
# check, if home GPS position is valid |
sub HomePosIsValid() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'HomePos_Stat'} == 1 ); |
} |
# check, if target GPS position is valid |
sub TargetIsValid() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'TargetPos_Stat'} == 1 ); |
} |
# check, if motor are on |
sub MkIsMotorOn() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x01 ); |
} |
# check, if MK is flying |
sub MkIsFlying() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x02 ); |
} |
# check, if MK is calibrating |
sub MkIsCalibrating() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x04 ); |
} |
# check, if Motor is starting |
sub MkIsMotorStarting() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x08 ); |
} |
# check, Emergency Landing |
sub MkEmergencyLanding() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'MKFlags'} & 0x10 ); |
} |
# check, if MK is FREE Mode |
sub MkIsFreeMode() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x01 ); |
} |
# check, if MK is in PH Mode |
sub MkIsPhMode() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x02 ); |
} |
# check, if MK is in WPT Mode |
sub MkIsWptMode() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x04 ); |
} |
# check, Range Limit |
sub MkRangeLimit() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x08 ); |
} |
# check, Serial Link |
sub MkSerialLink() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x10 ); |
} |
# check, Target reached |
sub MkTargetReached() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x20 ); |
} |
# check, Manual Control |
sub MkManualControl() |
{ |
return ( &MkOsdIsValid() and $MkOsd{'NCFlags'} & 0x40 ); |
} |
# get battery capacity in % |
sub BatCapacity() |
{ |
my ($UBat) = @_; |
my $CfgVal = $Cfg->{'mkcockpit'}->{'BatCharacteristics'}; |
my @Voltage = split ' ', $CfgVal; |
my $Capacity = 0; |
if ( $UBat >= $Voltage[0] ) |
{ |
$Capacity = 100; |
} |
$Cnt = $#Voltage; |
for ($i=0; $i < $Cnt; $i++) |
{ |
my $V1 = $Voltage[$i]; |
my $V2 = $Voltage[$i+1]; |
if ( $UBat >= $V1 and $UBat < $V2 or |
$UBat <= $V1 and $UBat > $V2 ) |
{ |
# linear interpolation |
my $x = $i + ($UBat - $V1 ) / ($V2 - $V1); |
$Capacity = 100 - $x * 100 / $Cnt; |
last; |
} |
} |
return $Capacity; |
} |
# |
# Waypoint handling |
# |
# Add a Waypoint to @Waypoints List |
sub WpAdd() |
{ |
my ($Wp_x, $Wp_y) = @_; |
# save Wp-Hash in Waypoint-Array |
my $Wp = {}; |
my $Tag = sprintf "Waypoint-%d.%d", time, int (rand(9)) ; # kind of unique Tag for this Wp |
($Lat, $Lon) = &MapXY2Gps($Wp_x, $Wp_y); |
$Wp->{'Tag'} = $Tag; |
$Wp->{'MapX'} = $Wp_x; |
$Wp->{'MapY'} = $Wp_y; |
$Wp->{'Pos_Lat'} = $Lat; |
$Wp->{'Pos_Lon'} = $Lon; |
$Wp->{'Pos_Alt'} = $MkOsd{'CurPos_Alt'}; |
$Wp->{'Heading'} = $Cfg->{'waypoint'}->{'DefaultHeading'}; |
$Wp->{'ToleranceRadius'} = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; |
$Wp->{'Holdtime'} = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; |
$Wp->{'Event_Flag'} = $Cfg->{'waypoint'}->{'DefaultEventFlag'}; |
push @Waypoints, $Wp; |
} |
# Delete Waypoint from @Waypoints List |
sub WpDelete () |
{ |
my ($WpIndex) = @_; |
# delete Wp in Waypoint-Array |
splice @Waypoints, $WpIndex, 1; |
} |
# Load @Waypoints from file |
sub WpLoadFile () |
{ |
my ($WpFile) = @_; |
# XML in Hash-Ref lesen |
my $Wp = XMLin($WpFile, ForceArray => 1); |
# XML Hash-Ref in Wp-Array umkopieren |
undef @Waypoints; |
foreach $key (sort keys %$Wp) |
{ |
my $Point = $Wp->{$key}->[0]; |
# relative Pixelkoordinaten auf Bildgroesse umrechnen |
if ( $Point->{'MapX'} <= 1 and $Point->{'MapY'} <= 1 ) |
{ |
$Point->{'MapX'} = int ( $Point->{'MapX'} * $MapSizeX + 0.5 ); |
$Point->{'MapY'} = int ( $Point->{'MapY'} * $MapSizeY + 0.5 ); |
} |
# GPS Koordinaten für die aktuelle Karte neu aus Map x/y berechnen |
my ($Lat, $Lon) = &MapXY2Gps($Point->{'MapX'}, $Point->{'MapY'}); |
$Point->{'Pos_Lat'} = $Lat; |
$Point->{'Pos_Lon'} = $Lon; |
push @Waypoints, $Point; |
} |
} |
# Safe @Waypoints to file |
sub WpSaveFile() |
{ |
my ($WpFile) = @_; |
# Waypoint-Array in Hash umkopieren |
for $i ( 0 .. $#Waypoints ) |
{ |
my $key = sprintf ("WP-%04d", $i); |
my $Wp = {%{$Waypoints[$i]}}; # copy of Hash-content |
$WpOut{$key} = $Wp; |
# Pixelkoordinaten relativ zur Bildgroesse speichern |
$WpOut{$key}{'MapX_Pixel'} = $WpOut{$key}{'MapX'}; |
$WpOut{$key}{'MapY_Pixel'} = $WpOut{$key}{'MapY'}; |
$WpOut{$key}{'MapX'} /= $MapSizeX; |
$WpOut{$key}{'MapY'} /= $MapSizeY; |
} |
# WP-Hash als XML speichern |
&XMLout (\%WpOut, |
'OutputFile' => $WpFile, |
'AttrIndent' => '1', |
'RootName' => 'Waypoints', |
); |
} |
# Get Wp Index from Canvas Id |
sub WpGetIndexFromId() |
{ |
my ($id) = @_; |
my @Tags = $map_canvas->gettags($id); |
my $WpTag = $Tags[1]; |
for $i (0 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
if ( $Wp->{'Tag'} eq $WpTag ) |
{ |
# got it |
return $i; |
} |
} |
return -1; |
} |
# Resend all Waypoints to MK |
sub WpSendAll() |
{ |
# OSD/Debug Abfragefrequenz verringern, sonst kommen nicht alle Wp im MK an |
# Sicherheitshalber doppelt senden |
$MkSendWp = 1; # verhindert ueberschreiben im Timer |
$MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 1000) ); # Frequenz OSD Datensatz, * 10ms |
$MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 1000) ); # Frequenz MK Debug Datensatz, * 10ms |
usleep (200000); |
$MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 1000) ); # Frequenz OSD Datensatz, * 10ms |
$MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 1000) ); # Frequenz MK Debug Datensatz, * 10ms |
usleep (200000); |
# Alte WP-Liste im MK löschen |
my $Wp = $Waypoints[0]; |
&MkFlyTo ( '-lat' => $Wp->{'Pos_Lat'}, |
'-lon' => $Wp->{'Pos_Lon'}, |
'-mode' => "Waypoint Delete" |
); |
for $i (0 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
&MkFlyTo ( '-lat' => $Wp->{'Pos_Lat'}, |
'-lon' => $Wp->{'Pos_Lon'}, |
'-alt' => $Wp->{'Pos_Alt'}, |
'-heading' => $Wp->{'Heading'}, |
'-toleranceradius' => $Wp->{'ToleranceRadius'}, |
'-holdtime' => $Wp->{'Holdtime'}, |
'-eventflag' => $Wp->{'Event_Flag'}, |
'-mode' => "Waypoint" |
); |
usleep (150000) # NC Zeit zum Verarbeiten geben |
} |
$MkSendWp = 0; # normale OSD/Debug Abfragefrequenz wird automatisch im 5s Timer wieder eingestellt |
# gray connectors: Wp are sent to MK |
$map_canvas->itemconfigure('Waypoint-Connector', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorWpConnector'}, |
); |
# MK ist nun synchron mit @Waypoints |
$WaypointsModified = 0; |
} |
# Redraw Waypoint Icons |
sub WpRedrawIcons() |
{ |
if ( $PlayerWptKmlMode =~ /WPT/i ) |
{ |
# delete old icons and Wp-Number from canvas |
$map_canvas->delete('Waypoint'); |
$map_canvas->delete('WaypointNumber'); |
# create new icons |
for $i (0 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
my $x = $Wp->{'MapX'}; |
my $y = $Wp->{'MapY'}; |
my $Tag = $Wp->{'Tag'}; |
# Waypoint Icon |
my $IconHeight = 48; |
my $IconWidth = 48; |
$map_canvas->createImage($x-$IconWidth/2, $y-$IconHeight, |
'-tags' => ['Waypoint', $Tag], |
'-anchor' => 'nw', |
'-image' => 'Waypoint-Photo', |
); |
# Waypoint Number |
my $WpNumber = $i + 1; |
$map_canvas->createText ( $x+3, $y-$IconHeight/2+12, |
'-tags' => ['WaypointNumber', $Tag], |
'-text' => $WpNumber, |
'-font' => '-*-Arial-Bold-R-Normal--*-100-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorWpNumber'}, |
'-anchor' => 'w', |
); |
} |
$map_canvas->lower('Waypoint', 'Fox'); # waypoint below Fox |
$map_canvas->lower('WaypointNumber', 'Waypoint'); # waypoint-number below waypoint |
} |
} |
# Redraw Waypoint connectors |
sub WpRedrawLines() |
{ |
if ( $PlayerWptKmlMode =~ /WPT/i ) |
{ |
# delete old connectors from canvas |
$map_canvas->delete('Waypoint-Connector'); |
my $Color = $Cfg->{'mkcockpit'}->{'ColorWpConnector'}; |
if ( $WaypointsModified ) |
{ |
$Color = $Cfg->{'mkcockpit'}->{'ColorWpResend'}; |
} |
my $Wp = $Waypoints[0]; |
my $x_last = $Wp->{'MapX'}; |
my $y_last = $Wp->{'MapY'}; |
for $i (1 .. $#Waypoints) |
{ |
my $Wp = $Waypoints[$i]; |
my $x = $Wp->{'MapX'}; |
my $y = $Wp->{'MapY'}; |
$map_canvas->createLine ( $x_last, $y_last, $x, $y, |
'-tags' => 'Waypoint-Connector', |
'-arrow' => 'last', |
'-arrowshape' => [10, 10, 3 ], |
'-fill' => $Color, |
'-width' => 1, |
); |
$x_last = $x; |
$y_last = $y; |
} |
$map_canvas->lower('Waypoint-Connector', 'Waypoint'); # connector below waypoint |
} |
} |
# Hide Waypoints and connectors on Canvas |
sub WpHide() |
{ |
$map_canvas->delete('Waypoint'); |
$map_canvas->delete('WaypointNumber'); |
$map_canvas->delete('Waypoint-Connector'); |
} |
# Hide Kml-Track on Canvas |
sub KmlHide() |
{ |
$map_canvas->delete('KML-Track'); |
} |
# Load @KmlTargets from file |
sub KmlLoadFile() |
{ |
my ($File) = @_; |
# XML in Hash-Ref lesen |
my $Kml = XMLin($File); |
# init state maschine |
undef @KmlTargets; |
$KmlPlayerIndex = 0; |
my $Coordinates = $Kml->{Document}->{Placemark}->{LineString}->{coordinates}; |
foreach $Line (split "\n", $Coordinates) |
{ |
chomp $Line; |
$Line =~ s/\s//g; # remove white space |
if ( $Line ne "" ) |
{ |
my ($Lon, $Lat, $Alt) = split ",", $Line; |
$Lon = sprintf ("%f", $Lon); |
$Lat = sprintf ("%f", $Lat); |
$Alt = sprintf ("%f", $Alt); |
push @KmlTargets, {'Lat' => $Lat, |
'Lon' => $Lon, |
'Alt' => $Alt, |
}; |
} |
} |
} |
# Redraw KML track |
sub KmlRedraw() |
{ |
# delete old Track from canvas |
$map_canvas->delete('KML-Track'); |
my @Track; |
foreach $Target ( @KmlTargets ) |
{ |
my $Lat = $Target->{'Lat'}; |
my $Lon = $Target->{'Lon'}; |
my $Alt = $Target->{'Alt'}; |
my ($x, $y) = &MapGps2XY($Lat, $Lon); |
push @Track, $x, $y; |
} |
if ( scalar @Track >= 4 ) # at least 2 Koordinaten-Paare |
{ |
$map_canvas->createLine ( @Track, |
'-tags' => 'KML-Track', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorKmlTrack'}, |
'-width' => 1, |
); |
$map_canvas->lower('KML-Track', 'Target'); # Track below Target |
} |
} |
# Redraw Footprint |
sub FootprintRedraw() |
{ |
# delete old Footprint from canvas |
$map_canvas->delete('Footprint'); |
if ( scalar @Footprint >= 4 ) # at least 2 Koordinaten-Paare |
{ |
$map_canvas->createLine ( @Footprint, |
'-tags' => 'Footprint', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorFootprint'}, |
'-width' => 1, |
); |
} |
$map_canvas->lower('Footprint', 'Fox'); |
} |
# Waypoint Player: Set Waypoint - sequence or random |
sub WpTargetSet() |
{ |
my ($Index) = @_; |
my $WpCnt = scalar @Waypoints; |
if ( $Index < 0 or $Index >= $WpCnt ) |
{ |
# invalid WP number |
return 1; |
} |
my $Wp = $Waypoints[$Index]; |
my $Wp_x = $Wp->{'MapX'}; |
my $Wp_y = $Wp->{'MapY'}; |
# is Wp reachable? |
if ( ! &IsTargetReachable($Wp_x, $Wp_y) ) |
{ |
# new Wp-Target is not reachable |
return 1; |
} |
# set new Wp-Target |
$WpPlayerIndex = $Index; |
$WpPlayerHoldtime = -1; |
return 0; |
} |
# Waypoint Player: Goto next Waypoint - sequence or random |
sub WpTargetNext() |
{ |
my ($ParIndex) = @_; |
my $WpCnt = scalar @Waypoints; |
# Std- or Random Waypoint sequence |
if ( $PlayerRandomMode =~ /STD/i or |
$PlayerRandomMode =~ /RND/i ) |
{ |
$NewIndex = $WpPlayerIndex; |
# get next Wp |
for ( $i=0; $i<5; $i++) # avoid deadlock, if no WP reachable |
{ |
for ( $j=0; $j<5; $j++ ) # avoid deadlock, if only 1 WP |
{ |
if ( $PlayerRandomMode =~ /STD/i ) |
{ |
$NewIndex ++; |
if ( $NewIndex >= $WpCnt ) |
{ |
# Restart with 1st Wp |
$NewIndex = 0; |
} |
} |
if ( $PlayerRandomMode =~ /RND/i ) |
{ |
$NewIndex = int (rand($WpCnt)); |
} |
# want to have different Wp |
if ( $NewIndex ne $WpPlayerIndex ) |
{ |
last; |
} |
} |
# Set new Target |
if ( &WpTargetSet ($NewIndex) == 0 ) |
{ |
# new Wp-Target set |
last; |
} |
} |
} |
# Random Map sequence |
if ( $PlayerRandomMode =~ /MAP/i ) |
{ |
$RandomTarget_x = $MkPos_x; |
$RandomTarget_y = $MkPos_y; |
for ( $i=0; $i<50; $i++) # avoid deadlock, if target not reachable |
{ |
# don't use 10% around the map |
my $New_x = int (rand($MapSizeX - 2 * $MapSizeX/10)); |
my $New_y = int (rand($MapSizeY - 2 * $MapSizeY/10)); |
$New_x += $MapSizeX/10; |
$New_y += $MapSizeY/10; |
# is Target reachable? |
if ( &IsTargetReachable($New_x, $New_y) ) |
{ |
# new Target found |
$RandomTarget_x = $New_x; |
$RandomTarget_y = $New_y; |
last; |
} |
} |
} |
&TtsSpeak ('MEDIUM', $Translate{'TtsNextTarget'}); |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Goto previous Waypoint |
sub WpTargetPrev() |
{ |
if ( $PlayerRandomMode =~ /STD/i ) |
{ |
$WpPlayerIndex --; |
if ( $WpPlayerIndex < 0 ) |
{ |
# Restart with last Wp |
$WpPlayerIndex = $#Waypoints; |
} |
} |
else |
{ |
# Next Random Target |
&WpTargetNext(); |
} |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Goto first Waypoint |
sub WpTargetFirst() |
{ |
$WpPlayerIndex = 0; |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Goto last Waypoint |
sub WpTargetLast() |
{ |
$WpPlayerIndex = $#Waypoints; |
$WpPlayerHoldtime = -1; |
} |
# Waypoint Player: Waypoint Target reached? |
sub WpCheckTargetReached() |
{ |
if ( $WpPlayerHoldtime == -1 ) |
{ |
lock (%MkOsd); # until end of block |
if ( &CurPosIsValid() and &HomePosIsValid() and &MkIsWptMode() ) |
{ |
# Gueltige SAT Daten |
# for Wp mode |
my $Wp = $Waypoints[$WpPlayerIndex]; |
my $WpTarget_Lat = $Wp->{'Pos_Lat'}; |
my $WpTarget_Lon = $Wp->{'Pos_Lon'}; |
my $WpTolerance = $Wp->{'ToleranceRadius'}; |
my $WpHoldtime = $Wp->{'Holdtime'}; |
# Random-Map Mode |
if ( $PlayerRandomMode =~ /MAP/i ) |
{ |
($WpTarget_Lat, $WpTarget_Lon) = &MapXY2Gps ($RandomTarget_x, $RandomTarget_y); |
$WpTolerance = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; |
$WpHoldtime = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; |
} |
# Operation Radius pruefen |
my ($HomeDist, $HomeBearing) = &MapGpsTo($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, $WpTarget_Lat, $WpTarget_Lon ); |
if ( $HomeDist > $MkOsd{'OperatingRadius'} ) |
{ |
# Target entsprechend Operation Radius neu berechnen |
$HomeDist = $MkOsd{'OperatingRadius'}; |
($WpTarget_Lat, $WpTarget_Lon) = &MapGpsAt($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}, $HomeDist, $HomeBearing); |
} |
# Abstand zum Ziel pruefen |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, $WpTarget_Lat, $WpTarget_Lon ); |
$Dist = int ($Dist + 0.5); |
if ( $Dist <= $WpTolerance ) |
{ |
# Target reached - count down Holdtime |
$WpPlayerHoldtime = 2 * $WpHoldtime; # 0..2n - decrement im 0.5s timer |
&TtsSpeak ('MEDIUM', $Translate{'TtsTargetReached'}); |
} |
} |
} |
if ( $WpPlayerHoldtime == 0 ) # wird im 0.5s timer runtergezaehlt |
{ |
# Target reached - Holdtime is over |
$WpPlayerHoldtime = -1; |
return 1; |
} |
# Target NOT reached |
return 0; |
} |
# KML Player: 10s forward |
sub KmlTargetNext() |
{ |
$KmlPlayerIndex += int (10 / $Cfg->{waypoint}->{'KmlTimeBase'} + 0.5); |
if ( $KmlPlayerIndex > $#KmlTargets ) |
{ |
# Next loop |
$KmlPlayerIndex -= $#KmlTargets; |
} |
} |
# KML Player: 10s backward |
sub KmlTargetPrev() |
{ |
$KmlPlayerIndex -= int (10 / $Cfg->{waypoint}->{'KmlTimeBase'} + 0.5); |
if ( $KmlPlayerIndex < 0 ) |
{ |
# Next loop |
$KmlPlayerIndex += $#KmlTargets; |
} |
} |
# KML Player: Goto first Target |
sub KmlTargetFirst() |
{ |
$KmlPlayerIndex = 0; |
} |
# KML Player: Goto last Target |
sub KmlTargetLast() |
{ |
$KmlPlayerIndex = $#KmlTargets; |
} |
# |
# Set Player modes |
# |
# set player to "Play" mode |
sub PlayerPlay() |
{ |
$PlayerMode = 'Play'; |
$WpPlayerHoldtime = -1; |
# Play/Pause-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPause-Foto', |
); |
} |
# set player to "Pause" mode |
sub PlayerPause() |
{ |
$PlayerMode = 'Pause'; |
$WpPlayerHoldtime = -1; |
# Play/Pause-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPlay-Foto', |
); |
# momentane Position merken und im Player-Timer senden |
$PlayerPause_Lon = ""; |
$PlayerPause_Lat = ""; |
lock (%MkOsd); # until end of block |
if ( &MkOsdIsValid() ) |
{ |
# Gueltige OSD Daten |
if ( $MkOsd{'SatsInUse'} >= 6 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
$PlayerPause_Lon = $MkOsd{'CurPos_Lon'}; |
$PlayerPause_Lat = $MkOsd{'CurPos_Lat'}; |
} |
} |
} |
# set player to "Home" mode |
sub PlayerHome() |
{ |
$PlayerMode = 'Home'; |
&WpTargetFirst(); |
# Play/Pause-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPlay-Foto', |
); |
} |
# set player to "Stop" mode |
sub PlayerStop() |
{ |
$PlayerMode = 'Stop'; |
&WpTargetFirst(); |
# set Play/Pause Icon to "Play |
$map_canvas->delete('Wp-PlayPause'); |
$map_canvas->createImage($MapSizeX/2+150, $MapSizeY-48, |
'-tags' => 'Wp-PlayPause', |
'-anchor' => 'nw', |
'-image' => 'WpPlay-Foto', |
); |
# switch player to Wp Mode |
&PlayerWpt(); |
} |
# set player Random Mode to "STD" |
sub PlayerRandomStd() |
{ |
$PlayerRandomMode = "STD"; |
# Set Icon |
$map_canvas->delete('Wp-WptRandom'); |
$map_canvas->createImage($MapSizeX/2-200, $MapSizeY-48, |
'-tags' => 'Wp-WptRandom', |
'-anchor' => 'nw', |
'-image' => 'WpRandomOn-Foto', |
); |
# redraw connectors and Icons on canvas |
&WpRedrawLines(); |
&WpRedrawIcons(); |
} |
# set player Random Mode to "RND" |
sub PlayerRandomRnd() |
{ |
$PlayerRandomMode = "RND"; |
# Set Icon |
$map_canvas->delete('Wp-WptRandom'); |
$map_canvas->createImage($MapSizeX/2-200, $MapSizeY-48, |
'-tags' => 'Wp-WptRandom', |
'-anchor' => 'nw', |
'-image' => 'WpRandomMap-Foto', |
); |
# delete Wp-connectors from canvas |
$map_canvas->delete('Waypoint-Connector'); |
} |
# set player Random Mode to "MAP" |
sub PlayerRandomMap() |
{ |
$PlayerRandomMode = "MAP"; |
# Set Icon |
$map_canvas->delete('Wp-WptRandom'); |
$map_canvas->createImage($MapSizeX/2-200, $MapSizeY-48, |
'-tags' => 'Wp-WptRandom', |
'-anchor' => 'nw', |
'-image' => 'WpRandomOff-Foto', |
); |
# Get 1st Target |
&WpTargetNext(); |
# hide WP and connectors on canvas |
&WpHide(); |
} |
# set player to KML mode |
sub PlayerKml() |
{ |
$PlayerWptKmlMode = 'KML'; |
# Wpt/Kml-Player-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-WptKml'); |
$map_canvas->createImage($MapSizeX/2-250, $MapSizeY-48, |
'-tags' => 'Wp-WptKml', |
'-anchor' => 'nw', |
'-image' => 'WpKml-Foto', |
); |
# delete Waypoints from canvas |
&WpHide(); |
# show KML Track |
&KmlRedraw(); |
} |
# set player to WPT mode |
sub PlayerWpt() |
{ |
$PlayerWptKmlMode = 'WPT'; |
# Wpt/Kml-Player-Icon loeschen und neu anzeigen |
$map_canvas->delete('Wp-WptKml'); |
$map_canvas->createImage($MapSizeX/2-250, $MapSizeY-48, |
'-tags' => 'Wp-WptKml', |
'-anchor' => 'nw', |
'-image' => 'WpWpt-Foto', |
); |
# delete Kml-Track from canvas |
&KmlHide(); |
# Show waypoints, WP resend required |
$WaypointsModified = 1; |
if ( $PlayerRandomMode ne 'MAP' ) |
{ |
&WpRedrawIcons() |
} |
if ( $PlayerRandomMode eq 'STD' ) |
{ |
&WpRedrawLines() |
} |
} |
# Activate Recording mode |
sub PlayerRecordOn |
{ |
$PlayerRecordMode = "REC"; |
$map_canvas->itemconfigure ('MK-OSD-Rec-Value', '-text' => "Recording" ); |
# Record new KML-Track |
undef @KmlTargets; |
$KmlPlayerIndex = 0; |
# delete Kml-Track from canvas |
&KmlHide(); |
} |
# Deactivate Recording mode |
sub PlayerRecordOff |
{ |
$PlayerRecordMode = ""; |
$map_canvas->itemconfigure ('MK-OSD-Rec-Value', '-text' => "" ); |
} |
# |
# System Messages |
# |
# Init Messages for a Subsystem/timer |
sub MkMessageInit () |
{ |
my ($Id) = @_; |
$MkMessages{$Id} = []; |
} |
# Register message |
sub MkMessage () |
{ |
my ($Message, $Id) = @_; |
push @{$MkMessages{$Id}}, $Message; |
} |
# show registered messages |
sub MkMessageShow() |
{ |
my @Messages; |
my $MsgLines = 0; |
my $MaxMsgLen = 0; |
# Collect Messages of each category |
foreach my $Id (keys %MkMessages) |
{ |
foreach $i ( 0 .. $#{$MkMessages{$Id}} ) |
{ |
my $Msg = $MkMessages{$Id}[$i]; |
push @Messages, $Msg; |
$MsgLines ++; |
my $Len = length $Msg; |
if ( $Len > $MaxMsgLen ) |
{ |
$MaxMsgLen = $Len; |
} |
} |
} |
$map_canvas->delete('Message-Balloon'); # delete old Balloon |
if ( $MsgLines > 0 ) |
{ |
# draw Balloon |
my @MsgBalloon = ( $MkPos_x , $MkPos_y, |
$MkPos_x + 30 , $MkPos_y + 40, |
$MkPos_x + 30 + $MaxMsgLen * 11, $MkPos_y + 40, |
$MkPos_x + 30 + $MaxMsgLen * 11, $MkPos_y + 44 + $MsgLines * 20, |
$MkPos_x + 20, $MkPos_y + 44 + $MsgLines * 20, |
$MkPos_x + 20, $MkPos_y + 40, |
$MkPos_x, $MkPos_y, |
); |
$map_canvas->createPolygon( @MsgBalloon, |
'-tags' => ['Message-Balloon', 'Message-BalloonBubble'], |
'-fill' => 'yellow', |
'-outline' => 'yellow', |
'-width' => 1, |
); |
# draw Messages |
my $MsgLine = 1; |
foreach my $Msg (@Messages) |
{ |
$map_canvas->createText ( $MkPos_x + 25, $MkPos_y + 32 + $MsgLine * 20 , |
'-tags' => ['Message-Balloon', 'Message-BalloonText'], |
'-text' => $Msg, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => 'blue', |
'-anchor' => 'w', |
); |
$MsgLine ++; |
} |
$map_canvas->lower('Message-Balloon', 'MK-Arrow'); |
} |
} |
# Show Balloon, when arproaching Target |
sub TargetMessageShow () |
{ |
$map_canvas->delete('Target-Balloon'); # delete old Balloon |
if ( $OperationMode ne "Free" and $MkOsd{'TargetPos_Stat'} == 1 and $MkOsd{'TargetPosDev_Dist'} /10 < 25 ) |
{ |
my $BalloonLines = 0; |
$ColorBalloon = "blue"; |
my ($T_x, $T_y) = &MapGps2XY($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}); |
my $Wp = $Waypoints[$MkOsd{'WaypointIndex'}]; |
# Holdtime Wp-Player Mode |
if ( $WpPlayerHoldtime >= 0 ) |
{ |
# Holdtime |
$ColorBalloon = 'red'; |
my $HoldTime = sprintf ("%5s %3d s", "HLD:", int ($WpPlayerHoldtime / 2 + 0.5) ); |
$map_canvas->createText ( $T_x + 25, $T_y - 40, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $HoldTime, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Holdtime WPT-Mode |
if ( &MkTargetReached() and $OperationMode eq "WPT" ) |
{ |
# Holdtime from MK |
$ColorBalloon = 'red'; |
my $HoldTime = sprintf ("%5s %3d s", "HLD:", int ($MkOsd{'TargetHoldTime'} + 0.5) ); |
$map_canvas->createText ( $T_x + 25, $T_y - 40, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $HoldTime, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Tolerance Radius Player Mode |
if ( &MkIsWptMode() and $OperationMode eq "Play" and $PlayerWptKmlMode eq "WPT" ) |
{ |
my $WpTolerance = sprintf ("%5s %3d m", "TOL:", $Wp->{'ToleranceRadius'}); |
$map_canvas->createText ( $T_x + 25, $T_y - 60, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $WpTolerance, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Tolerance WPT-Mode |
if ( &MkIsWptMode and $OperationMode eq "WPT" ) |
{ |
my $WpTolerance = sprintf ("%5s %3d m", "TOL:", $Wp->{'ToleranceRadius'} ); |
$map_canvas->createText ( $T_x + 25, $T_y - 60, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => $WpTolerance, |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
} |
# Distance to Target |
my $Dist = int ($MkOsd{'TargetPosDev_Dist'} /10 + 0.5); |
$map_canvas->createText ( $T_x + 25, $T_y - 80, |
'-tags' => ['Target-Balloon', 'Target-BalloonText'], |
'-text' => sprintf ("%5s %3d m", "DST:", $Dist) , |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $ColorBalloon, |
'-anchor' => 'w', |
); |
$BalloonLines ++; |
if ( $BalloonLines >= 1 ) |
{ |
# draw Balloon |
my @TargetBalloon = ( $T_x , $T_y, |
$T_x + 30, $T_y - (3 - $BalloonLines) * 20 -27, |
$T_x + 150, $T_y - (3 - $BalloonLines) * 20 -27 , |
$T_x + 150, $T_y - 93, |
$T_x + 20, $T_y - 93, |
$T_x + 20, $T_y - (3 - $BalloonLines) * 20 -27, |
$T_x, $T_y, |
); |
$map_canvas->createPolygon( @TargetBalloon, |
'-tags' => ['Target-Balloon', 'Target-BalloonBubble'], |
'-fill' => 'lightgray', |
'-outline' => 'yellow', |
'-width' => 1, |
); |
} |
$map_canvas->lower('Target-Balloon', 'MK-Home-Line'); |
$map_canvas->lower('Target-BalloonBubble', 'Target-BalloonText'); |
} |
} |
# |
# Airfield border |
# |
# Are two segments A(a1/a2), B(b1/b2) and C(c1/c2), D(d1/d2) crossing ? |
sub SegmentCross() |
{ |
my ( $a1, $a2, $b1, $b2, $c1, $c2, $d1, $d2) = @_; |
# segment C/D ist vertical, avoid div/0 |
if ( $c1 == $d1 ) |
{ |
$d1 += 0.00001; |
} |
my $n = ($b1 - $a1) * ($d2 - $c2) - ($b2 - $a2) * ($d1 - $c1); |
if ( $n == 0.0 ) |
{ |
# AB und CD sind parallel |
return 0; |
} |
my $s = ( ($c1 - $a1) * ($d2 - $c2) - ($c2 - $a2) * ($d1 - $c1) ) / $n; |
my $t = ( $a1 - $c1 + $s * ($b1 - $a1) ) / ( $d1 - $c1 ); |
if ( $s >= 0.0 and $s <= 1.0 and $t >= 0.0 and $t <= 1.0 ) |
{ |
# beide Strecken kreuzen sich |
# Schnittpunkt: s_x, s_y |
my $s_x = $a1 + $s * ( $b1 - $a1 ); |
my $s_y = $a2 + $s * ( $b2 - $a2 ); |
return 1; |
} |
# beide Strecken kreuzen sich nicht |
return 0; |
} |
# How often does a segment A(a1,a2), B(b1,b2) cross the polygon? |
sub SegmentPolygonCross() |
{ |
my ( $a1, $a2, $b1, $b2, $Polygon) = @_; |
my $Cross = 0; |
my $PolyCnt = scalar @{$Polygon}; |
my $PolyPointCnt = $PolyCnt / 2; |
my $i = 0; |
for ( $p=0; $p < $PolyPointCnt; $p++ ) |
{ |
my $c1 = ${$Polygon}[$i++]; |
my $c2 = ${$Polygon}[$i++]; |
if ( $i >= $PolyCnt ) { $i = 0; } |
my $d1 = ${$Polygon}[$i]; |
my $d2 = ${$Polygon}[$i+1]; |
# map calibration offsets |
$c1 -= $Map{'Offset_x'}; |
$c2 += $Map{'Offset_y'}; |
$d1 -= $Map{'Offset_x'}; |
$d2 += $Map{'Offset_y'}; |
if ( &SegmentCross($a1, $a2, $b1, $b2, $c1, $c2, $d1, $d2) ) |
{ |
$Cross ++; |
} |
} |
return $Cross; |
} |
# Is point A inside airfield border? |
sub IsInsideBorder() |
{ |
my ($a1, $a2) = @_; |
if ( scalar @Map{'Border'} == 0 ) |
{ |
# no border defined, always inside |
return 1; |
} |
my $Cross = &SegmentPolygonCross (-10, -10, $a1, $a2, @Map{'Border'} ); |
# Ungerade Anzahl Kreuzungen: Inside |
return ( $Cross % 2 ); |
} |
# Is segment A, B crossing the airfield border? |
sub IsCrossingBorder() |
{ |
my ($a1, $a2, $b1, $b2) = @_; |
if ( scalar @Map{'Border'} == 0 ) |
{ |
# no border defined, always not crossing |
return 0; |
} |
my $Cross = &SegmentPolygonCross ($a1, $a2, $b1, $b2, @Map{'Border'} ); |
return ( $Cross > 0 ); |
} |
# How often is segment A, B crossing the airfield border? |
sub CrossingBorderCount() |
{ |
my ($a1, $a2, $b1, $b2) = @_; |
if ( scalar @Map{'Border'} == 0 ) |
{ |
# no border defined, not crossing |
return 0; |
} |
my $Cross = &SegmentPolygonCross ($a1, $a2, $b1, $b2, @Map{'Border'} ); |
return ( $Cross ); |
} |
# check, if Target is reachable my MK |
sub IsTargetReachable() |
{ |
my ($T_x, $T_y) = @_; |
my $MkIsInside = &IsInsideBorder($MkPos_x, $MkPos_y); |
my $TargetIsInside = &IsInsideBorder($T_x, $T_y); |
my $MkTargetCrossingCount = &CrossingBorderCount($MkPos_x, $MkPos_y, $T_x, $T_y); |
if ( ($MkIsInside and $MkTargetCrossingCount == 0 ) or |
(! $MkIsInside and $TargetIsInside and $MkTargetCrossingCount == 1) ) |
{ |
# Target is reachable |
return 1; |
} |
# Target is not reachable |
return 0; |
} |
# |
# Configuration and data-visualisation |
# |
# Display or Modify Hash |
sub DisplayHash() |
{ |
my ($hrefData, $Titel, $Mode) = @_; |
# $Mode: Display, Edit, Waypoint, Refresh |
my %Id; |
my $Label; |
my $Value; |
# Neues Fenster aufmachen |
my $popup = $main->Toplevel(); |
$popup->title($Titel); |
# Buttons |
my $popup_button = $popup->Frame() -> pack('-side' => 'bottom', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$popup_button->Button('-text' => 'Schließen', |
'-command' => sub |
{ |
if ( $Mode =~ /edit/i and $Mode =~ /waypoint/i ) |
{ |
$WaypointsModified = 1; |
&WpRedrawLines(); |
&WpRedrawIcons(); |
} |
$popup->destroy() |
})->pack; |
# Frame mit den Labels |
my $popup_label = $popup->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Labels anzeigen |
foreach $Label ( sort keys %{$hrefData}) |
{ |
if ( $Translate{$Label} ne "" ) |
{ |
$Label = $Translate{$Label}; |
} |
$popup_label->Label ('-text' => $Label, |
'-width' => 25, |
'-anchor' => 'w', |
) -> pack(); |
} |
# Frame mit den Daten |
my $popup_values = $popup->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Daten anzeigen |
foreach $Value ( sort keys %{$hrefData}) |
{ |
if ( $Mode =~ /display/i ) |
{ |
# Display |
$Id{$Value} = $popup_values->Label ('-text' => ${$hrefData}{$Value}, |
'-width' => 20, |
'-anchor' => 'e', |
'-relief' => 'sunken', |
) -> pack(); |
} |
if ( $Mode =~ /edit/i ) |
{ |
# Edit |
$Id{$Value} = $popup_values->Entry ('-textvariable' => \${$hrefData}{$Value}, |
'-exportselection' => '1', |
'-width' => 20, |
'-relief' => 'sunken', |
) -> pack(); |
if ( $Mode =~ /waypoint/i ) |
{ |
# einige Waypoint-Felder nicht aenderbar einstellen |
if ( "MapX MapY Pos_Lat Pos_Lon Tag" =~ /$Value/i ) |
{ |
$Id{$Value}->configure('-state' => 'disabled', ); |
} |
} |
} |
} |
if ( $Mode =~ /refresh/i ) |
{ |
# Timer: 0.1s |
$popup_values->repeat (100, sub |
{ |
# Datenfelder alle 100ms aktualisieren |
my $BgColor = 'white'; |
if ( $Mode =~ /heartbeat/i ) |
{ |
$BgColor = 'red'; |
if ( &MkOsdIsValid() ) |
{ |
# gültige daten vom MK |
$BgColor = 'white'; |
} |
} |
foreach $Value ( sort keys %{$hrefData} ) |
{ |
# Eingebbare Waypoint-Felder nicht aktualisieren |
if ( ! ($Mode =~ /waypoint/i and |
"Event_Flag Heading ToleranceRadius HoldTime Pos_Alt" =~ /$Value/i) ) |
{ |
$Id{$Value}->configure('-text' => ${$hrefData}{$Value}, |
'-background' => "$BgColor", |
); |
} |
} |
}); |
} |
return 0; |
} |
# Konfigurationsdatei mkcockpit.xml im Popup-Fenster editieren |
sub Configure() |
{ |
# Copy Cfg-Hash for editing |
my $CfgEdit = {%{$Cfg}}; |
foreach $key (keys %{$Cfg}) |
{ |
if ( ref $Cfg->{$key} ) |
{ |
$CfgEdit->{$key} = {%{$Cfg->{$key}}}; |
} |
} |
# Neues Fenster aufmachen |
my $popup = $main->Toplevel(); |
$popup->title("Einstellungen - $XmlConfigFile"); |
# jede Sektion in einem Tab anzeigen |
my $book = $popup->NoteBook()->pack( -fill=>'both', -expand=>1 ); |
foreach $key (sort keys %{$CfgEdit}) |
{ |
if ( ! ref $CfgEdit->{$key} ) |
{ |
next; |
} |
my $TabLabel = "$key"; |
if ( $Translate{$key} ne "" ) |
{ |
$TabLabel = $Translate{$key}; |
} |
my $Tab = $book->add( "$key", -label=>"$TabLabel", ); |
# Frame fuer Buttons |
my $book_button = $Tab->Frame() -> pack('-side' => 'bottom', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$book_button->Button('-text' => 'OK', |
'-width' => '10', |
'-command' => sub |
{ |
# Copy back CfgEdit-Hash |
$Cfg = {%{$CfgEdit}}; |
foreach $key (keys %{$CfgEdit}) |
{ |
if ( ref $CfgEdit->{$key} ) |
{ |
$Cfg->{$key} = {%{$CfgEdit->{$key}}}; |
} |
} |
# set new timestamp |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
$Cfg->{'CreationDate'} = $TimeStamp; |
# Cfg in mkcockpit.xml speichern |
&XMLout ($Cfg, |
'OutputFile' => $XmlConfigFile, |
'AttrIndent' => '1', |
'RootName' => 'mkcockpit-Config', |
); |
$popup->destroy(); |
} )->pack ('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$book_button->Button('-text' => $Translate{'Abort'}, |
'-width' => '10', |
'-command' => sub { $popup->destroy() }, |
)->pack ('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 5, |
'-pady' => 5, |
); |
$book_button->Label ('-text' => $Translate{'RestartRequired'}, |
'-anchor' => 'w', |
'-foreground' => 'red', |
) ->pack ('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 's', |
'-padx' => 10, |
'-pady' => 5, |
); |
# Frame mit den Labels |
my $popup_label = $Tab->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Labels anzeigen |
foreach $Label ( sort keys %{$CfgEdit->{$key}}) |
{ |
if ( $Translate{$Label} ne "" ) |
{ |
$Label = $Translate{$Label}; |
} |
$popup_label->Label ('-text' => $Label, |
'-width' => 35, |
'-anchor' => 'w', |
) -> pack(); |
} |
# Frame mit den Daten |
my $popup_values = $Tab->Frame() -> pack('-side' => 'left', |
'-expand' => 'y', |
'-anchor' => 'w', |
'-padx' => 10, |
'-pady' => 10, |
); |
# Eingabefelder mit Daten anzeigen |
foreach $Value ( sort keys %{$CfgEdit->{$key}}) |
{ |
$popup_values->Entry ('-textvariable' => \$CfgEdit->{$key}->{$Value}, |
'-exportselection' => '1', |
'-width' => 30, |
'-relief' => 'sunken', |
) -> pack(); |
} |
} |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/libmktimer.pl |
---|
0,0 → 1,782 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# libmktime.pl - MK Mission Cockpit - Timer for GUI Frontend |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-08-09 0.2.5 rw Timer moved from mkcockpit.pl |
# Optional Player home-pos in map configuration |
# |
############################################################################### |
$Version{'libmktimer.pl'} = "0.2.5 - 2009-08-09"; |
use Math::Trig; |
# |
# Timer: 5s |
# |
$main->repeat (5000, sub |
{ |
if ( ! $MkSendWp ) |
{ |
# Abfragefrequenz OSD und Debug regelmäßig neu einstellen, falls Übertragungsfehler |
$MkSendQueue->enqueue( "o", "$AddrNC", pack ("C", 10) ); # Frequenz OSD Datensatz, * 10ms |
$MkSendQueue->enqueue( "d", "$AddrNC", pack ("C", 10) ); # Frequenz MK Debug Datensatz, * 10ms |
$MkSendQueue->enqueue( "v", "$AddrNC", ""); # Version |
$MkSendQueue->enqueue( "e", "$AddrNC", ""); # Error Text Request |
} |
}); |
# |
# Timer: 0.1s - Map Overlay aktualisieren |
# |
$frame_map_top->repeat (100, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-MapOverlay"); |
lock (%MkOsd); # until end of block |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
if ( &MkOsdIsValid() ) |
{ |
# Gueltige OSD Daten |
# Operation Mode |
$OperationMode = ""; |
if ( &MkIsWptMode() ) { $OperationMode = "WPT"; } |
if ( $PlayerMode eq "Play" ) { $OperationMode = "Play"; } |
if ( $PlayerMode eq "Pause" ) { $OperationMode = "Paus"; } |
if ( $PlayerMode eq "Home" ) { $OperationMode = "Home"; } |
if ( &MkIsPhMode() ) { $OperationMode = "PH"; } |
if ( &MkIsFreeMode() ) { $OperationMode = "Free"; } |
my $SatsInUse = $MkOsd{'SatsInUse'}; |
if ( $SatsInUse > 0 and &CurPosIsValid() and &HomePosIsValid() ) |
{ |
# ausreichender GPS Empfang |
# get x,y map coords of current position |
my ($C_x, $C_y, $C_Angel) = &MapGps2XY($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, $MkOsd{'CompassHeading'}); |
$MkPos_x = $C_x; |
$MkPos_y = $C_y; |
# rotate MK arrow |
my $dy = sin (deg2rad $C_Angel) * ($MapMkLen/2); |
my $dx = cos (deg2rad $C_Angel) * ($MapMkLen/2); |
my $x0 = $C_x - $dx; |
my $y0 = $C_y - $dy; |
my $x1 = $C_x + $dx; |
my $y1 = $C_y + $dy; |
$map_canvas->coords ('MK-Arrow', $x0, $y0, $x1, $y1); |
# Update speed vector |
my $MapAngel = &MapAngel(); # North to Map-Horizont |
my $GpsSpeedNorth = $MkNcDebug{'Analog_21'}; |
my $GpsSpeedEast = $MkNcDebug{'Analog_22'}; |
my $PhiGpsSpeed = rad2deg atan2 ( $GpsSpeedEast, $GpsSpeedNorth ); |
$PhiMapSpeed = $PhiGpsSpeed - $MapAngel; |
# 555 cm/s ~ 20 km/h -> Zeigerlänge = $MkSpeedLen bei 20 km/h |
my $dy = sin (deg2rad $PhiMapSpeed) * $MapMkSpeedLen * $MkOsd{'GroundSpeed'} / 555; |
my $dx = cos (deg2rad $PhiMapSpeed) * $MapMkSpeedLen * $MkOsd{'GroundSpeed'} / 555; |
my $x0 = $C_x; |
my $y0 = $C_y; |
my $x1 = $C_x + $dx; |
my $y1 = $C_y + $dy; |
$map_canvas->coords ('MK-Speed', $x0, $y0, $x1, $y1); |
# Update Line between Home and MK |
my ($H_x, $H_y) = &MapGps2XY($MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'}); |
$map_canvas->coords ('MK-Home-Line', $H_x, $H_y, $C_x, $C_y); |
# Update Distance between Home and MK |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$MkOsd{'HomePos_Lat'}, $MkOsd{'HomePos_Lon'} ); |
my $x = ($C_x - $H_x) / 2 + $H_x + 8; |
my $y = ($C_y - $H_y) / 2 + $H_y + 8; |
$map_canvas->coords ('MK-Home-Dist', $x, $y); |
$map_canvas->itemconfigure ('MK-Home-Dist', |
'-text' => sprintf ("%4d m", int ($Dist + 0.5) ), |
); |
# Update OSD - Sat dependent values |
$map_canvas->itemconfigure ('MK-OSD-Spd-Value', '-text' => sprintf ("%3d km/h", $MkOsd{'GroundSpeed'} * 0.036) ); |
# Alt = average Luftdruck und Sat |
my $Alt = int ( ($MkOsd{'Altimeter'} / $Cfg->{'mkcockpit'}->{'AltFactor'} + |
$MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'} ) / 2 + 0.5 ); |
$System{'Alt'} = $Alt; |
$map_canvas->itemconfigure ('MK-OSD-Alt-Value', '-text' => sprintf ("%3d m", $Alt) ); |
if ( &TargetIsValid() ) |
{ |
# Valid Target |
# Update Line between Target and MK |
my ($T_x, $T_y) = &MapGps2XY($MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'}); |
$map_canvas->coords ('MK-Target-Line', $C_x, $C_y, $T_x, $T_y); |
# Update Distance between Target and MK |
my ($Dist, $Bearing) = &MapGpsTo($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}, |
$MkOsd{'TargetPos_Lat'}, $MkOsd{'TargetPos_Lon'} ); |
if ( $Dist >= 25 ) |
{ |
my $x = ($C_x - $T_x) / 2 + $T_x - 8; |
my $y = ($C_y - $T_y) / 2 + $T_y + 8; |
$map_canvas->coords ('MK-Target-Dist', $x, $y); |
$map_canvas->itemconfigure ('MK-Target-Dist', |
'-text' => sprintf ("%4d m", int ($Dist + 0.5) ), |
); |
} |
else |
{ |
# Don't show distance < 25m |
$map_canvas->coords ('MK-Target-Dist', 0, -100); |
} |
# show target icon |
my $IconHeight = 48; |
my $IconWidth = 48; |
$map_canvas->coords('Target', $T_x - $IconWidth/2, $T_y - $IconHeight ); |
$System{'CrossingBorder'} = 0; |
if ( &MkIsFlying() and &IsCrossingBorder($MkPos_x, $MkPos_y, $T_x, $T_y) ) |
{ |
# only, if MK is flying |
$System{'CrossingBorder'} = 1; |
&MkMessage ($Translate{'MsgCrossingBorder'}, "Timer-MapOverlay"); |
} |
} |
else |
{ |
# No valid Target, move target line out of sight/canvas |
$map_canvas->coords ('MK-Target-Line', 0, -100, 0, -100); |
$map_canvas->coords ('MK-Target-Dist', 0, -100); |
# hide target icon |
$map_canvas->coords('Target', 0, -100, ); |
} |
} |
else |
{ |
# kein ausreichender Sat-Empfang |
$map_canvas->itemconfigure ('MK-OSD-Spd-Value', '-text' => sprintf ("%3d km/h", 0 ) ); |
} |
# Update OSD - non Sat dependent values |
$map_canvas->itemconfigure ('MK-OSD-Odo-Value', '-text' => sprintf ("%3.3f km", $OdoMeter / 1000) ); |
$map_canvas->itemconfigure ('MK-OSD-Tim-Value', '-text' => sprintf ("%02d:%02d", $MkFlyingTime / 60, $MkFlyingTime % 60) ); |
$map_canvas->itemconfigure ('MK-OSD-Sat-Value', '-text' => $MkOsd{'SatsInUse'} ); |
# battery - OSD and warning |
my $UBat = sprintf ("%3.1f", $MkOsd{'UBat'}); |
$System{'UBat'} = $UBat; |
$map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-text' => "$UBat V" ); |
$System{'BatWarning'} = 0; |
$map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'}); |
if ( $MkOsd{'UBat'} < $Cfg->{'mkcockpit'}->{'UBatWarning'} ) |
{ |
if ( time %2 ) |
{ |
$map_canvas->itemconfigure ('MK-OSD-Bat-Value', '-fill' => 'red'); |
} |
&MkMessage ($Translate{'MsgBatWarning'}, "Timer-MapOverlay"); |
$System{'BatWarning'} = 1; |
} |
# Display Operation Mode |
my $DisplayMode = $OperationMode; |
if ( &MkIsWptMode() and $OperationMode eq "Play" ) |
{ |
my %ModeMatrix = |
( |
"KML-STD" => "Play KML", |
"KML-RND" => "Play KML", |
"KML-MAP" => "Play KML", |
"WPT-STD" => "Play WPT", |
"WPT-RND" => "Rand WPT", |
"WPT-MAP" => "Rand MAP", |
); |
my $Key = "${PlayerWptKmlMode}-${PlayerRandomMode}"; |
$DisplayMode = $ModeMatrix{$Key}; |
} |
$System{'RangeWarning'} = 0; |
if ( &MkRangeLimit() ) |
{ |
$DisplayMode = "$DisplayMode" . " !!"; # Range Warning |
$System{'RangeWarning'} = 1; |
} |
$map_canvas->itemconfigure ('MK-OSD-Mode-Value', '-text' => $DisplayMode ); |
# Waypoints abhaengig vom Modus NC/Player |
my $WpValue = "-- / --"; |
if ( $MkOsd{'WaypointNumber'} > 0) |
{ |
$WpValue = sprintf ("%d / %d", $MkOsd{'WaypointIndex'} + 1, $MkOsd{'WaypointNumber'}); |
} |
if ($PlayerMode ne "Stop" and $PlayerWptKmlMode eq "WPT") |
{ |
$WpValue = sprintf ("%d / %d", $WpPlayerIndex +1, scalar @Waypoints); |
} |
if ($PlayerMode ne "Stop" and $PlayerWptKmlMode eq "KML" ) |
{ |
my $KmlTimeBase = $Cfg->{'waypoint'}->{'KmlTimeBase'} || 1.0; |
my $CurrTime = int ($KmlPlayerIndex * $KmlTimeBase + 0.5); |
my $TotTime = int (scalar @KmlTargets * $KmlTimeBase + 0.5); |
$WpValue = sprintf ("%02d:%02d / %02d:%02d", $CurrTime / 60, $CurrTime % 60, $TotTime / 60, $TotTime % 60); |
} |
$map_canvas->itemconfigure ('MK-OSD-Wp-Value', '-text' => "$WpValue"); |
# Recording Mode |
my $RecordText = ""; |
if ( $PlayerRecordMode =~ /REC/i ) |
{ |
my $KmlTimeBase = $Cfg->{'waypoint'}->{'KmlTimeBase'} || 1.0; |
my $TotTime = int (scalar @KmlTargets * $KmlTimeBase + 0.5); |
$RecordText = sprintf ("Recording %02d:%02d", $TotTime / 60, $TotTime % 60); |
} |
$map_canvas->itemconfigure ('MK-OSD-Rec-Value', '-text' => $RecordText ); |
# Farbe MK-Zeiger abhängig vom GPS Empfang |
my $MkCol= $Cfg->{'mkcockpit'}->{'ColorMkSatNo'}; |
if ( $SatsInUse >= 1 ) { $MkCol = $Cfg->{'mkcockpit'}->{'ColorMkSatLow'} ; } |
if ( $SatsInUse >= 6 ) { $MkCol = $Cfg->{'mkcockpit'}->{'ColorMkSatGood'}; } |
$map_canvas->itemconfigure ('MK-Arrow', '-fill' => $MkCol); |
# Show/Hide SatFix Icon |
if ($SatsInUse >= 6 ) |
{ |
$map_canvas->coords('Satellite', $MapSizeX-300, 10, ); |
} |
else |
{ |
# move icon out of sight |
$map_canvas->coords('Satellite', 0, -100, ); |
} |
# Variometer Pointer |
my $dy = -$MkOsd{'Variometer'} * 10; |
$map_canvas->coords('Map-Variometer-Pointer', 5, $MapSizeY/2+$dy, 20, $MapSizeY/2+10+$dy, 20, $MapSizeY/2-10+$dy); |
# |
# System checks |
# |
if ( ! &MkIsMotorOn() ) { &MkMessage ($Translate{'MsgMotorOff'}, "Timer-MapOverlay"); } |
if ( ! &MkIsFlying() ) { &MkMessage ($Translate{'MsgNotFlying'}, "Timer-MapOverlay"); } |
if ( &MkIsCalibrating() ) { &MkMessage ($Translate{'MsgCalibrate'}, "Timer-MapOverlay"); } |
if ( &MkIsMotorStarting() ) { &MkMessage ($Translate{'MsgStart'}, "Timer-MapOverlay") } |
if ( &MkEmergencyLanding() ) { &MkMessage ($Translate{'MsgEmergencyLanding'}, "Timer-MapOverlay"); } |
if ( &MkRangeLimit() ) { &MkMessage ($Translate{'MsgRangeLimit'}, "Timer-MapOverlay"); } |
# RC range check |
my $RcQuality = $MkOsd{'RC_Quality'}; |
$System{'RCQuality'} = ""; |
if ( $RcQuality < 100 ) |
{ |
$System{'RCQuality'} = "NO"; |
&MkMessage ($Translate{'MsgRcError'}, "Timer-MapOverlay"); |
} |
elsif ( $RcQuality < 150 ) |
{ |
$System{'RCQuality'} = "WEAK"; |
&MkMessage ($Translate{'MsgRcWarning'}, "Timer-MapOverlay"); |
} |
# Sat reception quality |
if ( $SatsInUse == 0 ) |
{ |
&MkMessage ($Translate{'MsgNoSatReception'}, "Timer-MapOverlay"); |
} |
elsif ( $SatsInUse > 0 and $SatsInUse < 6 ) |
{ |
&MkMessage ($Translate{'MsgWeakSatReception'}, "Timer-MapOverlay"); |
} |
# MK Border check |
$System{'OutsideBorder'} = "0"; |
if ( &MkIsFlying() and ! &IsInsideBorder($MkPos_x, $MkPos_y) ) |
{ |
# only, if MK is flying |
$System{'OutsideBorder'} = "1"; |
&MkMessage ($Translate{'MsgOutsideBorder'}, "Timer-MapOverlay"); |
} |
# Show Balloon, when aproaching Target |
&TargetMessageShow(); |
} |
else |
{ |
# keine aktuellen OSD Daten vom MK verfügbar |
&MkMessage ($Translate{'MsgNoData'}, "Timer-MapOverlay"); |
} |
# Wp-Number input from keyboard |
$KbTimer++; |
if ( $CbPlayerKey ne "" ) |
{ |
# Key pressed |
$KbNum = "$KbNum" . "$CbPlayerKey"; |
$CbPlayerKey = ""; |
$KbTimer = 0; |
} |
if ( $KbTimer > 7 and $KbNum ne "" ) |
{ |
# number complete, set target |
my $WpIndex = sprintf ("%d", $KbNum); |
&WpTargetSet ($WpIndex - 1); |
# prepare for next number |
$KbNum = ""; |
} |
# Show System Messages |
&MkMessageShow(); |
}); |
# |
# Timer: 0.1s - Tracking Anzeige aktualisieren |
# |
if ( $Cfg->{'track'}->{'Active'} =~ /y/i ) |
{ |
$frame_map_top->repeat (100, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-Tracking"); |
lock (%MkOsd); # until end of block |
lock (%MkTrack); # until end of block |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
# Zeiger neu zeichnen |
my $ServoPan = @ServoPos[$MkTrack{'ServoPan'}]; |
if ( $ServoPan ne "" ) |
{ |
my $x0 = $TrackSizeX/2; |
my $y0 = $TrackSizeY - 0 - $TrackOffY; |
my $x1 = $TrackSizeX/2 - ($TrackPtrLen-22) * cos( deg2rad $ServoPan); |
my $y1 = $TrackSizeY - ($TrackPtrLen-22) * sin (deg2rad $ServoPan) - $TrackOffY; |
$track_canvas->coords ('Track-Ptr', $x0, $y0, $x1, $y1); |
} |
# Farbe Zeiger abhängig vom GPS Empfang |
my $SatsInUse = $MkOsd{'SatsInUse'}; |
my $TrackPtrCol= 'red'; |
if ( $SatsInUse >= 1 ) { $TrackPtrCol = 'orange'; } |
if ( $SatsInUse >= 6 ) { $TrackPtrCol = 'green'; } |
$track_canvas->itemconfigure ('Track-Ptr', '-fill' => $TrackPtrCol); |
}); |
} |
# |
# Timer: 0.5s - Waypoint Player |
# |
$frame_map_top->repeat (500, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-Player"); |
lock (%MkOsd); # until end of block |
if ( &MkIsWptMode() ) |
{ |
# NC is in WPT Mode |
if ( $PlayerMode eq "Pause" ) |
{ |
if ( $PlayerPause_Lat ne "" and $PlayerPause_Lon ne "" ) |
{ |
# Gespeicherte Pausen-Pos senden |
&MkFlyTo ( '-lat' => $PlayerPause_Lat, |
'-lon' => $PlayerPause_Lon, |
'-holdtime' => "60", |
'-mode' => "Target", |
); |
} |
} |
if ( $PlayerMode eq "Home" and &HomePosIsValid() ) |
{ |
# Gespeicherte oder eingestellte Home-Pos senden |
my $Home_Lat = $Map{'Home_Lat'} || $MkOsd{'HomePos_Lat'}; |
my $Home_Lon = $Map{'Home_Lon'} || $MkOsd{'HomePos_Lon'}; |
&MkFlyTo ( '-lat' => $Home_Lat, |
'-lon' => $Home_Lon, |
'-holdtime' => "60", |
'-mode' => "Target", |
); |
} |
if ( $PlayerWptKmlMode ne 'WPT' ) |
{ |
# not in Wp mode |
return; |
} |
if ( $PlayerMode eq "Play" ) |
{ |
if ( $PlayerRandomMode =~ /RND/i or $PlayerRandomMode =~ /STD/i ) |
{ |
my $WpCnt = scalar @Waypoints; |
if ( $WpCnt > 0 and $WpPlayerIndex < $WpCnt ) |
{ |
# Target WP-Pos senden |
my $Wp = $Waypoints[$WpPlayerIndex]; |
my $Wp_Lon = $Wp->{'Pos_Lon'}; |
my $Wp_Lat = $Wp->{'Pos_Lat'}; |
if ( $Wp_Lat ne "" and $Wp_Lon ne "" ) |
{ |
&MkFlyTo ( '-lat' => $Wp_Lat, |
'-lon' => $Wp_Lon, |
'-holdtime' => "60", |
'-mode' => "Target", |
); |
} |
} |
} |
if ( $PlayerRandomMode =~ /MAP/i ) |
{ |
# Target Map-Pos senden |
&MkFlyTo ( '-x' => $RandomTarget_x , |
'-y' => $RandomTarget_y , |
'-holdtime' => "60", |
'-mode' => "Target", |
); |
} |
# Ziel erreicht? |
if ( &WpCheckTargetReached() ) |
{ |
&WpTargetNext(); |
} |
} |
} |
# WP Player Holdtime count down |
if ( $WpPlayerHoldtime > 0 ) |
{ |
$WpPlayerHoldtime --; |
} |
}); |
# |
# Timer: variabel - KML Player |
# |
my $KmlTimeBase = $Cfg->{'waypoint'}->{'KmlTimeBase'} || 1.0; |
$KmlTimeBase *= 1000; |
$frame_map_top->repeat ($KmlTimeBase, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-KMLPlayer"); |
lock (%MkOsd); # until end of block |
if ( &CurPosIsValid() and $PlayerRecordMode =~ /REC/i ) |
{ |
# record current position |
push @KmlTargets, { |
'Lat' => $MkOsd{'CurPos_Lat'}, |
'Lon' => $MkOsd{'CurPos_Lon'}, |
'Alt' => $MkOsd{'CurPos_Alt'}, |
}; |
} |
if ( &MkIsWptMode() and $PlayerMode eq "Play" and $PlayerWptKmlMode eq 'KML') |
{ |
# Play KML |
# Pause, Home is handled in WPT-Timer |
my $KmlCnt = scalar @KmlTargets; |
if ( $KmlCnt > 0 and $KmlPlayerIndex < $KmlCnt ) |
{ |
my $Lat = $KmlTargets[$KmlPlayerIndex]->{'Lat'}; |
my $Lon = $KmlTargets[$KmlPlayerIndex]->{'Lon'}; |
my $Alt = $KmlTargets[$KmlPlayerIndex]->{'Alt'}; |
&MkFlyTo ( '-lat' => $Lat, |
'-lon' => $Lon, |
'-alt' => $Alt, |
'-holdtime' => "60", |
'-mode' => "Target", |
); |
# proceed to next Target |
$KmlPlayerIndex ++; |
if ( $KmlPlayerIndex >= $KmlCnt ) |
{ |
$KmlPlayerIndex = 0; |
} |
} |
} |
}); |
# |
# Timer: 1s |
# |
$frame_map_top->repeat (1000, sub |
{ |
# Clear old messages from this timer |
&MkMessageInit ("Timer-Misc-1s"); |
lock (%MkOsd); # until end of block |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
if ( &MkOsdIsValid() ) |
{ |
# Heartbeat MK Datenübertragung |
if ( time %2 ) |
{ |
$map_canvas->itemconfigure('Heartbeat', '-image' => 'HeartbeatLarge', ); |
} |
else |
{ |
$map_canvas->itemconfigure('Heartbeat', '-image' => 'HeartbeatSmall', ); |
} |
# Flugzeit aktualisieren |
# Flugzeit selber mitzählen, da $MkOsd{'FlyingTime'} immer 0 (0.14b) |
if ( &MkIsFlying() ) |
{ |
$MkFlyingTime += 1; |
} |
# Update ODO-Meter |
if ( &CurPosIsValid() ) |
{ |
my $C_Lat = $MkOsd{'CurPos_Lat'}; |
my $C_Lon = $MkOsd{'CurPos_Lon'}; |
if ( $OdoFirst ne "" ) |
{ |
my ($Dist, $Bearing) = &MapGpsTo($C_Lat, $C_Lon, $OdoPos_Lat, $OdoPos_Lon ); |
$OdoMeter += $Dist; |
} |
$OdoPos_Lat = $C_Lat; |
$OdoPos_Lon = $C_Lon; |
$OdoFirst = "1"; |
} |
# Bat capacity |
my $Capacity = 100.0; |
my $CapacityText = ""; |
if ( &MkIsFlying() ) |
{ |
if ( $UBatAverage eq "" ) |
{ |
$UBatAverage = $MkOsd{'UBat'}; |
} |
$UBatAverage = (9.0 * $UBatAverage + $MkOsd{'UBat'}) / 10.0; |
$Capacity = &BatCapacity($UBatAverage); |
$CapacityText = sprintf ("(%d %)", int ($Capacity + 0.5) ); |
} |
$map_canvas->itemconfigure ('MK-OSD-Bat-Level', '-text' => $CapacityText ); |
# # Estimate remaining flight time |
# my $TextTimeLeft = ""; |
# if ( &MkIsFlying() and $Capacity <= 90 ) |
# { |
# my $MaxTime = 100.0 / (100.0 - $Capacity) * $MkFlyingTime; |
# my $TimeLeft = $MaxTime - $MkFlyingTime; |
# $TextTimeLeft = sprintf ("(%d min)", int ($TimeLeft / 60.0 + 0.8) ); |
# } |
# $map_canvas->itemconfigure ('MK-OSD-Tim-Left', '-text' => $TextTimeLeft ); |
# Footprint |
if ( $Cfg->{'mkcockpit'}->{'FootprintLength'} > 0 ) |
{ |
if ( &CurPosIsValid() ) |
{ |
# neuen Footprint hinten anhaengen |
my ($x, $y) = &MapGps2XY($MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}); |
push @Footprint, $x, $y; |
} |
while ( $#Footprint / 2 > $Cfg->{'mkcockpit'}->{'FootprintLength'} ) |
{ |
# alte Footprints entfernen |
splice @Footprint, 0, 2; |
} |
&FootprintRedraw(); |
} |
# tracking antenne |
lock (%MkTrack); # until end of block |
if ( &MkIsMotorOn() and ! $MkTrack{'IsRunning'} and |
$Cfg->{'track'}->{'Active'} =~ /y/i ) |
{ |
# start track at 1st motor start |
$track_thr = threads->create (\&TrackAntennaGps)->detach(); |
} |
# fun :-) |
if ( int rand (100) == 43 ) |
{ |
&TtsSpeak ('LOW', $Translate{'TtsFun'}); |
} |
} |
}); |
# |
# Timer: 1s - TTS Sprachausgabe |
# |
$frame_map_top->repeat (1000, sub |
{ |
# Aktuell gültige Karte |
%Map = %{$Maps{'Current'}}; |
lock (%MkOsd); # until end of block |
my $StatusInterval = $Cfg->{'tts'}->{'StatusInterval'} || "30"; |
$SpeechTimer ++; |
my @TtsMsg; |
if ( &MkOsdIsValid() ) |
{ |
# Gueltige OSD Daten |
if ( $SpeechTimer % $StatusInterval == 0 ) |
{ |
# |
# give system status, low prio messages |
# |
# clear old low prio messages |
&TtsClear('LOW'); |
# Flight time |
my $Min = int ( ($MkFlyingTime +1) / 60); |
my $Sec = int ( ($MkFlyingTime +1) % 60); |
my $Text = sprintf ("$Translate{'TtsFlightTimeMinSec'}", $Min, $Sec); |
if ( $Min == 0 ) |
{ |
$Text = sprintf ("$Translate{'TtsFlightTimeSec'}", $Sec); |
} |
&TtsSpeak ('LOW', "$Text"); |
# Battery |
my ($Volt, $Tenth) = split '\.', $System{'UBat'}; |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsBattery'}", $Volt, $Tenth)); |
# Altitude |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsAltitude'}", $System{'Alt'}) ); |
# Satellites |
&TtsSpeak ('LOW', sprintf ("$Translate{'TtsSatellite'}", $MkOsd{'SatsInUse'}) ); |
} |
# high prio messages |
if ( $SpeechTimer % 5 == 0 ) |
{ |
if ( $System{'BatWarning'} ) { push @TtsMsg, $Translate{'TtsBatteryWarning'}; } |
if ( $System{'RCQuality'} eq "WEAK" ) { push @TtsMsg, $Translate{'TtsRcWeak'}; } |
if ( $System{'RCQuality'} eq "NO" ) { push @TtsMsg, $Translate{'TtsRcNo'}; } |
if ( $System{'CrossingBorder'} ) { push @TtsMsg, $Translate{'TtsCrossingBorder'}; } |
if ( $System{'OutsideBorder'} ) { push @TtsMsg, $Translate{'TtsOutsideAirfield'}; } |
if ( $System{'RangeWarning'} ) { push @TtsMsg, $Translate{'TtsRange'}; } |
} |
} |
else |
{ |
# no data link |
if ( $SpeechTimer % 5 == 0 ) |
{ |
push @TtsMsg, $Translate{'TtsNoDataLink'}; |
} |
} |
# speak high prio messages |
if ( scalar @TtsMsg > 0 ) |
{ |
# Clear pending messsages |
&TtsClear('HIGH'); |
# Speak collected messages |
foreach $Msg (@TtsMsg) |
{ |
&TtsSpeak ('HIGH', $Msg); |
} |
} |
}); |
__END__ |
/MissionCockpit/tags/V0.2.5/logging.pl |
---|
0,0 → 1,422 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# logging.pl - CSV, KLM, GPS Logging |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-02-23 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-05-01 0.1.1 rw configurable logging interval |
# 2009-05-17 0.1.7 rw _Timestamp timeout von 2s auf 10s erhoeht |
# |
############################################################################### |
$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-10 ) |
{ |
# active connection to MK |
&LogCsvOpen(); |
# NC OSD |
my $Sep = ""; |
foreach $Label (sort keys %MkOsd) |
{ |
print LOGCSV "$Sep" . "$MkOsd{$Label}"; |
$Sep = ","; |
} |
# NC Debug |
foreach $Label (sort keys %MkNcDebug) |
{ |
print LOGCSV "$Sep" . "$MkNcDebug{$Label}"; |
} |
print LOGCSV "\n"; |
} |
else |
{ |
# connection to MK lost, close Logfile |
&LogCsvClose(); |
} |
return 0; |
} |
# |
# GPX |
# http://www.topografix.com/gpx_manual.asp |
# |
# Open GPX logfile |
sub LogGpxOpen() |
{ |
if ( ! $LogGpxIsOpen ) |
{ |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
my $Filename = "mk-" . $TimeStamp . ".gpx"; |
open LOGGPX, ">$Cfg->{'logging'}->{'GpxLogDir'}/$Filename"; |
$LogGpxIsOpen = 1; |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); |
my $UtcTimeStamp = sprintf ("%04d-%02d-%02dT%02d:%02d:%02dZ", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
# print GPX-Header |
print LOGGPX <<EOF; |
<?xml version="1.0" encoding="UTF-8"?> |
<gpx |
version="1.0" |
creator="MK Mission Cockpit" |
xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" |
xmlns="http://www.topografix.com/GPX/1/0" |
xsi:schemaLocation="http://www.topografix.com/GPX/1/0 http://www.topografix.com/GPX/1/0/gpx.xsd"> |
<time>${UtcTimeStamp}</time> |
<trk> |
<name>Mikrokopter GPS logging</name> |
<desc>Flight ${TimeStamp}</desc> |
<trkseg> |
EOF |
} |
return 0; |
} |
# Close GPX |
sub LogGpxClose() |
{ |
if ( $LogGpxIsOpen ) |
{ |
# print GPX-Trailer |
print LOGGPX <<EOF; |
</trkseg> |
</trk> |
</gpx> |
EOF |
close LOGGPX; |
$LogGpxIsOpen = 0; |
} |
return 0; |
} |
# Log GPX |
sub LogGpx() |
{ |
lock %MkOsd; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 and |
$MkOsd{'MKFlags'} & 0x02 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
# active connection to MK, MK is flying, valid GPS |
&LogGpxOpen(); |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time); |
my $UtcTimeStamp = sprintf ("%04d-%02d-%02dT%02d:%02d:%02dZ", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
my $Speed = $MkOsd{'GroundSpeed'} / 100; # m/s |
printf LOGGPX <<EOF; |
<trkpt lat="$MkOsd{'CurPos_Lat'}" lon="$MkOsd{'CurPos_Lon'}"> |
<ele>$MkOsd{'CurPos_Alt'}</ele> |
<time>${UtcTimeStamp}</time> |
<sat>$MkOsd{'SatsInUse'}</sat> |
<course>$MkOsd{'CompassHeading'}</course> |
<speed>$Speed</speed> |
<extensions> |
<Target-Lat>$MkOsd{'TargetPos_Lat'}</Target-Lat> |
<Target-Lon>$MkOsd{'TargetPos_Lon'}</Target-Lon> |
<Target-Alt>$MkOsd{'TargetPos_Alt'}</Target-Alt> |
<Target-Bearing>$MkOsd{'TargetPosDev_Bearing'}</Target-Bearing> |
<Target-Dist>$MkOsd{'TargetPosDev_Dist'}</Target-Dist> |
<Waypoint>$MkOsd{'WaypointIndex'} / $MkOsd{'WaypointNumber'}</Waypoint> |
<Altimeter>$MkOsd{'Altimeter'}</Altimeter> |
<Variometer>$MkOsd{'Variometer'}</Variometer> |
<UBat>$MkOsd{'UBat'}</UBat> |
<AngleNick>$MkOsd{'AngleNick'}</AngleNick> |
<AngleRoll>$MkOsd{'AngleRoll'}</AngleRoll> |
<MKFlags>$MkOsd{'MKFlags'}</MKFlags> |
<NCFlags>$MkOsd{'NCFlags'}</NCFlags> |
</extensions> |
</trkpt> |
EOF |
} |
else |
{ |
&LogGpxClose(); |
} |
} |
# |
# KML |
# http://code.google.com/intl/de-DE/apis/kml/documentation/kml_tut.html |
# |
# Open KML logfile |
sub LogKmlOpen() |
{ |
if ( ! $LogKmlIsOpen ) |
{ |
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); |
my $TimeStamp = sprintf ("%04d%02d%02d-%02d%02d%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec); |
my $Filename = "mk-" . $TimeStamp . ".kml"; |
open LOGKML, ">$Cfg->{'logging'}->{'KmlLogDir'}/$Filename"; |
$LogKmlIsOpen = 1; |
# print KML-Header |
print LOGKML <<EOF; |
<?xml version="1.0" encoding="UTF-8"?> |
<kml xmlns="http://earth.google.com/kml/2.2"> |
<Document> |
<name>Mikrokopter GPS logging</name> |
<Style id="MK_gps-style"> |
<LineStyle> |
<color>ff0000ff</color> |
<width>2</width> |
</LineStyle> |
</Style> |
<Placemark> |
<name>Flight ${TimeStamp}</name> |
<styleUrl>MK_gps-style</styleUrl> |
<LineString> |
<tessellate>1</tessellate> |
<altitudeMode>relativeToGround</altitudeMode> |
<coordinates> |
EOF |
} |
return 0; |
} |
# Close KML |
sub LogKmlClose() |
{ |
if ( $LogKmlIsOpen ) |
{ |
# print KML-Trailer |
print LOGKML <<EOF; |
</coordinates> |
</LineString> |
</Placemark> |
</Document> |
</kml> |
EOF |
close LOGKML; |
$LogKmlIsOpen = 0; |
} |
return 0; |
} |
# Log KML |
sub LogKml() |
{ |
lock %MkOsd; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 and |
$MkOsd{'MKFlags'} & 0x02 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
# active connection to MK, MK is flying, valid GPS |
&LogKmlOpen(); |
my $AltRel = $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'}; |
if ( $AltRel < 0 ) { $AltRel = 0; } |
printf LOGKML " %f, %f, %f\n", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $AltRel; |
} |
else |
{ |
&LogKmlClose(); |
} |
} |
# Send Coords to GoogleEarth server |
sub Send2GeServer() |
{ |
lock %MkOsd; # until end of Block |
if ( $MkOsd{'_Timestamp'} >= time-10 and |
$MkOsd{'MKFlags'} & 0x02 and $MkOsd{'CurPos_Stat'} == 1 ) |
{ |
# active connection to MK, MK is flying, valid GPS |
my $AltRel = $MkOsd{'CurPos_Alt'} - $MkOsd{'HomePos_Alt'}; |
if ( $AltRel < 0 ) { $AltRel = 0; } |
push @GeCoords, sprintf "%f, %f, %f", $MkOsd{'CurPos_Lon'}, $MkOsd{'CurPos_Lat'}, $AltRel; |
} |
} |
sub MkLogLoop() |
{ |
while (1) |
{ |
&LogCsv(); |
&LogKml(); |
&LogGpx(); |
&Send2GeServer(); # Google Earth |
# kurz schlafen legen |
usleep $LoopTime; |
} |
} |
# |
# Hauptprgramm |
# |
if ( $0 =~ /logging.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
# Kommunikation zum MK herstellen |
$mk_thr = threads->create (\&MkCommLoop) -> detach(); |
&MkLogLoop(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/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.5/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.5/map/hemhofen-example.xml |
---|
0,0 → 1,32 |
<mkcockpit-Maps> |
<Hemhofen |
Name="Hemhofen" |
Size_X="800" |
Size_Y="600" |
File="hemhofen-800.gif" |
P1_x="66" |
P1_y="62" |
P2_x="778" |
P2_y="488" |
P1_Lat="49.685333" |
P1_Lon="10.950134" |
P2_Lat="49.682949" |
P2_Lon="10.944580" |
Border="555, 430, |
516, 555, |
258, 555, |
100, 300, |
580, 260, |
530, 94, |
627, 130, |
735, 300, |
680, 400, |
757, 470, |
720, 515, |
575, 420," |
/> |
</mkcockpit-Maps> |
/MissionCockpit/tags/V0.2.5/map/map.pl |
---|
0,0 → 1,159 |
############################################################################### |
# |
# map.pl - Map definition |
# |
## Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
## |
# 2009-03-06 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-04-18 0.1.1 rw Select default map, if configured map does not exist |
# 2009-07-22 0.1.2 rw Offset_x and Offset_y for adjustment of map calibration |
# 2009-08-15 0.1.3 rw Tracking Antenne Home position added |
# Player home position added |
# Read map definition from XML file |
# |
############################################################################### |
$Version{'map/map.pl'} = "0.1.3 - 2009-08-15"; |
use XML::Simple; # http://search.cpan.org/dist/XML-Simple-2.18/lib/XML/Simple.pm |
%Maps = |
( |
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', |
# 'Offset_x' => 5, # Optional Pixel offset MK to right |
# 'Offset_y' => 5, # Optional pixel offset MK to top |
# 'Home_Lat' => '54.090153', # Optional home position for player |
# 'Home_Lon' => '12.133249', # Optional home position for player |
# 'Track_Lat' => '49.685333', # Optional Tracking Antenna pos |
# 'Track_Lon' => '10.950134', # Optional Tracking Antenna pos |
# 'Track_Alt' => '500', # Optional Tracking Antenna altitude |
# 'Track_Bearing' => 10, # Optional Tracking antenne direction |
# 'Border' => [ 555, 430, # airfield border |
# 516, 555, |
# 258, 555, |
# 100, 300, |
# 580, 260, |
# 530, 94, |
# 627, 130, |
# 735, 300, |
# 680, 400, |
# 757, 470, |
# 720, 515, |
# 575, 420, |
# ], |
}, |
); |
# |
# load additional Maps from XML files |
# |
my $MapDir = $Cfg->{'map'}->{'MapDir'} || "map"; |
if ( -d $MapDir ) |
{ |
opendir DIR, $MapDir; |
my @Files = readdir DIR; |
@Files = grep /\.xml$/, @Files; |
closedir DIR; |
foreach $Xml (@Files) |
{ |
my $MapConfigFile = "$MapDir/$Xml"; |
if ( -f $MapConfigFile ) |
{ |
my $XmlMap = XMLin($MapConfigFile); |
foreach $Location (keys %{$XmlMap}) |
{ |
foreach $Key (keys %{$XmlMap->{$Location}} ) |
{ |
my $Value = $XmlMap->{$Location}->{$Key}; |
if ( $Key =~ /Border/i ) |
{ |
$Value =~ s/\s//g; |
my @Border = split ',', $Value; |
@{$Maps{$Location}->{$Key}} = @Border; |
} |
else |
{ |
$Maps{$Location}->{$Key} = $Value; |
} |
} |
} |
} |
} |
} |
# |
# Die verwendete Karte |
# |
my $MapDefault = $Cfg->{'map'}->{'MapDefault'}; |
if ( defined $Maps{$MapDefault} ) |
{ |
$Maps{'Current'} = $Maps{$MapDefault}; |
} |
else |
{ |
$Maps{'Current'} = $Maps{'Default'}; |
print "Map \"$MapDefault\" not found in map.pl. Using \"Default\" map\n"; |
} |
# |
# Todo: Karte automatisch anhand der aktuellen GPS Position auswählen |
# |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/mkcockpit.pl |
---|
0,0 → 1,1263 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# mkcockpit.pl - MK Mission Cockpit - GUI |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-02-20 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-04-16 0.1.1 rw Bugfix, ALT= average of airsensor and Sat |
# 2009-05-14 0.2.0 rw Waypoint Player |
# 2009-05-17 0.2.1 rw Cursor-Steuerung fuer WP-Player. Cmdline-Parameter "-geometry" |
# 2009-07-18 0.2.2 rw DE/EN multinational |
# Target-Balloon with Distance, Tolerance and Holdtime |
# Fix footprint "Ausreiser" |
# JPEG and PNG maps supported |
# Player for KML Files |
# 2009-07-26 0.2.3 rw System Messages Balloon |
# 2009-07-31 0.2.4 rw ODO Kilometerzähler |
# Enter WP-Number from Keyboard |
# Random WP-Player (Waypoint and Map) |
# Check Airfield Border |
# Draw Calibration points on map |
# 2009-08-08 0.2.5 rw KML Recorder |
# Text to speech |
# Subroutines moved to libmkcockpit.pl |
# Timer moved to libmktimer.pl |
# Start Scenarion configuration |
# Battery capacity estimation |
# Read map definition from maps/map.xml |
# |
############################################################################### |
$Version = "0.2.5 - 2009-08-08"; |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Tk; |
use Tk::Balloon; |
use Tk::Dialog; |
use Tk::Notebook; |
use Tk::JPEG; # http://search.cpan.org/~srezic/Tk-804.028/JPEG/JPEG.pm |
use Tk::PNG; # http://search.cpan.org/~srezic/Tk-804.028/PNG/PNG.pm |
use Math::Trig; |
use Time::HiRes qw(usleep); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
use XML::Simple; # http://search.cpan.org/dist/XML-Simple-2.18/lib/XML/Simple.pm |
# 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 |
require "tts.pl"; # Text to Speech |
require "libmkcockpit.pl"; # Subroutines |
# Commandline parameter |
my %CmdLine = @ARGV; |
# Thread fuer Kommunikation mit MK starten |
# Output: %MkOsd, %MkTarget, %MkNcDebug, %Mk |
# Input: Thread-Queue: $MkSendQueue |
$mk_thr = threads->create (\&MkCommLoop) -> detach(); |
# Start Logging Thread |
$log_thr = threads->create (\&MkLogLoop) -> detach(); |
# Start GoogleEarth Thread |
$ge_thr = threads->create (\&GeServer) -> detach(); |
# Start TTS Thread |
$tts_thr = threads->create (\&TtsLoop) -> detach(); |
# |
# Player: |
# Waypoint-List: @Waypoints |
# KML-Target-List: @KmlTargets |
# |
# Player state machine |
$PlayerMode = 'Stop'; # Play, Stop, Pause, Home ... |
$PlayerWptKmlMode = 'WPT'; # WPT, KML |
$PlayerRandomMode = 'STD'; # STD, RND, MAP |
$PlayerRecordMode = ""; # "", REC |
$WpPlayerIndex = 0; |
$WpPlayerHoldtime = -1; |
$KmlPlayerIndex = 0; |
$PlayerPause_Lat = ""; |
$PlayerPause_Lon = ""; |
# Aktuell gültige Karte |
my %Map = %{$Maps{'Current'}}; |
# Hauptfenster |
$main = new MainWindow; |
$main->title ("MK Mission Cockpit - Version $Version"); |
if ( $CmdLine{'-geometry'} ne "" ) |
{ |
$main->geometry( "$CmdLine{'-geometry'}" ); |
} |
#----------------------------------------------------------------- |
# Menu |
#----------------------------------------------------------------- |
# Menu bar |
my $menu_bar = $main->Menu; |
$main->optionAdd("*tearOff", "false"); |
$main->configure ('-menu' => $menu_bar); |
my $menu_file = $menu_bar->cascade('-label' => $Translate{'File'}); |
$menu_file->command('-label' => $Translate{'Preferences'}, |
'-command' => [\&Configure], |
); |
$menu_file->separator; |
$menu_file->command('-label' => $Translate{'Exit'}, |
'-command' => [\&CbExit ], |
); |
my $menu_debug = $menu_bar->cascade(-label => $Translate{'Debug'}); |
$menu_debug->command('-label' => $Translate{'NcOsdDataset'}, |
'-command' => [\&DisplayHash, \%MkOsd, $Translate{'NcOsdDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->command('-label' => $Translate{'NcTargetDataset'}, |
'-command' => [\&DisplayHash, \%MkTarget, $Translate{'NcTargetDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->command('-label' => $Translate{'NcDebugDataset'}, |
'-command' => [\&DisplayHash, \%MkNcDebug, $Translate{'NcDebugDataset'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->command('-label' => $Translate{'NcOther'}, |
'-command' => [\&DisplayHash, \%Mk, $Translate{'NcOther'}, "Display Refresh Heartbeat"], |
); |
$menu_debug->separator; |
$menu_debug->command('-label' => $Translate{'TrackingDebugDataset'}, |
'-command' => [\&DisplayHash, \%MkTrack, $Translate{'TrackingDebugDataset'}, "Display Refresh Heartbeat"], |
); |
#$menu_debug->command('-label' => $Translate{'MapDebugDataset'}, |
# '-command' => [\&DisplayHash, \%Map, $Translate{'MapDebugDataset'}, "Display"], |
# ); |
my $menu_help = $menu_bar->cascade(-label => $Translate{'Help'}); |
$menu_help->command('-label' => 'Version', |
'-command' => [\&DisplayHash, \%Version, $Translate{'Version'}, "Display"], |
); |
$menu_help->separator; |
$menu_help->command('-label' => $Translate{'About'}, |
'-command' => sub |
{ |
my $License = <<EOF; |
Copyright (C) 2009 Rainer Walther (rainerwalther-mail\@web.de) |
Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
See LICENSE.TXT |
EOF |
my $DlgAbout = $frame_map->Dialog('-title' => $Translate{'AboutMissionCockpit'}, |
'-text' => "$License", |
'-buttons' => ['OK'], |
'-bitmap' => 'info', |
); |
$DlgAbout->Show; |
}); |
# Hauptfenster Statuszeile |
$frame_status = $main->Frame( '-background' => 'lightgray', |
) -> pack('-side' => 'bottom', |
'-anchor' => 'w', |
'-fill' => 'none', |
'-expand' => 'y', |
); |
$status_line = $frame_status->Label ('-text' => $Translate{'StatusLine'}, |
) -> pack ('-side' => 'bottom', |
); |
#----------------------------------------------------------------- |
# Frames |
#----------------------------------------------------------------- |
# |
# Frame: Map |
# |
$frame_map = $main->Frame( '-background' => 'lightgray', |
'-relief' => 'sunken', |
'-borderwidth' => 5, |
) -> pack('-side' => 'top', |
'-fill' => 'x', |
); |
# Map Überschrift |
$frame_map_top = $frame_map->Frame() -> pack( '-side' => 'top', |
'-expand' => 'x', |
'-anchor' => 'w', |
); |
$frame_map_top->Label ('-text' => "$Translate{'Map'}: $Map{'Name'} ($Map{'File'})", |
'-background' => 'lightgray', |
'-relief' => 'flat', |
) -> pack( '-side' => 'left' ); |
# Map Statuszeile |
$map_status = $frame_map->Frame( '-background' => 'lightgray', |
) -> pack('-side' => 'bottom', |
'-anchor' => 'w', |
'-fill' => 'none', |
'-expand' => 'y', |
); |
$map_status_line = $map_status->Label ( '-text' => $Translate{'StatusLine'}, |
'-background' => 'lightgray', |
) -> pack ('-side' => 'bottom',); |
# |
# Map Canvas |
# |
# Canvas size |
$MapSizeX = $Map{'Size_X'}; |
$MapSizeY = $Map{'Size_Y'}; |
$map_canvas = $frame_map->Canvas( '-width' => $MapSizeX, |
'-height' => $MapSizeY, |
'-cursor' => 'cross', |
) -> pack(); |
# Images and Icons on canvas |
my @Icons = ( |
# Image Tag File Pos_x Pos_y |
'Map', 'Map', "$Cfg->{'map'}->{'MapDir'}/$Map{'File'}", 0, 0, |
'HeartbeatSmall', 'Heartbeat', "$Cfg->{'mkcockpit'}->{'IconHeartSmall'}", $MapSizeX/4, 10, |
'HeartbeatLarge', 'Heartbeat', "$Cfg->{'mkcockpit'}->{'IconHeartLarge'}", $MapSizeX/4, -100, |
'Satellite-Photo', 'Satellite', "$Cfg->{'mkcockpit'}->{'IconSatellite'}", $MapSizeX-300, -100, |
'Waypoint-Photo', 'Waypoint', "$Cfg->{'mkcockpit'}->{'IconWaypoint'}", 0, -150, |
'Target-Photo', 'Target', "$Cfg->{'mkcockpit'}->{'IconTarget'}", 0, -100, |
'Fox-Photo', 'Fox', "$Cfg->{'mkcockpit'}->{'IconFox'}", $MapSizeX/2-100, $MapSizeY/2, |
'WpPlay-Foto', 'Wp-PlayPause', "$Cfg->{'waypoint'}->{'IconPlay'}", $MapSizeX/2+150, $MapSizeY-48, |
'WpPause-Foto', 'Wp-PlayPause', "$Cfg->{'waypoint'}->{'IconPause'}", $MapSizeX/2+150, -100, |
'WpStop-Foto', 'Wp-Stop', "$Cfg->{'waypoint'}->{'IconStop'}", $MapSizeX/2+200, $MapSizeY-48, |
'WpNext-Foto', 'Wp-Next', "$Cfg->{'waypoint'}->{'IconNext'}", $MapSizeX/2+50, $MapSizeY-48, |
'WpPrev-Foto', 'Wp-Prev', "$Cfg->{'waypoint'}->{'IconPrev'}", $MapSizeX/2, $MapSizeY-48, |
'WpFirst-Foto', 'Wp-First', "$Cfg->{'waypoint'}->{'IconFirst'}", $MapSizeX/2-50, $MapSizeY-48, |
'WpLast-Foto', 'Wp-Last', "$Cfg->{'waypoint'}->{'IconLast'}", $MapSizeX/2+100, $MapSizeY-48, |
'WpHome-Foto', 'Wp-Home', "$Cfg->{'waypoint'}->{'IconHome'}", $MapSizeX/2-100, $MapSizeY-48, |
'WpRecord-Foto', 'Wp-Record', "$Cfg->{'waypoint'}->{'IconRecord'}", $MapSizeX/2-150, $MapSizeY-48, |
'WpRandomOff-Foto', 'Wp-WptRandom', "$Cfg->{'waypoint'}->{'IconRandomOff'}", $MapSizeX/2-200, -100, |
'WpRandomOn-Foto', 'Wp-WptRandom', "$Cfg->{'waypoint'}->{'IconRandomOn'}", $MapSizeX/2-200, $MapSizeY-48, |
'WpRandomMap-Foto', 'Wp-WptRandom', "$Cfg->{'waypoint'}->{'IconRandomMap'}", $MapSizeX/2-200, -100, |
'WpWpt-Foto', 'Wp-WptKml', "$Cfg->{'waypoint'}->{'IconWpt'}", $MapSizeX/2-250, $MapSizeY-48, |
'WpKml-Foto', 'Wp-WptKml', "$Cfg->{'waypoint'}->{'IconKml'}", $MapSizeX/2-250, -100 , |
); |
my $i = 0; |
for $Icon (0 .. $#Icons/5) |
{ |
my $Image = $Icons[$i++]; |
my $Tag = $Icons[$i++]; |
my $File = $Icons[$i++]; |
my $Pos_x = $Icons[$i++]; |
my $Pos_y = $Icons[$i++]; |
$map_canvas->Photo( $Image, |
'-file' => $File, |
); |
$map_canvas->createImage( $Pos_x, $Pos_y, |
'-tags' => $Tag, |
'-anchor' => 'nw', |
'-image' => $Image, |
); |
} |
# Calibration Points |
$map_canvas->createLine ( $Map{'P1_x'}-8, $Map{'P1_y'}, |
$Map{'P1_x'}+8, $Map{'P1_y'}, |
$Map{'P1_x'}, $Map{'P1_y'}, |
$Map{'P1_x'}, $Map{'P1_y'}-8, |
$Map{'P1_x'}, $Map{'P1_y'}+8, |
'-tags' => 'Calibration', |
'-arrow' => 'none', |
'-fill' => 'red', |
'-width' => 1, |
); |
$map_canvas->createLine ( $Map{'P2_x'}-8, $Map{'P2_y'}, |
$Map{'P2_x'}+8, $Map{'P2_y'}, |
$Map{'P2_x'}, $Map{'P2_y'}, |
$Map{'P2_x'}, $Map{'P2_y'}-8, |
$Map{'P2_x'}, $Map{'P2_y'}+8, |
'-tags' => 'Calibration', |
'-arrow' => 'none', |
'-fill' => 'red', |
'-width' => 1, |
); |
# border polygon |
$map_canvas->createPolygon( @Map{'Border'}, |
'-tags' => 'Map-Border', |
'-fill' => '', |
'-outline' => $Cfg->{'mkcockpit'}->{'ColorAirfield'}, '-width' => 2, |
); |
$map_canvas->raise('Map-Border', 'Map'); # Border above Map |
# Balloon attached to Canvas |
$map_balloon = $frame_map->Balloon('-statusbar' => $status_line, ); |
$map_balloon->attach($map_canvas, |
'-balloonposition' => 'mouse', |
'-state' => 'balloon', |
'-msg' => { 'MK-Arrow' => $Translate{'Balloon-MK-Arrow'}, |
'MK-Home-Line' => $Translate{'Balloon-MK-Home-Line'}, |
'MK-Home-Dist' => $Translate{'Balloon-MK-Home-Dist'}, |
'MK-Target-Line' => $Translate{'Balloon-MK-Target-Line' }, |
'MK-Target-Dist' => $Translate{'Balloon-MK-Target-Dist'}, |
'MK-Speed' => $Translate{'Balloon-MK-Speed'}, |
'Map-Variometer' => $Translate{'Balloon-Map-Variometer' }, |
'Map-Variometer-Pointer' => $Translate{'Balloon-Map-Variometer-Pointer'}, |
'Map-Variometer-Skala' => $Translate{'Balloon-Map-Variometer-Pointer'}, |
'Fox' => $Translate{'Balloon-Fox'}, |
'Heartbeat' => $Translate{'Balloon-Heartbeat'}, |
'Satellite' => $Translate{'Balloon-Satellite'}, |
'Waypoint' => $Translate{'Balloon-Waypoint'}, |
'Map-Border' => $Translate{'Balloon-Map-Border'}, |
'Waypoint-Connector' => $Translate{'Balloon-Waypoint-Connector'}, |
'Wp-PlayPause' => $Translate{'Balloon-Wp-PlayPause'}, |
'Wp-Stop' => $Translate{'Balloon-Wp-Stop'}, |
'Wp-First' => $Translate{'Balloon-Wp-First'}, |
'Wp-Last' => $Translate{'Balloon-Wp-Last'}, |
'Wp-Next' => $Translate{'Balloon-Wp-Next'}, |
'Wp-Prev' => $Translate{'Balloon-Wp-Prev'}, |
'Wp-Home' => $Translate{'Balloon-Wp-Home'}, |
'Wp-WptKml' => $Translate{'Balloon-Wp-WptKml'}, |
'Wp-WptRandom' => $Translate{'Balloon-Wp-WptRandom'}, |
'Wp-Record' => $Translate{'Balloon-Wp-Record'}, |
}, |
); |
# |
# 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' => "$Translate{'TargetCoordSent'} -> 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' => "$Translate{'TargetCoordSent'} -> Lat: $Lat Lon: $Lon x: $x y: $y"); |
}); |
# Pick Waypoint |
my $WpOldx; |
my $WpOldy; |
$map_canvas->bind('Waypoint' => '<Button-1>' => sub |
{ |
# prepare to move |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
$WpOldx = $x; |
$WpOldy = $y; |
}); |
# Move Waypoint |
$map_canvas->bind('Waypoint' => '<Button1-Motion>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
# move icon and Wp-Number |
my $WpIndex = &WpGetIndexFromId($id); |
if ( $WpIndex >= 0 ) |
{ |
my $Tag = $Waypoints[$WpIndex]{'Tag'}; |
$map_canvas->move($Tag => $x - $WpOldx, $y - $WpOldy); |
} |
$WpOldx = $x; |
$WpOldy = $y; |
}); |
# Release Wp |
$map_canvas->bind('Waypoint' => '<Button1-ButtonRelease>' => sub |
{ |
my ($x, $y) = ($Tk::event->x, $Tk::event->y); |
my $id = $map_canvas->find('withtag', 'current'); |
# take coords from lower/middle icon position |
my ($x0, $y0, $x1, $y1) = $map_canvas->bbox ($id); |
$x = $x0 + ($x1 - $x0)/2; |
$y = $y1; |
# update Waypoint-Array |
my $WpIndex = &WpGetIndexFromId($id); |
if ( $WpIndex >= 0 ) |
{ |
# got it: set new coords |
my ($Lat, $Lon) = &MapXY2Gps($x, $y); |
my $Wp = $Waypoints[$WpIndex]; |
$Wp->{'MapX'} = $x; |
$Wp->{'MapY'} = $y; |
$Wp->{'Pos_Lat'} = $Lat; |
$Wp->{'Pos_Lon'} = $Lon; |
# redraw connector-lines |
&WpRedrawLines(); |
# red connectors: Wp still have to be sent to MK |
$map_canvas->itemconfigure('Waypoint-Connector', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorWpResend'}, |
); |
$WaypointsModified = 1; |
my $WpNum = $WpIndex + 1; |
$map_status_line->configure ('-text' => "$Translate{'WpMoved'}: $WpNum -> Lat: $Lat Lon: $Lon x: $x y: $y"); |
} |
}); |
# |
# Mouse button 3 context menu |
# |
my $map_menu = $map_canvas->Menu('-tearoff' => 0, |
'-title' =>'None', |
'-menuitems' => |
[ |
[Button => $Translate{'WpAddAndSend'}, -command => sub |
{ |
# send Wp to MK |
($Lat, $Lon) = &MapXY2Gps($Wp_x, $Wp_y); |
&MkFlyTo ( '-lat' => $Lat, |
'-lon' => $Lon, |
'-mode' => "Waypoint" |
); |
# Add Wp to Waypoints list |
&WpAdd ($MapCanvasX, $MapCanvasY); |
# switch player to Wp mode and redraw waypoints |
&PlayerWpt(); |
$map_status_line->configure ('-text' => "$Translate{'WpSavedAndSent'} -> Lat: $Lat Lon: $Lon"); |
}], |
[Button => $Translate{'WpProperties'}, -command => sub |
{ |
# find Wp-Hash for selected icon/tag |
my $WpIndex = &WpGetIndexFromId($MapCanvasId); |
if ( $WpIndex >= 0 ) |
{ |
my $Wp = $Waypoints[$WpIndex]; |
my $WpNum = $WpIndex + 1; |
&DisplayHash ($Wp, "$Translate{'WpProperties'} $WpNum", "Edit Waypoint Refresh"); |
$map_status_line->configure ('-text' => "$Translate{'WpProperties'} $WpNum"); |
} |
}], |
[Button => $Translate{'WpResendAll'}, -command => sub |
{ |
&WpSendAll(); |
$map_status_line->configure ('-text' => $Translate{'WpAllSent'}); |
}], |
'', # Separator |
[Button => $Translate{'WpLoadAndSend'}, -command => sub |
{ |
my $WpFile = $main->getOpenFile('-defaultextension' => ".xml", |
'-filetypes' => |
[['Waypoints', '.xml' ], |
['All Files', '*', ], |
], |
'-initialdir' => $Cfg->{'waypoint'}->{'WpDir'}, |
'-title' => $Translate{'WpLoad'}, |
); |
if ( -f $WpFile ) |
{ |
&WpLoadFile ($WpFile); |
# send all Wp to MK |
&WpSendAll(); |
# switch player to Wp mode and redraw waypoints |
$PlayerRandomMode = 'STD'; |
&PlayerWpt(); |
$map_status_line->configure ('-text' => "$Translate{'WpLoadedAndSent'}: $WpFile"); |
} |
}], |
[Button => $Translate{'WpSave'}, -command => sub |
{ |
my $WpFile = $main->getSaveFile('-defaultextension' => ".xml", |
'-filetypes' => |
[['Waypoints', '.xml' ], |
['All Files', '*', ], |
], |
'-initialdir' => $Cfg->{'waypoint'}->{'WpDir'}, |
'-title' => $Translate{'WpSave'}, |
); |
&WpSaveFile ($WpFile); |
$map_status_line->configure ('-text' => "$Translate{'WpSaved'}: $WpFile"); |
}], |
'', # Separator |
[Button => $Translate{'WpDelete'}, -command => sub |
{ |
# find Wp-Hash for selected icon/tag |
my $WpIndex = &WpGetIndexFromId($MapCanvasId); |
if ( $WpIndex >= 0 ) |
{ |
&WpDelete ($WpIndex); |
# redraw connector-lines |
$WaypointsModified = 1; |
&WpRedrawLines(); |
&WpRedrawIcons(); # wg. Wp-Nummern |
my $WpNum = $WpIndex + 1; |
$map_status_line->configure ('-text' => "$Translate{'WpDeleted'}: $WpNum"); |
} |
}], |
[Button => $Translate{'WpAllDeleteAndSend'}, -command => sub |
{ |
undef @Waypoints; |
$WpPlayerIndex = 0; |
$WpPlayerHoldtime = -1; |
# remove all Wp-Icons and Wp-Number on canvas |
&WpHide(); |
&WpSendAll(); |
$map_status_line->configure ('-text' => "$Translate{'WpAllDeleted'}: $WpIndex"); |
}], |
'', # Separator |
[Button => $Translate{'KmlLoadAndPlay'}, -command => sub |
{ |
$KmlFile = $main->getOpenFile('-defaultextension' => ".kml", |
'-filetypes' => |
[['KML', '.kml' ], |
['All Files', '*', ], |
], |
'-initialdir' => $Cfg->{'waypoint'}->{'KmlDir'}, |
'-title' => $Translate{'KmlLoad'}, |
); |
if ( -f $KmlFile ) |
{ |
&KmlLoadFile($KmlFile); |
# switch player to KML mode and redraw track |
&PlayerKml(); |
$map_status_line->configure ('-text' => "$Translate{'KmlLoaded'}: $KmlFile" ); |
} |
}], |
'', # Separator |
[Button => $Translate{'WpFlyImmediately'}, -command => sub |
{ |
&MkFlyTo ( '-x' => $MapCanvasX, |
'-y' => $MapCanvasY, |
'-mode' => "Target" |
); |
# redraw connector-lines |
$WaypointsModified = 1; |
&WpRedrawLines(); |
$map_status_line->configure ('-text' => "$Translate{'TargetCoordSent'} -> Lat: $Lat Lon: $Lon x: $MapCanvasX y: $MapCanvasY"); |
}], |
] |
); |
$map_canvas->CanvasBind("<Button-3>" => [ sub |
{ |
$map_canvas->focus; |
my($w, $x, $y) = @_; |
($MapCanvasX, $MapCanvasY) = ($Tk::event->x, $Tk::event->y); |
$MapCanvasId = $map_canvas->find('withtag', 'current'); |
$map_menu->post($x, $y); |
}, Ev('X'), Ev('Y') ] ); |
# Mouse bindings |
$map_canvas->bind('Wp-PlayPause' => '<Button-1>' => \&CbPlayerPlayPause ); |
$map_canvas->bind('Wp-Next' => '<Button-1>' => \&CbPlayerNext ); |
$map_canvas->bind('Wp-Prev' => '<Button-1>' => \&CbPlayerPrev ); |
$map_canvas->bind('Wp-First' => '<Button-1>' => \&CbPlayerFirst ); |
$map_canvas->bind('Wp-Last' => '<Button-1>' => \&CbPlayerLast ); |
$map_canvas->bind('Wp-Home' => '<Button-1>' => \&CbPlayerHome ); |
$map_canvas->bind('Wp-Stop' => '<Button-1>' => \&CbPlayerStop ); |
$map_canvas->bind('Wp-WptKml' => '<Button-1>' => \&CbPlayerWptKml ); |
$map_canvas->bind('Wp-WptRandom' => '<Button-1>' => \&CbPlayerWptRandom ); |
$map_canvas->bind('Wp-Record' => '<Button-1>' => \&CbPlayerRecord ); |
# Focus Canvas, if any key pressed. Needed for the following key-bindings |
$main->bind('<Any-Enter>' => sub { $map_canvas->Tk::focus }); |
# Disable default arrow-key bindings on canvas |
$main->bind('Tk::Canvas',"<$_>",undef)for qw /Left Right Up Down/; |
# keyboard bindings |
$map_canvas->Tk::bind( '<Key-space>' , \&CbPlayerPlayPause ); |
$map_canvas->Tk::bind( '<Key-n>' , \&CbPlayerNext ); |
$map_canvas->Tk::bind( '<Key-p>' , \&CbPlayerPrev ); |
$map_canvas->Tk::bind( '<Key-f>' , \&CbPlayerFirst ); |
$map_canvas->Tk::bind( '<Key-l>' , \&CbPlayerLast ); |
$map_canvas->Tk::bind( '<Key-h>' , \&CbPlayerHome ); |
$map_canvas->Tk::bind( '<Key-s>' , \&CbPlayerStop ); |
$map_canvas->Tk::bind( '<Key-w>' , \&CbPlayerWptKml ); |
$map_canvas->Tk::bind( '<Key-k>' , \&CbPlayerWptKml ); |
$map_canvas->Tk::bind( '<Key-r>' , \&CbPlayerWptRandom ); |
$map_canvas->Tk::bind( '<Key-a>' , \&CbPlayerRecord ); |
$map_canvas->Tk::bind( '<Key-m>' , \&CbPlayerMute ); |
$map_canvas->Tk::bind( '<Key-0>' , [\&CbPlayerNum, "0"] ); |
$map_canvas->Tk::bind( '<Key-1>' , [\&CbPlayerNum, "1"] ); |
$map_canvas->Tk::bind( '<Key-2>' , [\&CbPlayerNum, "2"] ); |
$map_canvas->Tk::bind( '<Key-3>' , [\&CbPlayerNum, "3"] ); |
$map_canvas->Tk::bind( '<Key-4>' , [\&CbPlayerNum, "4"] ); |
$map_canvas->Tk::bind( '<Key-5>' , [\&CbPlayerNum, "5"] ); |
$map_canvas->Tk::bind( '<Key-6>' , [\&CbPlayerNum, "6"] ); |
$map_canvas->Tk::bind( '<Key-7>' , [\&CbPlayerNum, "7"] ); |
$map_canvas->Tk::bind( '<Key-8>' , [\&CbPlayerNum, "8"] ); |
$map_canvas->Tk::bind( '<Key-9>' , [\&CbPlayerNum, "9"] ); |
$map_canvas->Tk::bind( '<Key-Left>' , [\&CbPlayerMove, -1, 0] ); |
$map_canvas->Tk::bind( '<Key-Right>' , [\&CbPlayerMove, 1, 0] ); |
$map_canvas->Tk::bind( '<Key-Up>' , [\&CbPlayerMove, 0, 1] ); |
$map_canvas->Tk::bind( '<Key-Down>' , [\&CbPlayerMove, 0, -1] ); |
$map_canvas->Tk::bind( '<Key-Escape>', \&CbExit ); |
# |
# dynamic objecs on canvas |
# |
# current MK position on canvas |
$MkPos_x = $MapSizeX/2; |
$MkPos_y = $MapSizeY/2; |
# Line from MK to Home |
$map_canvas->createLine ( $MapSizeX/2, $MapSizeY/2, $MapSizeX/2, $MapSizeY/2, |
'-tags' => 'MK-Home-Line', |
'-arrow' => 'none', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeLine'}, |
'-width' => 3, |
); |
# Text Entfernung positioniert an der Home-Linie |
$map_canvas->createText ( $MapSizeX/2 + 8, $MapSizeY/2 - 8, |
'-tags' => 'MK-Home-Dist', |
'-text' => '0 m', |
'-anchor' => 'w', |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorHomeDist'}, |
); |
# Line from MK to Target, draw invisible out of sight |
$map_canvas->createLine ( 0, -100, 0, -100, |
'-tags' => 'MK-Target-Line', |
'-arrow' => 'none', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetLine'}, |
'-width' => 3, |
); |
# Text Entfernung positioniert an der Target-Linie |
$map_canvas->createText ( 0, -100, |
'-tags' => 'MK-Target-Dist', |
'-text' => '0 m', |
'-anchor' => 'w', |
'-font' => '-*-Arial-Bold-R-Normal--*-200-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorTargetDist'}, |
); |
# MK Geschwindigkeits-Vektor |
$MapMkSpeedLen = 60; # Länge Speed-Zeiger |
my $x0 = $MapSizeX/2; |
my $y0 = $MapSizeY/2; |
my $x1 = $MapSizeX/2; |
my $y1 = $MapSizeY/2 - $MapMkSpeedLen; |
$map_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-tags' => 'MK-Speed', |
'-arrow' => 'last', |
'-arrowshape' => [10, 10, 3 ], |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorSpeedVector'}, |
'-width' => 4, |
); |
# MK als Pfeilspitze einer Linie darstellen |
$MapMkLen = 25; |
my $x0 = $MapSizeX/2; |
my $y0 = $MapSizeY/2 + $MapMkLen/2; |
my $x1 = $MapSizeX/2; |
my $y1 = $MapSizeY/2 - $MapMkLen/2; |
$map_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-tags' => 'MK-Arrow', |
'-arrow' => 'last', |
'-arrowshape' => [25, 30, 10 ], |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorMkSatNo'}, |
'-width' => 1 |
); |
# OSD Texte auf Karte anzeigen |
my @Texts = ( |
# Tag Text Pos_x Pos_y Font |
'MK-OSD-Tim-Label', "TIM", $MapSizeX/2 - 40, 20, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Tim-Value', "00:00", $MapSizeX/2, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Tim-Left', "", $MapSizeX/2 + 90, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Bat-Label', "BAT", $MapSizeX/2 - 40, 50, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Bat-Value', "0.0 V", $MapSizeX/2, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
# 'MK-OSD-Bat-Level', "", $MapSizeX/2 + 90, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Spd-Label', "SPD", 10, 20, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Spd-Value', "0.0 km/h", 60, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Alt-Label', "ALT", 10, 50, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Alt-Value', "0 m", 60, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Odo-Label', "ODO", 10, 80, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Odo-Value', "0.000 km", 60, 80, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Sat-Label', "SAT", $MapSizeX - 230, 20, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Sat-Value', "0", $MapSizeX - 180, 20, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Wp-Label', "WPT", $MapSizeX - 230, 50, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Wp-Value', "0 / 0", $MapSizeX - 180, 50, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Mode-Label', "MOD", $MapSizeX - 230, 80, '-*-Arial-Bold-R-Normal--*-150-*', |
'MK-OSD-Mode-Value', "", $MapSizeX - 180, 80, '-*-Arial-Bold-R-Normal--*-270-*', |
'MK-OSD-Rec-Value', "", $MapSizeX - 180, 110, '-*-Arial-Bold-R-Normal--*-200-*', |
); |
my $i = 0; |
for $Text (0 .. $#Texts/5) |
{ |
my $Tag = $Texts[$i++]; |
my $Text = $Texts[$i++]; |
my $Pos_x = $Texts[$i++]; |
my $Pos_y = $Texts[$i++]; |
my $Font = $Texts[$i++]; |
$map_canvas->createText ( $Pos_x, $Pos_y, |
'-tags' => $Tag, |
'-text' => $Text, |
'-font' => $Font, |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorOsd'}, |
'-anchor' => 'w', |
); |
} |
# Variometer on canvas |
my @Polygon; |
for ( $y = -100; $y <= 100; $y += 10) |
{ |
my $Len = 5; |
if ( ($y % 50) == 0 ) |
{ |
$Len = 10; |
$map_canvas->createText ( $Len+5, $MapSizeY/2 + $y, |
'-tags' => 'Map-Variometer-Skala', |
'-text' => sprintf ("%3d", -$y / 10), |
'-anchor' => 'w', |
'-font' => '-*-Arial-Normal-R-Normal--*-150-*', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'}, |
); |
} |
push @Polygon, ( 0, $MapSizeY/2 + $y); |
push @Polygon, ($Len, $MapSizeY/2 + $y); |
push @Polygon, ( 0, $MapSizeY/2 + $y); |
} |
$map_canvas->createLine(@Polygon, |
'-tags' => 'Map-Variometer', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometer'}, |
'-width' => 2, |
'-arrow' => 'none', |
); |
# Vario Pointer |
$map_canvas->createPolygon( 5, $MapSizeY/2, 20, $MapSizeY/2+10, 20, $MapSizeY/2-10, |
'-tags' => 'Map-Variometer-Pointer', |
'-fill' => $Cfg->{'mkcockpit'}->{'ColorVariometerPointer'}, |
'-outline' => 'black', '-width' => 1, |
); |
# Tracking Canvas |
if ( $Cfg->{'track'}->{'Active'} =~ /y/i ) |
{ |
# Canvas size |
$TrackSizeX = 125; |
$TrackSizeY = 100; |
$TrackOffY = $TrackSizeY - $MapSizeY + 20; |
$TrackPtrLen = 50; # Länge Zeiger |
# draw in map-canvas |
$track_canvas = $map_canvas; |
# Ziffernblatt |
my $x0 = $TrackSizeX/2 - $TrackPtrLen; |
my $y0 = $TrackSizeY + $TrackPtrLen - $TrackOffY; |
my $x1 = $TrackSizeX/2 + $TrackPtrLen; |
my $y1 = $TrackSizeY - $TrackPtrLen - $TrackOffY; |
$track_canvas->createArc ( $x0, $y0, $x1, $y1, |
'-extent' => '200', |
'-start' => '-10', |
'-style' => 'chord', |
'-outline' => 'gray', '-width' => '1', |
); |
# Skala Ziffernblatt |
for ($i=0; $i<=180; $i+=15) |
{ |
my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 20) * cos( deg2rad $i ); |
my $y0 = $TrackSizeY - ($TrackPtrLen - 20) * sin( deg2rad $i ) - $TrackOffY; |
my $x1 = $TrackSizeX/2 - ($TrackPtrLen - 28) * cos( deg2rad $i ); |
my $y1 = $TrackSizeY - ($TrackPtrLen - 28) * sin( deg2rad $i ) - $TrackOffY; |
$track_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-fill' => 'white', |
'-width' => 1, |
); |
} |
# Skala Beschriftung Ziffernblatt |
for ($i=0; $i<=180; $i+=45) |
{ |
my $x0 = $TrackSizeX/2 - ($TrackPtrLen - 12) * cos( deg2rad $i ); |
my $y0 = $TrackSizeY - ($TrackPtrLen - 12) * sin( deg2rad $i ) - $TrackOffY; |
$track_canvas->createText ( $x0, $y0, |
'-text' => $i - 90, |
'-fill' => 'white', |
); |
} |
# Ziffernblatt Beschriftung Einheit |
my $x0 = $TrackSizeX/2; |
my $y0 = $MapSizeY -6; |
$track_canvas->createText ( $x0, $y0, |
'-text' => "Antenne Winkel", |
'-justify' => 'center', |
'-fill' => 'white', |
); |
# Zeiger |
my $x0 = $TrackSizeX/2; |
my $y0 = $TrackSizeY - 0 - $TrackOffY; |
my $x1 = $TrackSizeX/2; |
my $y1 = $TrackSizeY - ($TrackPtrLen - 22) - $TrackOffY; |
$track_ptr_id= $track_canvas->createLine ( $x0, $y0, $x1, $y1, |
'-tags' => 'Track-Ptr', |
'-arrow' => 'last', |
'-arrowshape' => [20, 30, 5 ], |
'-fill' => 'red', |
'-width' => 8, |
); |
# Zeiger Center |
my $Dia = 7; |
my $x0 = $TrackSizeX/2 - $Dia; |
my $y0 = $TrackSizeY + $Dia - $TrackOffY; |
my $x1 = $TrackSizeX/2 + $Dia; |
my $y1 = $TrackSizeY - $Dia - $TrackOffY; |
$track_canvas->createArc ( $x0, $y0, $x1, $y1, |
'-extent' => '359', |
'-outline' => 'gray', '-width' => 1, |
'-fill' => 'gray', |
); |
} |
# |
# Load Start Scenario |
# |
# Waypoint file |
my $CfgVal = $Cfg->{'StartScenario'}->{'WpFile'}; |
if ( ! -f $CfgVal ) |
{ |
$CfgVal = $Cfg->{'waypoint'}->{'WpDir'} . "/" . $Cfg->{'StartScenario'}->{'WpFile'}; |
} |
if ( -f $CfgVal ) |
{ |
&WpLoadFile($CfgVal); |
# send all Wp to MK |
&WpSendAll(); |
} |
# KML file |
my $CfgVal = $Cfg->{'StartScenario'}->{'KmlFile'}; |
if ( ! -f $CfgVal ) |
{ |
$CfgVal = $Cfg->{'waypoint'}->{'KmlDir'} . "/" . $Cfg->{'StartScenario'}->{'KmlFile'}; |
} |
if ( -f $CfgVal ) |
{ |
&KmlLoadFile($CfgVal); |
} |
# PLayer Mode |
my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerMode'}; |
if ( $CfgVal =~ /Play/i ) { &PlayerPlay(); } |
if ( $CfgVal =~ /Pause/i ) { &PlayerPause(); } |
if ( $CfgVal =~ /Home/i ) { &PlayerHome(); } |
if ( $CfgVal =~ /Stop/i ) { &PlayerStop(); } |
# Player Random Mode |
my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerRandomMode'}; |
if ( $CfgVal eq "STD" ) { &PlayerRandomStd(); } |
if ( $CfgVal eq "RND" ) { &PlayerRandomRnd(); } |
if ( $CfgVal eq "MAP" ) { &PlayerRandomMap(); } |
# PLayer Wpt/Kml Mode |
my $CfgVal = $Cfg->{'StartScenario'}->{'PlayerWptKmlMode'}; |
if ( $CfgVal eq "WPT" ) { &PlayerWpt(); } |
if ( $CfgVal eq "KML" ) { &PlayerKml(); } |
# Audio TTS Mute |
my $CfgVal = $Cfg->{'StartScenario'}->{'AudioMute'}; |
if ( $CfgVal =~ /y/i ) |
{ |
$TtsMute = 1; |
} |
# |
# Timer |
# |
require "libmktimer.pl"; |
MainLoop(); # should never end |
# |
# GUI Call Back |
# |
# Player CallBack: Play/Pause button |
sub CbPlayerPlayPause() |
{ |
if ( ($PlayerMode eq "Pause") or ($PlayerMode eq "Stop") or ($PlayerMode eq "Home") ) |
{ |
&PlayerPlay(); |
} |
else |
{ |
&PlayerPause(); |
} |
} |
# Player CallBack: Next |
sub CbPlayerNext() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetNext(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetNext(); |
} |
} |
} |
# Player CallBack: Prev |
sub CbPlayerPrev() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetPrev(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetPrev(); |
} |
} |
} |
# Player CallBack: First |
sub CbPlayerFirst() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetFirst(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetFirst(); |
} |
} |
} |
# Player CallBack: Last |
sub CbPlayerLast() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
if ( $PlayerWptKmlMode eq 'WPT' ) |
{ |
&WpTargetLast(); |
} |
if ( $PlayerWptKmlMode eq 'KML' ) |
{ |
&KmlTargetLast(); |
} |
} |
} |
# Player CallBack: Home |
sub CbPlayerHome() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
&PlayerHome(); |
} |
} |
# Player CallBack: Stop |
sub CbPlayerStop() |
{ |
if ( $PlayerMode ne 'Stop' ) |
{ |
&PlayerStop(); |
} |
} |
# Player CallBack: Move MK in Pause-Mode |
sub CbPlayerMove() |
{ |
my ($Id, $DirX, $DirY) = @_; |
if ( $PlayerMode eq 'Pause' and |
$PlayerPause_Lat ne "" and $PlayerPause_Lon ne "" ) |
{ |
my $Dist = $Cfg->{'waypoint'}->{'PauseMoveDist'} || 1; # 1m default |
my $BearingTop = &MapAngel() - 90.0; |
my $BearingKey = rad2deg atan2($DirX, $DirY); |
my $Bearing = $BearingTop + $BearingKey; |
($PlayerPause_Lat, $PlayerPause_Lon) = &MapGpsAt($PlayerPause_Lat, $PlayerPause_Lon, $Dist, $Bearing) |
} |
} |
# Player CallBack: Toggle WPT/KML button |
sub CbPlayerWptKml() |
{ |
if ( $PlayerWptKmlMode =~ /WPT/i ) |
{ |
&PlayerKml(); |
} |
elsif ( $PlayerWptKmlMode =~ /KML/i ) |
{ |
&PlayerWpt(); |
} |
} |
# Player CallBack: Toggle Random modes. STD -> RND -> MAP |
sub CbPlayerWptRandom() |
{ |
if ( $PlayerRandomMode eq "STD" ) |
{ |
&PlayerRandomRnd(); |
} |
elsif ( $PlayerRandomMode eq "RND" ) |
{ |
&PlayerRandomMap(); |
} |
else |
{ |
&PlayerRandomStd(); |
} |
} |
# Player CallBack: Togglle Record KML |
sub CbPlayerRecord() |
{ |
if ( $PlayerRecordMode =~ /REC/i ) |
{ |
&PlayerRecordOff(); |
} |
elsif ( $PlayerRecordMode eq "" ) |
{ |
&PlayerRecordOn(); |
} |
} |
# Player CallBack: Number Keys |
sub CbPlayerNum() |
{ |
my ($Id, $Num) = @_; |
$CbPlayerKey = "$CbPlayerKey" . "$Num"; |
} |
# Player CallBack: mute TTS audio |
sub CbPlayerMute() |
{ |
if ( $TtsMute ) |
{ |
$TtsMute = 0; |
} |
else |
{ |
$TtsMute = 1; |
} |
} |
# CallBack: Exit Mission Cockpit |
sub CbExit() |
{ |
# stop tracking antenna thread |
$TrackQueue->enqueue( "EXIT" ); |
exit; |
} |
# |
# subroutines moved to libmkcockpit.pl |
# Timer moved to libmktimer.pl |
# |
__END__ |
/MissionCockpit/tags/V0.2.5/mkcockpit.xml |
---|
0,0 → 1,73 |
<mkcockpit-Config CreationDate="20090820-214349"> |
<StartScenario AudioMute="n" |
KmlFile="" |
PlayerMode="Stop" |
PlayerRandomMode="STD" |
PlayerWptKmlMode="WPT" |
WpFile="" /> |
<geserver HttpPort="8080" /> |
<logging CsvLogDir="log" |
GpxLogDir="log" |
Intervall="0.5" |
KmlLogDir="log" /> |
<map MapDefault="Hemhofen" |
MapDir="map" /> |
<mkcockpit AltFactor="20" |
ColorAirfield="blue" |
ColorFootprint="magenta" |
ColorHomeDist="white" |
ColorHomeLine="red" |
ColorKmlTrack="gray" |
ColorMkSatGood="yellow" |
ColorMkSatLow="orange" |
ColorMkSatNo="red" |
ColorOsd="white" |
ColorSpeedVector="white" |
ColorTargetDist="cyan" |
ColorTargetLine="green" |
ColorVariometer="white" |
ColorVariometerPointer="yellow" |
ColorWpConnector="gray" |
ColorWpNumber="gray" |
ColorWpResend="red" |
FootprintLength="120" |
IconFox="icon/bear_48.gif" |
IconHeartLarge="icon/heart_48.gif" |
IconHeartSmall="icon/heart_32.gif" |
IconSatellite="icon/satellite_64.gif" |
IconTarget="icon/target_48.gif" |
IconWaypoint="icon/waypoint_48.gif" |
UBatWarning="10.0" /> |
<mkcomm Port="COM1" /> |
<track Active="n" |
Port="COM8" |
ServoPanCtrl="29" |
ServoTiltCtrl="59" /> |
<tts Active="y" |
Options="-v de -a 200 -s 200" |
Program="C:/Programme/eSpeak/command_line/espeak.exe" |
StatusInterval="20" |
Welcome="Starte Mischn Kockpit, Bitte anschnallen, und das Rauchen einstellen." /> |
<waypoint DefaultEventFlag="0" |
DefaultHeading="0" |
DefaultHoldtime="5" |
DefaultToleranceRadius="5" |
IconFirst="icon/WpFirst.gif" |
IconHome="icon/WpHome.gif" |
IconKml="icon/ModeKml_48.gif" |
IconLast="icon/WpLast.gif" |
IconNext="icon/WpNext.gif" |
IconPause="icon/WpPause.gif" |
IconPlay="icon/WpPlay.gif" |
IconPrev="icon/WpPrev.gif" |
IconRandomMap="icon/RandomMap_48.gif" |
IconRandomOff="icon/RandomOff_48.gif" |
IconRandomOn="icon/RandomWpt_48.gif" |
IconRecord="icon/Record_48.gif" |
IconStop="icon/WpStop.gif" |
IconWpt="icon/ModeWpt_48.gif" |
KmlDir="log" |
KmlTimeBase="0.5" |
PauseMoveDist="1.0" |
WpDir="waypoints" /> |
</mkcockpit-Config> |
/MissionCockpit/tags/V0.2.5/mkcomm.pl |
---|
0,0 → 1,756 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# mkcomm.pl - MK Communication Routines |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-02-21 0.0.1 rw created |
# 2009-03-18 0.0.2 rw NC 0.14e |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-04-06 0.1.1 rw NC 0.15c |
# 2009-05-16 0.1.2 rw External control |
# 2009-08-15 0.1.3 rw SIG-Handler removed |
# |
############################################################################### |
$Version{'mkcomm.pl'} = "0.1.3 - 2009-08-15"; |
# 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(); |
sub MkCommExit() |
{ |
# close COM port |
&MkClose(); |
if ( defined threads->self() ) |
{ |
threads->exit(); |
} |
exit; |
} |
sub MkInit() |
{ |
if ( defined $MkPort ) |
{ |
return; # already open |
} |
# open COM-Port |
my $MkComPort = $Cfg->{'mkcomm'}->{'Port'}; |
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; |
} |
elsif ( $Id eq "B" ) |
{ |
# |
# External Control |
# |
# Datenstruktur: |
# u8 ConfirmFrame; |
my ($ConfirmFrame) = unpack ('C5', $Data); |
} |
else |
{ |
print "Unknown Command: $Header $Data\n"; |
} |
} |
# send Target or Waypoint to MK |
sub MkFlyTo() |
{ |
my %Param = @_; |
my $x = $Param{'-x'}; |
my $y = $Param{'-y'}; |
my $Lat = $Param{'-lat'}; |
my $Lon = $Param{'-lon'}; |
my $Alt = $Param{'-alt'}; |
my $Heading = $Param{'-heading'}; |
my $ToleranceRadius = $Param{'-toleranceradius'}; |
my $Holdtime = $Param{'-holdtime'}; |
my $EventFlag = $Param{'-eventflag'}; |
my $Mode = $Param{'-mode'}; |
if ( $x ne "" and $y ne "" and $Lat eq "" and $Lon eq "" ) |
{ |
($Lat, $Lon) = &MapXY2Gps($x, $y); |
} |
if ( $Alt eq "" ) { $Alt = $MkOsd{'CurPos_Alt'}; } |
if ( $Heading eq "" ) { $Heading = $Cfg->{'waypoint'}->{'DefaultHeading'}; } |
if ( $ToleranceRadius eq "" ) { $ToleranceRadius = $Cfg->{'waypoint'}->{'DefaultToleranceRadius'}; } |
if ( $Holdtime eq "" ) { $Holdtime = $Cfg->{'waypoint'}->{'DefaultHoldtime'}; } |
if ( $EventFlag eq "" ) { $EventFlag = $Cfg->{'waypoint'}->{'DefaultEventFlag'}; } |
my $Status = 1; # valid |
if ( $Mode =~ /delete/i ) |
{ |
$Status = 0; # invalid -> delete NC WP-List |
} |
my $Lat_i = sprintf "%d", $Lat * 10000000; |
my $Lon_i = sprintf "%d", $Lon * 10000000; |
my $Alt_i = sprintf "%d", $Alt * 1000; |
# Datenstruktur: |
# GPS_Pos_t Position; // the gps position of the waypoint, see ubx.h for details |
# s16 Heading; // orientation, future implementation |
# u8 ToleranceRadius; // in meters, if the MK is within that range around the target, then the next target is |
# u8 HoldTime; // in seconds, if the MK was once in the tolerance area around a WP, |
# // this time defines the delay before the next WP is triggered |
# u8 Event_Flag; // future emplementation |
# u8 reserve[12]; // reserved |
my $Wp = pack ('lllCsC15', |
$Lon_i, |
$Lat_i, |
$Alt_i, |
$Status, |
$Heading, |
$ToleranceRadius, |
$Holdtime, |
$EventFlag, |
0,0,0,0,0,0,0,0,0,0,0,0, |
); |
if ( $Mode =~ /waypoint/i ) |
{ |
$MkSendQueue->enqueue( "w", "$AddrNC", $Wp ); |
# &MkSend( "w", "$AddrNC", $Wp ); |
} |
elsif ( $Mode =~ /target/i ) |
{ |
$MkSendQueue->enqueue( "s", "$AddrNC", $Wp ); |
# &MkSend( "w", "$AddrNC", $Wp ); |
} |
else |
{ |
# ignore |
} |
return 0; |
} |
# send External control to MK |
sub ExternalControl() |
{ |
my %Param = @_; |
my $RemoteButtons = $Param{'-remotebuttons'}; |
my $Nick = $Param{'-nick'}; |
my $Roll = $Param{'-roll'}; |
my $Yaw = $Param{'-yaw'}; |
my $Gas = $Param{'-gas'}; |
my $Hight = $Param{'-hight'}; |
my $Free = $Param{'-free'}; |
my $Frame = $Param{'-frame'}; |
my $Config = $Param{'-config'}; |
# Datenstruktur: |
# u8 Digital[2]; |
# u8 RemoteButtons; |
# s8 Nick; |
# s8 Roll; |
# s8 Yaw; |
# u8 Gas; |
# s8 Height; |
# u8 free; |
# u8 Frame; |
# u8 Config; |
my $Ec = pack ('CCCcccCcCCC', |
0, 0, |
$RemoteButtons, |
$Nick, |
$Roll, |
$Yaw, |
$Gas, |
$Hight, |
$Free, |
$Frame, |
$Config |
); |
$MkSendQueue->enqueue( "b", "$AddrNC", $Ec ); |
# &MkSend( "b", "$AddrNC", $Ec ); |
return 0; |
} |
# when called as thread |
sub MkCommLoop() |
{ |
while (1) |
{ |
&MkIO(); |
} |
} |
# |
# Hauptprgramm |
# |
if ( $0 =~ /mkcomm.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
&MkCommLoop(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/perl/lib/Thread/Queue.pm |
---|
0,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; |
}; |
1; |
=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 |
5.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.5/perl/lib/XML/Simple.pm |
---|
0,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/&/&/sg; |
$data =~ s/</</sg; |
$data =~ s/>/>/sg; |
$data =~ s/"/"/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; |
1; |
__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 '<', '>', '&' and '"' 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 * |
0 = (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 * |
1 = 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 * |
2 = 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: €) in the XML output. Three |
levels are possible: |
0 - default: no numeric escaping (OK if you're writing out UTF8) |
1 - only characters above 0xFF are escaped (ie: characters in the 0x80-FF range are not escaped), possibly useful with ISO8859-1 output |
2 - 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.5/perl/lib/threads.pm |
---|
0,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 |
); |
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 |
16 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.5/perl/site/lib/Geo/Ellipsoid.pm |
---|
0,0 → 1,950 |
# Geo::Ellipsoid |
# |
# This package implements an Ellipsoid class to perform latitude |
# and longitude calculations on the surface of an ellipsoid. |
# |
# This is a Perl conversion of existing Fortran code (see |
# ACKNOWLEDGEMENTS) and the author of this class makes no |
# claims of originality. Nor can he even vouch for the |
# results of the calculations, although they do seem to |
# work for him and have been tested against other methods. |
package Geo::Ellipsoid; |
use warnings; |
use strict; |
use 5.006_00; |
use Scalar::Util 'looks_like_number'; |
use Math::Trig; |
use Carp; |
=head1 NAME |
Geo::Ellipsoid - Longitude and latitude calculations using an ellipsoid model. |
=head1 VERSION |
Version 1.12, released July 4, 2008. |
=cut |
our $VERSION = '1.12'; |
our $DEBUG = 0; |
=head1 SYNOPSIS |
use Geo::Ellipsoid; |
$geo = Geo::Ellipsoid->new(ellipsoid=>'NAD27', units=>'degrees'); |
@origin = ( 37.619002, -122.374843 ); # SFO |
@dest = ( 33.942536, -118.408074 ); # LAX |
( $range, $bearing ) = $geo->to( @origin, @dest ); |
($lat,$lon) = $geo->at( @origin, 2000, 45.0 ); |
( $x, $y ) = $geo->displacement( @origin, $lat, $lon ); |
@pos = $geo->location( $lat, $lon, $x, $y ); |
=head1 DESCRIPTION |
Geo::Ellipsoid performs geometrical calculations on the surface of |
an ellipsoid. An ellipsoid is a three-dimension object formed from |
the rotation of an ellipse about one of its axes. The approximate |
shape of the earth is an ellipsoid, so Geo::Ellipsoid can accurately |
calculate distance and bearing between two widely-separated locations |
on the earth's surface. |
The shape of an ellipsoid is defined by the lengths of its |
semi-major and semi-minor axes. The shape may also be specifed by |
the flattening ratio C<f> as: |
f = ( semi-major - semi-minor ) / semi-major |
which, since f is a small number, is normally given as the reciprocal |
of the flattening C<1/f>. |
The shape of the earth has been surveyed and estimated differently |
at different times over the years. The two most common sets of values |
used to describe the size and shape of the earth in the United States |
are 'NAD27', dating from 1927, and 'WGS84', from 1984. United States |
Geological Survey topographical maps, for example, use one or the |
other of these values, and commonly-available Global Positioning |
System (GPS) units can be set to use one or the other. |
See L<"DEFINED ELLIPSOIDS"> below for the ellipsoid survey values |
that may be selected for use by Geo::Ellipsoid. |
=cut |
# class data and constants |
our $degrees_per_radian = 180/pi; |
our $eps = 1.0e-23; |
our $max_loop_count = 20; |
our $twopi = 2 * pi; |
our $halfpi = pi/2; |
our %defaults = ( |
ellipsoid => 'WGS84', |
units => 'radians', |
distance_units => 'meter', |
longitude => 0, |
latitude => 1, # allows use of _normalize_output |
bearing => 0, |
); |
our %distance = ( |
'foot' => 0.3048, |
'kilometer' => 1_000, |
'meter' => 1.0, |
'mile' => 1_609.344, |
'nm' => 1_852, |
); |
# set of ellipsoids that can be used. |
# values are |
# 1) a = semi-major (equatorial) radius of Ellipsoid |
# 2) 1/f = reciprocal of flattening (f), the ratio of the semi-minor |
# (polar) radius to the semi-major (equatorial) axis, or |
# polar radius = equatorial radius * ( 1 - f ) |
our %ellipsoids = ( |
'AIRY' => [ 6377563.396, 299.3249646 ], |
'AIRY-MODIFIED' => [ 6377340.189, 299.3249646 ], |
'AUSTRALIAN' => [ 6378160.0, 298.25 ], |
'BESSEL-1841' => [ 6377397.155, 299.1528128 ], |
'CLARKE-1880' => [ 6378249.145, 293.465 ], |
'EVEREST-1830' => [ 6377276.345, 300.8017 ], |
'EVEREST-MODIFIED' => [ 6377304.063, 300.8017 ], |
'FISHER-1960' => [ 6378166.0, 298.3 ], |
'FISHER-1968' => [ 6378150.0, 298.3 ], |
'GRS80' => [ 6378137.0, 298.25722210088 ], |
'HOUGH-1956' => [ 6378270.0, 297.0 ], |
'HAYFORD' => [ 6378388.0, 297.0 ], |
'IAU76' => [ 6378140.0, 298.257 ], |
'KRASSOVSKY-1938' => [ 6378245.0, 298.3 ], |
'NAD27' => [ 6378206.4, 294.9786982138 ], |
'NWL-9D' => [ 6378145.0, 298.25 ], |
'SOUTHAMERICAN-1969' => [ 6378160.0, 298.25 ], |
'SOVIET-1985' => [ 6378136.0, 298.257 ], |
'WGS72' => [ 6378135.0, 298.26 ], |
'WGS84' => [ 6378137.0, 298.257223563 ], |
); |
=head1 CONSTRUCTOR |
=head2 new |
The new() constructor may be called with a hash list to set the value of the |
ellipsoid to be used, the value of the units to be used for angles and |
distances, and whether or not the output range of longitudes and bearing |
angles should be symmetric around zero or always greater than zero. |
The initial default constructor is equivalent to the following: |
my $geo = Geo::Ellipsoid->new( |
ellipsoid => 'WGS84', |
units => 'radians' , |
distance_units => 'meter', |
longitude => 0, |
bearing => 0, |
); |
The constructor arguments may be of any case and, with the exception of |
the ellipsoid value, abbreviated to their first three characters. |
Thus, ( UNI => 'DEG', DIS => 'FEE', Lon => 1, ell => 'NAD27', bEA => 0 ) |
is valid. |
=cut |
sub new |
{ |
my( $class, %args ) = @_; |
my $self = {%defaults}; |
print "new: @_\n" if $DEBUG; |
foreach my $key ( keys %args ) { |
my $val = $args{$key}; |
if( $key =~ /^ell/i ) { |
$self->{ellipsoid} = uc $args{$key}; |
}elsif( $key =~ /^uni/i ) { |
$self->{units} = $args{$key}; |
}elsif( $key =~ /^dis/i ) { |
$self->{distance_units} = $args{$key}; |
}elsif( $key =~ /^lon/i ) { |
$self->{longitude} = $args{$key}; |
}elsif( $key =~ /^bea/i ) { |
$self->{bearing} = $args{$key}; |
}else{ |
carp("Unknown argument: $key => $args{$key}"); |
} |
} |
set_units($self,$self->{units}); |
set_ellipsoid($self,$self->{ellipsoid}); |
set_distance_unit($self,$self->{distance_units}); |
set_longitude_symmetric($self,$self->{longitude}); |
set_bearing_symmetric($self,$self->{bearing}); |
"Ellipsoid(units=>$self->{units},distance_units=>" . |
"$self->{distance_units},ellipsoid=>$self->{ellipsoid}," . |
"longitude=>$self->{longitude},bearing=>$self->{bearing})\n" if $DEBUG; |
bless $self,$class; |
return $self; |
} |
=head1 METHODS |
=head2 set_units |
Set the angle units used by the Geo::Ellipsoid object. The units may |
also be set in the constructor of the object. The allowable values are |
'degrees' or 'radians'. The default is 'radians'. The units value is |
not case sensitive and may be abbreviated to 3 letters. The units of |
angle apply to both input and output latitude, longitude, and bearing |
values. |
$geo->set_units('degrees'); |
=cut |
sub set_units |
{ |
my $self = shift; |
my $units = shift; |
if( $units =~ /deg/i ) { |
$units = 'degrees'; |
}elsif( $units =~ /rad/i ) { |
$units = 'radians'; |
}else{ |
croak("Invalid units specifier '$units' - please use either " . |
"degrees or radians (the default)") unless $units =~ /rad/i; |
} |
$self->{units} = $units; |
} |
=head2 set_distance_unit |
Set the distance unit used by the Geo::Ellipsoid object. The unit of |
distance may also be set in the constructor of the object. The recognized |
values are 'meter', 'kilometer', 'mile', 'nm' (nautical mile), or 'foot'. |
The default is 'meter'. The value is not case sensitive and may be |
abbreviated to 3 letters. |
$geo->set_distance_unit('kilometer'); |
For any other unit of distance not recogized by this method, pass a |
numerical argument representing the length of the distance unit in |
meters. For example, to use units of furlongs, call |
$geo->set_distance_unit(201.168); |
The distance conversion factors used by this module are as follows: |
Unit Units per meter |
-------- --------------- |
foot 0.3048 |
kilometer 1000.0 |
mile 1609.344 |
nm 1852.0 |
=cut |
sub set_distance_unit |
{ |
my $self = shift; |
my $unit = shift; |
print "distance unit = $unit\n" if $DEBUG; |
my $conversion = 0; |
if( defined $unit ) { |
my( $key, $val ); |
while( ($key,$val) = each %distance ) { |
my $re = substr($key,0,3); |
print "trying ($key,$re,$val)\n" if $DEBUG; |
if( $unit =~ /^$re/i ) { |
$self->{distance_units} = $unit; |
$conversion = $val; |
# finish iterating to reset 'each' function call |
while( each %distance ) {} |
last; |
} |
} |
if( $conversion == 0 ) { |
if( looks_like_number($unit) ) { |
$conversion = $unit; |
}else{ |
carp("Unknown argument to set_distance_unit: $unit\nAssuming meters"); |
$conversion = 1.0; |
} |
} |
}else{ |
carp("Missing or undefined argument to set_distance_unit: ". |
"$unit\nAssuming meters"); |
$conversion = 1.0; |
} |
$self->{conversion} = $conversion; |
} |
=head2 set_ellipsoid |
Set the ellipsoid to be used by the Geo::Ellipsoid object. See |
L<"DEFINED ELLIPSOIDS"> below for the allowable values. The value |
may also be set by the constructor. The default value is 'WGS84'. |
$geo->set_ellipsoid('NAD27'); |
=cut |
sub set_ellipsoid |
{ |
my $self = shift; |
my $ellipsoid = uc shift || $defaults{ellipsoid}; |
print " set ellipsoid to $ellipsoid\n" if $DEBUG; |
unless( exists $ellipsoids{$ellipsoid} ) { |
croak("Ellipsoid $ellipsoid does not exist - please use " . |
"set_custom_ellipsoid to use an ellipsoid not in valid set"); |
} |
$self->{ellipsoid} = $ellipsoid; |
my( $major, $recip ) = @{$ellipsoids{$ellipsoid}}; |
$self->{equatorial} = $major; |
if( $recip == 0 ) { |
carp("Infinite flattening specified by ellipsoid -- assuming a sphere"); |
$self->{polar} = $self->{equatorial}; |
$self->{flattening} = 0; |
$self->{eccentricity} = 0; |
}else{ |
$self->{flattening} = ( 1.0 / $ellipsoids{$ellipsoid}[1]); |
$self->{polar} = $self->{equatorial} * ( 1.0 - $self->{flattening} ); |
$self->{eccentricity} = sqrt( 2.0 * $self->{flattening} - |
( $self->{flattening} * $self->{flattening} ) ); |
} |
} |
=head2 set_custom_ellipsoid |
Sets the ellipsoid parameters to the specified ( major semiaxis and |
reciprocal flattening. A zero value for the reciprocal flattening |
will result in a sphere for the ellipsoid, and a warning message |
will be issued. |
$geo->set_custom_ellipsoid( 'sphere', 6378137, 0 ); |
=cut |
sub set_custom_ellipsoid |
{ |
my $self = shift; |
my( $name, $major, $recip ) = @_; |
$name = uc $name; |
$recip = 0 unless defined $recip; |
if( $major ) { |
$ellipsoids{$name} = [ $major, $recip ]; |
}else{ |
croak("set_custom_ellipsoid called without semi-major radius parameter"); |
} |
set_ellipsoid($self,$name); |
} |
=head2 set_longitude_symmetric |
If called with no argument or a true argument, sets the range of output |
values for longitude to be in the range [-pi,+pi) radians. If called with |
a false or undefined argument, sets the output angle range to be |
[0,2*pi) radians. |
$geo->set_longitude_symmetric(1); |
=cut |
sub set_longitude_symmetric |
{ |
my( $self, $sym ) = @_; |
# see if argument passed |
if( $#_ > 0 ) { |
# yes -- use value passed |
$self->{longitude} = $sym; |
}else{ |
# no -- set to true |
$self->{longitude} = 1; |
} |
} |
=head2 set_bearing_symmetric |
If called with no argument or a true argument, sets the range of output |
values for bearing to be in the range [-pi,+pi) radians. If called with |
a false or undefined argument, sets the output angle range to be |
[0,2*pi) radians. |
$geo->set_bearing_symmetric(1); |
=cut |
sub set_bearing_symmetric |
{ |
my( $self, $sym ) = @_; |
# see if argument passed |
if( $#_ > 0 ) { |
# yes -- use value passed |
$self->{bearing} = $sym; |
}else{ |
# no -- set to true |
$self->{bearing} = 1; |
} |
} |
=head2 set_defaults |
Sets the defaults for the new method. Call with key, value pairs similar to |
new. |
$Geo::Ellipsoid->set_defaults( |
units => 'degrees', |
ellipsoid => 'GRS80', |
distance_units => 'kilometer', |
longitude => 1, |
bearing => 0 |
); |
Keys and string values (except for the ellipsoid identifier) may be shortened |
to their first three letters and are case-insensitive: |
$Geo::Ellipsoid->set_defaults( |
uni => 'deg', |
ell => 'GRS80', |
dis => 'kil', |
lon => 1, |
bea => 0 |
); |
=cut |
sub set_defaults |
{ |
my $self = shift; |
my %args = @_; |
foreach my $key ( keys %args ) { |
if( $key =~ /^ell/i ) { |
$defaults{ellipsoid} = uc $args{$key}; |
}elsif( $key =~ /^uni/i ) { |
$defaults{units} = $args{$key}; |
}elsif( $key =~ /^dis/i ) { |
$defaults{distance_units} = $args{$key}; |
}elsif( $key =~ /^lon/i ) { |
$defaults{longitude} = $args{$key}; |
}elsif( $key =~ /^bea/i ) { |
$defaults{bearing} = $args{$key}; |
}else{ |
croak("Geo::Ellipsoid::set_defaults called with invalid key: $key"); |
} |
} |
print "Defaults set to ($defaults{ellipsoid},$defaults{units}\n" |
if $DEBUG; |
} |
=head2 scales |
Returns a list consisting of the distance unit per angle of latitude |
and longitude (degrees or radians) at the specified latitude. |
These values may be used for fast approximations of distance |
calculations in the vicinity of some location. |
( $lat_scale, $lon_scale ) = $geo->scales($lat0); |
$x = $lon_scale * ($lon - $lon0); |
$y = $lat_scale * ($lat - $lat0); |
=cut |
sub scales |
{ |
my $self = shift; |
my $units = $self->{units}; |
my $lat = $_[0]; |
if( defined $lat ) { |
$lat /= $degrees_per_radian if( $units eq 'degrees' ); |
}else{ |
carp("scales() method requires latitude argument; assuming 0"); |
$lat = 0; |
} |
my $aa = $self->{equatorial}; |
my $bb = $self->{polar}; |
my $a2 = $aa*$aa; |
my $b2 = $bb*$bb; |
my $d1 = $aa * cos($lat); |
my $d2 = $bb * sin($lat); |
my $d3 = $d1*$d1 + $d2*$d2; |
my $d4 = sqrt($d3); |
my $n1 = $aa * $bb; |
my $latscl = ( $n1 * $n1 ) / ( $d3 * $d4 * $self->{conversion} ); |
my $lonscl = ( $aa * $d1 ) / ( $d4 * $self->{conversion} ); |
if( $DEBUG ) { |
print "lat=$lat, aa=$aa, bb=$bb\nd1=$d1, d2=$d2, d3=$d3, d4=$d4\n"; |
print "latscl=$latscl, lonscl=$lonscl\n"; |
} |
if( $self->{units} eq 'degrees' ) { |
$latscl /= $degrees_per_radian; |
$lonscl /= $degrees_per_radian; |
} |
return ( $latscl, $lonscl ); |
} |
=head2 range |
Returns the range in distance units between two specified locations given |
as latitude, longitude pairs. |
my $dist = $geo->range( $lat1, $lon1, $lat2, $lon2 ); |
my $dist = $geo->range( @origin, @destination ); |
=cut |
sub range |
{ |
my $self = shift; |
my @args = _normalize_input($self->{units},@_); |
my($range,$bearing) = _inverse($self,@args); |
print "inverse(@_[1..4]) returns($range,$bearing)\n" if $DEBUG; |
return $range; |
} |
=head2 bearing |
Returns the bearing in degrees or radians from the first location to |
the second. Zero bearing is true north. |
my $bearing = $geo->bearing( $lat1, $lon1, $lat2, $lon2 ); |
=cut |
sub bearing |
{ |
my $self = shift; |
my $units = $self->{units}; |
my @args = _normalize_input($units,@_); |
my($range,$bearing) = _inverse($self,@args); |
print "inverse(@args) returns($range,$bearing)\n" if $DEBUG; |
my $t = $bearing; |
$self->_normalize_output('bearing',$bearing); |
print "_normalize_output($t) returns($bearing)\n" if $DEBUG; |
return $bearing; |
} |
=head2 at |
Returns the list (latitude,longitude) in degrees or radians that is a |
specified range and bearing from a given location. |
my( $lat2, $lon2 ) = $geo->at( $lat1, $lon1, $range, $bearing ); |
=cut |
sub at |
{ |
my $self = shift; |
my $units = $self->{units}; |
my( $lat, $lon, $az ) = _normalize_input($units,@_[0,1,3]); |
my $r = $_[2]; |
print "at($lat,$lon,$r,$az)\n" if $DEBUG; |
my( $lat2, $lon2 ) = _forward($self,$lat,$lon,$r,$az); |
print "_forward returns ($lat2,$lon2)\n" if $DEBUG; |
$self->_normalize_output('longitude',$lon2); |
$self->_normalize_output('latitude',$lat2); |
return ( $lat2, $lon2 ); |
} |
=head2 to |
In list context, returns (range, bearing) between two specified locations. |
In scalar context, returns just the range. |
my( $dist, $theta ) = $geo->to( $lat1, $lon1, $lat2, $lon2 ); |
my $dist = $geo->to( $lat1, $lon1, $lat2, $lon2 ); |
=cut |
sub to |
{ |
my $self = shift; |
my $units = $self->{units}; |
my @args = _normalize_input($units,@_); |
print "to($units,@args)\n" if $DEBUG; |
my($range,$bearing) = _inverse($self,@args); |
print "to: inverse(@args) returns($range,$bearing)\n" if $DEBUG; |
#$bearing *= $degrees_per_radian if $units eq 'degrees'; |
$self->_normalize_output('bearing',$bearing); |
if( wantarray() ) { |
return ( $range, $bearing ); |
}else{ |
return $range; |
} |
} |
=head2 displacement |
Returns the (x,y) displacement in distance units between the two specified |
locations. |
my( $x, $y ) = $geo->displacement( $lat1, $lon1, $lat2, $lon2 ); |
NOTE: The x and y displacements are only approximations and only valid |
between two locations that are fairly near to each other. Beyond 10 kilometers |
or more, the concept of X and Y on a curved surface loses its meaning. |
=cut |
sub displacement |
{ |
my $self = shift; |
print "displacement(",join(',',@_),"\n" if $DEBUG; |
my @args = _normalize_input($self->{units},@_); |
print "call _inverse(@args)\n" if $DEBUG; |
my( $range, $bearing ) = _inverse($self,@args); |
print "disp: _inverse(@args) returns ($range,$bearing)\n" if $DEBUG; |
my $x = $range * sin($bearing); |
my $y = $range * cos($bearing); |
return ($x,$y); |
} |
=head2 location |
Returns the list (latitude,longitude) of a location at a given (x,y) |
displacement from a given location. |
my @loc = $geo->location( $lat, $lon, $x, $y ); |
=cut |
sub location |
{ |
my $self = shift; |
my $units = $self->{units}; |
my($lat,$lon,$x,$y) = @_; |
my $range = sqrt( $x*$x+ $y*$y ); |
my $bearing = atan2($x,$y); |
$bearing *= $degrees_per_radian if $units eq 'degrees'; |
print "location($lat,$lon,$x,$y,$range,$bearing)\n" if $DEBUG; |
return $self->at($lat,$lon,$range,$bearing); |
} |
######################################################################## |
# |
# internal functions |
# |
# inverse |
# |
# Calculate the displacement from origin to destination. |
# The input to this subroutine is |
# ( latitude-1, longitude-1, latitude-2, longitude-2 ) in radians. |
# |
# Return the results as the list (range,bearing) with range in the |
# current specified distance unit and bearing in radians. |
sub _inverse() |
{ |
my $self = shift; |
my( $lat1, $lon1, $lat2, $lon2 ) = (@_); |
print "_inverse($lat1,$lon1,$lat2,$lon2)\n" if $DEBUG; |
my $a = $self->{equatorial}; |
my $f = $self->{flattening}; |
my $r = 1.0 - $f; |
my $tu1 = $r * sin($lat1) / cos($lat1); |
my $tu2 = $r * sin($lat2) / cos($lat2); |
my $cu1 = 1.0 / ( sqrt(($tu1*$tu1) + 1.0) ); |
my $su1 = $cu1 * $tu1; |
my $cu2 = 1.0 / ( sqrt( ($tu2*$tu2) + 1.0 )); |
my $s = $cu1 * $cu2; |
my $baz = $s * $tu2; |
my $faz = $baz * $tu1; |
my $dlon = $lon2 - $lon1; |
if( $DEBUG ) { |
printf "lat1=%.8f, lon1=%.8f\n", $lat1, $lon1; |
printf "lat2=%.8f, lon2=%.8f\n", $lat2, $lon2; |
printf "r=%.8f, tu1=%.8f, tu2=%.8f\n", $r, $tu1, $tu2; |
printf "faz=%.8f, dlon=%.8f\n", $faz, $dlon; |
} |
my $x = $dlon; |
my $cnt = 0; |
print "enter loop:\n" if $DEBUG; |
my( $c2a, $c, $cx, $cy, $cz, $d, $del, $e, $sx, $sy, $y ); |
do { |
printf " x=%.8f\n", $x if $DEBUG; |
$sx = sin($x); |
$cx = cos($x); |
$tu1 = $cu2*$sx; |
$tu2 = $baz - ($su1*$cu2*$cx); |
printf " sx=%.8f, cx=%.8f, tu1=%.8f, tu2=%.8f\n", |
$sx, $cx, $tu1, $tu2 if $DEBUG; |
$sy = sqrt( $tu1*$tu1 + $tu2*$tu2 ); |
$cy = $s*$cx + $faz; |
$y = atan2($sy,$cy); |
my $sa; |
if( $sy == 0.0 ) { |
$sa = 1.0; |
}else{ |
$sa = ($s*$sx) / $sy; |
} |
printf " sy=%.8f, cy=%.8f, y=%.8f, sa=%.8f\n", $sy, $cy, $y, $sa |
if $DEBUG; |
$c2a = 1.0 - ($sa*$sa); |
$cz = $faz + $faz; |
if( $c2a > 0.0 ) { |
$cz = ((-$cz)/$c2a) + $cy; |
} |
$e = ( 2.0 * $cz * $cz ) - 1.0; |
$c = ( ((( (-3.0 * $c2a) + 4.0)*$f) + 4.0) * $c2a * $f )/16.0; |
$d = $x; |
$x = ( ($e * $cy * $c + $cz) * $sy * $c + $y) * $sa; |
$x = ( 1.0 - $c ) * $x * $f + $dlon; |
$del = $d - $x; |
if( $DEBUG ) { |
printf " c2a=%.8f, cz=%.8f\n", $c2a, $cz; |
printf " e=%.8f, d=%.8f\n", $e, $d; |
printf " (d-x)=%.8g\n", $del; |
} |
}while( (abs($del) > $eps) && ( ++$cnt <= $max_loop_count ) ); |
$faz = atan2($tu1,$tu2); |
$baz = atan2($cu1*$sx,($baz*$cx - $su1*$cu2)) + pi; |
$x = sqrt( ((1.0/($r*$r)) -1.0 ) * $c2a+1.0 ) + 1.0; |
$x = ($x-2.0)/$x; |
$c = 1.0 - $x; |
$c = (($x*$x)/4.0 + 1.0)/$c; |
$d = ((0.375*$x*$x) - 1.0)*$x; |
$x = $e*$cy; |
if( $DEBUG ) { |
printf "e=%.8f, cy=%.8f, x=%.8f\n", $e, $cy, $x; |
printf "sy=%.8f, c=%.8f, d=%.8f\n", $sy, $c, $d; |
printf "cz=%.8f, a=%.8f, r=%.8f\n", $cz, $a, $r; |
} |
$s = 1.0 - $e - $e; |
$s = (((((((( $sy * $sy * 4.0 ) - 3.0) * $s * $cz * $d/6.0) - $x) * |
$d /4.0) + $cz) * $sy * $d) + $y ) * $c * $a * $r; |
printf "s=%.8f\n", $s if $DEBUG; |
# adjust azimuth to (0,360) or (-180,180) as specified |
if( $self->{symmetric} ) { |
$faz += $twopi if $faz < -(pi); |
$faz -= $twopi if $faz >= pi; |
}else{ |
$faz += $twopi if $faz < 0; |
$faz -= $twopi if $faz >= $twopi; |
} |
# return result |
my @disp = ( ($s/$self->{conversion}), $faz ); |
print "disp = (@disp)\n" if $DEBUG; |
return @disp; |
} |
# _forward |
# |
# Calculate the location (latitue,longitude) of a point |
# given a starting point and a displacement from that |
# point as (range,bearing) |
# |
sub _forward |
{ |
my $self = shift; |
my( $lat1, $lon1, $range, $bearing ) = @_; |
if( $DEBUG ) { |
printf "_forward(lat1=%.8f,lon1=%.8f,range=%.8f,bearing=%.8f)\n", |
$lat1, $lon1, $range, $bearing; |
} |
my $eps = 0.5e-13; |
my $a = $self->{equatorial}; |
my $f = $self->{flattening}; |
my $r = 1.0 - $f; |
my $tu = $r * sin($lat1) / cos($lat1); |
my $faz = $bearing; |
my $s = $self->{conversion} * $range; |
my $sf = sin($faz); |
my $cf = cos($faz); |
my $baz = 0.0; |
$baz = 2.0 * atan2($tu,$cf) if( $cf != 0.0 ); |
my $cu = 1.0 / sqrt(1.0 + $tu*$tu); |
my $su = $tu * $cu; |
my $sa = $cu * $sf; |
my $c2a = 1.0 - ($sa*$sa); |
my $x = 1.0 + sqrt( (((1.0/($r*$r)) - 1.0 )*$c2a) +1.0); |
$x = ($x-2.0)/$x; |
my $c = 1.0 - $x; |
$c = ((($x*$x)/4.0) + 1.0)/$c; |
my $d = $x * ((0.375*$x*$x)-1.0); |
$tu = (($s/$r)/$a)/$c; |
my $y = $tu; |
if( $DEBUG ) { |
printf "r=%.8f, tu=%.8f, faz=%.8f\n", $r, $tu, $faz; |
printf "baz=%.8f, sf=%.8f, cf=%.8f\n", $baz, $sf, $cf; |
printf "cu=%.8f, su=%.8f, sa=%.8f\n", $cu, $su, $sa; |
printf "x=%.8f, c=%.8f, y=%.8f\n", $x, $c, $y; |
} |
my( $cy, $cz, $e, $sy ); |
do { |
$sy = sin($y); |
$cy = cos($y); |
$cz = cos($baz+$y); |
$e = (2.0*$cz*$cz)-1.0; |
$c = $y; |
$x = $e * $cy; |
$y = (2.0 * $e) - 1.0; |
$y = ((((((((($sy*$sy*4.0)-3.0)*$y*$cz*$d)/6.0)+$x)*$d)/4.0)-$cz)*$sy*$d) + |
$tu; |
} while( abs($y-$c) > $eps ); |
$baz = ($cu*$cy*$cf) - ($su*$sy); |
$c = $r*sqrt(($sa*$sa) + ($baz*$baz)); |
$d = $su*$cy + $cu*$sy*$cf; |
my $lat2 = atan2($d,$c); |
$c = $cu*$cy - $su*$sy*$cf; |
$x = atan2($sy*$sf,$c); |
$c = (((((-3.0*$c2a)+4.0)*$f)+4.0)*$c2a*$f)/16.0; |
$d = (((($e*$cy*$c) + $cz)*$sy*$c)+$y)*$sa; |
my $lon2 = $lon1 + $x - (1.0-$c)*$d*$f; |
#$baz = atan2($sa,$baz) + pi; |
# return result |
return ($lat2,$lon2); |
} |
# _normalize_input |
# |
# Normalize a set of input angle values by converting to |
# radians if given in degrees and by converting to the |
# range [0,2pi), i.e. greater than or equal to zero and |
# less than two pi. |
# |
sub _normalize_input |
{ |
my $units = shift; |
my @args = @_; |
return map { |
$_ = deg2rad($_) if $units eq 'degrees'; |
while( $_ < 0 ) { $_ += $twopi } |
while( $_ >= $twopi ) { $_ -= $twopi } |
$_ |
} @args; |
} |
# _normalize_output |
# |
# Normalize a set of output angle values by converting to |
# degrees if needed and by converting to the range [-pi,+pi) or |
# [0,2pi) as needed. |
# |
sub _normalize_output |
{ |
my $self = shift; |
my $elem = shift; # 'bearing' or 'longitude' |
# adjust remaining input values by reference |
for ( @_ ) { |
if( $self->{$elem} ) { |
# normalize to range [-pi,pi) |
while( $_ < -(pi) ) { $_ += $twopi } |
while( $_ >= pi ) { $_ -= $twopi } |
}else{ |
# normalize to range [0,2*pi) |
while( $_ < 0 ) { $_ += $twopi } |
while( $_ >= $twopi ) { $_ -= $twopi } |
} |
$_ = rad2deg($_) if $self->{units} eq 'degrees'; |
} |
} |
=head1 DEFINED ELLIPSOIDS |
The following ellipsoids are defined in Geo::Ellipsoid, with the |
semi-major axis in meters and the reciprocal flattening as shown. |
The default ellipsoid is WGS84. |
Ellipsoid Semi-Major Axis (m.) 1/Flattening |
--------- ------------------- --------------- |
AIRY 6377563.396 299.3249646 |
AIRY-MODIFIED 6377340.189 299.3249646 |
AUSTRALIAN 6378160.0 298.25 |
BESSEL-1841 6377397.155 299.1528128 |
CLARKE-1880 6378249.145 293.465 |
EVEREST-1830 6377276.345 290.8017 |
EVEREST-MODIFIED 6377304.063 290.8017 |
FISHER-1960 6378166.0 298.3 |
FISHER-1968 6378150.0 298.3 |
GRS80 6378137.0 298.25722210088 |
HOUGH-1956 6378270.0 297.0 |
HAYFORD 6378388.0 297.0 |
IAU76 6378140.0 298.257 |
KRASSOVSKY-1938 6378245.0 298.3 |
NAD27 6378206.4 294.9786982138 |
NWL-9D 6378145.0 298.25 |
SOUTHAMERICAN-1969 6378160.0 298.25 |
SOVIET-1985 6378136.0 298.257 |
WGS72 6378135.0 298.26 |
WGS84 6378137.0 298.257223563 |
=head1 LIMITATIONS |
The methods should not be used on points which are too near the poles |
(above or below 89 degrees), and should not be used on points which |
are antipodal, i.e., exactly on opposite sides of the ellipsoid. The |
methods will not return valid results in these cases. |
=head1 ACKNOWLEDGEMENTS |
The conversion algorithms used here are Perl translations of Fortran |
routines written by LCDR S<L. Pfeifer> NGS Rockville MD that implement |
S<T. Vincenty's> Modified Rainsford's method with Helmert's elliptical |
terms as published in "Direct and Inverse Solutions of Ellipsoid on |
the Ellipsoid with Application of Nested Equations", S<T. Vincenty,> |
Survey Review, April 1975. |
The Fortran source code files inverse.for and forward.for |
may be obtained from |
ftp://ftp.ngs.noaa.gov/pub/pcsoft/for_inv.3d/source/ |
=head1 AUTHOR |
Jim Gibson, C<< <Jim@Gibson.org> >> |
=head1 BUGS |
See LIMITATIONS, above. |
Please report any bugs or feature requests to |
C<bug-geo-ellipsoid@rt.cpan.org>, or through the web interface at |
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Geo-Ellipsoid>. |
=head1 COPYRIGHT & LICENSE |
Copyright 2005-2008 Jim Gibson, all rights reserved. |
This program is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head1 SEE ALSO |
Geo::Distance, Geo::Ellipsoids |
=cut |
1; # End of Geo::Ellipsoid |
/MissionCockpit/tags/V0.2.5/perl/site/lib/Time/HiRes.pm |
---|
0,0 → 1,591 |
package Time::HiRes; |
use strict; |
use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); |
require Exporter; |
require DynaLoader; |
@ISA = qw(Exporter DynaLoader); |
@EXPORT = qw( ); |
@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval |
getitimer setitimer nanosleep clock_gettime clock_getres |
clock clock_nanosleep |
CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID |
CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID |
CLOCK_TIMEOFDAY CLOCKS_PER_SEC |
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF |
TIMER_ABSTIME |
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer |
d_nanosleep d_clock_gettime d_clock_getres |
d_clock d_clock_nanosleep |
stat |
); |
$VERSION = '1.9719'; |
$XS_VERSION = $VERSION; |
$VERSION = eval $VERSION; |
sub AUTOLOAD { |
my $constname; |
($constname = $AUTOLOAD) =~ s/.*:://; |
# print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n"; |
die "&Time::HiRes::constant not defined" if $constname eq 'constant'; |
my ($error, $val) = constant($constname); |
# print "AUTOLOAD: error = $error, val = $val\n"; |
if ($error) { |
my (undef,$file,$line) = caller; |
die "$error at $file line $line.\n"; |
} |
{ |
no strict 'refs'; |
*$AUTOLOAD = sub { $val }; |
} |
goto &$AUTOLOAD; |
} |
sub import { |
my $this = shift; |
for my $i (@_) { |
if (($i eq 'clock_getres' && !&d_clock_getres) || |
($i eq 'clock_gettime' && !&d_clock_gettime) || |
($i eq 'clock_nanosleep' && !&d_clock_nanosleep) || |
($i eq 'clock' && !&d_clock) || |
($i eq 'nanosleep' && !&d_nanosleep) || |
($i eq 'usleep' && !&d_usleep) || |
($i eq 'ualarm' && !&d_ualarm)) { |
require Carp; |
Carp::croak("Time::HiRes::$i(): unimplemented in this platform"); |
} |
} |
Time::HiRes->export_to_level(1, $this, @_); |
} |
bootstrap Time::HiRes; |
# Preloaded methods go here. |
sub tv_interval { |
# probably could have been done in C |
my ($a, $b) = @_; |
$b = [gettimeofday()] unless defined($b); |
(${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000); |
} |
# Autoload methods go after =cut, and are processed by the autosplit program. |
1; |
__END__ |
=head1 NAME |
Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers |
=head1 SYNOPSIS |
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep |
clock_gettime clock_getres clock_nanosleep clock |
stat ); |
usleep ($microseconds); |
nanosleep ($nanoseconds); |
ualarm ($microseconds); |
ualarm ($microseconds, $interval_microseconds); |
$t0 = [gettimeofday]; |
($seconds, $microseconds) = gettimeofday; |
$elapsed = tv_interval ( $t0, [$seconds, $microseconds]); |
$elapsed = tv_interval ( $t0, [gettimeofday]); |
$elapsed = tv_interval ( $t0 ); |
use Time::HiRes qw ( time alarm sleep ); |
$now_fractions = time; |
sleep ($floating_seconds); |
alarm ($floating_seconds); |
alarm ($floating_seconds, $floating_interval); |
use Time::HiRes qw( setitimer getitimer ); |
setitimer ($which, $floating_seconds, $floating_interval ); |
getitimer ($which); |
use Time::HiRes qw( clock_gettime clock_getres clock_nanosleep |
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF ); |
$realtime = clock_gettime(CLOCK_REALTIME); |
$resolution = clock_getres(CLOCK_REALTIME); |
clock_nanosleep(CLOCK_REALTIME, 1.5e9); |
clock_nanosleep(CLOCK_REALTIME, time()*1e9 + 10e9, TIMER_ABSTIME); |
my $ticktock = clock(); |
use Time::HiRes qw( stat ); |
my @stat = stat("file"); |
my @stat = stat(FH); |
=head1 DESCRIPTION |
The C<Time::HiRes> module implements a Perl interface to the |
C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and |
C<setitimer>/C<getitimer> system calls, in other words, high |
resolution time and timers. See the L</EXAMPLES> section below and the |
test scripts for usage; see your system documentation for the |
description of the underlying C<nanosleep> or C<usleep>, C<ualarm>, |
C<gettimeofday>, and C<setitimer>/C<getitimer> calls. |
If your system lacks C<gettimeofday()> or an emulation of it you don't |
get C<gettimeofday()> or the one-argument form of C<tv_interval()>. |
If your system lacks all of C<nanosleep()>, C<usleep()>, |
C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>, |
C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>. |
If your system lacks both C<ualarm()> and C<setitimer()> you don't get |
C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>. |
If you try to import an unimplemented function in the C<use> statement |
it will fail at compile time. |
If your subsecond sleeping is implemented with C<nanosleep()> instead |
of C<usleep()>, you can mix subsecond sleeping with signals since |
C<nanosleep()> does not use signals. This, however, is not portable, |
and you should first check for the truth value of |
C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and |
then carefully read your C<nanosleep()> C API documentation for any |
peculiarities. |
If you are using C<nanosleep> for something else than mixing sleeping |
with signals, give some thought to whether Perl is the tool you should |
be using for work requiring nanosecond accuracies. |
Remember that unless you are working on a I<hard realtime> system, |
any clocks and timers will be imprecise, especially so if you are working |
in a pre-emptive multiuser system. Understand the difference between |
I<wallclock time> and process time (in UNIX-like systems the sum of |
I<user> and I<system> times). Any attempt to sleep for X seconds will |
most probably end up sleeping B<more> than that, but don't be surpised |
if you end up sleeping slightly B<less>. |
The following functions can be imported from this module. |
No functions are exported by default. |
=over 4 |
=item gettimeofday () |
In array context returns a two-element array with the seconds and |
microseconds since the epoch. In scalar context returns floating |
seconds like C<Time::HiRes::time()> (see below). |
=item usleep ( $useconds ) |
Sleeps for the number of microseconds (millionths of a second) |
specified. Returns the number of microseconds actually slept. |
Can sleep for more than one second, unlike the C<usleep> system call. |
Can also sleep for zero seconds, which often works like a I<thread yield>. |
See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and |
C<Time::HiRes::clock_nanosleep()>. |
Do not expect usleep() to be exact down to one microsecond. |
=item nanosleep ( $nanoseconds ) |
Sleeps for the number of nanoseconds (1e9ths of a second) specified. |
Returns the number of nanoseconds actually slept (accurate only to |
microseconds, the nearest thousand of them). Can sleep for more than |
one second. Can also sleep for zero seconds, which often works like |
a I<thread yield>. See also C<Time::HiRes::sleep()>, |
C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>. |
Do not expect nanosleep() to be exact down to one nanosecond. |
Getting even accuracy of one thousand nanoseconds is good. |
=item ualarm ( $useconds [, $interval_useconds ] ) |
Issues a C<ualarm> call; the C<$interval_useconds> is optional and |
will be zero if unspecified, resulting in C<alarm>-like behaviour. |
Returns the remaining time in the alarm in microseconds, or C<undef> |
if an error occurred. |
ualarm(0) will cancel an outstanding ualarm(). |
Note that the interaction between alarms and sleeps is unspecified. |
=item tv_interval |
tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] ) |
Returns the floating seconds between the two times, which should have |
been returned by C<gettimeofday()>. If the second argument is omitted, |
then the current time is used. |
=item time () |
Returns a floating seconds since the epoch. This function can be |
imported, resulting in a nice drop-in replacement for the C<time> |
provided with core Perl; see the L</EXAMPLES> below. |
B<NOTE 1>: This higher resolution timer can return values either less |
or more than the core C<time()>, depending on whether your platform |
rounds the higher resolution timer values up, down, or to the nearest second |
to get the core C<time()>, but naturally the difference should be never |
more than half a second. See also L</clock_getres>, if available |
in your system. |
B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when |
the C<time()> seconds since epoch rolled over to 1_000_000_000, the |
default floating point format of Perl and the seconds since epoch have |
conspired to produce an apparent bug: if you print the value of |
C<Time::HiRes::time()> you seem to be getting only five decimals, not |
six as promised (microseconds). Not to worry, the microseconds are |
there (assuming your platform supports such granularity in the first |
place). What is going on is that the default floating point format of |
Perl only outputs 15 digits. In this case that means ten digits |
before the decimal separator and five after. To see the microseconds |
you can use either C<printf>/C<sprintf> with C<"%.6f">, or the |
C<gettimeofday()> function in list context, which will give you the |
seconds and microseconds as two separate values. |
=item sleep ( $floating_seconds ) |
Sleeps for the specified amount of seconds. Returns the number of |
seconds actually slept (a floating point value). This function can |
be imported, resulting in a nice drop-in replacement for the C<sleep> |
provided with perl, see the L</EXAMPLES> below. |
Note that the interaction between alarms and sleeps is unspecified. |
=item alarm ( $floating_seconds [, $interval_floating_seconds ] ) |
The C<SIGALRM> signal is sent after the specified number of seconds. |
Implemented using C<setitimer()> if available, C<ualarm()> if not. |
The C<$interval_floating_seconds> argument is optional and will be |
zero if unspecified, resulting in C<alarm()>-like behaviour. This |
function can be imported, resulting in a nice drop-in replacement for |
the C<alarm> provided with perl, see the L</EXAMPLES> below. |
Returns the remaining time in the alarm in seconds, or C<undef> |
if an error occurred. |
B<NOTE 1>: With some combinations of operating systems and Perl |
releases C<SIGALRM> restarts C<select()>, instead of interrupting it. |
This means that an C<alarm()> followed by a C<select()> may together |
take the sum of the times specified for the the C<alarm()> and the |
C<select()>, not just the time of the C<alarm()>. |
Note that the interaction between alarms and sleeps is unspecified. |
=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] ) |
Start up an interval timer: after a certain time, a signal ($which) arrives, |
and more signals may keep arriving at certain intervals. To disable |
an "itimer", use C<$floating_seconds> of zero. If the |
C<$interval_floating_seconds> is set to zero (or unspecified), the |
timer is disabled B<after> the next delivered signal. |
Use of interval timers may interfere with C<alarm()>, C<sleep()>, |
and C<usleep()>. In standard-speak the "interaction is unspecified", |
which means that I<anything> may happen: it may work, it may not. |
In scalar context, the remaining time in the timer is returned. |
In list context, both the remaining time and the interval are returned. |
There are usually three or four interval timers (signals) available: the |
C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or |
C<ITIMER_REALPROF>. Note that which ones are available depends: true |
UNIX platforms usually have the first three, but only Solaris seems to |
have C<ITIMER_REALPROF> (which is used to profile multithreaded programs). |
Win32 unfortunately does not haveinterval timers. |
C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in |
I<real time>; that is, wallclock time. C<SIGALRM> is delivered when |
the timer expires. |
C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is, |
only when the process is running. In multiprocessor/user/CPU systems |
this may be more or less than real or wallclock time. (This time is |
also known as the I<user time>.) C<SIGVTALRM> is delivered when the |
timer expires. |
C<ITIMER_PROF> counts time when either the process virtual time or when |
the operating system is running on behalf of the process (such as I/O). |
(This time is also known as the I<system time>.) (The sum of user |
time and system time is known as the I<CPU time>.) C<SIGPROF> is |
delivered when the timer expires. C<SIGPROF> can interrupt system calls. |
The semantics of interval timers for multithreaded programs are |
system-specific, and some systems may support additional interval |
timers. For example, it is unspecified which thread gets the signals. |
See your C<setitimer()> documentation. |
=item getitimer ( $which ) |
Return the remaining time in the interval timer specified by C<$which>. |
In scalar context, the remaining time is returned. |
In list context, both the remaining time and the interval are returned. |
The interval is always what you put in using C<setitimer()>. |
=item clock_gettime ( $which ) |
Return as seconds the current value of the POSIX high resolution timer |
specified by C<$which>. All implementations that support POSIX high |
resolution timers are supposed to support at least the C<$which> value |
of C<CLOCK_REALTIME>, which is supposed to return results close to the |
results of C<gettimeofday>, or the number of seconds since 00:00:00:00 |
January 1, 1970 Greenwich Mean Time (GMT). Do not assume that |
CLOCK_REALTIME is zero, it might be one, or something else. |
Another potentially useful (but not available everywhere) value is |
C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time |
value (unlike time() or gettimeofday(), which can be adjusted). |
See your system documentation for other possibly supported values. |
=item clock_getres ( $which ) |
Return as seconds the resolution of the POSIX high resolution timer |
specified by C<$which>. All implementations that support POSIX high |
resolution timers are supposed to support at least the C<$which> value |
of C<CLOCK_REALTIME>, see L</clock_gettime>. |
=item clock_nanosleep ( $which, $nanoseconds, $flags = 0) |
Sleeps for the number of nanoseconds (1e9ths of a second) specified. |
Returns the number of nanoseconds actually slept. The $which is the |
"clock id", as with clock_gettime() and clock_getres(). The flags |
default to zero but C<TIMER_ABSTIME> can specified (must be exported |
explicitly) which means that C<$nanoseconds> is not a time interval |
(as is the default) but instead an absolute time. Can sleep for more |
than one second. Can also sleep for zero seconds, which often works |
like a I<thread yield>. See also C<Time::HiRes::sleep()>, |
C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>. |
Do not expect clock_nanosleep() to be exact down to one nanosecond. |
Getting even accuracy of one thousand nanoseconds is good. |
=item clock() |
Return as seconds the I<process time> (user + system time) spent by |
the process since the first call to clock() (the definition is B<not> |
"since the start of the process", though if you are lucky these times |
may be quite close to each other, depending on the system). What this |
means is that you probably need to store the result of your first call |
to clock(), and subtract that value from the following results of clock(). |
The time returned also includes the process times of the terminated |
child processes for which wait() has been executed. This value is |
somewhat like the second value returned by the times() of core Perl, |
but not necessarily identical. Note that due to backward |
compatibility limitations the returned value may wrap around at about |
2147 seconds or at about 36 minutes. |
=item stat |
=item stat FH |
=item stat EXPR |
As L<perlfunc/stat> but with the access/modify/change file timestamps |
in subsecond resolution, if the operating system and the filesystem |
both support such timestamps. To override the standard stat(): |
use Time::HiRes qw(stat); |
Test for the value of &Time::HiRes::d_hires_stat to find out whether |
the operating system supports subsecond file timestamps: a value |
larger than zero means yes. There are unfortunately no easy |
ways to find out whether the filesystem supports such timestamps. |
UNIX filesystems often do; NTFS does; FAT doesn't (FAT timestamp |
granularity is B<two> seconds). |
A zero return value of &Time::HiRes::d_hires_stat means that |
Time::HiRes::stat is a no-op passthrough for CORE::stat(), |
and therefore the timestamps will stay integers. The same |
thing will happen if the filesystem does not do subsecond timestamps, |
even if the &Time::HiRes::d_hires_stat is non-zero. |
In any case do not expect nanosecond resolution, or even a microsecond |
resolution. Also note that the modify/access timestamps might have |
different resolutions, and that they need not be synchronized, e.g. |
if the operations are |
write |
stat # t1 |
read |
stat # t2 |
the access time stamp from t2 need not be greater-than the modify |
time stamp from t1: it may be equal or I<less>. |
=back |
=head1 EXAMPLES |
use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); |
$microseconds = 750_000; |
usleep($microseconds); |
# signal alarm in 2.5s & every .1s thereafter |
ualarm(2_500_000, 100_000); |
# cancel that ualarm |
ualarm(0); |
# get seconds and microseconds since the epoch |
($s, $usec) = gettimeofday(); |
# measure elapsed time |
# (could also do by subtracting 2 gettimeofday return values) |
$t0 = [gettimeofday]; |
# do bunch of stuff here |
$t1 = [gettimeofday]; |
# do more stuff here |
$t0_t1 = tv_interval $t0, $t1; |
$elapsed = tv_interval ($t0, [gettimeofday]); |
$elapsed = tv_interval ($t0); # equivalent code |
# |
# replacements for time, alarm and sleep that know about |
# floating seconds |
# |
use Time::HiRes; |
$now_fractions = Time::HiRes::time; |
Time::HiRes::sleep (2.5); |
Time::HiRes::alarm (10.6666666); |
use Time::HiRes qw ( time alarm sleep ); |
$now_fractions = time; |
sleep (2.5); |
alarm (10.6666666); |
# Arm an interval timer to go off first at 10 seconds and |
# after that every 2.5 seconds, in process virtual time |
use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time ); |
$SIG{VTALRM} = sub { print time, "\n" }; |
setitimer(ITIMER_VIRTUAL, 10, 2.5); |
use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME ); |
# Read the POSIX high resolution timer. |
my $high = clock_getres(CLOCK_REALTIME); |
# But how accurate we can be, really? |
my $reso = clock_getres(CLOCK_REALTIME); |
use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME ); |
clock_nanosleep(CLOCK_REALTIME, 1e6); |
clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME); |
use Time::HiRes qw( clock ); |
my $clock0 = clock(); |
... # Do something. |
my $clock1 = clock(); |
my $clockd = $clock1 - $clock0; |
use Time::HiRes qw( stat ); |
my ($atime, $mtime, $ctime) = (stat("istics"))[8, 9, 10]; |
=head1 C API |
In addition to the perl API described above, a C API is available for |
extension writers. The following C functions are available in the |
modglobal hash: |
name C prototype |
--------------- ---------------------- |
Time::NVtime double (*)() |
Time::U2time void (*)(pTHX_ UV ret[2]) |
Both functions return equivalent information (like C<gettimeofday>) |
but with different representations. The names C<NVtime> and C<U2time> |
were selected mainly because they are operating system independent. |
(C<gettimeofday> is Unix-centric, though some platforms like Win32 and |
VMS have emulations for it.) |
Here is an example of using C<NVtime> from C: |
double (*myNVtime)(); /* Returns -1 on failure. */ |
SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0); |
if (!svp) croak("Time::HiRes is required"); |
if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer"); |
myNVtime = INT2PTR(double(*)(), SvIV(*svp)); |
printf("The current time is: %f\n", (*myNVtime)()); |
=head1 DIAGNOSTICS |
=head2 useconds or interval more than ... |
In ualarm() you tried to use number of microseconds or interval (also |
in microseconds) more than 1_000_000 and setitimer() is not available |
in your system to emulate that case. |
=head2 negative time not invented yet |
You tried to use a negative time argument. |
=head2 internal error: useconds < 0 (unsigned ... signed ...) |
Something went horribly wrong-- the number of microseconds that cannot |
become negative just became negative. Maybe your compiler is broken? |
=head2 useconds or uinterval equal to or more than 1000000 |
In some platforms it is not possible to get an alarm with subsecond |
resolution and later than one second. |
=head2 unimplemented in this platform |
Some calls simply aren't available, real or emulated, on every platform. |
=head1 CAVEATS |
Notice that the core C<time()> maybe rounding rather than truncating. |
What this means is that the core C<time()> may be reporting the time |
as one second later than C<gettimeofday()> and C<Time::HiRes::time()>. |
Adjusting the system clock (either manually or by services like ntp) |
may cause problems, especially for long running programs that assume |
a monotonously increasing time (note that all platforms do not adjust |
time as gracefully as UNIX ntp does). For example in Win32 (and derived |
platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily |
drift off from the system clock (and the original time()) by up to 0.5 |
seconds. Time::HiRes will notice this eventually and recalibrate. |
Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC) |
might help in this (in case your system supports CLOCK_MONOTONIC). |
Some systems have APIs but not implementations: for example QNX and Haiku |
have the interval timer APIs but not the functionality. |
=head1 SEE ALSO |
Perl modules L<BSD::Resource>, L<Time::TAI64>. |
Your system documentation for C<clock>, C<clock_gettime>, |
C<clock_getres>, C<clock_nanosleep>, C<clock_settime>, C<getitimer>, |
C<gettimeofday>, C<setitimer>, C<sleep>, C<stat>, C<ualarm>. |
=head1 AUTHORS |
D. Wegscheid <wegscd@whirlpool.com> |
R. Schertler <roderick@argon.org> |
J. Hietaniemi <jhi@iki.fi> |
G. Aas <gisle@aas.no> |
=head1 COPYRIGHT AND LICENSE |
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved. |
Copyright (c) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Jarkko Hietaniemi. |
All rights reserved. |
This program is free software; you can redistribute it and/or modify |
it under the same terms as Perl itself. |
=cut |
/MissionCockpit/tags/V0.2.5/perl/site/lib/Win32/Locale.pm |
---|
0,0 → 1,371 |
package Win32::Locale; |
# Time-stamp: "2004-01-11 18:56:06 AST" |
use strict; |
use vars qw($VERSION %MSLocale2LangTag); |
$VERSION = '0.04'; |
%MSLocale2LangTag = ( |
0x0436 => 'af' , # <AFK> <Afrikaans> <Afrikaans> |
0x041c => 'sq' , # <SQI> <Albanian> <Albanian> |
0x0401 => 'ar-sa', # <ARA> <Arabic> <Arabic (Saudi Arabia)> |
0x0801 => 'ar-iq', # <ARI> <Arabic> <Arabic (Iraq)> |
0x0C01 => 'ar-eg', # <ARE> <Arabic> <Arabic (Egypt)> |
0x1001 => 'ar-ly', # <ARL> <Arabic> <Arabic (Libya)> |
0x1401 => 'ar-dz', # <ARG> <Arabic> <Arabic (Algeria)> |
0x1801 => 'ar-ma', # <ARM> <Arabic> <Arabic (Morocco)> |
0x1C01 => 'ar-tn', # <ART> <Arabic> <Arabic (Tunisia)> |
0x2001 => 'ar-om', # <ARO> <Arabic> <Arabic (Oman)> |
0x2401 => 'ar-ye', # <ARY> <Arabic> <Arabic (Yemen)> |
0x2801 => 'ar-sy', # <ARS> <Arabic> <Arabic (Syria)> |
0x2C01 => 'ar-jo', # <ARJ> <Arabic> <Arabic (Jordan)> |
0x3001 => 'ar-lb', # <ARB> <Arabic> <Arabic (Lebanon)> |
0x3401 => 'ar-kw', # <ARK> <Arabic> <Arabic (Kuwait)> |
0x3801 => 'ar-ae', # <ARU> <Arabic> <Arabic (U.A.E.)> |
0x3C01 => 'ar-bh', # <ARH> <Arabic> <Arabic (Bahrain)> |
0x4001 => 'ar-qa', # <ARQ> <Arabic> <Arabic (Qatar)> |
0x042b => 'hy' , # <HYE> <Armenian> <Armenian> |
0x044d => 'as' , # <ASM> <Assamese> <Assamese> |
0x042c => 'az-latn', # <AZE> <Azeri> <Azeri (Latin)> |
0x082c => 'az-cyrl', # <AZC> <Azeri> <Azeri (Cyrillic)> |
0x042D => 'eu' , # <EUQ> <Basque> <Basque> |
0x0423 => 'be' , # <BEL> <Belarussian> <Belarussian> |
0x0445 => 'bn' , # <BEN> <Bengali> <Bengali> |
0x0402 => 'bg' , # <BGR> <Bulgarian> <Bulgarian> |
0x0403 => 'ca' , # <CAT> <Catalan> <Catalan> |
# Chinese is zh, not cn! |
0x0404 => 'zh-tw', # <CHT> <Chinese> <Chinese (Taiwan)> |
0x0804 => 'zh-cn', # <CHS> <Chinese> <Chinese (PRC)> |
0x0C04 => 'zh-hk', # <ZHH> <Chinese> <Chinese (Hong Kong)> |
0x1004 => 'zh-sg', # <ZHI> <Chinese> <Chinese (Singapore)> |
0x1404 => 'zh-mo', # <ZHM> <Chinese> <Chinese (Macau SAR)> |
0x041a => 'hr' , # <HRV> <Croatian> <Croatian> |
0x0405 => 'cs' , # <CSY> <Czech> <Czech> |
0x0406 => 'da' , # <DAN> <Danish> <Danish> |
0x0413 => 'nl-nl', # <NLD> <Dutch> <Dutch (Netherlands)> |
0x0813 => 'nl-be', # <NLB> <Dutch> <Dutch (Belgium)> |
0x0409 => 'en-us', # <ENU> <English> <English (United States)> |
0x0809 => 'en-gb', # <ENG> <English> <English (United Kingdom)> |
0x0c09 => 'en-au', # <ENA> <English> <English (Australia)> |
0x1009 => 'en-ca', # <ENC> <English> <English (Canada)> |
0x1409 => 'en-nz', # <ENZ> <English> <English (New Zealand)> |
0x1809 => 'en-ie', # <ENI> <English> <English (Ireland)> |
0x1c09 => 'en-za', # <ENS> <English> <English (South Africa)> |
0x2009 => 'en-jm', # <ENJ> <English> <English (Jamaica)> |
0x2409 => 'en-jm', # <ENB> <English> <English (Caribbean)> # a hack |
0x2809 => 'en-bz', # <ENL> <English> <English (Belize)> |
0x2c09 => 'en-tt', # <ENT> <English> <English (Trinidad)> |
0x3009 => 'en-zw', # <ENW> <English> <English (Zimbabwe)> |
0x3409 => 'en-ph', # <ENP> <English> <English (Philippines)> |
0x0425 => 'et' , # <ETI> <Estonian> <Estonian> |
0x0438 => 'fo' , # <FOS> <Faeroese> <Faeroese> |
0x0429 => 'pa' , # <FAR> <Farsi> <Farsi> # =Persian |
0x040b => 'fi' , # <FIN> <Finnish> <Finnish> |
0x040c => 'fr-fr', # <FRA> <French> <French (France)> |
0x080c => 'fr-be', # <FRB> <French> <French (Belgium)> |
0x0c0c => 'fr-ca', # <FRC> <French> <French (Canada)> |
0x100c => 'fr-ch', # <FRS> <French> <French (Switzerland)> |
0x140c => 'fr-lu', # <FRL> <French> <French (Luxembourg)> |
0x180c => 'fr-mc', # <FRM> <French> <French (Monaco)> |
0x0437 => 'ka' , # <KAT> <Georgian> <Georgian> |
0x0407 => 'de-de', # <DEU> <German> <German (Germany)> |
0x0807 => 'de-ch', # <DES> <German> <German (Switzerland)> |
0x0c07 => 'de-at', # <DEA> <German> <German (Austria)> |
0x1007 => 'de-lu', # <DEL> <German> <German (Luxembourg)> |
0x1407 => 'de-li', # <DEC> <German> <German (Liechtenstein)> |
0x0408 => 'el' , # <ELL> <Greek> <Greek> |
0x0447 => 'gu' , # <GUJ> <Gujarati> <Gujarati> |
0x040D => 'he' , # <HEB> <Hebrew> <Hebrew> # formerly 'iw' |
0x0439 => 'hi' , # <HIN> <Hindi> <Hindi> |
0x040e => 'hu' , # <HUN> <Hungarian> <Hungarian> |
0x040F => 'is' , # <ISL> <Icelandic> <Icelandic> |
0x0421 => 'id' , # <IND> <Indonesian> <Indonesian> # formerly 'in' |
0x0410 => 'it-it', # <ITA> <Italian> <Italian (Italy)> |
0x0810 => 'it-ch', # <ITS> <Italian> <Italian (Switzerland)> |
0x0411 => 'ja' , # <JPN> <Japanese> <Japanese> # not "jp"! |
0x044b => 'kn' , # <KAN> <Kannada> <Kannada> |
0x0860 => 'ks' , # <KAI> <Kashmiri> <Kashmiri (India)> |
0x043f => 'kk' , # <KAZ> <Kazakh> <Kazakh> |
0x0457 => 'kok' , # <KOK> <Konkani> <Konkani> 3-letters! |
0x0412 => 'ko' , # <KOR> <Korean> <Korean> |
0x0812 => 'ko' , # <KOJ> <Korean> <Korean (Johab)> ? |
0x0426 => 'lv' , # <LVI> <Latvian> <Latvian> # = lettish |
0x0427 => 'lt' , # <LTH> <Lithuanian> <Lithuanian> |
0x0827 => 'lt' , # <LTH> <Lithuanian> <Lithuanian (Classic)> ? |
0x042f => 'mk' , # <MKD> <FYOR Macedonian> <FYOR Macedonian> |
0x043e => 'ms' , # <MSL> <Malay> <Malaysian> |
0x083e => 'ms-bn', # <MSB> <Malay> <Malay Brunei Darussalam> |
0x044c => 'ml' , # <MAL> <Malayalam> <Malayalam> |
0x044e => 'mr' , # <MAR> <Marathi> <Marathi> |
0x0461 => 'ne-np', # <NEP> <Nepali> <Nepali (Nepal)> |
0x0861 => 'ne-in', # <NEI> <Nepali> <Nepali (India)> |
0x0414 => 'nb' , # <NOR> <Norwegian> <Norwegian (Bokmal)> #was no-bok |
0x0814 => 'nn' , # <NON> <Norwegian> <Norwegian (Nynorsk)> #was no-nyn |
# note that this leaves nothing using "no" ("Norwegian") |
0x0448 => 'or' , # <ORI> <Oriya> <Oriya> |
0x0415 => 'pl' , # <PLK> <Polish> <Polish> |
0x0416 => 'pt-br', # <PTB> <Portuguese> <Portuguese (Brazil)> |
0x0816 => 'pt-pt', # <PTG> <Portuguese> <Portuguese (Portugal)> |
0x0446 => 'pa' , # <PAN> <Punjabi> <Punjabi> |
0x0417 => 'rm' , # <RMS> <Rhaeto-Romanic> <Rhaeto-Romanic> |
0x0418 => 'ro' , # <ROM> <Romanian> <Romanian> |
0x0818 => 'ro-md', # <ROV> <Romanian> <Romanian (Moldova)> |
0x0419 => 'ru' , # <RUS> <Russian> <Russian> |
0x0819 => 'ru-md', # <RUM> <Russian> <Russian (Moldova)> |
0x043b => 'se' , # <SZI> <Sami> <Sami (Lappish)> assuming == "Northern Sami" |
0x044f => 'sa' , # <SAN> <Sanskrit> <Sanskrit> |
0x0c1a => 'sr-cyrl', # <SRB> <Serbian> <Serbian (Cyrillic)> |
0x081a => 'sr-latn', # <SRL> <Serbian> <Serbian (Latin)> |
0x0459 => 'sd' , # <SND> <Sindhi> <Sindhi> |
0x041b => 'sk' , # <SKY> <Slovak> <Slovak> |
0x0424 => 'sl' , # <SLV> <Slovenian> <Slovenian> |
0x042e => 'wen' , # <SBN> <Sorbian> <Sorbian> # !!! 3 letters |
0x040a => 'es-es', # <ESP> <Spanish> <Spanish (Spain - Traditional Sort)> |
0x080a => 'es-mx', # <ESM> <Spanish> <Spanish (Mexico)> |
0x0c0a => 'es-es', # <ESN> <Spanish> <Spanish (Spain - Modern Sort)> |
0x100a => 'es-gt', # <ESG> <Spanish> <Spanish (Guatemala)> |
0x140a => 'es-cr', # <ESC> <Spanish> <Spanish (Costa Rica)> |
0x180a => 'es-pa', # <ESA> <Spanish> <Spanish (Panama)> |
0x1c0a => 'es-do', # <ESD> <Spanish> <Spanish (Dominican Republic)> |
0x200a => 'es-ve', # <ESV> <Spanish> <Spanish (Venezuela)> |
0x240a => 'es-co', # <ESO> <Spanish> <Spanish (Colombia)> |
0x280a => 'es-pe', # <ESR> <Spanish> <Spanish (Peru)> |
0x2c0a => 'es-ar', # <ESS> <Spanish> <Spanish (Argentina)> |
0x300a => 'es-ec', # <ESF> <Spanish> <Spanish (Ecuador)> |
0x340a => 'es-cl', # <ESL> <Spanish> <Spanish (Chile)> |
0x380a => 'es-uy', # <ESY> <Spanish> <Spanish (Uruguay)> |
0x3c0a => 'es-py', # <ESZ> <Spanish> <Spanish (Paraguay)> |
0x400a => 'es-bo', # <ESB> <Spanish> <Spanish (Bolivia)> |
0x440a => 'es-sv', # <ESE> <Spanish> <Spanish (El Salvador)> |
0x480a => 'es-hn', # <ESH> <Spanish> <Spanish (Honduras)> |
0x4c0a => 'es-ni', # <ESI> <Spanish> <Spanish (Nicaragua)> |
0x500a => 'es-pr', # <ESU> <Spanish> <Spanish (Puerto Rico)> |
0x0430 => 'st' , # <SXT> <Sutu> <Sutu> == soto, sesotho |
0x0441 => 'sw-ke', # <SWK> <Swahili> <Swahili (Kenya)> |
0x041D => 'sv' , # <SVE> <Swedish> <Swedish> |
0x081d => 'sv-fi', # <SVF> <Swedish> <Swedish (Finland)> |
0x0449 => 'ta' , # <TAM> <Tamil> <Tamil> |
0x0444 => 'tt' , # <TAT> <Tatar> <Tatar (Tatarstan)> |
0x044a => 'te' , # <TEL> <Telugu> <Telugu> |
0x041E => 'th' , # <THA> <Thai> <Thai> |
0x0431 => 'ts' , # <TSG> <Tsonga> <Tsonga> (not Tonga!) |
0x0432 => 'tn' , # <TNA> <Tswana> <Tswana> == Setswana |
0x041f => 'tr' , # <TRK> <Turkish> <Turkish> |
0x0422 => 'uk' , # <UKR> <Ukrainian> <Ukrainian> |
0x0420 => 'ur-pk', # <URD> <Urdu> <Urdu (Pakistan)> |
0x0820 => 'ur-in', # <URI> <Urdu> <Urdu (India)> |
0x0443 => 'uz-latn', # <UZB> <Uzbek> <Uzbek (Latin)> |
0x0843 => 'uz-cyrl', # <UZC> <Uzbek> <Uzbek (Cyrillic)> |
0x0433 => 'ven' , # <VEN> <Venda> <Venda> |
0x042a => 'vi' , # <VIT> <Vietnamese> <Vietnamese> |
0x0434 => 'xh' , # <XHS> <Xhosa> <Xhosa> |
0x043d => 'yi' , # <JII> <Yiddish> <Yiddish> # formetly ji |
0x0435 => 'zu' , # <ZUL> <Zulu> <Zulu> |
); |
#----------------------------------------------------------------------------- |
sub get_ms_locale { |
my $locale; |
return unless defined do { |
# see if there's a W32 registry on this machine, and if so, look in it |
local $SIG{"__DIE__"} = ""; |
eval ' |
use Win32::TieRegistry (); |
my $i18n = Win32::TieRegistry->new( |
"HKEY_CURRENT_USER/Control Panel/International", |
{ Delimiter => "/" } |
); |
#print "no key!" unless $i18n; |
$locale = $i18n->GetValue("Locale") if $i18n; |
undef $i18n; |
'; |
#print "<$@>\n" if $@; |
$locale; |
}; |
return unless $locale =~ m/^[0-9a-fA-F]+$/s; |
return hex($locale); |
} |
sub get_language { |
my $lang = $MSLocale2LangTag{ $_[0] || get_ms_locale() || '' }; |
return unless $lang; |
return $lang; |
} |
sub get_locale { |
# I guess this is right. |
my $lang = get_language(@_); |
return unless $lang and $lang =~ m/^[a-z]{2}(?:-[a-z]{2})?$/s; |
# should we try to turn "fi" into "fi_FI"? |
$lang =~ tr/-/_/; |
return $lang; |
} |
#----------------------------------------------------------------------------- |
# If we're just executed... |
unless(caller) { |
my $locale = get_ms_locale(); |
if($locale) { |
printf "Locale 0x%08x (%s => %s) => Lang %s\n", |
$locale, $locale, |
get_locale($locale) || '?', |
get_language($locale) || '?', |
} else { |
print "Can't get ms-locale\n"; |
} |
} |
#----------------------------------------------------------------------------- |
1; |
__END__ |
=head1 NAME |
Win32::Locale - get the current MSWin locale or language |
=head1 SYNOPSIS |
use Win32::Locale; |
my $language = Win32::Locale::get_language(); |
if($language eq 'en-us') { |
print "Wasaaap homeslice!\n"; |
} else { |
print "You $language people ain't FROM around here, are ya?\n"; |
} |
=head1 DESCRIPTION |
This library provides some simple functions allowing Perl under MSWin |
to ask what the current locale/language setting is. (Yes, MSWin |
conflates locales and languages, it seems; and the way it's |
conflated is even stranger after MSWin98.) |
Note that you should be able to safely use this module under any |
OS; the functions just won't be able to access any current |
locale value. |
=head1 FUNCTIONS |
Note that these functions are not exported, |
nor are they exportable: |
=over |
=item Win32::Locale::get_language() |
Returns the (all-lowercase) RFC3066 language tag corresponding |
to the currently currently selected MS locale. |
Returns nothing if the MS locale value isn't accessible |
(notably, if you're not running under MSWin!), or if it |
corresponds to no known language tag. Example: "en-us". |
In list context, this may in the future be made to return |
multiple values. |
=item Win32::Locale::get_locale() |
Returns the (all-lowercase) Unixish locale tag corresponding |
to the currently currently selected MS locale. Example: "en_us". |
Returns nothing if the MS locale value isn't accessible |
(notably, if you're not running under MSWin!), or if it |
corresponds to no locale. |
In list context, this may in the future be made to return |
multiple values. |
Note that this function is B<experimental>, and I greatly welcome |
suggestions. |
=item Win32::Locale::get_ms_locale() |
Returns the MS locale ID code for the currently selected MSWindows |
locale. For example, returns the number 1033 for "US |
English". (You may know the number 1033 better as 0x00000409, |
as these numbers are usually given in hex in MS documents). |
Returns nothing if the value isn't accessible (notably, if you're |
not running under MSWin!). |
=item Win32::Locale::get_language($msid) |
Returns the (all-lowercase) RFC3066 language tag corresponding |
to the given MS locale code, or nothing if none. |
In list context, this may in the future be made to return |
multiple values. |
=item Win32::Locale::get_locale($msid) |
Returns the (all-lowercase) Unixish locale tag corresponding |
to the given MS locale code, or nothing if none. |
In list context, this may in the future be made to return |
multiple values. |
=back |
("Nothing", above, means "in scalar context, undef; in list |
context, empty-list".) |
=head1 AND MORE |
This module provides an (unexported) public hash, |
%Win32::Locale::MSLocale2LangTag, that maps |
from the MS locale ID code to my idea of the single best corresponding |
RFC3066 language tag. |
The hash's contents are relatively certain for well-known |
languages (US English is "en-us"), but are still experimental |
in its finer details (like Konkani being "kok"). |
=head1 SEE ALSO |
L<I18N::LangTags|I18N::LangTags>, |
L<I18N::LangTags::List|I18N::LangTags::List>, |
L<Locale::Maketext|Locale::Maketext>. |
=head1 COPYRIGHT AND DISCLAIMER |
Copyright (c) 2001,2003 Sean M. Burke. All rights reserved. |
This library is free software; you can redistribute it and/or modify |
it under the same terms as Perl itself. |
This program is distributed in the hope that it will be useful, but |
without any warranty; without even the implied warranty of |
merchantability or fitness for a particular purpose. |
I am not affiliated with the Microsoft corporation, nor the ActiveState |
corporation. |
Product and company names mentioned in this document may be the |
trademarks or service marks of their respective owners. Trademarks |
and service marks might not be identified as such, although |
this must not be construed as anyone's expression of validity |
or invalidity of each trademark or service mark. |
=head1 AUTHOR |
Sean M. Burke C<sburke@cpan.org> |
=cut |
# No big whoop. |
/MissionCockpit/tags/V0.2.5/perl/site/lib/Win32/SerialPort.pm |
---|
0,0 → 1,2969 |
package Win32::SerialPort; |
use Win32; |
use Win32API::CommPort qw( :STAT :PARAM 0.17 ); |
use Carp; |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); |
$VERSION = '0.19'; |
require Exporter; |
## require AutoLoader; |
@ISA = qw( Exporter Win32API::CommPort ); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= @Win32API::CommPort::EXPORT_OK; |
%EXPORT_TAGS = %Win32API::CommPort::EXPORT_TAGS; |
# parameters that must be included in a "save" and "checking subs" |
my %validate = ( |
ALIAS => "alias", |
BAUD => "baudrate", |
BINARY => "binary", |
DATA => "databits", |
E_MSG => "error_msg", |
EOFCHAR => "eof_char", |
ERRCHAR => "error_char", |
EVTCHAR => "event_char", |
HSHAKE => "handshake", |
PARITY => "parity", |
PARITY_EN => "parity_enable", |
RCONST => "read_const_time", |
READBUF => "set_read_buf", |
RINT => "read_interval", |
RTOT => "read_char_time", |
STOP => "stopbits", |
U_MSG => "user_msg", |
WCONST => "write_const_time", |
WRITEBUF => "set_write_buf", |
WTOT => "write_char_time", |
XOFFCHAR => "xoff_char", |
XOFFLIM => "xoff_limit", |
XONCHAR => "xon_char", |
XONLIM => "xon_limit", |
intr => "is_stty_intr", |
quit => "is_stty_quit", |
s_eof => "is_stty_eof", |
eol => "is_stty_eol", |
erase => "is_stty_erase", |
s_kill => "is_stty_kill", |
bsdel => "stty_bsdel", |
clear => "is_stty_clear", |
echo => "stty_echo", |
echoe => "stty_echoe", |
echok => "stty_echok", |
echonl => "stty_echonl", |
echoke => "stty_echoke", |
echoctl => "stty_echoctl", |
istrip => "stty_istrip", |
icrnl => "stty_icrnl", |
ocrnl => "stty_ocrnl", |
opost => "stty_opost", |
igncr => "stty_igncr", |
inlcr => "stty_inlcr", |
onlcr => "stty_onlcr", |
isig => "stty_isig", |
icanon => "stty_icanon", |
DVTYPE => "devicetype", |
HNAME => "hostname", |
HADDR => "hostaddr", |
DATYPE => "datatype", |
CFG_1 => "cfg_param_1", |
CFG_2 => "cfg_param_2", |
CFG_3 => "cfg_param_3", |
); |
# parameters supported by the stty method |
my %opts = ( "intr" => "is_stty_intr:argv_char", |
"quit" => "is_stty_quit:argv_char", |
"eof" => "is_stty_eof:argv_char", |
"eol" => "is_stty_eol:argv_char", |
"erase" => "is_stty_erase:argv_char", |
"kill" => "is_stty_kill:argv_char", |
"echo" => "stty_echo:1", |
"-echo" => "stty_echo:0", |
"echoe" => "stty_echoe:1", |
"-echoe" => "stty_echoe:0", |
"echok" => "stty_echok:1", |
"-echok" => "stty_echok:0", |
"echonl" => "stty_echonl:1", |
"-echonl" => "stty_echonl:0", |
"echoke" => "stty_echoke:1", |
"-echoke" => "stty_echoke:0", |
"echoctl" => "stty_echoctl:1", |
"-echoctl" => "stty_echoctl:0", |
"istrip" => "stty_istrip:1", |
"-istrip" => "stty_istrip:0", |
"icrnl" => "stty_icrnl:1", |
"-icrnl" => "stty_icrnl:0", |
"ocrnl" => "stty_ocrnl:1", |
"-ocrnl" => "stty_ocrnl:0", |
"igncr" => "stty_igncr:1", |
"-igncr" => "stty_igncr:0", |
"inlcr" => "stty_inlcr:1", |
"-inlcr" => "stty_inlcr:0", |
"onlcr" => "stty_onlcr:1", |
"-onlcr" => "stty_onlcr:0", |
"opost" => "stty_opost:1", |
"-opost" => "stty_opost:0", |
"isig" => "stty_isig:1", |
"-isig" => "stty_isig:0", |
"icanon" => "stty_icanon:1", |
"-icanon" => "stty_icanon:0", |
"parenb" => "parity_enable:1", |
"-parenb" => "parity_enable:0", |
"inpck" => "parity_enable:1", |
"-inpck" => "parity:none", |
"cs5" => "databits:5", |
"cs6" => "databits:6", |
"cs7" => "databits:7", |
"cs8" => "databits:8", |
"cstopb" => "stopbits:2", |
"-cstopb" => "stopbits:1", |
"parodd" => "parity:odd", |
"-parodd" => "parity:even", |
"clocal" => "handshake:none", |
"-clocal" => "handshake:dtr", |
"crtscts" => "handshake:rts", |
"-crtscts" => "handshake:none", |
"ixon" => "handshake:xoff", |
"-ixon" => "handshake:none", |
"ixoff" => "handshake:xoff", |
"-ixoff" => "handshake:none", |
"start" => "xon_char:argv_char", |
"stop" => "xoff_char:argv_char", |
); |
#### Package variable declarations #### |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $cfg_file_sig="Win32::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
my $Verbose = 0; |
# test*.t only - suppresses default messages |
sub set_test_mode_active { |
return unless (@_ == 2); |
Win32API::CommPort->set_no_messages($_[1]); |
# object not defined but :: upsets strict |
return (keys %validate); |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $device = shift; |
my @new_cmd = ($device); |
my $quiet = shift; |
if ($quiet) { |
push @new_cmd, 1; |
} |
my $self = $class->SUPER::new(@new_cmd); |
unless ($self) { |
return 0 if ($quiet); |
return; |
} |
# "private" data |
$self->{"_DEBUG"} = 0; |
$self->{U_MSG} = 0; |
$self->{E_MSG} = 0; |
$self->{OFS} = ""; |
$self->{ORS} = ""; |
$self->{"_T_INPUT"} = ""; |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
$self->{"_LASTLINE"} = ""; |
$self->{"_CLASTLINE"} = ""; |
$self->{"_SIZE"} = 1; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
$self->{"_PROMPT"} = ""; |
$self->{"_MATCH"} = []; |
$self->{"_CMATCH"} = []; |
@{ $self->{"_MATCH"} } = "\n"; |
@{ $self->{"_CMATCH"} } = "\n"; |
$self->{DVTYPE} = "none"; |
$self->{HNAME} = "localhost"; |
$self->{HADDR} = 0; |
$self->{DATYPE} = "raw"; |
$self->{CFG_1} = "none"; |
$self->{CFG_2} = "none"; |
$self->{CFG_3} = "none"; |
# user settable options for lookfor (the "stty" collection) |
# defaults like RedHat linux unless indicated |
# char to abort nextline subroutine |
$self->{intr} = "\cC"; # MUST be single char |
# char to abort perl |
$self->{quit} = "\cD"; # MUST be single char |
# end_of_file char (linux typ: "\cD") |
$self->{s_eof} = "\cZ"; # MUST be single char |
# end_of_line char |
$self->{eol} = "\cJ"; # MUST be single char |
# delete one character from buffer (backspace) |
$self->{erase} = "\cH"; # MUST be single char |
# clear line buffer |
$self->{s_kill} = "\cU"; # MUST be single char |
# written after erase character |
$self->{bsdel} = "\cH \cH"; |
# written after kill character |
my $space76 = " "x76; |
$self->{clear} = "\r$space76\r"; # 76 spaces |
# echo every character |
$self->{echo} = 0; |
# echo erase character with bsdel string |
$self->{echoe} = 1; |
# echo \n after kill character |
$self->{echok} = 1; |
# echo \n |
$self->{echonl} = 0; |
# echo clear string after kill character |
$self->{echoke} = 1; # linux console yes, serial no |
# echo "^Char" for control chars |
$self->{echoctl} = 0; # linux console yes, serial no |
# strip input to 7-bits |
$self->{istrip} = 0; |
# map \r to \n on input |
$self->{icrnl} = 0; |
# map \r to \n on output |
$self->{ocrnl} = 0; |
# ignore \r on input |
$self->{igncr} = 0; |
# map \n to \r on input |
$self->{inlcr} = 0; |
# map \n to \r\n on output |
$self->{onlcr} = 1; |
# enable output mapping |
$self->{opost} = 0; |
# enable quit and intr characters |
$self->{isig} = 0; # linux actually SUPPORTS signals |
# enable erase and kill characters |
$self->{icanon} = 0; |
my $token; |
my @bauds = $self->are_baudrate; |
foreach $token (@bauds) { $opts{$token} = "baudrate:$token"; } |
# initialize (in CommPort) and write_settings need these defined |
$self->{"_N_U_MSG"} = 0; |
$self->{"_N_E_MSG"} = 0; |
$self->{"_N_ALIAS"} = 0; |
$self->{"_N_intr"} = 0; |
$self->{"_N_quit"} = 0; |
$self->{"_N_s_eof"} = 0; |
$self->{"_N_eol"} = 0; |
$self->{"_N_erase"} = 0; |
$self->{"_N_s_kill"} = 0; |
$self->{"_N_bsdel"} = 0; |
$self->{"_N_clear"} = 0; |
$self->{"_N_echo"} = 0; |
$self->{"_N_echoe"} = 0; |
$self->{"_N_echok"} = 0; |
$self->{"_N_echonl"} = 0; |
$self->{"_N_echoke"} = 0; |
$self->{"_N_echoctl"} = 0; |
$self->{"_N_istrip"} = 0; |
$self->{"_N_icrnl"} = 0; |
$self->{"_N_ocrnl"} = 0; |
$self->{"_N_opost"} = 0; |
$self->{"_N_igncr"} = 0; |
$self->{"_N_inlcr"} = 0; |
$self->{"_N_onlcr"} = 0; |
$self->{"_N_isig"} = 0; |
$self->{"_N_icanon"} = 0; |
$self->{"_N_DVTYPE"} = 0; |
$self->{"_N_HNAME"} = 0; |
$self->{"_N_HADDR"} = 0; |
$self->{"_N_DATYPE"} = 0; |
$self->{"_N_CFG_1"} = 0; |
$self->{"_N_CFG_2"} = 0; |
$self->{"_N_CFG_3"} = 0; |
$self->{ALIAS} = $device; # so "\\.\+++" can be changed |
$self->{DEVICE} = $device; # clone so NAME stays in CommPort |
($self->{MAX_RXB}, $self->{MAX_TXB}) = $self->buffer_max; |
bless ($self, $class); |
return $self; |
} |
sub stty_intr { |
my $self = shift; |
if (@_ == 1) { $self->{intr} = shift; } |
return if (@_); |
return $self->{intr}; |
} |
sub stty_quit { |
my $self = shift; |
if (@_ == 1) { $self->{quit} = shift; } |
return if (@_); |
return $self->{quit}; |
} |
sub is_stty_eof { |
my $self = shift; |
if (@_ == 1) { $self->{s_eof} = chr(shift); } |
return if (@_); |
return ord($self->{s_eof}); |
} |
sub is_stty_eol { |
my $self = shift; |
if (@_ == 1) { $self->{eol} = chr(shift); } |
return if (@_); |
return ord($self->{eol}); |
} |
sub is_stty_quit { |
my $self = shift; |
if (@_ == 1) { $self->{quit} = chr(shift); } |
return if (@_); |
return ord($self->{quit}); |
} |
sub is_stty_intr { |
my $self = shift; |
if (@_ == 1) { $self->{intr} = chr(shift); } |
return if (@_); |
return ord($self->{intr}); |
} |
sub is_stty_erase { |
my $self = shift; |
if (@_ == 1) { $self->{erase} = chr(shift); } |
return if (@_); |
return ord($self->{erase}); |
} |
sub is_stty_kill { |
my $self = shift; |
if (@_ == 1) { $self->{s_kill} = chr(shift); } |
return if (@_); |
return ord($self->{s_kill}); |
} |
sub is_stty_clear { |
my $self = shift; |
my @chars; |
if (@_ == 1) { |
@chars = split (//, shift); |
for (@chars) { |
$_ = chr ( ord($_) - 32 ); |
} |
$self->{clear} = join("", @chars); |
return $self->{clear}; |
} |
return if (@_); |
@chars = split (//, $self->{clear}); |
for (@chars) { |
$_ = chr ( ord($_) + 32 ); |
} |
my $permute = join("", @chars); |
return $permute; |
} |
sub stty_eof { |
my $self = shift; |
if (@_ == 1) { $self->{s_eof} = shift; } |
return if (@_); |
return $self->{s_eof}; |
} |
sub stty_eol { |
my $self = shift; |
if (@_ == 1) { $self->{eol} = shift; } |
return if (@_); |
return $self->{eol}; |
} |
sub stty_erase { |
my $self = shift; |
if (@_ == 1) { |
my $tmp = shift; |
return unless (length($tmp) == 1); |
$self->{erase} = $tmp; |
} |
return if (@_); |
return $self->{erase}; |
} |
sub stty_kill { |
my $self = shift; |
if (@_ == 1) { |
my $tmp = shift; |
return unless (length($tmp) == 1); |
$self->{s_kill} = $tmp; |
} |
return if (@_); |
return $self->{s_kill}; |
} |
sub stty_bsdel { |
my $self = shift; |
if (@_ == 1) { $self->{bsdel} = shift; } |
return if (@_); |
return $self->{bsdel}; |
} |
sub stty_clear { |
my $self = shift; |
if (@_ == 1) { $self->{clear} = shift; } |
return if (@_); |
return $self->{clear}; |
} |
sub stty_echo { |
my $self = shift; |
if (@_ == 1) { $self->{echo} = yes_true ( shift ) } |
return if (@_); |
return $self->{echo}; |
} |
sub stty_echoe { |
my $self = shift; |
if (@_ == 1) { $self->{echoe} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoe}; |
} |
sub stty_echok { |
my $self = shift; |
if (@_ == 1) { $self->{echok} = yes_true ( shift ) } |
return if (@_); |
return $self->{echok}; |
} |
sub stty_echonl { |
my $self = shift; |
if (@_ == 1) { $self->{echonl} = yes_true ( shift ) } |
return if (@_); |
return $self->{echonl}; |
} |
sub stty_echoke { |
my $self = shift; |
if (@_ == 1) { $self->{echoke} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoke}; |
} |
sub stty_echoctl { |
my $self = shift; |
if (@_ == 1) { $self->{echoctl} = yes_true ( shift ) } |
return if (@_); |
return $self->{echoctl}; |
} |
sub stty_istrip { |
my $self = shift; |
if (@_ == 1) { $self->{istrip} = yes_true ( shift ) } |
return if (@_); |
return $self->{istrip}; |
} |
sub stty_icrnl { |
my $self = shift; |
if (@_ == 1) { $self->{icrnl} = yes_true ( shift ) } |
return if (@_); |
return $self->{icrnl}; |
} |
sub stty_ocrnl { |
my $self = shift; |
if (@_ == 1) { $self->{ocrnl} = yes_true ( shift ) } |
return if (@_); |
return $self->{ocrnl}; |
} |
sub stty_opost { |
my $self = shift; |
if (@_ == 1) { $self->{opost} = yes_true ( shift ) } |
return if (@_); |
return $self->{opost}; |
} |
sub stty_igncr { |
my $self = shift; |
if (@_ == 1) { $self->{igncr} = yes_true ( shift ) } |
return if (@_); |
return $self->{igncr}; |
} |
sub stty_inlcr { |
my $self = shift; |
if (@_ == 1) { $self->{inlcr} = yes_true ( shift ) } |
return if (@_); |
return $self->{inlcr}; |
} |
sub stty_onlcr { |
my $self = shift; |
if (@_ == 1) { $self->{onlcr} = yes_true ( shift ) } |
return if (@_); |
return $self->{onlcr}; |
} |
sub stty_isig { |
my $self = shift; |
if (@_ == 1) { $self->{isig} = yes_true ( shift ) } |
return if (@_); |
return $self->{isig}; |
} |
sub stty_icanon { |
my $self = shift; |
if (@_ == 1) { $self->{icanon} = yes_true ( shift ) } |
return if (@_); |
return $self->{icanon}; |
} |
sub is_prompt { |
my $self = shift; |
if (@_ == 1) { $self->{"_PROMPT"} = shift; } |
return if (@_); |
return $self->{"_PROMPT"}; |
} |
sub are_match { |
my $self = shift; |
my $pat; |
my $patno = 0; |
my $reno = 0; |
my $re_next = 0; |
if (@_) { |
@{ $self->{"_MATCH"} } = @_; |
if ($] >= 5.005) { |
@{ $self->{"_CMATCH"} } = (); |
while ($pat = shift) { |
if ($re_next) { |
$re_next = 0; |
eval 'push (@{ $self->{"_CMATCH"} }, qr/$pat/)'; |
} else { |
push (@{ $self->{"_CMATCH"} }, $pat); |
} |
if ($pat eq "-re") { |
$re_next++; |
} |
} |
} else { |
@{ $self->{"_CMATCH"} } = @_; |
} |
} |
return @{ $self->{"_MATCH"} }; |
} |
# parse values for start/restart |
sub get_start_values { |
return unless (@_ == 2); |
my $self = shift; |
my $filename = shift; |
unless ( open CF, "<$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
my ($signature, $name, @values) = <CF>; |
close CF; |
unless ( $cfg_file_sig eq $signature ) { |
carp "Invalid signature in $filename: $signature"; |
return; |
} |
chomp $name; |
unless ( $self->{DEVICE} eq $name ) { |
carp "Invalid Port DEVICE=$self->{DEVICE} in $filename: $name"; |
return; |
} |
if ($Verbose or not $self) { |
print "signature = $signature"; |
print "name = $name\n"; |
if ($Verbose) { |
print "values:\n"; |
foreach (@values) { print " $_"; } |
} |
} |
my $item; |
my $key; |
my $value; |
my $gosub; |
my $fault = 0; |
no strict 'refs'; # for $gosub |
foreach $item (@values) { |
chomp $item; |
($key, $value) = split (/,/, $item); |
if ($value eq "") { $fault++ } |
else { |
$gosub = $validate{$key}; |
unless (defined &$gosub ($self, $value)) { |
carp "Invalid parameter for $key=$value "; |
return; |
} |
} |
} |
use strict 'refs'; |
if ($fault) { |
carp "Invalid value in $filename"; |
undef $self; |
return; |
} |
1; |
} |
sub restart { |
return unless (@_ == 2); |
my $self = shift; |
my $filename = shift; |
unless ( $self->init_done ) { |
carp "Can't restart before Port has been initialized"; |
return; |
} |
get_start_values($self, $filename); |
write_settings($self); |
} |
sub start { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
return unless (@_); |
my $filename = shift; |
unless ( open CF, "<$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
my ($signature, $name, @values) = <CF>; |
close CF; |
unless ( $cfg_file_sig eq $signature ) { |
carp "Invalid signature in $filename: $signature"; |
return; |
} |
chomp $name; |
my $self = new ($class, $name); |
if ($Verbose or not $self) { |
print "signature = $signature"; |
print "class = $class\n"; |
print "name = $name\n"; |
if ($Verbose) { |
print "values:\n"; |
foreach (@values) { print " $_"; } |
} |
} |
if ($self) { |
if ( get_start_values($self, $filename) ) { |
write_settings ($self); |
} |
else { |
carp "Invalid value in $filename"; |
undef $self; |
return; |
} |
} |
return $self; |
} |
sub write_settings { |
my $self = shift; |
my @items = keys %validate; |
# initialize returns number of faults |
if ( $self->initialize(@items) ) { |
unless (nocarp) { |
carp "write_settings failed, closing port"; |
$self->close; |
} |
return; |
} |
$self->update_DCB; |
if ($Verbose) { |
print "writing settings to $self->{ALIAS}\n"; |
} |
1; |
} |
sub save { |
my $self = shift; |
my $item; |
my $getsub; |
my $value; |
return unless (@_); |
unless ($self->init_done) { |
carp "can't save until init_done"; |
return; |
} |
my $filename = shift; |
unless ( open CF, ">$filename" ) { |
carp "can't open file: $filename"; |
return; |
} |
print CF "$cfg_file_sig"; |
print CF "$self->{DEVICE}\n"; |
# used to "reopen" so must be DEVICE=NAME |
no strict 'refs'; # for $gosub |
while (($item, $getsub) = each %validate) { |
chomp $getsub; |
$value = scalar &$getsub($self); |
print CF "$item,$value\n"; |
} |
use strict 'refs'; |
close CF; |
if ($Verbose) { |
print "wrote file $filename for $self->{ALIAS}\n"; |
} |
1; |
} |
##### tied FileHandle support |
sub TIEHANDLE { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
return unless (@_); |
my $self = start($class, shift); |
return $self; |
} |
# WRITE this, LIST |
# This method will be called when the handle is written to via the |
# syswrite function. |
sub WRITE { |
return if (@_ < 3); |
my $self = shift; |
my $buf = shift; |
my $len = shift; |
my $offset = 0; |
if (@_) { $offset = shift; } |
my $out2 = substr($buf, $offset, $len); |
return unless ($self->post_print($out2)); |
return length($out2); |
} |
# PRINT this, LIST |
# This method will be triggered every time the tied handle is printed to |
# with the print() function. Beyond its self reference it also expects |
# the list that was passed to the print function. |
sub PRINT { |
my $self = shift; |
return unless (@_); |
my $ofs = $, ? $, : ""; |
if ($self->{OFS}) { $ofs = $self->{OFS}; } |
my $ors = $\ ? $\ : ""; |
if ($self->{ORS}) { $ors = $self->{ORS}; } |
my $output = join($ofs,@_); |
$output .= $ors; |
return $self->post_print($output); |
} |
sub output_field_separator { |
my $self = shift; |
my $prev = $self->{OFS}; |
if (@_) { $self->{OFS} = shift; } |
return $prev; |
} |
sub output_record_separator { |
my $self = shift; |
my $prev = $self->{ORS}; |
if (@_) { $self->{ORS} = shift; } |
return $prev; |
} |
sub post_print { |
my $self = shift; |
return unless (@_); |
my $output = shift; |
if ($self->stty_opost) { |
if ($self->stty_ocrnl) { $output =~ s/\r/\n/osg; } |
if ($self->stty_onlcr) { $output =~ s/\n/\r\n/osg; } |
} |
my $to_do = length($output); |
my $done = 0; |
my $written = 0; |
while ($done < $to_do) { |
my $out2 = substr($output, $done); |
$written = $self->write($out2); |
if (! defined $written) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
return 0 unless ($written); |
$done += $written; |
} |
$^E = 0; |
1; |
} |
# PRINTF this, LIST |
# This method will be triggered every time the tied handle is printed to |
# with the printf() function. Beyond its self reference it also expects |
# the format and list that was passed to the printf function. |
sub PRINTF { |
my $self = shift; |
my $fmt = shift; |
return unless ($fmt); |
return unless (@_); |
my $output = sprintf($fmt, @_); |
$self->PRINT($output); |
} |
# READ this, LIST |
# This method will be called when the handle is read from via the read |
# or sysread functions. |
sub READ { |
return if (@_ < 3); |
my $buf = \$_[1]; |
my ($self, $junk, $len, $offset) = @_; |
unless (defined $offset) { $offset = 0; } |
my $done = 0; |
my $count_in = 0; |
my $string_in = ""; |
my $in2 = ""; |
my $bufsize = $self->internal_buffer; |
while ($done < $len) { |
my $size = $len - $done; |
if ($size > $bufsize) { $size = $bufsize; } |
($count_in, $string_in) = $self->read($size); |
if ($count_in) { |
$in2 .= $string_in; |
$done += $count_in; |
$^E = 0; |
} |
elsif ($done) { |
$^E = 0; |
last; |
} |
else { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
last; |
} |
} |
my $tail = substr($$buf, $offset + $done); |
my $head = substr($$buf, 0, $offset); |
if ($self->{icrnl}) { $in2 =~ tr/\r/\n/; } |
if ($self->{inlcr}) { $in2 =~ tr/\n/\r/; } |
if ($self->{igncr}) { $in2 =~ s/\r//gos; } |
$$buf = $head.$in2.$tail; |
return $done if ($done); |
return; |
} |
# READLINE this |
# This method will be called when the handle is read from via <HANDLE>. |
# The method should return undef when there is no more data. |
sub READLINE { |
my $self = shift; |
return if (@_); |
my $gotit = ""; |
my $match = ""; |
my $was; |
if (wantarray) { |
my @lines; |
for (;;) { |
$was = $self->reset_error; |
if ($was) { |
$^E = 1117; # ERROR_IO_DEVICE |
return @lines if (@lines); |
return; |
} |
if (! defined ($gotit = $self->streamline($self->{"_SIZE"}))) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return @lines if (@lines); |
return; |
} |
$match = $self->matchclear; |
if ( ($gotit ne "") || ($match ne "") ) { |
$^E = 0; |
$gotit .= $match; |
push (@lines, $gotit); |
return @lines if ($gotit =~ /$self->{"_CLASTLINE"}/s); |
} |
} |
} |
else { |
for (;;) { |
$was = $self->reset_error; |
if ($was) { |
$^E = 1117; # ERROR_IO_DEVICE |
return; |
} |
if (! defined ($gotit = $self->lookfor($self->{"_SIZE"}))) { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
$match = $self->matchclear; |
if ( ($gotit ne "") || ($match ne "") ) { |
$^E = 0; |
return $gotit.$match; # traditional <HANDLE> behavior |
} |
} |
} |
} |
# GETC this |
# This method will be called when the getc function is called. |
sub GETC { |
my $self = shift; |
my ($count, $in) = $self->read(1); |
if ($count == 1) { |
$^E = 0; |
return $in; |
} |
else { |
$^E = 1121; # ERROR_COUNTER_TIMEOUT |
return; |
} |
} |
# CLOSE this |
# This method will be called when the handle is closed via the close |
# function. |
sub CLOSE { |
my $self = shift; |
my $success = $self->close; |
if ($Verbose) { printf "CLOSE result:%d\n", $success; } |
return $success; |
} |
# DESTROY this |
# As with the other types of ties, this method will be called when the |
# tied handle is about to be destroyed. This is useful for debugging and |
# possibly cleaning up. |
sub DESTROY { |
my $self = shift; |
if ($Verbose) { print "SerialPort::DESTROY called.\n"; } |
$self->SUPER::DESTROY(); |
} |
############### |
sub alias { |
my $self = shift; |
if (@_) { $self->{ALIAS} = shift; } # should return true for legal names |
return $self->{ALIAS}; |
} |
sub user_msg { |
my $self = shift; |
if (@_) { $self->{U_MSG} = yes_true ( shift ) } |
return wantarray ? @binary_opt : $self->{U_MSG}; |
} |
sub error_msg { |
my $self = shift; |
if (@_) { $self->{E_MSG} = yes_true ( shift ) } |
return wantarray ? @binary_opt : $self->{E_MSG}; |
} |
sub devicetype { |
my $self = shift; |
if (@_) { $self->{DVTYPE} = shift; } # return true for legal names |
return $self->{DVTYPE}; |
} |
sub hostname { |
my $self = shift; |
if (@_) { $self->{HNAME} = shift; } # return true for legal names |
return $self->{HNAME}; |
} |
sub hostaddr { |
my $self = shift; |
if (@_) { $self->{HADDR} = shift; } # return true for assigned port |
return $self->{HADDR}; |
} |
sub datatype { |
my $self = shift; |
if (@_) { $self->{DATYPE} = shift; } # return true for legal types |
return $self->{DATYPE}; |
} |
sub cfg_param_1 { |
my $self = shift; |
if (@_) { $self->{CFG_1} = shift; } # return true for legal param |
return $self->{CFG_1}; |
} |
sub cfg_param_2 { |
my $self = shift; |
if (@_) { $self->{CFG_2} = shift; } # return true for legal param |
return $self->{CFG_2}; |
} |
sub cfg_param_3 { |
my $self = shift; |
if (@_) { $self->{CFG_3} = shift; } # return true for legal param |
return $self->{CFG_3}; |
} |
sub baudrate { |
my $self = shift; |
if (@_) { |
unless ( defined $self->is_baudrate( shift ) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set baudrate on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_baudrate : $self->is_baudrate; |
} |
sub status { |
my $self = shift; |
my $ok = 0; |
my $fmask = 0; |
my $v1 = $Verbose | $self->{"_DEBUG"}; |
my $v2 = $v1 | $self->{U_MSG}; |
my $v3 = $v1 | $self->{E_MSG}; |
my @stat = $self->is_status; |
return unless (scalar @stat); |
$fmask=$stat[ST_BLOCK]; |
if ($v1) { printf "BlockingFlags= %lx\n", $fmask; } |
if ($v2 && $fmask) { |
printf "Waiting for CTS\n" if ($fmask & BM_fCtsHold); |
printf "Waiting for DSR\n" if ($fmask & BM_fDsrHold); |
printf "Waiting for RLSD\n" if ($fmask & BM_fRlsdHold); |
printf "Waiting for XON\n" if ($fmask & BM_fXoffHold); |
printf "Waiting, XOFF was sent\n" if ($fmask & BM_fXoffSent); |
printf "End_of_File received\n" if ($fmask & BM_fEof); |
printf "Character waiting to TX\n" if ($fmask & BM_fTxim); |
} |
$fmask=$stat[ST_ERROR]; |
if ($v1) { printf "Error_BitMask= %lx\n", $fmask; } |
if ($v3 && $fmask) { |
# only prints if error is new (API resets each call) |
printf "Invalid MODE or bad HANDLE\n" if ($fmask & CE_MODE); |
printf "Receive Overrun detected\n" if ($fmask & CE_RXOVER); |
printf "Buffer Overrun detected\n" if ($fmask & CE_OVERRUN); |
printf "Parity Error detected\n" if ($fmask & CE_RXPARITY); |
printf "Framing Error detected\n" if ($fmask & CE_FRAME); |
printf "Break Signal detected\n" if ($fmask & CE_BREAK); |
printf "Transmit Buffer is full\n" if ($fmask & CE_TXFULL); |
} |
return @stat; |
} |
sub handshake { |
my $self = shift; |
if (@_) { |
unless ( $self->is_handshake(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set handshake on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_handshake : $self->is_handshake; |
} |
sub parity { |
my $self = shift; |
if (@_) { |
unless ( $self->is_parity(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set parity on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_parity : $self->is_parity; |
} |
sub databits { |
my $self = shift; |
if (@_) { |
unless ( $self->is_databits(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set databits on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_databits : $self->is_databits; |
} |
sub stopbits { |
my $self = shift; |
if (@_) { |
unless ( $self->is_stopbits(shift) ) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Could not set stopbits on $self->{ALIAS}"; |
} |
return; |
} |
} |
return wantarray ? $self->are_stopbits : $self->is_stopbits; |
} |
# single value for save/start |
sub set_read_buf { |
my $self = shift; |
if (@_) { |
return unless (@_ == 1); |
my $rbuf = int shift; |
return unless (($rbuf > 0) and ($rbuf <= $self->{MAX_RXB})); |
$self->is_read_buf($rbuf); |
} |
return $self->is_read_buf; |
} |
# single value for save/start |
sub set_write_buf { |
my $self = shift; |
if (@_) { |
return unless (@_ == 1); |
my $wbuf = int shift; |
return unless (($wbuf >= 0) and ($wbuf <= $self->{MAX_TXB})); |
$self->is_write_buf($wbuf); |
} |
return $self->is_write_buf; |
} |
sub buffers { |
my $self = shift; |
if (@_ == 2) { |
my $rbuf = shift; |
my $wbuf = shift; |
unless (defined set_read_buf ($self, $rbuf)) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Can't set read buffer on $self->{ALIAS}"; |
} |
return; |
} |
unless (defined set_write_buf ($self, $wbuf)) { |
if ($self->{U_MSG} or $Verbose) { |
carp "Can't set write buffer on $self->{ALIAS}"; |
} |
return; |
} |
$self->is_buffers($rbuf, $wbuf) || return; |
} |
elsif (@_) { return; } |
return wantarray ? $self->are_buffers : 1; |
} |
sub read { |
return unless (@_ == 2); |
my $self = shift; |
my $wanted = shift; |
my $ok = 0; |
my $result = ""; |
return unless ($wanted > 0); |
my $got = $self->read_bg ($wanted); |
if ($got != $wanted) { |
($ok, $got, $result) = $self->read_done(1); # block until done |
} |
else { ($ok, $got, $result) = $self->read_done(0); } |
print "read=$got\n" if ($Verbose); |
return ($got, $result); |
} |
sub lookclear { |
my $self = shift; |
if (nocarp && (@_ == 1)) { |
$self->{"_T_INPUT"} = shift; |
} |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
return if (@_); |
1; |
} |
sub linesize { |
my $self = shift; |
if (@_) { |
my $val = int shift; |
return if ($val < 0); |
$self->{"_SIZE"} = $val; |
} |
return $self->{"_SIZE"}; |
} |
sub lastline { |
my $self = shift; |
if (@_) { |
$self->{"_LASTLINE"} = shift; |
if ($] >= 5.005) { |
eval '$self->{"_CLASTLINE"} = qr/$self->{"_LASTLINE"}/'; |
} else { |
$self->{"_CLASTLINE"} = $self->{"_LASTLINE"}; |
} |
} |
return $self->{"_LASTLINE"}; |
} |
sub matchclear { |
my $self = shift; |
my $found = $self->{"_LMATCH"}; |
$self->{"_LMATCH"} = ""; |
return if (@_); |
return $found; |
} |
sub lastlook { |
my $self = shift; |
return if (@_); |
return ( $self->{"_LMATCH"}, $self->{"_LASTLOOK"}, |
$self->{"_LPATT"}, $self->{"_LOOK"} ); |
} |
sub lookfor { |
my $self = shift; |
my $size = 0; |
if (@_) { $size = shift; } |
my $loc = ""; |
my $count_in = 0; |
my $string_in = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
if ( ! $self->{"_LOOK"} ) { |
$loc = $self->{"_LASTLOOK"}; |
} |
if ($size) { |
my ($bbb, $iii, $ooo, $eee) = status($self); |
if ($iii > $size) { $size = $iii; } |
($count_in, $string_in) = $self->read($size); |
return unless ($count_in); |
$loc .= $string_in; |
} |
else { |
$loc .= $self->input; |
} |
if ($loc ne "") { |
if ($self->{icrnl}) { $loc =~ tr/\r/\n/; } |
my $n_char; |
my $mpos; |
my $erase_is_bsdel = 0; |
my $nl_after_kill = ""; |
my $clear_after_kill = 0; |
my $echo_ctl = 0; |
my $lookbuf; |
my $re_next = 0; |
my $got_match = 0; |
my $pat; |
my $lf_erase = ""; |
my $lf_kill = ""; |
my $lf_eof = ""; |
my $lf_quit = ""; |
my $lf_intr = ""; |
my $nl_2_crnl = 0; |
my $cr_2_nl = 0; |
if ($self->{opost}) { |
$nl_2_crnl = $self->{onlcr}; |
$cr_2_nl = $self->{ocrnl}; |
} |
if ($self->{echo}) { |
$erase_is_bsdel = $self->{echoe}; |
if ($self->{echok}) { |
$nl_after_kill = $self->{onlcr} ? "\r\n" : "\n"; |
} |
$clear_after_kill = $self->{echoke}; |
$echo_ctl = $self->{echoctl}; |
} |
if ($self->{icanon}) { |
$lf_erase = $self->{erase}; |
$lf_kill = $self->{s_kill}; |
$lf_eof = $self->{s_eof}; |
} |
if ($self->{isig}) { |
$lf_quit = $self->{quit}; |
$lf_intr = $self->{intr}; |
} |
my @loc_char = split (//, $loc); |
while (defined ($n_char = shift @loc_char)) { |
## printf STDERR "0x%x ", ord($n_char); |
if ($n_char eq $lf_erase) { |
if ($erase_is_bsdel && (length $self->{"_LOOK"}) ) { |
$mpos = chop $self->{"_LOOK"}; |
$self->write($self->{bsdel}); |
if ($echo_ctl && (($mpos lt "@")|($mpos eq chr(127)))) { |
$self->write($self->{bsdel}); |
} |
} |
} |
elsif ($n_char eq $lf_kill) { |
$self->{"_LOOK"} = ""; |
$self->write($self->{clear}) if ($clear_after_kill); |
$self->write($nl_after_kill); |
$self->write($self->{"_PROMPT"}); |
} |
elsif ($n_char eq $lf_intr) { |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
return; |
} |
elsif ($n_char eq $lf_quit) { |
exit; |
} |
else { |
$mpos = ord $n_char; |
if ($self->{istrip}) { |
if ($mpos > 127) { $n_char = chr($mpos - 128); } |
} |
$self->{"_LOOK"} .= $n_char; |
## print $n_char; |
if ($cr_2_nl) { $n_char =~ s/\r/\n/os; } |
if ($nl_2_crnl) { $n_char =~ s/\n/\r\n/os; } |
if (($mpos < 32) && $echo_ctl && |
($mpos != is_stty_eol($self))) { |
$n_char = chr($mpos + 64); |
$self->write("^$n_char"); |
} |
elsif (($mpos == 127) && $echo_ctl) { |
$self->write("^."); |
} |
elsif ($self->{echonl} && ($n_char =~ "\n")) { |
# also writes "\r\n" for onlcr |
$self->write($n_char); |
} |
elsif ($self->{echo}) { |
# also writes "\r\n" for onlcr |
$self->write($n_char); |
} |
$lookbuf = $self->{"_LOOK"}; |
if (($lf_eof ne "") and ($lookbuf =~ /$lf_eof$/)) { |
$self->{"_LOOK"} = ""; |
$self->{"_LASTLOOK"} = ""; |
return $lookbuf; |
} |
$count_in = 0; |
foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
if ($pat eq "-re") { |
$re_next++; |
$count_in++; |
next; |
} |
if ($re_next) { |
$re_next = 0; |
# always at $lookbuf end when processing single char |
if ( $lookbuf =~ s/$pat//s ) { |
$self->{"_LMATCH"} = $&; |
$got_match++; |
} |
} |
elsif (($mpos = index($lookbuf, $pat)) > -1) { |
$got_match++; |
$lookbuf = substr ($lookbuf, 0, $mpos); |
$self->{"_LMATCH"} = $pat; |
} |
if ($got_match) { |
$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
if (scalar @loc_char) { |
$self->{"_LASTLOOK"} = join("", @loc_char); |
## print ".$self->{\"_LASTLOOK\"}."; |
} |
else { |
$self->{"_LASTLOOK"} = ""; |
} |
$self->{"_LOOK"} = ""; |
return $lookbuf; |
} |
$count_in++; |
} |
} |
} |
} |
return ""; |
} |
sub streamline { |
my $self = shift; |
my $size = 0; |
if (@_) { $size = shift; } |
my $loc = ""; |
my $mpos; |
my $count_in = 0; |
my $string_in = ""; |
my $re_next = 0; |
my $got_match = 0; |
my $best_pos = 0; |
my $pat; |
my $match = ""; |
my $before = ""; |
my $after = ""; |
my $best_match = ""; |
my $best_before = ""; |
my $best_after = ""; |
my $best_pat = ""; |
$self->{"_LMATCH"} = ""; |
$self->{"_LPATT"} = ""; |
if ( ! $self->{"_LOOK"} ) { |
$loc = $self->{"_LASTLOOK"}; |
} |
if ($size) { |
my ($bbb, $iii, $ooo, $eee) = status($self); |
if ($iii > $size) { $size = $iii; } |
($count_in, $string_in) = $self->read($size); |
return unless ($count_in); |
$loc .= $string_in; |
} |
else { |
$loc .= $self->input; |
} |
if ($loc ne "") { |
$self->{"_LOOK"} .= $loc; |
$count_in = 0; |
foreach $pat ( @{ $self->{"_CMATCH"} } ) { |
if ($pat eq "-re") { |
$re_next++; |
$count_in++; |
next; |
} |
if ($re_next) { |
$re_next = 0; |
if ( $self->{"_LOOK"} =~ /$pat/s ) { |
( $match, $before, $after ) = ( $&, $`, $' ); |
$got_match++; |
$mpos = length($before); |
if ($mpos) { |
next if ($best_pos && ($mpos > $best_pos)); |
$best_pos = $mpos; |
$best_pat = $self->{"_MATCH"}[$count_in]; |
$best_match = $match; |
$best_before = $before; |
$best_after = $after; |
} else { |
$self->{"_LPATT"} = $self->{"_MATCH"}[$count_in]; |
$self->{"_LMATCH"} = $match; |
$self->{"_LASTLOOK"} = $after; |
$self->{"_LOOK"} = ""; |
return $before; |
# pattern at start will be best |
} |
} |
} |
elsif (($mpos = index($self->{"_LOOK"}, $pat)) > -1) { |
$got_match++; |
$before = substr ($self->{"_LOOK"}, 0, $mpos); |
if ($mpos) { |
next if ($best_pos && ($mpos > $best_pos)); |
$best_pos = $mpos; |
$best_pat = $pat; |
$best_match = $pat; |
$best_before = $before; |
$mpos += length($pat); |
$best_after = substr ($self->{"_LOOK"}, $mpos); |
} else { |
$self->{"_LPATT"} = $pat; |
$self->{"_LMATCH"} = $pat; |
$before = substr ($self->{"_LOOK"}, 0, $mpos); |
$mpos += length($pat); |
$self->{"_LASTLOOK"} = substr ($self->{"_LOOK"}, $mpos); |
$self->{"_LOOK"} = ""; |
return $before; |
# match at start will be best |
} |
} |
$count_in++; |
} |
if ($got_match) { |
$self->{"_LPATT"} = $best_pat; |
$self->{"_LMATCH"} = $best_match; |
$self->{"_LASTLOOK"} = $best_after; |
$self->{"_LOOK"} = ""; |
return $best_before; |
} |
} |
return ""; |
} |
sub input { |
return unless (@_ == 1); |
my $self = shift; |
my $result = ""; |
if (nocarp && $self->{"_T_INPUT"}) { |
$result = $self->{"_T_INPUT"}; |
$self->{"_T_INPUT"} = ""; |
return $result; |
} |
my $ok = 0; |
my $got_p = " "x4; |
my ($bbb, $wanted, $ooo, $eee) = status($self); |
return "" if ($eee); |
return "" unless $wanted; |
my $got = $self->read_bg ($wanted); |
if ($got != $wanted) { |
# block if unexpected happens |
($ok, $got, $result) = $self->read_done(1); # block until done |
} |
else { ($ok, $got, $result) = $self->read_done(0); } |
### print "input: got= $got result=$result\n"; |
return $got ? $result : ""; |
} |
sub write { |
return unless (@_ == 2); |
my $self = shift; |
my $wbuf = shift; |
my $ok = 1; |
return 0 if ($wbuf eq ""); |
my $lbuf = length ($wbuf); |
my $written = $self->write_bg ($wbuf); |
if ($written != $lbuf) { |
($ok, $written) = $self->write_done(1); # block until done |
} |
if ($Verbose) { |
print "wbuf=$wbuf\n"; |
print "lbuf=$lbuf\n"; |
print "written=$written\n"; |
} |
return unless ($ok); |
return $written; |
} |
sub transmit_char { |
my $self = shift; |
return unless (@_ == 1); |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
return unless $self->xmit_imm_char ($v); |
return wantarray ? @byte_opt : 1; |
} |
sub xon_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_xon_char($v); |
} |
return wantarray ? @byte_opt : $self->is_xon_char; |
} |
sub xoff_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_xoff_char($v); |
} |
return wantarray ? @byte_opt : $self->is_xoff_char; |
} |
sub eof_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_eof_char($v); |
} |
return wantarray ? @byte_opt : $self->is_eof_char; |
} |
sub event_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_event_char($v); |
} |
return wantarray ? @byte_opt : $self->is_event_char; |
} |
sub error_char { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > 255)); |
$self->is_error_char($v); |
} |
return wantarray ? @byte_opt : $self->is_error_char; |
} |
sub xon_limit { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->is_xon_limit($v); |
} |
return wantarray ? (0, SHORTsize) : $self->is_xon_limit; |
} |
sub xoff_limit { |
my $self = shift; |
if (@_ == 1) { |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->is_xoff_limit($v); |
} |
return wantarray ? (0, SHORTsize) : $self->is_xoff_limit; |
} |
sub read_interval { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_interval( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_interval; |
} |
sub read_char_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_char_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_char_time; |
} |
sub read_const_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_read_const_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_read_const_time; |
} |
sub write_const_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_write_const_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_write_const_time; |
} |
sub write_char_time { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_write_char_time( shift ); |
} |
return wantarray ? (0, LONGsize) : $self->is_write_char_time; |
} |
# true/false parameters |
sub binary { |
my $self = shift; |
if (@_) { |
return unless defined $self->is_binary( shift ); |
} |
return $self->is_binary; |
} |
sub parity_enable { |
my $self = shift; |
if (@_) { |
if ( $self->can_parity_enable ) { |
$self->is_parity_enable( shift ); |
} |
elsif ($self->{U_MSG}) { |
carp "Can't set parity enable on $self->{ALIAS}"; |
} |
} |
return $self->is_parity_enable; |
} |
sub modemlines { |
return unless (@_ == 1); |
my $self = shift; |
my $result = $self->is_modemlines; |
if ($Verbose) { |
print "CTS is ON\n" if ($result & MS_CTS_ON); |
print "DSR is ON\n" if ($result & MS_DSR_ON); |
print "RING is ON\n" if ($result & MS_RING_ON); |
print "RLSD is ON\n" if ($result & MS_RLSD_ON); |
} |
return $result; |
} |
sub stty { |
my $ob = shift; |
my $token; |
if (@_) { |
my $ok = 1; |
no strict 'refs'; # for $gosub |
while ($token = shift) { |
if (exists $opts{$token}) { |
## print " $opts{$token}\n"; |
my ($gosub, $value) = split (':', $opts{$token}); |
if ($value eq "argv_char") { $value = &argv_char(shift); } |
if (defined $value) { |
&$gosub($ob, $value); |
} else { |
nocarp or carp "bad value for parameter $token\n"; |
$ok = 0; |
} |
} |
else { |
nocarp or carp "parameter $token not found\n"; |
$ok = 0; |
} |
} |
use strict 'refs'; |
return $ok; |
} |
else { |
my @settings; # array returned by () |
my $current = $ob->baudrate; |
push @settings, "$current"; |
push @settings, "intr"; |
push @settings, cntl_char($ob->stty_intr); |
push @settings, "quit"; |
push @settings, cntl_char($ob->stty_quit); |
push @settings, "erase"; |
push @settings, cntl_char($ob->stty_erase); |
push @settings, "kill"; |
push @settings, cntl_char($ob->stty_kill); |
push @settings, "eof"; |
push @settings, cntl_char($ob->stty_eof); |
push @settings, "eol"; |
push @settings, cntl_char($ob->stty_eol); |
push @settings, "start"; |
push @settings, cntl_char(chr $ob->xon_char); |
push @settings, "stop"; |
push @settings, cntl_char(chr $ob->xoff_char); |
# "stop" is last CHAR type |
push @settings, ($ob->stty_echo ? "" : "-")."echo"; |
push @settings, ($ob->stty_echoe ? "" : "-")."echoe"; |
push @settings, ($ob->stty_echok ? "" : "-")."echok"; |
push @settings, ($ob->stty_echonl ? "" : "-")."echonl"; |
push @settings, ($ob->stty_echoke ? "" : "-")."echoke"; |
push @settings, ($ob->stty_echoctl ? "" : "-")."echoctl"; |
push @settings, ($ob->stty_istrip ? "" : "-")."istrip"; |
push @settings, ($ob->stty_icrnl ? "" : "-")."icrnl"; |
push @settings, ($ob->stty_ocrnl ? "" : "-")."ocrnl"; |
push @settings, ($ob->stty_igncr ? "" : "-")."igncr"; |
push @settings, ($ob->stty_inlcr ? "" : "-")."inlcr"; |
push @settings, ($ob->stty_onlcr ? "" : "-")."onlcr"; |
push @settings, ($ob->stty_opost ? "" : "-")."opost"; |
push @settings, ($ob->stty_isig ? "" : "-")."isig"; |
push @settings, ($ob->stty_icanon ? "" : "-")."icanon"; |
$current = $ob->databits; |
push @settings, "cs$current"; |
push @settings, (($ob->stopbits == 2) ? "" : "-")."cstopb"; |
$current = $ob->handshake; |
push @settings, (($current eq "dtr") ? "" : "-")."clocal"; |
push @settings, (($current eq "rts") ? "" : "-")."crtscts"; |
push @settings, (($current eq "xoff") ? "" : "-")."ixoff"; |
push @settings, (($current eq "xoff") ? "" : "-")."ixon"; |
my $parity = $ob->parity; |
if ($parity eq "none") { |
push @settings, "-parenb"; |
push @settings, "-parodd"; |
push @settings, "-inpck"; |
} |
else { |
$current = $ob->is_parity_enable; |
push @settings, ($current ? "" : "-")."parenb"; |
push @settings, (($parity eq "odd") ? "" : "-")."parodd"; |
push @settings, ($current ? "" : "-")."inpck"; |
# mark and space not supported |
} |
return @settings; |
} |
} |
sub cntl_char { |
my $n_char = shift; |
return "<undef>" unless (defined $n_char); |
my $pos = ord $n_char; |
if ($pos < 32) { |
$n_char = "^".chr($pos + 64); |
} |
if ($pos > 126) { |
$n_char = sprintf "0x%x", $pos; |
} |
return $n_char; |
} |
sub argv_char { |
my $n_char = shift; |
return unless (defined $n_char); |
my $pos = $n_char; |
if ($n_char =~ s/^\^//) { |
$pos = ord($n_char) - 64; |
} |
elsif ($n_char =~ s/^0x//) { |
$pos = hex($n_char); |
} |
elsif ($n_char =~ /^0/) { |
$pos = oct($n_char); |
} |
## print "pos = $pos\n"; |
return $pos; |
} |
sub debug { |
my $self = shift; |
if (ref($self)) { |
if (@_) { $self->{"_DEBUG"} = yes_true ( shift ); } |
else { |
my $tmp = $self->{"_DEBUG"}; |
nocarp || carp "Debug level: $self->{ALIAS} = $tmp"; |
$self->debug_comm($tmp); |
return $self->{"_DEBUG"}; |
} |
} else { |
$Verbose = yes_true ($self); |
nocarp || carp "SerialPort Debug Class = $Verbose"; |
Win32API::CommPort::debug_comm($Verbose); |
return $Verbose; |
} |
} |
sub close { |
my $self = shift; |
return unless (defined $self->{ALIAS}); |
if ($Verbose or $self->{"_DEBUG"}) { |
carp "Closing $self " . $self->{ALIAS}; |
} |
my $success = $self->SUPER::close; |
$self->{DEVICE} = undef; |
$self->{ALIAS} = undef; |
if ($Verbose) { |
printf "SerialPort close result:%d\n", $success; |
} |
return $success; |
} |
1; # so the require or use succeeds |
# Autoload methods go after =cut, and are processed by the autosplit program. |
__END__ |
=pod |
=head1 NAME |
Win32::SerialPort - User interface to Win32 Serial API calls |
=head1 SYNOPSIS |
require 5.003; |
use Win32::SerialPort qw( :STAT 0.19 ); |
=head2 Constructors |
$PortObj = new Win32::SerialPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
$PortObj = start Win32::SerialPort ($Configuration_File_Name) |
|| die "Can't start $Configuration_File_Name: $^E\n"; |
$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die "Can't tie using $Configuration_File_Name: $^E\n"; |
=head2 Configuration Utility Methods |
$PortObj->alias("MODEM1"); |
# before using start, restart, or tie |
$PortObj->save($Configuration_File_Name) |
|| warn "Can't save $Configuration_File_Name: $^E\n"; |
# after new, must check for failure |
$PortObj->write_settings || undef $PortObj; |
print "Can't change Device_Control_Block: $^E\n" unless ($PortObj); |
# rereads file to either return open port to a known state |
# or switch to a different configuration on the same port |
$PortObj->restart($Configuration_File_Name) |
|| warn "Can't reread $Configuration_File_Name: $^E\n"; |
# "app. variables" saved in $Configuration_File, not used internally |
$PortObj->devicetype('none'); # CM11, CM17, 'weeder', 'modem' |
$PortObj->hostname('localhost'); # for socket-based implementations |
$PortObj->hostaddr(0); # false unless specified |
$PortObj->datatype('raw'); # in case an application needs_to_know |
$PortObj->cfg_param_1('none'); # null string '' hard to save/restore |
$PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
$PortObj->cfg_param_3('none'); # one may end up as a log file path |
# specials for test suite only |
@necessary_param = Win32::SerialPort->set_test_mode_active(1); |
$PortObj->lookclear("loopback to next 'input' method"); |
=head2 Configuration Parameter Methods |
# most methods can be called three ways: |
$PortObj->handshake("xoff"); # set parameter |
$flowcontrol = $PortObj->handshake; # current value (scalar) |
@handshake_opts = $PortObj->handshake; # permitted choices (list) |
# similar |
$PortObj->baudrate(9600); |
$PortObj->parity("odd"); |
$PortObj->databits(8); |
$PortObj->stopbits(1); |
# range parameters return (minimum, maximum) in list context |
$PortObj->xon_limit(100); # bytes left in buffer |
$PortObj->xoff_limit(100); # space left in buffer |
$PortObj->xon_char(0x11); |
$PortObj->xoff_char(0x13); |
$PortObj->eof_char(0x0); |
$PortObj->event_char(0x0); |
$PortObj->error_char(0); # for parity errors |
$PortObj->buffers(4096, 4096); # read, write |
# returns current in list context |
$PortObj->read_interval(100); # max time between read char (milliseconds) |
$PortObj->read_char_time(5); # avg time between read char |
$PortObj->read_const_time(100); # total = (avg * bytes) + const |
$PortObj->write_char_time(5); |
$PortObj->write_const_time(100); |
# true/false parameters (return scalar context only) |
$PortObj->binary(T); # just say Yes (Win 3.x option) |
$PortObj->parity_enable(F); # faults during input |
$PortObj->debug(0); |
=head2 Operating Methods |
($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->status |
|| warn "could not get port status\n"; |
if ($BlockingFlags) { warn "Port is blocked"; } |
if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
# The API resets errors when reading status, $LatchErrorFlags |
# is all $ErrorFlags seen since the last reset_error |
Additional useful constants may be exported eventually. If the only fault |
action desired is a message, B<status> provides I<Built-In> BitMask processing: |
$PortObj->error_msg(1); # prints hardware messages like "Framing Error" |
$PortObj->user_msg(1); # prints function messages like "Waiting for CTS" |
($count_in, $string_in) = $PortObj->read($InBytes); |
warn "read unsuccessful\n" unless ($count_in == $InBytes); |
$count_out = $PortObj->write($output_string); |
warn "write failed\n" unless ($count_out); |
warn "write incomplete\n" if ( $count_out != length($output_string) ); |
if ($string_in = $PortObj->input) { PortObj->write($string_in); } |
# simple echo with no control character processing |
$PortObj->transmit_char(0x03); # bypass buffer (and suspend) |
$ModemStatus = $PortObj->modemlines; |
if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
=head2 Methods used with Tied FileHandles |
$PortObj = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die "Can't tie: $^E\n"; ## TIEHANDLE ## |
print FH "text"; ## PRINT ## |
$char = getc FH; ## GETC ## |
syswrite FH, $out, length($out), 0; ## WRITE ## |
$line = <FH>; ## READLINE ## |
@lines = <FH>; ## READLINE ## |
printf FH "received: %s", $line; ## PRINTF ## |
read (FH, $in, 5, 0) or die "$^E"; ## READ ## |
sysread (FH, $in, 5, 0) or die "$^E"; ## READ ## |
close FH || warn "close failed"; ## CLOSE ## |
undef $PortObj; |
untie *FH; ## DESTROY ## |
$PortObj->linesize(10); # with READLINE |
$PortObj->lastline("_GOT_ME_"); # with READLINE, list only |
$old_ors = $PortObj->output_record_separator("RECORD"); # with PRINT |
$old_ofs = $PortObj->output_field_separator("COMMA"); # with PRINT |
=head2 Destructors |
$PortObj->close || warn "close failed"; |
# passed to CommPort to release port to OS - needed to reopen |
# close will not usually DESTROY the object |
# also called as: close FH || warn "close failed"; |
undef $PortObj; |
# preferred unless reopen expected since it triggers DESTROY |
# calls $PortObj->close but does not confirm success |
# MUST precede untie - do all three IN THIS SEQUENCE before re-tie. |
untie *FH; |
=head2 Methods for I/O Processing |
$PortObj->are_match("text", "\n"); # possible end strings |
$PortObj->lookclear; # empty buffers |
$PortObj->write("Feed Me:"); # initial prompt |
$PortObj->is_prompt("More Food:"); # new prompt after "kill" char |
my $gotit = ""; |
my $match1 = ""; |
until ("" ne $gotit) { |
$gotit = $PortObj->lookfor; # poll until data ready |
die "Aborted without match\n" unless (defined $gotit); |
last if ($gotit); |
$match1 = $PortObj->matchclear; # match is first thing received |
last if ($match1); |
sleep 1; # polling sample time |
} |
printf "gotit = %s\n", $gotit; # input BEFORE the match |
my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
# input that MATCHED, input AFTER the match, PATTERN that matched |
# input received INSTEAD when timeout without match |
if ($match1) { |
$match = $match1; |
} |
printf "lastlook-match = %s -after = %s -pattern = %s\n", |
$match, $after, $pattern; |
$gotit = $PortObj->lookfor($count); # block until $count chars received |
$PortObj->are_match("-re", "pattern", "text"); |
# possible match strings: "pattern" is a regular expression, |
# "text" is a literal string |
$gotit = $PortObj->streamline; # poll until data ready |
$gotit = $PortObj->streamline($count);# block until $count chars received |
# fast alternatives to lookfor with no character processing |
$PortObj->stty_intr("\cC"); # char to abort lookfor method |
$PortObj->stty_quit("\cD"); # char to abort perl |
$PortObj->stty_eof("\cZ"); # end_of_file char |
$PortObj->stty_eol("\cJ"); # end_of_line char |
$PortObj->stty_erase("\cH"); # delete one character from buffer (backspace) |
$PortObj->stty_kill("\cU"); # clear line buffer |
$PortObj->is_stty_intr(3); # ord(char) to abort lookfor method |
$qc = $PortObj->is_stty_quit; # ($qc == 4) for "\cD" |
$PortObj->is_stty_eof(26); |
$PortObj->is_stty_eol(10); |
$PortObj->is_stty_erase(8); |
$PortObj->is_stty_kill(21); |
my $air = " "x76; |
$PortObj->stty_clear("\r$air\r"); # written after kill character |
$PortObj->is_stty_clear; # internal version for config file |
$PortObj->stty_bsdel("\cH \cH"); # written after erase character |
$PortObj->stty_echo(0); # echo every character |
$PortObj->stty_echoe(1); # if echo erase character with bsdel string |
$PortObj->stty_echok(1); # if echo \n after kill character |
$PortObj->stty_echonl(0); # if echo \n |
$PortObj->stty_echoke(1); # if echo clear string after kill character |
$PortObj->stty_echoctl(0); # if echo "^Char" for control chars |
$PortObj->stty_istrip(0); # strip input to 7-bits |
$PortObj->stty_icrnl(0); # map \r to \n on input |
$PortObj->stty_ocrnl(0); # map \r to \n on output |
$PortObj->stty_igncr(0); # ignore \r on input |
$PortObj->stty_inlcr(0); # map \n to \r on input |
$PortObj->stty_onlcr(1); # map \n to \r\n on output |
$PortObj->stty_opost(0); # enable output mapping |
$PortObj->stty_isig(0); # enable quit and intr characters |
$PortObj->stty_icanon(0); # enable erase and kill characters |
$PortObj->stty("-icanon"); # disable eof, erase and kill char, Unix-style |
@stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
=head2 Capability Methods inherited from Win32API::CommPort |
These return scalar context only. |
can_baud can_databits can_stopbits |
can_dtrdsr can_handshake can_parity_check |
can_parity_config can_parity_enable can_rlsd |
can_16bitmode is_rs232 is_modem |
can_rtscts can_xonxoff can_xon_char |
can_spec_char can_interval_timeout can_total_timeout |
buffer_max can_rlsd_config |
=head2 Operating Methods inherited from Win32API::CommPort |
write_bg write_done read_bg |
read_done reset_error suspend_tx |
resume_tx dtr_active rts_active |
break_active xoff_active xon_active |
purge_all purge_rx purge_tx |
pulse_rts_on pulse_rts_off pulse_dtr_on |
pulse_dtr_off ignore_null ignore_no_dsr |
subst_pe_char abort_on_error output_xoff |
output_dsr output_cts tx_on_xoff |
input_xoff get_tick_count |
=head1 DESCRIPTION |
This module uses Win32API::CommPort for raw access to the API calls and |
related constants. It provides an object-based user interface to allow |
higher-level use of common API call sequences for dealing with serial |
ports. |
Uses features of the Win32 API to implement non-blocking I/O, serial |
parameter setting, event-loop operation, and enhanced error handling. |
To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
This is expected to change to an empty list reference, C<[]>, when Perl |
supports that form in this usage. |
=head2 Initialization |
The primary constructor is B<new> with a F<PortName> (as the Registry |
knows it) specified. This will create an object, and get the available |
options and capabilities via the Win32 API. The object is a superset |
of a B<Win32API::CommPort> object, and supports all of its methods. |
The port is not yet ready for read/write access. First, the desired |
I<parameter settings> must be established. Since these are tuning |
constants for an underlying hardware driver in the Operating System, |
they are all checked for validity by the methods that set them. The |
B<write_settings> method writes a new I<Device Control Block> to the |
driver. The B<write_settings> method will return true if the port is |
ready for access or C<undef> on failure. Ports are opened for binary |
transfers. A separate C<binmode> is not needed. The USER must release |
the object if B<write_settings> does not succeed. |
Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
to open a port prints a error message to STDOUT by default. Since only |
one application at a time can "own" the port, one source of failure was |
"port in use". There was previously no way to check this without getting |
a "fail message". Setting C<$quiet> disables this built-in message. It |
also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
used for testing this condition - other faults may still return C<undef>). |
Use of C<$quiet> only applies to B<new>. |
=over 8 |
Certain parameters I<MUST> be set before executing B<write_settings>. |
Others will attempt to deduce defaults from the hardware or from other |
parameters. The I<Required> parameters are: |
=item baudrate |
Any legal value. |
=item parity |
One of the following: "none", "odd", "even", "mark", "space". |
If you select anything except "none", you will need to set B<parity_enable>. |
=item databits |
An integer from 5 to 8. |
=item stopbits |
Legal values are 1, 1.5, and 2. But 1.5 only works with 5 databits, 2 does |
not work with 5 databits, and other combinations may not work on all |
hardware if parity is also used. |
=back |
The B<handshake> setting is recommended but no longer required. Select one |
of the following: "none", "rts", "xoff", "dtr". |
Some individual parameters (eg. baudrate) can be changed after the |
initialization is completed. These will be validated and will |
update the I<Device Control Block> as required. The B<save> |
method will write the current parameters to a file that B<start, tie,> and |
B<restart> can use to reestablish a functional setup. |
$PortObj = new Win32::SerialPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
$PortObj->user_msg(ON); |
$PortObj->databits(8); |
$PortObj->baudrate(9600); |
$PortObj->parity("none"); |
$PortObj->stopbits(1); |
$PortObj->handshake("rts"); |
$PortObj->buffers(4096, 4096); |
$PortObj->write_settings || undef $PortObj; |
$PortObj->save($Configuration_File_Name); |
$PortObj->baudrate(300); |
$PortObj->restart($Configuration_File_Name); # back to 9600 baud |
$PortObj->close || die "failed to close"; |
undef $PortObj; # frees memory back to perl |
The F<PortName> maps to both the Registry I<Device Name> and the |
I<Properties> associated with that device. A single I<Physical> port |
can be accessed using two or more I<Device Names>. But the options |
and setup data will differ significantly in the two cases. A typical |
example is a Modem on port "COM2". Both of these F<PortNames> open |
the same I<Physical> hardware: |
$P1 = new Win32::SerialPort ("COM2"); |
$P2 = new Win32::SerialPort ("\\\\.\\Nanohertz Modem model K-9"); |
$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
of modem-specific added options and features. The "raw" API calls return |
different size configuration structures in the two cases. Win32 uses the |
"\\.\" prefix to identify "named" devices. Since both names use the same |
I<Physical> hardware, they can not both be used at the same time. The OS |
will complain. Consider this A Good Thing. Use B<alias> to convert the |
name used by "built-in" messages. |
$P2->alias("FIDO"); |
The second constructor, B<start> is intended to simplify scripts which |
need a constant setup. It executes all the steps from B<new> to |
B<write_settings> based on a previously saved configuration. This |
constructor will return C<undef> on a bad configuration file or failure |
of a validity check. The returned object is ready for access. |
$PortObj2 = start Win32::SerialPort ($Configuration_File_Name) |
|| die; |
The third constructor, B<tie>, combines the B<start> with Perl's |
support for tied FileHandles (see I<perltie>). Win32::SerialPort |
implements the complete set of methods: TIEHANDLE, PRINT, PRINTF, |
WRITE, READ, GETC, READLINE, CLOSE, and DESTROY. Tied FileHandle |
support was new with Version 0.14. |
$PortObj2 = tie (*FH, 'Win32::SerialPort', $Configuration_File_Name) |
|| die; |
The implementation attempts to mimic STDIN/STDOUT behaviour as closely |
as possible: calls block until done, data strings that exceed internal |
buffers are divided transparently into multiple calls, and B<stty_onlcr> |
and B<stty_ocrnl> are applied to output data (WRITE, PRINT, PRINTF) when |
B<stty_opost> is true. In Version 0.17, the output separators C<$,> and |
C<$\> are also applied to PRINT if set. Since PRINTF is treated internally |
as a single record PRINT, C<$\> will be applied. Output separators are not |
applied to WRITE (called as C<syswrite FH, $scalar, $length, [$offset]>). |
The B<output_record_separator> and B<output_field_separator> methods can set |
I<Port-FileHandle-Specific> versions of C<$,> and C<$\> if desired. |
The input_record_separator C<$/> is not explicitly supported - but an |
identical function can be obtained with a suitable B<are_match> setting. |
Record separators are experimental in Version 0.17. They are not saved |
in the configuration_file. |
The tied FileHandle methods may be combined with the Win32::SerialPort |
methods for B<read, input>, and B<write> as well as other methods. The |
typical restrictions against mixing B<print> with B<syswrite> do not |
apply. Since both B<(tied) read> and B<sysread> call the same C<$ob-E<gt>READ> |
method, and since a separate C<$ob-E<gt>read> method has existed for some |
time in Win32::SerialPort, you should always use B<sysread> with the |
tied interface. Beginning in Version 0.17, B<sysread> checks the input |
against B<stty_icrnl>, B<stty_inlcr>, and B<stty_igncr>. With B<stty_igncr> |
active, the B<sysread> returns the count of all characters received including |
and C<\r> characters subsequently deleted. |
Because all the tied methods block, they should ALWAYS be used with |
timeout settings and are not suitable for background operations and |
polled loops. The B<sysread> method may return fewer characters than |
requested when a timeout occurs. The method call is still considered |
successful. If a B<sysread> times out after receiving some characters, |
the actual elapsed time may be as much as twice the programmed limit. |
If no bytes are received, the normal timing applies. |
=head2 Configuration and Capability Methods |
Starting in Version 0.18, a number of I<Application Variables> are saved |
in B<$Configuration_File>. These parameters are not used internally. But |
methods allow setting and reading them. The intent is to facilitate the |
use of separate I<configuration scripts> to create the files. Then an |
application can use B<start> as the Constructor and not bother with |
command line processing or managing its own small configuration file. |
The default values and number of parameters is subject to change. |
$PortObj->devicetype('none'); |
$PortObj->hostname('localhost'); # for socket-based implementations |
$PortObj->hostaddr(0); # a "false" value |
$PortObj->datatype('raw'); # 'record' is another possibility |
$PortObj->cfg_param_1('none'); |
$PortObj->cfg_param_2('none'); # 3 spares should be enough for now |
$PortObj->cfg_param_3('none'); |
The Win32 Serial Comm API provides extensive information concerning |
the capabilities and options available for a specific port (and |
instance). "Modem" ports have different capabilties than "RS-232" |
ports - even if they share the same Hardware. Many traditional modem |
actions are handled via TAPI. "Fax" ports have another set of options - |
and are accessed via MAPI. Yet many of the same low-level API commands |
and data structures are "common" to each type ("Modem" is implemented |
as an "RS-232" superset). In addition, Win95 supports a variety of |
legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
16-data-bit paths, and 256Kbaud. |
=over 8 |
Binary selections will accept as I<true> any of the following: |
C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
Anything else is I<false>. |
There are a large number of possible configuration and option parameters. |
To facilitate checking option validity in scripts, most configuration |
methods can be used in three different ways: |
=item method called with an argument |
The parameter is set to the argument, if valid. An invalid argument |
returns I<false> (undef) and the parameter is unchanged. The function |
will also I<carp> if B<$user_msg> is I<true>. After B<write_settings>, |
the port will be updated immediately if allowed. Otherwise, the value |
will be applied when B<write_settings> is called. |
=item method called with no argument in scalar context |
The current value is returned. If the value is not initialized either |
directly or by default, return "undef" which will parse to I<false>. |
For binary selections (true/false), return the current value. All |
current values from "multivalue" selections will parse to I<true>. |
Current values may differ from requested values until B<write_settings>. |
There is no way to see requests which have not yet been applied. |
Setting the same parameter again overwrites the first request. Test |
the return value of the setting method to check "success". |
=item method called with no argument in list context |
Return a list consisting of all acceptable choices for parameters with |
discrete choices. Return a list C<(minimum, maximum)> for parameters |
which can be set to a range of values. Binary selections have no need |
to call this way - but will get C<(0,1)> if they do. Beginning in |
Version 0.16, Binary selections inherited from Win32API::CommPort may |
not return anything useful in list context. The null list C<(undef)> |
will be returned for failed calls in list context (e.g. for an invalid |
or unexpected argument). |
=item Asynchronous (Background) I/O |
The module handles Polling (do if Ready), Synchronous (block until |
Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
choices provided by the API. No effort has yet been made to interact with |
Windows events. But background I/O has been used successfully with the |
Perl Tk modules and callbacks from the event loop. |
=item Timeouts |
The API provides two timing models. The first applies only to reading and |
essentially determines I<Read Not Ready> by checking the time between |
consecutive characters. The B<ReadFile> operation returns if that time |
exceeds the value set by B<read_interval>. It does this by timestamping |
each character. It appears that at least one character must by received in |
I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
is then reset by each succeeding character. If no characters are received, |
the read will block indefinitely. |
Setting B<read_interval> to C<0xffffffff> will do a non-blocking read. |
The B<ReadFile> returns immediately whether or not any characters are |
actually read. This replicates the behavior of the API. |
The other model defines the total time allowed to complete the operation. |
A fixed overhead time is added to the product of bytes and per_byte_time. |
A wide variety of timeout options can be defined by selecting the three |
parameters: fixed, each, and size. |
Read_Total = B<read_const_time> + (B<read_char_time> * bytes_to_read) |
Write_Total = B<write_const_time> + (B<write_char_time> * bytes_to_write) |
When reading a known number of characters, the I<Read_Total> mechanism is |
recommended. This mechanism I<MUST> be used with I<tied FileHandles> because |
the tie methods can make multiple internal API calls in response to a single |
B<sysread> or B<READLINE>. The I<Read_Interval> mechanism is suitable for |
a B<read> method that expects a response of variable or unknown size. You |
should then also set a long I<Read_Total> timeout as a "backup" in case |
no bytes are received. |
=back |
=head2 Exports |
Nothing is exported by default. Nothing is currently exported. Optional |
tags from Win32API::CommPort are passed through. |
=over 4 |
=item :PARAM |
Utility subroutines and constants for parameter setting and test: |
LONGsize SHORTsize nocarp yes_true |
OS_Error internal_buffer |
=item :STAT |
Serial communications constants from Win32API::CommPort. Included are the |
constants for ascertaining why a transmission is blocked: |
BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
Which incoming bits are active: |
MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
What hardware errors have been detected: |
CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL CE_MODE |
Offsets into the array returned by B<status:> |
ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
=back |
=head2 Stty Emulation |
Nothing wrong with dreaming! A subset of stty options is available |
through a B<stty> method. The purpose is support of existing serial |
devices which have embedded knowledge of Unix communication line and |
login practices. It is also needed by Tom Christiansen's Perl Power Tools |
project. This is new and experimental in Version 0.15. The B<stty> method |
returns an array of "traditional stty values" when called with no |
arguments. With arguments, it sets the corresponding parameters. |
$ok = $PortObj->stty("-icanon"); # equivalent to stty_icanon(0) |
@stty_all = $PortObj->stty(); # get all the parameters, Perl-style |
$ok = $PortObj->stty("cs7",19200); # multiple parameters |
$ok = $PortObj->stty(@stty_save); # many parameters |
The distribution includes a demo script, stty.plx, which gives details |
of usage. Not all Unix parameters are currently supported. But the array |
will contain all those which can be set. The order in C<@stty_all> will |
match the following pattern: |
baud, # numeric, always first |
"intr", character, # the parameters which set special characters |
"name", character, ... |
"stop", character, # "stop" will always be the last "pair" |
"parameter", # the on/off settings |
"-parameter", ... |
Version 0.13 added the primitive functions required to implement this |
feature. A number of methods named B<stty_xxx> do what an |
I<experienced stty user> would expect. |
Unlike B<stty> on Unix, the B<stty_xxx> operations apply only to I/O |
processed via the B<lookfor> method or the I<tied FileHandle> methods. |
The B<read, input, read_done, write> methods all treat data as "raw". |
The following stty functions have related SerialPort functions: |
--------------------------------------------------------------- |
stty (control) SerialPort Default Value |
---------------- ------------------ ------------- |
parenb inpck parity_enable from port |
parodd parity from port |
cs5 cs6 cs7 cs8 databits from port |
cstopb stopbits from port |
clocal crtscts handshake from port |
ixon ixoff handshake from port |
time read_const_time from port |
110 300 600 1200 2400 baudrate from port |
4800 9600 19200 38400 baudrate |
75 134.5 150 1800 fixed baud only - not selectable |
g, "stty < /dev/x" start, save none |
sane restart none |
stty (input) SerialPort Default Value |
---------------- ------------------ ------------- |
istrip stty_istrip off |
igncr stty_igncr off |
inlcr stty_inlcr off |
icrnl stty_icrnl on |
parmrk error_char from port (off typ) |
stty (output) SerialPort Default Value |
---------------- ------------------ ------------- |
ocrnl stty_ocrnl off if opost |
onlcr stty_onlcr on if opost |
opost stty_opost off |
stty (local) SerialPort Default Value |
---------------- ------------------ ------------- |
raw read, write, input none |
cooked lookfor none |
echo stty_echo off |
echoe stty_echoe on if echo |
echok stty_echok on if echo |
echonl stty_echonl off |
echoke stty_echoke on if echo |
echoctl stty_echoctl off |
isig stty_isig off |
icanon stty_icanon off |
stty (char) SerialPort Default Value |
---------------- ------------------ ------------- |
intr stty_intr "\cC" |
is_stty_intr 3 |
quit stty_quit "\cD" |
is_stty_quit 4 |
erase stty_erase "\cH" |
is_stty_erase 8 |
(erase echo) stty_bsdel "\cH \cH" |
kill stty_kill "\cU" |
is_stty_kill 21 |
(kill echo) stty_clear "\r {76}\r" |
is_stty_clear "-@{76}-" |
eof stty_eof "\cZ" |
is_stty_eof 26 |
eol stty_eol "\cJ" |
is_stty_eol 10 |
start xon_char from port ("\cQ" typ) |
is_xon_char 17 |
stop xoff_char from port ("\cS" typ) |
is_xoff_char 19 |
The following stty functions have no equivalent in SerialPort: |
-------------------------------------------------------------- |
[-]hup [-]ignbrk [-]brkint [-]ignpar |
[-]tostop susp 0 50 |
134 200 exta extb |
[-]cread [-]hupcl |
The stty function list is taken from the documentation for IO::Stty by |
Austin Schutz. |
=head2 Lookfor and I/O Processing |
Many of the B<stty_xxx> methods support features which are necessary for |
line-oriented input (such as command-line handling). These include methods |
which select control-keys to delete characters (B<stty_erase>) and lines |
(B<stty_kill>), define input boundaries (B<stty_eol, stty_eof>), and abort |
processing (B<stty_intr, stty_quit>). These keys also have B<is_stty_xxx> |
methods which convert the key-codes to numeric equivalents which can be |
saved in the configuration file. |
Some communications programs have a different but related need - to collect |
(or discard) input until a specific pattern is detected. For lines, the |
pattern is a line-termination. But there are also requirements to search |
for other strings in the input such as "username:" and "password:". The |
B<lookfor> method provides a consistant mechanism for solving this problem. |
It searches input character-by-character looking for a match to any of the |
elements of an array set using the B<are_match> method. It returns the |
entire input up to the match pattern if a match is found. If no match |
is found, it returns "" unless an input error or abort is detected (which |
returns undef). |
The actual match and the characters after it (if any) may also be viewed |
using the B<lastlook> method. In Version 0.13, the match test included |
a C<s/$pattern//s> test which worked fine for literal text but returned |
the I<Regular Expression> that matched when C<$pattern> contained any Perl |
metacharacters. That was probably a bug - although no one reported it. |
In Version 0.14, B<lastlook> returns both the input and the pattern from |
the match test. It also adopts the convention from Expect.pm that match |
strings are literal text (tested using B<index>) unless preceeded in the |
B<are_match> list by a B<"-re",> entry. The default B<are_match> list |
is C<("\n")>, which matches complete lines. |
my ($match, $after, $pattern, $instead) = $PortObj->lastlook; |
# input that MATCHED, input AFTER the match, PATTERN that matched |
# input received INSTEAD when timeout without match ("" if match) |
$PortObj->are_match("text1", "-re", "pattern", "text2"); |
# possible match strings: "pattern" is a regular expression, |
# "text1" and "text2" are literal strings |
The I<Regular Expression> handling in B<lookfor> is still |
experimental. Please let me know if you use it (or can't use it), so |
I can confirm bug fixes don't break your code. For literal strings, |
C<$match> and C<$pattern> should be identical. The C<$instead> value |
returns the internal buffer tested by the match logic. A successful |
match or a B<lookclear> resets it to "" - so it is only useful for error |
handling such as timeout processing or reporting unexpected responses. |
The B<lookfor> method is designed to be sampled periodically (polled). Any |
characters after the match pattern are saved for a subsequent B<lookfor>. |
Internally, B<lookfor> is implemented using the nonblocking B<input> method |
when called with no parameter. If called with a count, B<lookfor> calls |
C<$PortObj-E<gt>read(count)> which blocks until the B<read> is I<Complete> or |
a I<Timeout> occurs. The blocking alternative should not be used unless a |
fault time has been defined using B<read_interval, read_const_time, and |
read_char_time>. It exists mostly to support the I<tied FileHandle> |
functions B<sysread, getc,> and B<E<lt>FHE<gt>>. |
The internal buffers used by B<lookfor> may be purged by the B<lookclear> |
method (which also clears the last match). For testing, B<lookclear> can |
accept a string which is "looped back" to the next B<input>. This feature |
is enabled only when C<set_test_mode_active(1)>. Normally, B<lookclear> |
will return C<undef> if given parameters. It still purges the buffers and |
last_match in that case (but nothing is "looped back"). You will want |
B<stty_echo(0)> when exercising loopback. |
Version 0.15 adds a B<matchclear> method. It is designed to handle the |
"special case" where the match string is the first character(s) received |
by B<lookfor>. In this case, C<$lookfor_return == "">, B<lookfor> does |
not provide a clear indication that a match was found. The B<matchclear> |
returns the same C<$match> that would be returned by B<lastlook> and |
resets it to "" without resetting any of the other buffers. Since the |
B<lookfor> already searched I<through> the match, B<matchclear> is used |
to both detect and step-over "blank" lines. |
The character-by-character processing used by B<lookfor> to support the |
I<stty emulation> is fine for interactive activities and tasks which |
expect short responses. But it has too much "overhead" to handle fast |
data streams. Version 0.15 adds a B<streamline> method which is a fast, |
line-oriented alternative with no echo support or input handling except |
for pattern searching. Exact benchmarks will vary with input data and |
patterns, but my tests indicate B<streamline> is 10-20 times faster then |
B<lookfor> when uploading files averaging 25-50 characters per line. |
Since B<streamline> uses the same internal buffers, the B<lookclear, |
lastlook, are_match, and matchclear> methods act the same in both cases. |
In fact, calls to B<streamline> and B<lookfor> can be interleaved if desired |
(e.g. an interactive task that starts an upload and returns to interactive |
activity when it is complete). |
Beginning in Version 0.15, the B<READLINE> method supports "list context". |
A tied FileHandle can slurp in a whole file with an "@lines = E<lt>FHE<gt>" |
construct. In "scalar context", B<READLINE> calls B<lookfor>. But it calls |
B<streamline> in "list context". Both contexts also call B<matchclear> |
to detect "empty" lines and B<reset_error> to detect hardware problems. |
The existance of a hardware fault is reported with C<$^E>, although the |
specific fault is only reported when B<error_msg> is true. |
There are two additional methods for supporting "list context" input: |
B<lastline> sets an "end_of_file" I<Regular Expression>, and B<linesize> |
permits changing the "packet size" in the blocking read operation to allow |
tuning performance to data characteristics. These two only apply during |
B<READLINE>. The default for B<linesize> is 1. There is no default for |
the B<lastline> method. |
In Version 0.15, I<Regular Expressions> set by B<are_match> and B<lastline> |
will be pre-compiled using the I<qr//> construct on Perl 5.005 and higher. |
This doubled B<lookfor> and B<streamline> speed in my tests with |
I<Regular Expressions> - but actual improvements depend on both patterns |
and input data. |
The functionality of B<lookfor> includes a limited subset of the capabilities |
found in Austin Schutz's I<Expect.pm> for Unix (and Tcl's expect which it |
resembles). The C<$before, $match, $pattern, and $after> return values are |
available if someone needs to create an "expect" subroutine for porting a |
script. When using multiple patterns, there is one important functional |
difference: I<Expect.pm> looks at each pattern in turn and returns the first |
match found; B<lookfor> and B<streamline> test all patterns and return the |
one found I<earliest> in the input if more than one matches. |
Because B<lookfor> can be used to manage a command-line environment much |
like a Unix serial login, a number of "stty-like" methods are included to |
handle the issues raised by serial logins. One issue is dissimilar line |
terminations. This is addressed by the following methods: |
$PortObj->stty_icrnl; # map \r to \n on input |
$PortObj->stty_igncr; # ignore \r on input |
$PortObj->stty_inlcr; # map \n to \r on input |
$PortObj->stty_ocrnl; # map \r to \n on output |
$PortObj->stty_onlcr; # map \n to \r\n on output |
$PortObj->stty_opost; # enable output mapping |
The default specifies a raw device with no input or output processing. |
In Version 0.14, the default was a device which sends "\r" at the end |
of a line, requires "\r\n" to terminate incoming lines, and expects the |
"host" to echo every keystroke. Many "dumb terminals" act this way and |
the defaults were similar to Unix defaults. But some users found this |
ackward and confusing. |
Sometimes, you want perl to echo input characters back to the serial |
device (and other times you don't want that). |
$PortObj->stty_echo; # echo every character |
$PortObj->stty_echoe; # if echo erase with bsdel string (default) |
$PortObj->stty_echok; # if echo \n after kill character (default) |
$PortObj->stty_echonl; # echo \n even if stty_echo(0) |
$PortObj->stty_echoke; # if echo clear string after kill (default) |
$PortObj->stty_echoctl; # if echo "^Char" for control chars |
$PortObj->stty_istrip; # strip input to 7-bits |
my $air = " "x76; # overwrite entire line with spaces |
$PortObj->stty_clear("\r$air\r"); # written after kill character |
$PortObj->is_prompt("PROMPT:"); # need to write after kill |
$PortObj->stty_bsdel("\cH \cH"); # written after erase character |
# internal method that permits clear string with \r in config file |
my $plus32 = "@"x76; # overwrite line with spaces (ord += 32) |
$PortObj->is_stty_clear("-$plus32-"); # equivalent to stty_clear |
=head1 NOTES |
The object returned by B<new> or B<start> is NOT a I<FileHandle>. You |
will be disappointed if you try to use it as one. If you need a |
I<FileHandle>, you must use B<tie> as the constructor. |
e.g. the following is WRONG!!____C<print $PortObj "some text";> |
You need something like this (Perl 5.005): |
# construct |
$tie_ob = tie(*FOO,'Win32::SerialPort', $cfgfile) |
or die "Can't start $cfgfile\n"; |
print FOO "enter char: "; # destination is FileHandle, not Object |
my $in = getc FOO; |
syswrite FOO, "$in\n", 2, 0; |
print FOO "enter line: "; |
$in = <FOO>; |
printf FOO "received: %s\n", $in; |
print FOO "enter 5 char: "; |
sysread (FOO, $in, 5, 0) or die; |
printf FOO "received: %s\n", $in; |
# destruct |
close FOO || print "close failed\n"; |
undef $tie_ob; # Don't forget this one!! |
untie *FOO; |
Always include the C<undef $tie_ob> before the B<untie>. See the I<Gotcha> |
description in I<perltie>. |
The Perl 5.004 implementation of I<tied FileHandles> is missing |
B<close> and B<syswrite>. The Perl 5.003 version is essentially unusable. |
If you need these functions, consider Perl 5.005 seriously. |
An important note about Win32 filenames. The reserved device names such |
as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
Thanks to Ken White for testing on NT. |
There is a linux clone of this module implemented using I<POSIX.pm>. |
It also runs on AIX and Solaris, and will probably run on other POSIX |
systems as well. It does not currently support the complete set of methods - |
although portability of user programs is excellent for the calls it does |
support. It is available from CPAN as I<Device::SerialPort>. |
=head1 KNOWN LIMITATIONS |
Since everything is (sometimes convoluted but still pure) Perl, you can |
fix flaws and change limits if required. But please file a bug report if |
you do. This module has been tested with each of the binary perl versions |
for which Win32::API is supported: AS builds 315, 316, 500-509 and GS |
5.004_02. It has only been tested on Intel hardware. |
Although the B<lookfor, stty_xxx, and Tied FileHandle> mechanisms are |
considered stable, they have only been tested on a small subset of possible |
applications. While "\r" characters may be included in the clear string |
using B<is_stty_clear> internally, "\n" characters may NOT be included |
in multi-character strings if you plan to save the strings in a configuration |
file (which uses "\n" as an internal terminator). |
=over 4 |
=item Tutorial |
With all the options, this module needs a good tutorial. It doesn't |
have a complete one yet. A I<"How to get started"> tutorial appeared |
B<The Perl Journal #13> (March 1999). Examples from the article are |
available from http://tpj.com and from http://members.aol.com/Bbirthisel. |
The demo programs in the distribution are a good starting point for |
additional examples. |
=item Buffers |
The size of the Win32 buffers are selectable with B<buffers>. But each read |
method currently uses a fixed internal buffer of 4096 bytes. This can be |
changed in the Win32API::CommPort source and read with B<internal_buffer>. |
The XS version will support dynamic buffer sizing. Large operations are |
automatically converted to multiple smaller ones by the B<tied FileHandle> |
methods. |
=item Modems |
Lots of modem-specific options are not supported. The same is true of |
TAPI, MAPI. I<API Wizards> are welcome to contribute. |
=item API Options |
Lots of options are just "passed through from the API". Some probably |
shouldn't be used together. The module validates the obvious choices when |
possible. For something really fancy, you may need additional API |
documentation. Available from I<Micro$oft Pre$$>. |
=back |
=head1 BUGS |
On Win32, a port must B<close> before it can be reopened again by the same |
process. If a physical port can be accessed using more than one name (see |
above), all names are treated as one. The perl script can also be run |
multiple times within a single batch file or shell script. The I<Makefile.PL> |
spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
but it works. |
On NT, a B<read_done> or B<write_done> returns I<False> if a background |
operation is aborted by a purge. Win95 returns I<True>. |
EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
A few NT systems seem to set B<can_parity_enable> true, but do not actually |
support setting B<parity_enable>. This may be a characteristic of certain |
third-party serial drivers. |
__Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
=head1 AUTHORS |
Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
=head1 SEE ALSO |
Win32API::CommPort - the low-level API calls which support this module |
Win32API::File I<when available> |
Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
Expect.pm - Austin Schutz's adaptation of TCL's "expect" for Unix Perls |
=head1 COPYRIGHT |
Copyright (C) 1999, Bill Birthisel. All rights reserved. |
This module is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head2 COMPATIBILITY |
Most of the code in this module has been stable since version 0.12. |
Except for items indicated as I<Experimental>, I do not expect functional |
changes which are not fully backwards compatible. However, Version 0.16 |
removes the "dummy (0, 1) list" which was returned by many binary methods |
in case they were called in list context. I do not know of any use outside |
the test suite for that feature. |
Version 0.12 added an I<Install.PL> script to put modules into the documented |
Namespaces. The script uses I<MakeMaker> tools not available in |
ActiveState 3xx builds. Users of those builds will need to install |
differently (see README). Programs in the test suite are modified for |
the current version. Additions to the configurtion files generated by |
B<save> prevent those created by Version 0.18 from being used by earlier |
Versions. 4 November 1999. |
=cut |
/MissionCockpit/tags/V0.2.5/perl/site/lib/Win32API/CommPort.pm |
---|
0,0 → 1,3146 |
# This part includes the low-level API calls |
package Win32API::CommPort; |
use Win32; |
use Win32::API 0.01; |
if ( $] < 5.004 ) { |
my $no_silly_warning = $Win32::API::VERSION; |
$no_silly_warning = $Win32::API::pack; |
} |
use Carp; |
use strict; |
#### API declarations #### |
no strict 'subs'; # these may be imported someday |
use vars qw( |
$_CloseHandle $_CreateFile $_GetCommState |
$_ReadFile $_SetCommState $_SetupComm |
$_PurgeComm $_CreateEvent $_GetCommTimeouts |
$_SetCommTimeouts $_GetCommProperties $_ClearCommBreak |
$_ClearCommError $_EscapeCommFunction $_GetCommConfig |
$_GetCommMask $_GetCommModemStatus $_SetCommBreak |
$_SetCommConfig $_SetCommMask $_TransmitCommChar |
$_WaitCommEvent $_WriteFile $_ResetEvent |
$_GetOverlappedResult |
); |
$_CreateFile = new Win32::API("kernel32", "CreateFile", |
[P, N, N, N, N, N, N], N); |
$_CloseHandle = new Win32::API("kernel32", "CloseHandle", [N], N); |
$_GetCommState = new Win32::API("kernel32", "GetCommState", [N, P], I); |
$_SetCommState = new Win32::API("kernel32", "SetCommState", [N, P], I); |
$_SetupComm = new Win32::API("kernel32", "SetupComm", [N, N, N], I); |
$_PurgeComm = new Win32::API("kernel32", "PurgeComm", [N, N], I); |
$_CreateEvent = new Win32::API("kernel32", "CreateEvent", [P, I, I, P], N); |
$_GetCommTimeouts = new Win32::API("kernel32", "GetCommTimeouts", |
[N, P], I); |
$_SetCommTimeouts = new Win32::API("kernel32", "SetCommTimeouts", |
[N, P], I); |
$_GetCommProperties = new Win32::API("kernel32", "GetCommProperties", |
[N, P], I); |
$_ReadFile = new Win32::API("kernel32", "ReadFile", [N, P, N, P, P], I); |
$_WriteFile = new Win32::API("kernel32", "WriteFile", [N, P, N, P, P], I); |
$_TransmitCommChar = new Win32::API("kernel32", "TransmitCommChar", [N, I], I); |
$_ClearCommBreak = new Win32::API("kernel32", "ClearCommBreak", [N], I); |
$_SetCommBreak = new Win32::API("kernel32", "SetCommBreak", [N], I); |
$_ClearCommError = new Win32::API("kernel32", "ClearCommError", [N, P, P], I); |
$_EscapeCommFunction = new Win32::API("kernel32", "EscapeCommFunction", |
[N, N], I); |
$_GetCommModemStatus = new Win32::API("kernel32", "GetCommModemStatus", |
[N, P], I); |
$_GetOverlappedResult = new Win32::API("kernel32", "GetOverlappedResult", |
[N, P, P, I], I); |
#### these are not used yet |
$_GetCommConfig = new Win32::API("kernel32", "GetCommConfig", [N, P, P], I); |
$_GetCommMask = new Win32::API("kernel32", "GetCommMask", [N, P], I); |
$_SetCommConfig = new Win32::API("kernel32", "SetCommConfig", [N, P, N], I); |
$_SetCommMask = new Win32::API("kernel32", "SetCommMask", [N, N], I); |
$_WaitCommEvent = new Win32::API("kernel32", "WaitCommEvent", [N, P, P], I); |
$_ResetEvent = new Win32::API("kernel32", "ResetEvent", [N], I); |
use strict; |
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $RBUF_Size); |
$VERSION = '0.19'; |
$RBUF_Size = 4096; |
require Exporter; |
## require AutoLoader; |
@ISA = qw(Exporter); |
# Items to export into callers namespace by default. Note: do not export |
# names by default without a very good reason. Use EXPORT_OK instead. |
# Do not simply export all your public functions/methods/constants. |
@EXPORT= qw(); |
@EXPORT_OK= qw(); |
%EXPORT_TAGS = (STAT => [qw( BM_fCtsHold BM_fDsrHold |
BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof |
BM_fTxim BM_AllBits |
MS_CTS_ON MS_DSR_ON |
MS_RING_ON MS_RLSD_ON |
CE_RXOVER CE_OVERRUN |
CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL |
CE_MODE ST_BLOCK |
ST_INPUT ST_OUTPUT |
ST_ERROR )], |
RAW => [qw( CloseHandle CreateFile |
GetCommState ReadFile |
SetCommState SetupComm |
PurgeComm CreateEvent |
GetCommTimeouts SetCommTimeouts |
GetCommProperties ClearCommBreak |
ClearCommError EscapeCommFunction |
GetCommConfig GetCommMask |
GetCommModemStatus SetCommBreak |
SetCommConfig SetCommMask |
TransmitCommChar WaitCommEvent |
WriteFile ResetEvent |
GetOverlappedResult |
PURGE_TXABORT PURGE_RXABORT |
PURGE_TXCLEAR PURGE_RXCLEAR |
SETXOFF SETXON |
SETRTS CLRRTS |
SETDTR CLRDTR |
SETBREAK CLRBREAK |
EV_RXCHAR EV_RXFLAG |
EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD |
EV_BREAK EV_ERR |
EV_RING EV_PERR |
EV_RX80FULL EV_EVENT1 |
EV_EVENT2 ERROR_IO_INCOMPLETE |
ERROR_IO_PENDING )], |
COMMPROP => [qw( BAUD_USER BAUD_075 BAUD_110 |
BAUD_134_5 BAUD_150 BAUD_300 |
BAUD_600 BAUD_1200 BAUD_1800 |
BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 |
BAUD_38400 BAUD_56K BAUD_57600 |
BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM |
PST_RS232 PST_RS422 PST_RS423 |
PST_RS449 PST_SCANNER PST_X25 |
PST_NETWORK_BRIDGE PST_PARALLELPORT |
PST_TCPIP_TELNET PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK |
PCF_16BITMODE PCF_DTRDSR |
PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR |
PCF_TOTALTIMEOUTS PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING |
SP_PARITY SP_PARITY_CHECK SP_RLSD |
SP_STOPBITS SP_SERIALCOMM |
DATABITS_5 DATABITS_6 DATABITS_7 |
DATABITS_8 DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD |
PARITY_EVEN PARITY_MARK |
COMMPROP_INITIALIZED )], |
DCB => [qw( CBR_110 CBR_300 CBR_600 |
CBR_1200 CBR_2400 CBR_4800 |
CBR_9600 CBR_14400 CBR_19200 |
CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE |
DTR_CONTROL_HANDSHAKE RTS_CONTROL_DISABLE |
RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY |
ODDPARITY SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity |
FM_fOutxCtsFlow FM_fOutxDsrFlow |
FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX |
FM_fInX FM_fErrorChar |
FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 )], |
PARAM => [qw( LONGsize SHORTsize OS_Error |
nocarp internal_buffer yes_true )]); |
Exporter::export_ok_tags('STAT', 'RAW', 'COMMPROP', 'DCB', 'PARAM'); |
$EXPORT_TAGS{ALL} = \@EXPORT_OK; |
#### subroutine wrappers for API calls |
sub CloseHandle { |
return unless ( 1 == @_ ); |
return $_CloseHandle->Call( shift ); |
} |
sub CreateFile { |
return $_CreateFile->Call( @_ ); |
# returns handle |
} |
sub GetCommState { |
return $_GetCommState->Call( @_ ); |
} |
sub SetCommState { |
return $_SetCommState->Call( @_ ); |
} |
sub SetupComm { |
return $_SetupComm->Call( @_ ); |
} |
sub PurgeComm { |
return $_PurgeComm->Call( @_ ); |
} |
sub CreateEvent { |
return $_CreateEvent->Call( @_ ); |
} |
sub GetCommTimeouts { |
return $_GetCommTimeouts->Call( @_ ); |
} |
sub SetCommTimeouts { |
return $_SetCommTimeouts->Call( @_ ); |
} |
sub GetCommProperties { |
return $_GetCommProperties->Call( @_ ); |
} |
sub ReadFile { |
return $_ReadFile->Call( @_ ); |
} |
sub WriteFile { |
return $_WriteFile->Call( @_ ); |
} |
sub TransmitCommChar { |
return $_TransmitCommChar->Call( @_ ); |
} |
sub ClearCommBreak { |
return unless ( 1 == @_ ); |
return $_ClearCommBreak->Call( shift ); |
} |
sub SetCommBreak { |
return unless ( 1 == @_ ); |
return $_SetCommBreak->Call( shift ); |
} |
sub ClearCommError { |
return $_ClearCommError->Call( @_ ); |
} |
sub EscapeCommFunction { |
return $_EscapeCommFunction->Call( @_ ); |
} |
sub GetCommModemStatus { |
return $_GetCommModemStatus->Call( @_ ); |
} |
sub GetOverlappedResult { |
return $_GetOverlappedResult->Call( @_ ); |
} |
sub GetCommConfig { |
return $_GetCommConfig->Call( @_ ); |
} |
sub GetCommMask { |
return $_GetCommMask->Call( @_ ); |
} |
sub SetCommConfig { |
return $_SetCommConfig->Call( @_ ); |
} |
sub SetCommMask { |
return $_SetCommMask->Call( @_ ); |
} |
sub WaitCommEvent { |
return $_WaitCommEvent->Call( @_ ); |
} |
sub ResetEvent { |
return unless ( 1 == @_ ); |
return $_ResetEvent->Call( shift ); |
} |
#### "constant" declarations from Win32 header files #### |
#### compatible with ActiveState #### |
## COMMPROP structure |
sub SP_SERIALCOMM { 0x1 } |
sub BAUD_075 { 0x1 } |
sub BAUD_110 { 0x2 } |
sub BAUD_134_5 { 0x4 } |
sub BAUD_150 { 0x8 } |
sub BAUD_300 { 0x10 } |
sub BAUD_600 { 0x20 } |
sub BAUD_1200 { 0x40 } |
sub BAUD_1800 { 0x80 } |
sub BAUD_2400 { 0x100 } |
sub BAUD_4800 { 0x200 } |
sub BAUD_7200 { 0x400 } |
sub BAUD_9600 { 0x800 } |
sub BAUD_14400 { 0x1000 } |
sub BAUD_19200 { 0x2000 } |
sub BAUD_38400 { 0x4000 } |
sub BAUD_56K { 0x8000 } |
sub BAUD_57600 { 0x40000 } |
sub BAUD_115200 { 0x20000 } |
sub BAUD_128K { 0x10000 } |
sub BAUD_USER { 0x10000000 } |
sub PST_FAX { 0x21 } |
sub PST_LAT { 0x101 } |
sub PST_MODEM { 0x6 } |
sub PST_NETWORK_BRIDGE { 0x100 } |
sub PST_PARALLELPORT { 0x2 } |
sub PST_RS232 { 0x1 } |
sub PST_RS422 { 0x3 } |
sub PST_RS423 { 0x4 } |
sub PST_RS449 { 0x5 } |
sub PST_SCANNER { 0x22 } |
sub PST_TCPIP_TELNET { 0x102 } |
sub PST_UNSPECIFIED { 0 } |
sub PST_X25 { 0x103 } |
sub PCF_16BITMODE { 0x200 } |
sub PCF_DTRDSR { 0x1 } |
sub PCF_INTTIMEOUTS { 0x80 } |
sub PCF_PARITY_CHECK { 0x8 } |
sub PCF_RLSD { 0x4 } |
sub PCF_RTSCTS { 0x2 } |
sub PCF_SETXCHAR { 0x20 } |
sub PCF_SPECIALCHARS { 0x100 } |
sub PCF_TOTALTIMEOUTS { 0x40 } |
sub PCF_XONXOFF { 0x10 } |
sub SP_BAUD { 0x2 } |
sub SP_DATABITS { 0x4 } |
sub SP_HANDSHAKING { 0x10 } |
sub SP_PARITY { 0x1 } |
sub SP_PARITY_CHECK { 0x20 } |
sub SP_RLSD { 0x40 } |
sub SP_STOPBITS { 0x8 } |
sub DATABITS_5 { 1 } |
sub DATABITS_6 { 2 } |
sub DATABITS_7 { 4 } |
sub DATABITS_8 { 8 } |
sub DATABITS_16 { 16 } |
sub DATABITS_16X { 32 } |
sub STOPBITS_10 { 1 } |
sub STOPBITS_15 { 2 } |
sub STOPBITS_20 { 4 } |
sub PARITY_NONE { 256 } |
sub PARITY_ODD { 512 } |
sub PARITY_EVEN { 1024 } |
sub PARITY_MARK { 2048 } |
sub PARITY_SPACE { 4096 } |
sub COMMPROP_INITIALIZED { 0xe73cf52e } |
## DCB structure |
sub CBR_110 { 110 } |
sub CBR_300 { 300 } |
sub CBR_600 { 600 } |
sub CBR_1200 { 1200 } |
sub CBR_2400 { 2400 } |
sub CBR_4800 { 4800 } |
sub CBR_9600 { 9600 } |
sub CBR_14400 { 14400 } |
sub CBR_19200 { 19200 } |
sub CBR_38400 { 38400 } |
sub CBR_56000 { 56000 } |
sub CBR_57600 { 57600 } |
sub CBR_115200 { 115200 } |
sub CBR_128000 { 128000 } |
sub CBR_256000 { 256000 } |
sub DTR_CONTROL_DISABLE { 0 } |
sub DTR_CONTROL_ENABLE { 1 } |
sub DTR_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_DISABLE { 0 } |
sub RTS_CONTROL_ENABLE { 1 } |
sub RTS_CONTROL_HANDSHAKE { 2 } |
sub RTS_CONTROL_TOGGLE { 3 } |
sub EVENPARITY { 2 } |
sub MARKPARITY { 3 } |
sub NOPARITY { 0 } |
sub ODDPARITY { 1 } |
sub SPACEPARITY { 4 } |
sub ONESTOPBIT { 0 } |
sub ONE5STOPBITS { 1 } |
sub TWOSTOPBITS { 2 } |
## Flowcontrol bit mask in DCB |
sub FM_fBinary { 0x1 } |
sub FM_fParity { 0x2 } |
sub FM_fOutxCtsFlow { 0x4 } |
sub FM_fOutxDsrFlow { 0x8 } |
sub FM_fDtrControl { 0x30 } |
sub FM_fDsrSensitivity { 0x40 } |
sub FM_fTXContinueOnXoff { 0x80 } |
sub FM_fOutX { 0x100 } |
sub FM_fInX { 0x200 } |
sub FM_fErrorChar { 0x400 } |
sub FM_fNull { 0x800 } |
sub FM_fRtsControl { 0x3000 } |
sub FM_fAbortOnError { 0x4000 } |
sub FM_fDummy2 { 0xffff8000 } |
## COMSTAT bit mask |
sub BM_fCtsHold { 0x1 } |
sub BM_fDsrHold { 0x2 } |
sub BM_fRlsdHold { 0x4 } |
sub BM_fXoffHold { 0x8 } |
sub BM_fXoffSent { 0x10 } |
sub BM_fEof { 0x20 } |
sub BM_fTxim { 0x40 } |
sub BM_AllBits { 0x7f } |
## PurgeComm bit mask |
sub PURGE_TXABORT { 0x1 } |
sub PURGE_RXABORT { 0x2 } |
sub PURGE_TXCLEAR { 0x4 } |
sub PURGE_RXCLEAR { 0x8 } |
## GetCommModemStatus bit mask |
sub MS_CTS_ON { 0x10 } |
sub MS_DSR_ON { 0x20 } |
sub MS_RING_ON { 0x40 } |
sub MS_RLSD_ON { 0x80 } |
## EscapeCommFunction operations |
sub SETXOFF { 0x1 } |
sub SETXON { 0x2 } |
sub SETRTS { 0x3 } |
sub CLRRTS { 0x4 } |
sub SETDTR { 0x5 } |
sub CLRDTR { 0x6 } |
sub SETBREAK { 0x8 } |
sub CLRBREAK { 0x9 } |
## ClearCommError bit mask |
sub CE_RXOVER { 0x1 } |
sub CE_OVERRUN { 0x2 } |
sub CE_RXPARITY { 0x4 } |
sub CE_FRAME { 0x8 } |
sub CE_BREAK { 0x10 } |
sub CE_TXFULL { 0x100 } |
#### LPT only |
# sub CE_PTO { 0x200 } |
# sub CE_IOE { 0x400 } |
# sub CE_DNS { 0x800 } |
# sub CE_OOP { 0x1000 } |
#### LPT only |
sub CE_MODE { 0x8000 } |
## GetCommMask bits |
sub EV_RXCHAR { 0x1 } |
sub EV_RXFLAG { 0x2 } |
sub EV_TXEMPTY { 0x4 } |
sub EV_CTS { 0x8 } |
sub EV_DSR { 0x10 } |
sub EV_RLSD { 0x20 } |
sub EV_BREAK { 0x40 } |
sub EV_ERR { 0x80 } |
sub EV_RING { 0x100 } |
sub EV_PERR { 0x200 } |
sub EV_RX80FULL { 0x400 } |
sub EV_EVENT1 { 0x800 } |
sub EV_EVENT2 { 0x1000 } |
## Allowed OVERLAP errors |
sub ERROR_IO_INCOMPLETE { 996 } |
sub ERROR_IO_PENDING { 997 } |
#### "constant" declarations compatible with ActiveState #### |
my $DCBformat="LLLSSSCCCCCCCCS"; |
my $CP_format1="SSLLLLLLLLLSSLLLLSA*"; # rs232 |
my $CP_format6="SSLLLLLLLLLSSLLLLLLLLLLLLLLLLLLLLLLLA*"; # modem |
my $CP_format0="SA50LA244"; # pre-read |
my $OVERLAPPEDformat="LLLLL"; |
my $TIMEOUTformat="LLLLL"; |
my $COMSTATformat="LLL"; |
my $cfg_file_sig="Win32API::SerialPort_Configuration_File -- DO NOT EDIT --\n"; |
sub SHORTsize { 0xffff; } |
sub LONGsize { 0xffffffff; } |
sub ST_BLOCK {0} # status offsets for caller |
sub ST_INPUT {1} |
sub ST_OUTPUT {2} |
sub ST_ERROR {3} # latched |
#### Package variable declarations #### |
my @Yes_resp = ( |
"YES","Y", |
"ON", |
"TRUE","T", |
"1" |
); |
my @binary_opt = (0, 1); |
my @byte_opt = (0, 255); |
my $Babble = 0; |
my $testactive = 0; # test mode active |
## my $null=[]; |
my $null=0; |
my $zero=0; |
# Preloaded methods go here. |
sub OS_Error { print Win32::FormatMessage ( Win32::GetLastError() ); } |
sub get_tick_count { return Win32::GetTickCount(); } |
# test*.t only - suppresses default messages |
sub set_no_messages { |
return unless (@_ == 2); |
$testactive = yes_true($_[1]); |
} |
sub nocarp { return $testactive } |
sub internal_buffer { return $RBUF_Size } |
sub yes_true { |
my $choice = uc shift; |
my $ans = 0; |
foreach (@Yes_resp) { $ans = 1 if ( $choice eq $_ ) } |
return $ans; |
} |
sub new { |
my $proto = shift; |
my $class = ref($proto) || $proto; |
my $self = {}; |
my $ok = 0; # API return value |
my $hr = 0; # temporary hashref |
my $fmask = 0; # temporary for bit banging |
my $fix_baud = 0; |
my $key; |
my $value; |
my $CommPropBlank = " "; |
# COMMPROP only used during new |
my $CommProperties = " "x300; # extra buffer for modems |
my $CP_Length = 0; |
my $CP_Version = 0; |
my $CP_ServiceMask = 0; |
my $CP_Reserved1 = 0; |
my $CP_MaxBaud = 0; |
my $CP_ProvCapabilities = 0; |
my $CP_SettableParams = 0; |
my $CP_SettableBaud = 0; |
my $CP_SettableData = 0; |
my $CP_SettableStopParity = 0; |
my $CP_ProvSpec1 = 0; |
my $CP_ProvSpec2 = 0; |
my $CP_ProvChar_start = 0; |
my $CP_Filler = 0; |
# MODEMDEVCAPS |
my $MC_ReqSize = 0; |
my $MC_SpecOffset = 0; |
my $MC_SpecSize = 0; |
my $MC_ProvVersion = 0; |
my $MC_ManfOffset = 0; |
my $MC_ManfSize = 0; |
my $MC_ModOffset = 0; |
my $MC_ModSize = 0; |
my $MC_VerOffset = 0; |
my $MC_VerSize = 0; |
my $MC_DialOpt = 0; |
my $MC_CallFailTime = 0; |
my $MC_IdleTime = 0; |
my $MC_SpkrVol = 0; |
my $MC_SpkrMode = 0; |
my $MC_ModOpt = 0; |
my $MC_MaxDTE = 0; |
my $MC_MaxDCE = 0; |
my $MC_Filler = 0; |
$self->{NAME} = shift; |
my $quiet = shift; |
$self->{"_HANDLE"}=CreateFile("$self->{NAME}", |
0xc0000000, |
0, |
$null, |
3, |
0x40000000, |
$null); |
# device name |
# GENERIC_READ | GENERIC_WRITE |
# no FILE_SHARE_xx |
# no SECURITY_xx |
# OPEN_EXISTING |
# FILE_FLAG_OVERLAPPED |
# template file |
unless ($self->{"_HANDLE"} >= 1) { |
$self->{"_HANDLE"} = 0; |
return 0 if ($quiet); |
return if (nocarp); |
OS_Error; |
carp "can't open device: $self->{NAME}\n"; |
return; |
} |
# let Win32 know we allowed room for modem properties |
$CP_Length = 300; |
$CP_ProvSpec1 = COMMPROP_INITIALIZED; |
$CommProperties = pack($CP_format0, |
$CP_Length, |
$CommPropBlank, |
$CP_ProvSpec1, |
$CommPropBlank); |
$ok=GetCommProperties($self->{"_HANDLE"}, $CommProperties); |
unless ( $ok ) { |
OS_Error; |
carp "can't get COMMPROP block"; |
undef $self; |
return; |
} |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$CP_Filler)= unpack($CP_format1, $CommProperties); |
if (($CP_Length > 64) and ($self->{"_TYPE"} == PST_RS232)) { |
carp "invalid COMMPROP block length= $CP_Length"; |
undef $self; |
return; |
} |
if ($CP_ServiceMask != SP_SERIALCOMM) { |
carp "doesn't claim to be a serial port\n"; |
undef $self; |
return; |
} |
if ($self->{"_TYPE"} == PST_MODEM) { |
($CP_Length, |
$CP_Version, |
$CP_ServiceMask, |
$CP_Reserved1, |
$self->{"_MaxTxQueue"}, |
$self->{"_MaxRxQueue"}, |
$CP_MaxBaud, |
$self->{"_TYPE"}, |
$CP_ProvCapabilities, |
$CP_SettableParams, |
$CP_SettableBaud, |
$CP_SettableData, |
$CP_SettableStopParity, |
$self->{WRITEBUF}, |
$self->{READBUF}, |
$CP_ProvSpec1, |
$CP_ProvSpec2, |
$CP_ProvChar_start, |
$MC_ReqSize, |
$MC_SpecOffset, |
$MC_SpecSize, |
$MC_ProvVersion, |
$MC_ManfOffset, |
$MC_ManfSize, |
$MC_ModOffset, |
$MC_ModSize, |
$MC_VerOffset, |
$MC_VerSize, |
$MC_DialOpt, |
$MC_CallFailTime, |
$MC_IdleTime, |
$MC_SpkrVol, |
$MC_SpkrMode, |
$MC_ModOpt, |
$MC_MaxDTE, |
$MC_MaxDCE, |
$MC_Filler)= unpack($CP_format6, $CommProperties); |
if ($Babble) { |
printf "\nMODEMDEVCAPS:\n"; |
printf "\$MC_ActualSize= %d\n", $CP_ProvChar_start; |
printf "\$MC_ReqSize= %d\n", $MC_ReqSize; |
printf "\$MC_SpecOffset= %d\n", $MC_SpecOffset; |
printf "\$MC_SpecSize= %d\n", $MC_SpecSize; |
if ($MC_SpecOffset) { |
printf " DeviceSpecificData= %s\n", substr ($CommProperties, |
60+$MC_SpecOffset, $MC_SpecSize); |
} |
printf "\$MC_ProvVersion= %d\n", $MC_ProvVersion; |
printf "\$MC_ManfOffset= %d\n", $MC_ManfOffset; |
printf "\$MC_ManfSize= %d\n", $MC_ManfSize; |
if ($MC_ManfOffset) { |
printf " Manufacturer= %s\n", substr ($CommProperties, |
60+$MC_ManfOffset, $MC_ManfSize); |
} |
printf "\$MC_ModOffset= %d\n", $MC_ModOffset; |
printf "\$MC_ModSize= %d\n", $MC_ModSize; |
if ($MC_ModOffset) { |
printf " Model= %s\n", substr ($CommProperties, |
60+$MC_ModOffset, $MC_ModSize); |
} |
printf "\$MC_VerOffset= %d\n", $MC_VerOffset; |
printf "\$MC_VerSize= %d\n", $MC_VerSize; |
if ($MC_VerOffset) { |
printf " Version= %s\n", substr ($CommProperties, |
60+$MC_VerOffset, $MC_VerSize); |
} |
printf "\$MC_DialOpt= %lx\n", $MC_DialOpt; |
printf "\$MC_CallFailTime= %d\n", $MC_CallFailTime; |
printf "\$MC_IdleTime= %d\n", $MC_IdleTime; |
printf "\$MC_SpkrVol= %d\n", $MC_SpkrVol; |
printf "\$MC_SpkrMode= %d\n", $MC_SpkrMode; |
printf "\$MC_ModOpt= %lx\n", $MC_ModOpt; |
printf "\$MC_MaxDTE= %d\n", $MC_MaxDTE; |
printf "\$MC_MaxDCE= %d\n", $MC_MaxDCE; |
$MC_Filler= $MC_Filler; # for -w |
} |
## $MC_ReqSize = 250; |
if ($CP_ProvChar_start != $MC_ReqSize) { |
printf "\nARGH, a Bug! The \$CommProperties buffer must be "; |
printf "at least %d bytes.\n", $MC_ReqSize+60; |
} |
} |
## if (1 | $Babble) { |
if ($Babble) { |
printf "\$CP_Length= %d\n", $CP_Length; |
printf "\$CP_Version= %d\n", $CP_Version; |
printf "\$CP_ServiceMask= %lx\n", $CP_ServiceMask; |
printf "\$CP_Reserved1= %lx\n", $CP_Reserved1; |
printf "\$CP_MaxTxQueue= %lx\n", $self->{"_MaxTxQueue"}; |
printf "\$CP_MaxRxQueue= %lx\n", $self->{"_MaxRxQueue"}; |
printf "\$CP_MaxBaud= %lx\n", $CP_MaxBaud; |
printf "\$CP_ProvSubType= %lx\n", $self->{"_TYPE"}; |
printf "\$CP_ProvCapabilities= %lx\n", $CP_ProvCapabilities; |
printf "\$CP_SettableParams= %lx\n", $CP_SettableParams; |
printf "\$CP_SettableBaud= %lx\n", $CP_SettableBaud; |
printf "\$CP_SettableData= %x\n", $CP_SettableData; |
printf "\$CP_SettableStopParity= %x\n", $CP_SettableStopParity; |
printf "\$CP_CurrentTxQueue= %lx\n", $self->{WRITEBUF}; |
printf "\$CP_CurrentRxQueue= %lx\n", $self->{READBUF}; |
printf "\$CP_ProvSpec1= %lx\n", $CP_ProvSpec1; |
printf "\$CP_ProvSpec2= %lx\n", $CP_ProvSpec2; |
} |
# "private" data |
$self->{"_INIT"} = undef; |
$self->{"_DEBUG_C"} = 0; |
$self->{"_LATCH"} = 0; |
$self->{"_W_BUSY"} = 0; |
$self->{"_R_BUSY"} = 0; |
$self->{"_TBUFMAX"} = $self->{"_MaxTxQueue"} ? |
$self->{"_MaxTxQueue"} : LONGsize; |
$self->{"_RBUFMAX"} = $self->{"_MaxRxQueue"} ? |
$self->{"_MaxRxQueue"} : LONGsize; |
# buffers |
$self->{"_R_OVERLAP"} = " "x24; |
$self->{"_W_OVERLAP"} = " "x24; |
$self->{"_TIMEOUT"} = " "x24; |
$self->{"_RBUF"} = " "x $RBUF_Size; |
# allowed setting hashes |
$self->{"_L_BAUD"} = {}; |
$self->{"_L_STOP"} = {}; |
$self->{"_L_PARITY"} = {}; |
$self->{"_L_DATA"} = {}; |
$self->{"_L_HSHAKE"} = {}; |
# capability flags |
$fmask = $CP_SettableParams; |
$self->{"_C_BAUD"} = $fmask & SP_BAUD; |
$self->{"_C_DATA"} = $fmask & SP_DATABITS; |
$self->{"_C_STOP"} = $fmask & SP_STOPBITS; |
$self->{"_C_HSHAKE"} = $fmask & SP_HANDSHAKING; |
$self->{"_C_PARITY_CFG"} = $fmask & SP_PARITY; |
$self->{"_C_PARITY_EN"} = $fmask & SP_PARITY_CHECK; |
$self->{"_C_RLSD_CFG"} = $fmask & SP_RLSD; |
$fmask = $CP_ProvCapabilities; |
$self->{"_C_RLSD"} = $fmask & PCF_RLSD; |
$self->{"_C_PARITY_CK"} = $fmask & PCF_PARITY_CHECK; |
$self->{"_C_DTRDSR"} = $fmask & PCF_DTRDSR; |
$self->{"_C_16BITMODE"} = $fmask & PCF_16BITMODE; |
$self->{"_C_RTSCTS"} = $fmask & PCF_RTSCTS; |
$self->{"_C_XONXOFF"} = $fmask & PCF_XONXOFF; |
$self->{"_C_XON_CHAR"} = $fmask & PCF_SETXCHAR; |
$self->{"_C_SPECHAR"} = $fmask & PCF_SPECIALCHARS; |
$self->{"_C_INT_TIME"} = $fmask & PCF_INTTIMEOUTS; |
$self->{"_C_TOT_TIME"} = $fmask & PCF_TOTALTIMEOUTS; |
if ($self->{"_C_INT_TIME"}) { |
$self->{"_N_RINT"} = LONGsize; # min interval default |
} |
else { |
$self->{"_N_RINT"} = 0; |
} |
$self->{"_N_RTOT"} = 0; |
$self->{"_N_RCONST"} = 0; |
if ($self->{"_C_TOT_TIME"}) { |
$self->{"_N_WCONST"} = 201; # startup overhead + 1 |
$self->{"_N_WTOT"} = 11; # per char out + 1 |
} |
else { |
$self->{"_N_WTOT"} = 0; |
$self->{"_N_WCONST"} = 0; |
} |
$hr = \%{$self->{"_L_HSHAKE"}}; |
if ($self->{"_C_HSHAKE"}) { |
${$hr}{"xoff"} = "xoff" if ($fmask & PCF_XONXOFF); |
${$hr}{"rts"} = "rts" if ($fmask & PCF_RTSCTS); |
${$hr}{"dtr"} = "dtr" if ($fmask & PCF_DTRDSR); |
${$hr}{"none"} = "none"; |
} |
else { $self->{"_N_HSHAKE"} = undef; } |
#### really just using the keys here, so value = Win32_definition |
#### in case we ever need it for something else |
# first check for programmable baud |
$hr = \%{$self->{"_L_BAUD"}}; |
if ($CP_MaxBaud & BAUD_USER) { |
$fmask = $CP_SettableBaud; |
${$hr}{110} = CBR_110 if ($fmask & BAUD_110); |
${$hr}{300} = CBR_300 if ($fmask & BAUD_300); |
${$hr}{600} = CBR_600 if ($fmask & BAUD_600); |
${$hr}{1200} = CBR_1200 if ($fmask & BAUD_1200); |
${$hr}{2400} = CBR_2400 if ($fmask & BAUD_2400); |
${$hr}{4800} = CBR_4800 if ($fmask & BAUD_4800); |
${$hr}{9600} = CBR_9600 if ($fmask & BAUD_9600); |
${$hr}{14400} = CBR_14400 if ($fmask & BAUD_14400); |
${$hr}{19200} = CBR_19200 if ($fmask & BAUD_19200); |
${$hr}{38400} = CBR_38400 if ($fmask & BAUD_38400); |
${$hr}{56000} = CBR_56000 if ($fmask & BAUD_56K); |
${$hr}{57600} = CBR_57600 if ($fmask & BAUD_57600); |
${$hr}{115200} = CBR_115200 if ($fmask & BAUD_115200); |
${$hr}{128000} = CBR_128000 if ($fmask & BAUD_128K); |
${$hr}{256000} = CBR_256000 if (0); # reserved ?? |
} |
else { |
# get fixed baud from CP_MaxBaud |
$fmask = $CP_MaxBaud; |
$fix_baud = 75 if ($fmask & BAUD_075); |
$fix_baud = 110 if ($fmask & BAUD_110); |
$fix_baud = 134.5 if ($fmask & BAUD_134_5); |
$fix_baud = 150 if ($fmask & BAUD_150); |
$fix_baud = 300 if ($fmask & BAUD_300); |
$fix_baud = 600 if ($fmask & BAUD_600); |
$fix_baud = 1200 if ($fmask & BAUD_1200); |
$fix_baud = 1800 if ($fmask & BAUD_1800); |
$fix_baud = 2400 if ($fmask & BAUD_2400); |
$fix_baud = 4800 if ($fmask & BAUD_4800); |
$fix_baud = 7200 if ($fmask & BAUD_7200); |
$fix_baud = 9600 if ($fmask & BAUD_9600); |
$fix_baud = 14400 if ($fmask & BAUD_14400); |
$fix_baud = 19200 if ($fmask & BAUD_19200); |
$fix_baud = 34800 if ($fmask & BAUD_38400); |
$fix_baud = 56000 if ($fmask & BAUD_56K); |
$fix_baud = 57600 if ($fmask & BAUD_57600); |
$fix_baud = 115200 if ($fmask & BAUD_115200); |
$fix_baud = 128000 if ($fmask & BAUD_128K); |
${$hr}{$fix_baud} = $fix_baud; |
$self->{"_N_BAUD"} = undef; |
} |
#### data bits |
$fmask = $CP_SettableData; |
if ($self->{"_C_DATA"}) { |
$hr = \%{$self->{"_L_DATA"}}; |
${$hr}{5} = 5 if ($fmask & DATABITS_5); |
${$hr}{6} = 6 if ($fmask & DATABITS_6); |
${$hr}{7} = 7 if ($fmask & DATABITS_7); |
${$hr}{8} = 8 if ($fmask & DATABITS_8); |
${$hr}{16} = 16 if ($fmask & DATABITS_16); |
## ${$hr}{16X} = 16 if ($fmask & DATABITS_16X); |
} |
else { $self->{"_N_DATA"} = undef; } |
#### value = (DCB Win32_definition + 1) so 0 means unchanged |
$fmask = $CP_SettableStopParity; |
if ($self->{"_C_STOP"}) { |
$hr = \%{$self->{"_L_STOP"}}; |
${$hr}{1} = 1 + ONESTOPBIT if ($fmask & STOPBITS_10); |
${$hr}{1.5} = 1 + ONE5STOPBITS if ($fmask & STOPBITS_15); |
${$hr}{2} = 1 + TWOSTOPBITS if ($fmask & STOPBITS_20); |
} |
else { $self->{"_N_STOP"} = undef; } |
if ($self->{"_C_PARITY_CFG"}) { |
$hr = \%{$self->{"_L_PARITY"}}; |
${$hr}{"none"} = 1 + NOPARITY if ($fmask & PARITY_NONE); |
${$hr}{"even"} = 1 + EVENPARITY if ($fmask & PARITY_EVEN); |
${$hr}{"odd"} = 1 + ODDPARITY if ($fmask & PARITY_ODD); |
${$hr}{"mark"} = 1 + MARKPARITY if ($fmask & PARITY_MARK); |
${$hr}{"space"} = 1 + SPACEPARITY if ($fmask & PARITY_SPACE); |
} |
else { $self->{"_N_PARITY"} = undef; } |
$hr = 0; # no loops |
# changable dcb parameters |
# 0 = no change requested |
# mask_on: requested value for OR |
# mask_off: complement of requested value for AND |
$self->{"_N_FM_ON"} = 0; |
$self->{"_N_FM_OFF"} = 0; |
$self->{"_N_AUX_ON"} = 0; |
$self->{"_N_AUX_OFF"} = 0; |
### "VALUE" is initialized from DCB by default (but also in %validate) |
# 0 = no change requested |
# integer: requested value or (value+1 if 0 is a legal value) |
# binary: 1=false requested, 2=true requested |
$self->{"_N_XONLIM"} = 0; |
$self->{"_N_XOFFLIM"} = 0; |
$self->{"_N_XOFFCHAR"} = 0; |
$self->{"_N_XONCHAR"} = 0; |
$self->{"_N_ERRCHAR"} = 0; |
$self->{"_N_EOFCHAR"} = 0; |
$self->{"_N_EVTCHAR"} = 0; |
$self->{"_N_BINARY"} = 0; |
$self->{"_N_PARITY_EN"} = 0; |
### "_N_items" for save/start |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
$self->{"_N_HSHAKE"} = 0; |
### The "required" DCB values are deliberately NOT defined. That way, |
### write_settings can verify they "exist" to assure they got set. |
### $self->{"_N_BAUD"} |
### $self->{"_N_DATA"} |
### $self->{"_N_STOP"} |
### $self->{"_N_PARITY"} |
$self->{"_R_EVENT"} = CreateEvent($null, # no security |
1, # explicit reset req |
0, # initial event reset |
$null); # no name |
unless ($self->{"_R_EVENT"}) { |
OS_Error; |
carp "could not create required read event"; |
undef $self; |
return; |
} |
$self->{"_W_EVENT"} = CreateEvent($null, # no security |
1, # explicit reset req |
0, # initial event reset |
$null); # no name |
unless ($self->{"_W_EVENT"}) { |
OS_Error; |
carp "could not create required write event"; |
undef $self; |
return; |
} |
$self->{"_R_OVERLAP"} = pack($OVERLAPPEDformat, |
$zero, # osRead_Internal, |
$zero, # osRead_InternalHigh, |
$zero, # osRead_Offset, |
$zero, # osRead_OffsetHigh, |
$self->{"_R_EVENT"}); |
$self->{"_W_OVERLAP"} = pack($OVERLAPPEDformat, |
$zero, # osWrite_Internal, |
$zero, # osWrite_InternalHigh, |
$zero, # osWrite_Offset, |
$zero, # osWrite_OffsetHigh, |
$self->{"_W_EVENT"}); |
# Device Control Block (DCB) |
unless ( fetch_DCB ($self) ) { |
carp "can't read Device Control Block for $self->{NAME}\n"; |
undef $self; |
return; |
} |
$self->{"_L_BAUD"}{$self->{BAUD}} = $self->{BAUD}; # actual must be ok |
# Read Timeouts |
unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
carp "Error in GetCommTimeouts"; |
undef $self; |
return; |
} |
($self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
bless ($self, $class); |
return $self; |
} |
sub fetch_DCB { |
my $self = shift; |
my $ok; |
my $hr; |
my $fmask; |
my $key; |
my $value; |
my $dcb = " "x32; |
GetCommState($self->{"_HANDLE"}, $dcb) or return; |
($self->{"_DCBLength"}, |
$self->{BAUD}, |
$self->{"_BitMask"}, |
$self->{"_ResvWORD"}, |
$self->{XONLIM}, |
$self->{XOFFLIM}, |
$self->{DATA}, |
$self->{"_Parity"}, |
$self->{"_StopBits"}, |
$self->{XONCHAR}, |
$self->{XOFFCHAR}, |
$self->{ERRCHAR}, |
$self->{EOFCHAR}, |
$self->{EVTCHAR}, |
$self->{"_PackWORD"})= unpack($DCBformat, $dcb); |
if ($self->{"_DCBLength"} > 32) { |
carp "invalid DCB block length"; |
return; |
} |
if ($Babble) { |
printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
printf "BaudRate= %d\n", $self->{BAUD}; |
printf "BitMask= %lx\n", $self->{"_BitMask"}; |
printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
printf "XonLim= %x\n", $self->{XONLIM}; |
printf "XoffLim= %x\n", $self->{XOFFLIM}; |
printf "ByteSize= %d\n", $self->{DATA}; |
printf "Parity= %d\n", $self->{"_Parity"}; |
printf "StopBits= %d\n", $self->{"_StopBits"}; |
printf "XonChar= %x\n", $self->{XONCHAR}; |
printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
printf "EofChar= %x\n", $self->{EOFCHAR}; |
printf "EvtChar= %x\n", $self->{EVTCHAR}; |
printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
printf "handle= %d\n\n", $self->{"_HANDLE"}; |
} |
$fmask = 1 + $self->{"_StopBits"}; |
while (($key, $value) = each %{ $self->{"_L_STOP"} }) { |
if ($value == $fmask) { |
$self->{STOP} = $key; |
} |
} |
$fmask = 1 + $self->{"_Parity"}; |
while (($key, $value) = each %{ $self->{"_L_PARITY"} }) { |
if ($value == $fmask) { |
$self->{PARITY} = $key; |
} |
} |
$fmask = $self->{"_BitMask"}; |
$hr = DTR_CONTROL_HANDSHAKE; |
$ok = RTS_CONTROL_HANDSHAKE; |
if ($fmask & ( $hr << 4) ) { |
$self->{HSHAKE} = "dtr"; |
} |
elsif ($fmask & ( $ok << 12) ) { |
$self->{HSHAKE} = "rts"; |
} |
elsif ($fmask & ( FM_fOutX | FM_fInX ) ) { |
$self->{HSHAKE} = "xoff"; |
} |
else { |
$self->{HSHAKE} = "none"; |
} |
$self->{BINARY} = ($fmask & FM_fBinary); |
$self->{PARITY_EN} = ($fmask & FM_fParity); |
if ($fmask & FM_fDummy2) { |
carp "Unknown DCB Flow Mask Bit in $self->{NAME}"; |
} |
1; |
} |
sub init_done { |
my $self = shift; |
return 0 unless (defined $self->{"_INIT"}); |
return $self->{"_INIT"}; |
} |
sub update_DCB { |
my $self = shift; |
my $ok = 0; |
return unless (defined $self->{"_INIT"}); |
fetch_DCB ($self); |
if ($self->{"_N_HSHAKE"}) { |
$self->{HSHAKE} = $self->{"_N_HSHAKE"}; |
if ($self->{HSHAKE} eq "dtr" ) { |
$self->{"_N_FM_ON"} = 0x1028; |
$self->{"_N_FM_OFF"} = 0xffffdceb; |
} |
elsif ($self->{HSHAKE} eq "rts" ) { |
$self->{"_N_FM_ON"} = 0x2014; |
$self->{"_N_FM_OFF"} = 0xffffecd7; |
} |
elsif ($self->{HSHAKE} eq "xoff" ) { |
$self->{"_N_FM_ON"} = 0x1310; |
$self->{"_N_FM_OFF"} = 0xffffdfd3; |
} |
else { |
$self->{"_N_FM_ON"} = 0x1010; |
$self->{"_N_FM_OFF"} = 0xffffdcd3; |
} |
$self->{"_N_HSHAKE"} = 0; |
} |
if ($self->{"_N_PARITY_EN"}) { |
if (2 == $self->{"_N_PARITY_EN"}) { |
$self->{"_N_FM_ON"} |= FM_fParity; # enable |
if ($self->{"_N_FM_OFF"}) { |
$self->{"_N_FM_OFF"} |= FM_fParity; |
} |
else { $self->{"_N_FM_OFF"} = LONGsize; } |
} |
else { |
if ($self->{"_N_FM_ON"}) { |
$self->{"_N_FM_ON"} &= ~FM_fParity; # disable |
} |
if ($self->{"_N_FM_OFF"}) { |
$self->{"_N_FM_OFF"} &= ~FM_fParity; |
} |
else { $self->{"_N_FM_OFF"} = ~FM_fParity; } |
} |
## DEBUG ## |
## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
## DEBUG ## |
$self->{"_N_PARITY_EN"} = 0; |
} |
## DEBUG ## |
## printf "_N_AUX_ON=%lx\n", $self->{"_N_AUX_ON"}; ## DEBUG ## |
## printf "_N_AUX_OFF=%lx\n", $self->{"_N_AUX_OFF"}; ## DEBUG ## |
## DEBUG ## |
if ( $self->{"_N_AUX_ON"} or $self->{"_N_AUX_OFF"} ) { |
if ( $self->{"_N_FM_OFF"} ) { |
$self->{"_N_FM_OFF"} &= $self->{"_N_AUX_OFF"}; |
} |
else { |
$self->{"_N_FM_OFF"} = $self->{"_N_AUX_OFF"}; |
} |
$self->{"_N_FM_ON"} |= $self->{"_N_AUX_ON"}; |
$self->{"_N_AUX_ON"} = 0; |
$self->{"_N_AUX_OFF"} = 0; |
} |
## DEBUG ## |
## printf "_N_FM_ON=%lx\n", $self->{"_N_FM_ON"}; ## DEBUG ## |
## printf "_N_FM_OFF=%lx\n", $self->{"_N_FM_OFF"}; ## DEBUG ## |
## DEBUG ## |
if ( $self->{"_N_FM_ON"} or $self->{"_N_FM_OFF"} ) { |
$self->{"_BitMask"} &= $self->{"_N_FM_OFF"}; |
$self->{"_BitMask"} |= $self->{"_N_FM_ON"}; |
$self->{"_N_FM_ON"} = 0; |
$self->{"_N_FM_OFF"} = 0; |
} |
if ($self->{"_N_XONLIM"}) { |
$self->{XONLIM} = $self->{"_N_XONLIM"} - 1; |
$self->{"_N_XONLIM"} = 0; |
} |
if ($self->{"_N_XOFFLIM"}) { |
$self->{XOFFLIM} = $self->{"_N_XOFFLIM"} - 1; |
$self->{"_N_XOFFLIM"} = 0; |
} |
if ($self->{"_N_BAUD"}) { |
$self->{BAUD} = $self->{"_N_BAUD"}; |
$self->{"_N_BAUD"} = 0; |
} |
if ($self->{"_N_DATA"}) { |
$self->{DATA} = $self->{"_N_DATA"}; |
$self->{"_N_DATA"} = 0; |
} |
if ($self->{"_N_STOP"}) { |
$self->{"_StopBits"} = $self->{"_N_STOP"} - 1; |
$self->{"_N_STOP"} = 0; |
} |
if ($self->{"_N_PARITY"}) { |
$self->{"_Parity"} = $self->{"_N_PARITY"} - 1; |
$self->{"_N_PARITY"} = 0; |
} |
if ($self->{"_N_XONCHAR"}) { |
$self->{XONCHAR} = $self->{"_N_XONCHAR"} - 1; |
$self->{"_N_XONCHAR"} = 0; |
} |
if ($self->{"_N_XOFFCHAR"}) { |
$self->{XOFFCHAR} = $self->{"_N_XOFFCHAR"} - 1; |
$self->{"_N_XOFFCHAR"} = 0; |
} |
if ($self->{"_N_ERRCHAR"}) { |
$self->{ERRCHAR} = $self->{"_N_ERRCHAR"} - 1; |
$self->{"_N_ERRCHAR"} = 0; |
} |
if ($self->{"_N_EOFCHAR"}) { |
$self->{EOFCHAR} = $self->{"_N_EOFCHAR"} - 1; |
$self->{"_N_EOFCHAR"} = 0; |
} |
if ($self->{"_N_EVTCHAR"}) { |
$self->{EVTCHAR} = $self->{"_N_EVTCHAR"} - 1; |
$self->{"_N_EVTCHAR"} = 0; |
} |
my $dcb = pack($DCBformat, |
$self->{"_DCBLength"}, |
$self->{BAUD}, |
$self->{"_BitMask"}, |
$self->{"_ResvWORD"}, |
$self->{XONLIM}, |
$self->{XOFFLIM}, |
$self->{DATA}, |
$self->{"_Parity"}, |
$self->{"_StopBits"}, |
$self->{XONCHAR}, |
$self->{XOFFCHAR}, |
$self->{ERRCHAR}, |
$self->{EOFCHAR}, |
$self->{EVTCHAR}, |
$self->{"_PackWORD"}); |
if ( SetCommState($self->{"_HANDLE"}, $dcb) ) { |
print "updated DCB for $self->{NAME}\n" if ($Babble); |
## DEBUG ## |
## printf "DEBUG BitMask= %lx\n", $self->{"_BitMask"}; ## DEBUG ## |
## DEBUG ## |
} |
else { |
carp "SetCommState failed"; |
OS_Error; |
if ($Babble) { |
printf "\ntried to write:\n"; |
printf "DCBLength= %d\n", $self->{"_DCBLength"}; |
printf "BaudRate= %d\n", $self->{BAUD}; |
printf "BitMask= %lx\n", $self->{"_BitMask"}; |
printf "ResvWORD= %x\n", $self->{"_ResvWORD"}; |
printf "XonLim= %x\n", $self->{XONLIM}; |
printf "XoffLim= %x\n", $self->{XOFFLIM}; |
printf "ByteSize= %d\n", $self->{DATA}; |
printf "Parity= %d\n", $self->{"_Parity"}; |
printf "StopBits= %d\n", $self->{"_StopBits"}; |
printf "XonChar= %x\n", $self->{XONCHAR}; |
printf "XoffChar= %x\n", $self->{XOFFCHAR}; |
printf "ErrorChar= %x\n", $self->{ERRCHAR}; |
printf "EofChar= %x\n", $self->{EOFCHAR}; |
printf "EvtChar= %x\n", $self->{EVTCHAR}; |
printf "PackWORD= %x\n", $self->{"_PackWORD"}; |
printf "handle= %d\n", $self->{"_HANDLE"}; |
} |
} |
} |
sub initialize { |
my $self = shift; |
my $item; |
my $fault = 0; |
foreach $item (@_) { |
unless (exists $self->{"_N_$item"}) { |
# must be "exists" so undef=not_settable |
$fault++; |
nocarp or carp "Missing REQUIRED setting for $item"; |
} |
} |
unless ($self->{"_INIT"}) { |
$self->{"_INIT"} = 1 unless ($fault); |
$self->{"_BitMask"} = 0x1011; |
$self->{XONLIM} = 100 unless ($self->{"_N_XONLIM"}); |
$self->{XOFFLIM} = 100 unless ($self->{"_N_XOFFLIM"}); |
$self->{XONCHAR} = 0x11 unless ($self->{"_N_XONCHAR"}); |
$self->{XOFFCHAR} = 0x13 unless ($self->{"_N_XOFFCHAR"}); |
$self->{ERRCHAR} = 0 unless ($self->{"_N_ERRCHAR"}); |
$self->{EOFCHAR} = 0 unless ($self->{"_N_EOFCHAR"}); |
$self->{EVTCHAR} = 0 unless ($self->{"_N_EVTCHAR"}); |
update_timeouts($self); |
} |
if ($self->{"_N_READBUF"} or $self->{"_N_WRITEBUF"}) { |
if ($self->{"_N_READBUF"}) { |
$self->{READBUF} = $self->{"_N_READBUF"}; |
} |
if ($self->{"_N_WRITEBUF"}) { |
$self->{WRITEBUF} = $self->{"_N_WRITEBUF"}; |
} |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
SetupComm($self->{"_HANDLE"}, $self->{READBUF}, $self->{WRITEBUF}); |
} |
purge_all($self); |
return $fault; |
} |
sub is_status { |
my $self = shift; |
my $ok = 0; |
my $error_p = " "x4; |
my $CommStatus = " "x12; |
if (@_ and $testactive) { |
$self->{"_LATCH"} |= shift; |
} |
$ok=ClearCommError($self->{"_HANDLE"}, $error_p, $CommStatus); |
my $Error_BitMask = unpack("L", $error_p); |
$self->{"_LATCH"} |= $Error_BitMask; |
my @stat = unpack($COMSTATformat, $CommStatus); |
push @stat, $self->{"_LATCH"}; |
$stat[ST_BLOCK] &= BM_AllBits; |
if ( $Babble or $self->{"_DEBUG_C"} ) { |
printf "Blocking Bits= %d\n", $stat[ST_BLOCK]; |
printf "Input Queue= %d\n", $stat[ST_INPUT]; |
printf "Output Queue= %d\n", $stat[ST_OUTPUT]; |
printf "Latched Errors= %d\n", $stat[ST_ERROR]; |
printf "ok= %d\n", $ok; |
} |
return ($ok ? @stat : undef); |
} |
sub reset_error { |
my $self = shift; |
my $was = $self->{"_LATCH"}; |
$self->{"_LATCH"} = 0; |
return $was; |
} |
sub can_baud { |
my $self = shift; |
return $self->{"_C_BAUD"}; |
} |
sub can_databits { |
my $self = shift; |
return $self->{"_C_DATA"}; |
} |
sub can_stopbits { |
my $self = shift; |
return $self->{"_C_STOP"}; |
} |
sub can_dtrdsr { |
my $self = shift; |
return $self->{"_C_DTRDSR"}; |
} |
sub can_handshake { |
my $self = shift; |
return $self->{"_C_HSHAKE"}; |
} |
sub can_parity_check { |
my $self = shift; |
return $self->{"_C_PARITY_CK"}; |
} |
sub can_parity_config { |
my $self = shift; |
return $self->{"_C_PARITY_CFG"}; |
} |
sub can_parity_enable { |
my $self = shift; |
return $self->{"_C_PARITY_EN"}; |
} |
sub can_rlsd_config { |
my $self = shift; |
return $self->{"_C_RLSD_CFG"}; |
} |
sub can_rlsd { |
my $self = shift; |
return $self->{"_C_RLSD"}; |
} |
sub can_16bitmode { |
my $self = shift; |
return $self->{"_C_16BITMODE"}; |
} |
sub is_rs232 { |
my $self = shift; |
return ($self->{"_TYPE"} == PST_RS232); |
} |
sub is_modem { |
my $self = shift; |
return ($self->{"_TYPE"} == PST_MODEM); |
} |
sub can_rtscts { |
my $self = shift; |
return $self->{"_C_RTSCTS"}; |
} |
sub can_xonxoff { |
my $self = shift; |
return $self->{"_C_XONXOFF"}; |
} |
sub can_xon_char { |
my $self = shift; |
return $self->{"_C_XON_CHAR"}; |
} |
sub can_spec_char { |
my $self = shift; |
return $self->{"_C_SPECHAR"}; |
} |
sub can_interval_timeout { |
my $self = shift; |
return $self->{"_C_INT_TIME"}; |
} |
sub can_total_timeout { |
my $self = shift; |
return $self->{"_C_TOT_TIME"}; |
} |
sub is_handshake { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_HSHAKE"}; |
return unless (defined $self->{"_L_HSHAKE"}{$_[0]}); |
$self->{"_N_HSHAKE"} = $self->{"_L_HSHAKE"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{HSHAKE}; |
} |
sub are_handshake { |
my $self = shift; |
return unless $self->{"_C_HSHAKE"}; |
return if (@_); |
return keys(%{$self->{"_L_HSHAKE"}}); |
} |
sub is_baudrate { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_BAUD"}; |
return unless (defined $self->{"_L_BAUD"}{$_[0]}); |
$self->{"_N_BAUD"} = int shift; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{BAUD}; |
} |
sub are_baudrate { |
my $self = shift; |
return unless $self->{"_C_BAUD"}; |
return if (@_); |
return keys(%{$self->{"_L_BAUD"}}); |
} |
sub is_parity { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_PARITY_CFG"}; |
return unless (defined $self->{"_L_PARITY"}{$_[0]}); |
$self->{"_N_PARITY"} = $self->{"_L_PARITY"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{PARITY}; |
} |
sub are_parity { |
my $self = shift; |
return unless $self->{"_C_PARITY_CFG"}; |
return if (@_); |
return keys(%{$self->{"_L_PARITY"}}); |
} |
sub is_databits { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_DATA"}; |
return unless (defined $self->{"_L_DATA"}{$_[0]}); |
$self->{"_N_DATA"} = $self->{"_L_DATA"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{DATA}; |
} |
sub are_databits { |
my $self = shift; |
return unless $self->{"_C_DATA"}; |
return if (@_); |
return keys(%{$self->{"_L_DATA"}}); |
} |
sub is_stopbits { |
my $self = shift; |
if (@_) { |
return unless $self->{"_C_STOP"}; |
return unless (defined $self->{"_L_STOP"}{$_[0]}); |
$self->{"_N_STOP"} = $self->{"_L_STOP"}{$_[0]}; |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
return $self->{STOP}; |
} |
sub are_stopbits { |
my $self = shift; |
return unless $self->{"_C_STOP"}; |
return if (@_); |
return keys(%{$self->{"_L_STOP"}}); |
} |
# single value for save/start |
sub is_read_buf { |
my $self = shift; |
if (@_) { $self->{"_N_READBUF"} = int shift; } |
return $self->{READBUF}; |
} |
# single value for save/start |
sub is_write_buf { |
my $self = shift; |
if (@_) { $self->{"_N_WRITEBUF"} = int shift; } |
return $self->{WRITEBUF}; |
} |
sub is_buffers { |
my $self = shift; |
return unless (@_ == 2); |
my $rbuf = shift; |
my $wbuf = shift; |
SetupComm($self->{"_HANDLE"}, $rbuf, $wbuf) or return; |
$self->{"_N_READBUF"} = 0; |
$self->{"_N_WRITEBUF"} = 0; |
$self->{READBUF} = $rbuf; |
$self->{WRITEBUF} = $wbuf; |
1; |
} |
sub read_bg { |
return unless (@_ == 2); |
my $self = shift; |
my $wanted = shift; |
return unless ($wanted > 0); |
if ($self->{"_R_BUSY"}) { |
nocarp or carp "Second Read attempted before First is done"; |
return; |
} |
my $got_p = " "x4; |
my $ok; |
my $got = 0; |
if ($wanted > $RBUF_Size) { |
$wanted = $RBUF_Size; |
warn "read buffer limited to $RBUF_Size bytes at the moment"; |
} |
$self->{"_R_BUSY"} = 1; |
$ok=ReadFile( $self->{"_HANDLE"}, |
$self->{"_RBUF"}, |
$wanted, |
$got_p, |
$self->{"_R_OVERLAP"}); |
if ($ok) { |
$got = unpack("L", $got_p); |
$self->{"_R_BUSY"} = 0; |
} |
return $got; |
} |
sub write_bg { |
return unless (@_ == 2); |
my $self = shift; |
my $wbuf = shift; |
if ($self->{"_W_BUSY"}) { |
nocarp or carp "Second Write attempted before First is done"; |
return; |
} |
my $ok; |
my $got_p = " "x4; |
return 0 if ($wbuf eq ""); |
my $lbuf = length ($wbuf); |
my $written = 0; |
$self->{"_W_BUSY"} = 1; |
$ok=WriteFile( $self->{"_HANDLE"}, |
$wbuf, |
$lbuf, |
$got_p, |
$self->{"_W_OVERLAP"}); |
if ($ok) { |
$written = unpack("L", $got_p); |
$self->{"_W_BUSY"} = 0; |
} |
if ($Babble) { |
print "error=$ok\n"; |
print "wbuf=$wbuf\n"; |
print "lbuf=$lbuf\n"; |
print "write_bg=$written\n"; |
} |
return $written; |
} |
sub read_done { |
return unless (@_ == 2); |
my $self = shift; |
my $wait = yes_true ( shift ); |
my $ov; |
my $got_p = " "x4; |
my $wanted = 0; |
$self->{"_R_BUSY"} = 1; |
$ov=GetOverlappedResult( $self->{"_HANDLE"}, |
$self->{"_R_OVERLAP"}, |
$got_p, |
$wait); |
if ($ov) { |
$wanted = unpack("L", $got_p); |
$self->{"_R_BUSY"} = 0; |
print "read_done=$wanted\n" if ($Babble); |
return (1, $wanted, substr($self->{"_RBUF"}, 0, $wanted)); |
} |
return (0, 0, ""); |
} |
sub write_done { |
return unless (@_ == 2); |
my $self = shift; |
my $wait = yes_true ( shift ); |
my $ov; |
my $got_p = " "x4; |
my $written = 0; |
$self->{"_W_BUSY"} = 1; |
$ov=GetOverlappedResult( $self->{"_HANDLE"}, |
$self->{"_W_OVERLAP"}, |
$got_p, |
$wait); |
if ($ov) { |
$written = unpack("L", $got_p); |
$self->{"_W_BUSY"} = 0; |
print "write_done=$written\n" if ($Babble); |
return (1, $written); |
} |
return (0, $written); |
} |
sub purge_all { |
my $self = shift; |
return if (@_); |
# PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000f) ) { |
carp "Error in PurgeComm"; |
OS_Error; |
return; |
} |
$self->{"_R_BUSY"} = 0; |
$self->{"_W_BUSY"} = 0; |
return 1; |
} |
sub purge_rx { |
my $self = shift; |
return if (@_); |
# PURGE_RXABORT | PURGE_RXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x0000000a) ) { |
OS_Error; |
carp "Error in PurgeComm"; |
return; |
} |
$self->{"_R_BUSY"} = 0; |
return 1; |
} |
sub purge_tx { |
my $self = shift; |
return if (@_); |
# PURGE_TXABORT | PURGE_TXCLEAR |
unless ( PurgeComm($self->{"_HANDLE"}, 0x00000005) ) { |
OS_Error; |
carp "Error in PurgeComm"; |
return; |
} |
$self->{"_W_BUSY"} = 0; |
return 1; |
} |
sub are_buffers { |
my $self = shift; |
return if (@_); |
return ($self->{READBUF}, $self->{WRITEBUF}); |
} |
sub buffer_max { |
my $self = shift; |
return if (@_); |
return ($self->{"_RBUFMAX"}, $self->{"_TBUFMAX"}); |
} |
sub suspend_tx { |
my $self = shift; |
return if (@_); |
return SetCommBreak($self->{"_HANDLE"}); |
} |
sub resume_tx { |
my $self = shift; |
return if (@_); |
return ClearCommBreak($self->{"_HANDLE"}); |
} |
sub xmit_imm_char { |
my $self = shift; |
return unless (@_ == 1); |
my $v = int shift; |
unless ( TransmitCommChar($self->{"_HANDLE"}, $v) ) { |
carp "Can't transmit char: $v"; |
return; |
} |
1; |
} |
sub is_xon_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
$self->{"_N_XONCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XONCHAR}; |
} |
sub is_xoff_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_XON_CHAR"}) { |
$self->{"_N_XOFFCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XOFFCHAR}; |
} |
sub is_eof_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_EOFCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{EOFCHAR}; |
} |
sub is_event_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_EVTCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{EVTCHAR}; |
} |
sub is_error_char { |
my $self = shift; |
if ((@_ == 1) and $self->{"_C_SPECHAR"}) { |
$self->{"_N_ERRCHAR"} = 1 + shift; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{ERRCHAR}; |
} |
sub is_xon_limit { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_XONXOFF"}); |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->{"_N_XONLIM"} = ++$v; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XONLIM}; |
} |
sub is_xoff_limit { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_XONXOFF"}); |
my $v = int shift; |
return if (($v < 0) or ($v > SHORTsize)); |
$self->{"_N_XOFFLIM"} = ++$v; |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
return $self->{XOFFLIM}; |
} |
sub is_read_interval { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_INT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v > LONGsize)); |
if ($v == LONGsize) { |
$self->{"_N_RINT"} = $v; # Win32 uses as flag |
} |
else { |
$self->{"_N_RINT"} = ++$v; |
} |
return unless update_timeouts ($self); |
} |
return $self->{RINT}; |
} |
sub is_read_char_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_RTOT"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{RTOT}; |
} |
sub is_read_const_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_RCONST"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{RCONST}; |
} |
sub is_write_const_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_WCONST"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{WCONST}; |
} |
sub is_write_char_time { |
my $self = shift; |
if (@_) { |
return unless ($self->{"_C_TOT_TIME"}); |
my $v = int shift; |
return if (($v < 0) or ($v >= LONGsize)); |
$self->{"_N_WTOT"} = ++$v; |
return unless update_timeouts ($self); |
} |
return $self->{WTOT}; |
} |
sub update_timeouts { |
return unless (@_ == 1); |
my $self = shift; |
unless ( GetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
carp "Error in GetCommTimeouts"; |
return; |
} |
($self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST})= unpack($TIMEOUTformat, $self->{"_TIMEOUT"}); |
if ($self->{"_N_RINT"}) { |
if ($self->{"_N_RINT"} == LONGsize) { |
$self->{RINT} = $self->{"_N_RINT"}; # Win32 uses as flag |
} |
else { |
$self->{RINT} = $self->{"_N_RINT"} -1; |
} |
$self->{"_N_RINT"} = 0; |
} |
if ($self->{"_N_RTOT"}) { |
$self->{RTOT} = $self->{"_N_RTOT"} -1; |
$self->{"_N_RTOT"} = 0; |
} |
if ($self->{"_N_RCONST"}) { |
$self->{RCONST} = $self->{"_N_RCONST"} -1; |
$self->{"_N_RCONST"} = 0; |
} |
if ($self->{"_N_WTOT"}) { |
$self->{WTOT} = $self->{"_N_WTOT"} -1; |
$self->{"_N_WTOT"} = 0; |
} |
if ($self->{"_N_WCONST"}) { |
$self->{WCONST} = $self->{"_N_WCONST"} -1; |
$self->{"_N_WCONST"} = 0; |
} |
$self->{"_TIMEOUT"} = pack($TIMEOUTformat, |
$self->{RINT}, |
$self->{RTOT}, |
$self->{RCONST}, |
$self->{WTOT}, |
$self->{WCONST}); |
if ( SetCommTimeouts($self->{"_HANDLE"}, $self->{"_TIMEOUT"}) ) { |
return 1; |
} |
else { |
carp "Error in SetCommTimeouts"; |
return; |
} |
} |
# true/false parameters |
sub is_binary { |
my $self = shift; |
if (@_) { |
$self->{"_N_BINARY"} = 1 + yes_true ( shift ); |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
### printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fBinary); |
} |
sub is_parity_enable { |
my $self = shift; |
if (@_) { |
$self->{"_N_PARITY_EN"} = 1 + yes_true ( shift ); |
update_DCB ($self); |
} |
return unless fetch_DCB ($self); |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ## DEBUG ## |
return ($self->{"_BitMask"} & FM_fParity); |
} |
sub ignore_null { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fNull; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fNull; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fNull; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fNull); |
} |
sub ignore_no_dsr { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fDsrSensitivity; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fDsrSensitivity; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fDsrSensitivity; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fDsrSensitivity); |
} |
sub subst_pe_char { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fErrorChar; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fErrorChar; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fErrorChar; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fErrorChar); |
} |
sub abort_on_error { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fAbortOnError; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fAbortOnError; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fAbortOnError; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fAbortOnError); |
} |
sub output_dsr { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutxDsrFlow; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutxDsrFlow; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutxDsrFlow; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutxDsrFlow); |
} |
sub output_cts { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutxCtsFlow; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutxCtsFlow; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutxCtsFlow; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutxCtsFlow); |
} |
sub input_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fInX; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fInX; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fInX; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fInX); |
} |
sub output_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fOutX; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fOutX; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fOutX; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fOutX); |
} |
sub tx_on_xoff { |
my $self = shift; |
if (@_) { |
if ($self->{"_N_AUX_OFF"}) { |
$self->{"_N_AUX_OFF"} &= ~FM_fTXContinueOnXoff; |
} |
else { |
$self->{"_N_AUX_OFF"} = ~FM_fTXContinueOnXoff; |
} |
if ( yes_true ( shift ) ) { |
$self->{"_N_AUX_ON"} |= FM_fTXContinueOnXoff; |
} |
update_DCB ($self); |
} |
else { |
return unless fetch_DCB ($self); |
} |
## printf "_BitMask=%lx\n", $self->{"_BitMask"}; ### |
return ($self->{"_BitMask"} & FM_fTXContinueOnXoff); |
} |
sub dtr_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETDTR : CLRDTR ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
sub rts_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETRTS : CLRRTS ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
# pulse parameters |
sub pulse_dtr_off { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_dtr_off not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->dtr_active(0) or carp "Did not pulse DTR off"; |
Win32::Sleep($delay); |
$self->dtr_active(1) or carp "Did not restore DTR on"; |
Win32::Sleep($delay); |
} |
sub pulse_rts_off { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_rts_off not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->rts_active(0) or carp "Did not pulse RTS off"; |
Win32::Sleep($delay); |
$self->rts_active(1) or carp "Did not restore RTS on"; |
Win32::Sleep($delay); |
} |
sub pulse_break_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_break_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->break_active(1) or carp "Did not pulse BREAK on"; |
Win32::Sleep($delay); |
$self->break_active(0) or carp "Did not restore BREAK off"; |
Win32::Sleep($delay); |
} |
sub pulse_dtr_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_dtr_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->dtr_active(1) or carp "Did not pulse DTR on"; |
Win32::Sleep($delay); |
$self->dtr_active(0) or carp "Did not restore DTR off"; |
Win32::Sleep($delay); |
} |
sub pulse_rts_on { |
return unless (@_ == 2); |
if ( ($] < 5.005) and ($] >= 5.004) ) { |
nocarp or carp "\npulse_rts_on not supported on version $]\n"; |
return; |
} |
my $self = shift; |
my $delay = shift; |
$self->rts_active(1) or carp "Did not pulse RTS on"; |
Win32::Sleep($delay); |
$self->rts_active(0) or carp "Did not restore RTS off"; |
Win32::Sleep($delay); |
} |
sub break_active { |
return unless (@_ == 2); |
my $self = shift; |
my $onoff = yes_true ( shift ) ? SETBREAK : CLRBREAK ; |
return EscapeCommFunction($self->{"_HANDLE"}, $onoff); |
} |
sub xon_active { |
return unless (@_ == 1); |
my $self = shift; |
return EscapeCommFunction($self->{"_HANDLE"}, SETXON); |
} |
sub xoff_active { |
return unless (@_ == 1); |
my $self = shift; |
return EscapeCommFunction($self->{"_HANDLE"}, SETXOFF); |
} |
sub is_modemlines { |
return unless (@_ == 1); |
my $self = shift; |
my $mstat = " " x4; |
unless ( GetCommModemStatus($self->{"_HANDLE"}, $mstat) ) { |
carp "Error in GetCommModemStatus"; |
return; |
} |
my $result = unpack ("L", $mstat); |
return $result; |
} |
sub debug_comm { |
my $self = shift; |
if (ref($self)) { |
if (@_) { $self->{"_DEBUG_C"} = yes_true ( shift ); } |
else { |
nocarp or carp "Debug level: $self->{NAME} = $self->{\"_DEBUG_C\"}"; |
return $self->{"_DEBUG_C"}; |
} |
} else { |
$Babble = yes_true ($self); |
nocarp or carp "CommPort Debug Class = $Babble"; |
return $Babble; |
} |
} |
sub close { |
my $self = shift; |
my $ok; |
my $success = 1; |
return unless (defined $self->{NAME}); |
if ($Babble) { |
carp "Closing $self " . $self->{NAME}; |
} |
if ($self->{"_HANDLE"}) { |
purge_all ($self); |
update_timeouts ($self); # if any running ?? |
$ok=CloseHandle($self->{"_HANDLE"}); |
if (! $ok) { |
print "Error Closing handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
elsif ($Babble) { |
print "Closing Device handle $self->{\"_HANDLE\"} for $self->{NAME}\n"; |
} |
$self->{"_HANDLE"} = undef; |
} |
if ($self->{"_R_EVENT"}) { |
$ok=CloseHandle($self->{"_R_EVENT"}); |
if (! $ok) { |
print "Error closing Read Event handle $self->{\"_R_EVENT\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
$self->{"_R_EVENT"} = undef; |
} |
if ($self->{"_W_EVENT"}) { |
$ok=CloseHandle($self->{"_W_EVENT"}); |
if (! $ok) { |
print "Error closing Write Event handle $self->{\"_W_EVENT\"} for $self->{NAME}\n"; |
OS_Error; |
$success = 0; |
} |
$self->{"_W_EVENT"} = undef; |
} |
$self->{NAME} = undef; |
if ($Babble) { |
printf "CommPort close result:%d\n", $success; |
} |
return $success; |
} |
sub DESTROY { |
my $self = shift; |
return unless (defined $self->{NAME}); |
if ($Babble or $self->{"_DEBUG_C"}) { |
print "Destroying $self->{NAME}\n" if (defined $self->{NAME}); |
} |
$self->close; |
} |
1; # so the require or use succeeds |
# Autoload methods go after =cut, and are processed by the autosplit program. |
__END__ |
=pod |
=head1 NAME |
Win32API::CommPort - Raw Win32 system API calls for serial communications. |
=head1 SYNOPSIS |
use Win32; ## not required under all circumstances |
require 5.003; |
use Win32API::CommPort qw( :PARAM :STAT 0.19 ); |
## when available ## use Win32API::File 0.07 qw( :ALL ); |
=head2 Constructors |
$PortObj = new Win32API::CommPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
@required = qw( BAUD DATA STOP ); |
$faults = $PortObj->initialize(@required); |
if ($faults) { die "Required parameters not set before initialize\n"; } |
=head2 Configuration Utility Methods |
set_no_messages(1); # test suite use |
# exported by :PARAM |
nocarp || carp "Something fishy"; |
$a = SHORTsize; # 0xffff |
$a = LONGsize; # 0xffffffff |
$answer = yes_true("choice"); # 1 or 0 |
OS_Error unless ($API_Call_OK); # prints error |
$PortObj->init_done || die "Not done"; |
$PortObj->fetch_DCB || die "Not done"; |
$PortObj->update_DCB || die "Not done"; |
$milliseconds = $PortObj->get_tick_count; |
=head2 Capability Methods (read only) |
# true/false capabilities |
$a = $PortObj->can_baud; # else fixed |
$a = $PortObj->can_databits; |
$a = $PortObj->can_stopbits; |
$a = $PortObj->can_dtrdsr; |
$a = $PortObj->can_handshake; |
$a = $PortObj->can_parity_check; |
$a = $PortObj->can_parity_config; |
$a = $PortObj->can_parity_enable; |
$a = $PortObj->can_rlsd; # receive line signal detect (carrier) |
$a = $PortObj->can_rlsd_config; |
$a = $PortObj->can_16bitmode; |
$a = $PortObj->is_rs232; |
$a = $PortObj->is_modem; |
$a = $PortObj->can_rtscts; |
$a = $PortObj->can_xonxoff; |
$a = $PortObj->can_xon_char; |
$a = $PortObj->can_spec_char; |
$a = $PortObj->can_interval_timeout; |
$a = $PortObj->can_total_timeout; |
# list output capabilities |
($rmax, $wmax) = $PortObj->buffer_max; |
($rbuf, $wbuf) = $PortObj->are_buffers; # current |
@choices = $PortObj->are_baudrate; # legal values |
@choices = $PortObj->are_handshake; |
@choices = $PortObj->are_parity; |
@choices = $PortObj->are_databits; |
@choices = $PortObj->are_stopbits; |
=head2 Configuration Methods |
# most methods can be called two ways: |
$PortObj->is_handshake("xoff"); # set parameter |
$flowcontrol = $PortObj->is_handshake; # current value (scalar) |
# similar |
$PortObj->is_baudrate(9600); |
$PortObj->is_parity("odd"); |
$PortObj->is_databits(8); |
$PortObj->is_stopbits(1); |
$PortObj->debug_comm(0); |
$PortObj->is_xon_limit(100); # bytes left in buffer |
$PortObj->is_xoff_limit(100); # space left in buffer |
$PortObj->is_xon_char(0x11); |
$PortObj->is_xoff_char(0x13); |
$PortObj->is_eof_char(0x0); |
$PortObj->is_event_char(0x0); |
$PortObj->is_error_char(0); # for parity errors |
$rbuf = $PortObj->is_read_buf; # read_only except internal use |
$wbuf = $PortObj->is_write_buf; |
$size = $PortObj->internal_buffer; |
$PortObj->is_buffers(4096, 4096); # read, write |
# returns current in list context |
$PortObj->is_read_interval(100); # max time between read char (millisec) |
$PortObj->is_read_char_time(5); # avg time between read char |
$PortObj->is_read_const_time(100); # total = (avg * bytes) + const |
$PortObj->is_write_char_time(5); |
$PortObj->is_write_const_time(100); |
$PortObj->is_binary(T); # just say Yes (Win 3.x option) |
$PortObj->is_parity_enable(F); # faults during input |
=head2 Operating Methods |
($BlockingFlags, $InBytes, $OutBytes, $LatchErrorFlags) = $PortObj->is_status |
|| warn "could not get port status\n"; |
$ClearedErrorFlags = $PortObj->reset_error; |
# The API resets errors when reading status, $LatchErrorFlags |
# is all $ErrorFlags since they were last explicitly cleared |
if ($BlockingFlags) { warn "Port is blocked"; } |
if ($BlockingFlags & BM_fCtsHold) { warn "Waiting for CTS"; } |
if ($LatchErrorFlags & CE_FRAME) { warn "Framing Error"; } |
Additional useful constants may be exported eventually. |
$count_in = $PortObj->read_bg($InBytes); |
($done, $count_in, $string_in) = $PortObj->read_done(1); |
# background read with wait until done |
$count_out = $PortObj->write_bg($output_string); # background write |
($done, $count_out) = $PortObj->write_done(0); |
$PortObj->suspend_tx; # output from write buffer |
$PortObj->resume_tx; |
$PortObj->xmit_imm_char(0x03); # bypass buffer (and suspend) |
$PortObj->xoff_active; # simulate received xoff |
$PortObj->xon_active; # simulate received xon |
$PortObj->purge_all; |
$PortObj->purge_rx; |
$PortObj->purge_tx; |
# controlling outputs from the port |
$PortObj->dtr_active(T); # sends outputs direct to hardware |
$PortObj->rts_active(Yes); # returns status of API call |
$PortObj->break_active(N); # NOT state of bit |
$PortObj->pulse_break_on($milliseconds); # off version is implausible |
$PortObj->pulse_rts_on($milliseconds); |
$PortObj->pulse_rts_off($milliseconds); |
$PortObj->pulse_dtr_on($milliseconds); |
$PortObj->pulse_dtr_off($milliseconds); |
# sets_bit, delays, resets_bit, delays |
# pulse_xxx methods not supported on Perl 5.004 |
$ModemStatus = $PortObj->is_modemlines; |
if ($ModemStatus & $PortObj->MS_RLSD_ON) { print "carrier detected"; } |
$PortObj->close || die; |
# "undef $PortObj" preferred unless reopening port |
# "close" should precede "undef" if both used |
=head1 DESCRIPTION |
This provides fairly low-level access to the Win32 System API calls |
dealing with serial ports. |
Uses features of the Win32 API to implement non-blocking I/O, serial |
parameter setting, event-loop operation, and enhanced error handling. |
To pass in C<NULL> as the pointer to an optional buffer, pass in C<$null=0>. |
This is expected to change to an empty list reference, C<[]>, when Perl |
supports that form in this usage. |
Beyond raw access to the API calls and related constants, this module |
will eventually handle smart buffer allocation and translation of return |
codes. |
=head2 Initialization |
The constructor is B<new> with a F<PortName> (as the Registry |
knows it) specified. This will do a B<CreateFile>, get the available |
options and capabilities via the Win32 API, and create the object. |
The port is not yet ready for read/write access. First, the desired |
I<parameter settings> must be established. Since these are tuning |
constants for an underlying hardware driver in the Operating System, |
they should all checked for validity by the method calls that set them. |
The B<initialize> method takes a list of required parameters and confirms |
they have been set. For others, it will attempt to deduce defaults from |
the hardware or from other parameters. The B<initialize> method returns |
the number of faults (zero if the port is setup ok). The B<update_DCB> |
method writes a new I<Device Control Block> to complete the startup and |
allow the port to be used. Ports are opened for binary transfers. A |
separate C<binmode> is not needed. The USER must release the object |
if B<initialize> or B<update_DCB> does not succeed. |
Version 0.15 adds an optional C<$quiet> parameter to B<new>. Failure |
to open a port prints a error message to STDOUT by default. Since only |
one application at a time can "own" the port, one source of failure was |
"port in use". There was previously no way to check this without getting |
a "fail message". Setting C<$quiet> disables this built-in message. It |
also returns 0 instead of C<undef> if the port is unavailable (still FALSE, |
used for testing this condition - other faults may still return C<undef>). |
Use of C<$quiet> only applies to B<new>. |
The fault checking in B<initialize> consists in verifying an I<_N_$item> |
internal variable exists for each I<$item> in the input list. The |
I<_N_$item> is created for each parameter that is set either directly |
or by default. A derived class must create the I<_N_$items> for any |
varibles it adds to the base class if it wants B<initialize> to check |
them. Win32API::CommPort supports the following: |
$item _N_$item setting method |
------ --------- -------------- |
BAUD "_N_BAUD" is_baudrate |
BINARY "_N_BINARY" is_binary |
DATA "_N_DATA" is_databits |
EOFCHAR "_N_EOFCHAR" is_eof_char |
ERRCHAR "_N_ERRCHAR" is_error_char |
EVTCHAR "_N_EVTCHAR" is_event_char |
HSHAKE "_N_HSHAKE" is_handshake |
PARITY "_N_PARITY" is_parity |
PARITY_EN "_N_PARITY_EN" is_parity_enable |
RCONST "_N_RCONST" is_read_const_time |
READBUF "_N_READBUF" is_read_buf |
RINT "_N_RINT" is_read_interval |
RTOT "_N_RTOT" is_read_char_time |
STOP "_N_STOP" is_stopbits |
WCONST "_N_WCONST" is_write_const_time |
WRITEBUF "_N_WRITEBUF" is_write_buf |
WTOT "_N_WTOT" is_write_char_time |
XOFFCHAR "_N_XOFFCHAR" is_xoff_char |
XOFFLIM "_N_XOFFLIM" is_xoff_limit |
XONCHAR "_N_XONCHAR" is_xon_char |
XONLIM "_N_XONLIM" is_xon_limit |
Some individual parameters (eg. baudrate) can be changed after the |
initialization is completed. These will automatically update the |
I<Device Control Block> as required. The I<init_done> method indicates |
when I<initialize> has completed successfully. |
$PortObj = new Win32API::CommPort ($PortName, $quiet) |
|| die "Can't open $PortName: $^E\n"; # $quiet is optional |
if $PortObj->can_databits { $PortObj->is_databits(8) }; |
$PortObj->is_baudrate(9600); |
$PortObj->is_parity("none"); |
$PortObj->is_stopbits(1); |
$PortObj->is_handshake("rts"); |
$PortObj->is_buffers(4096, 4096); |
$PortObj->dtr_active(T); |
@required = qw( BAUD DATA STOP PARITY ); |
$PortObj->initialize(@required) || undef $PortObj; |
$PortObj->dtr_active(f); |
$PortObj->is_baudrate(300); |
$PortObj->close || die; |
# "undef $PortObj" preferred unless reopening port |
# "close" should precede "undef" if both used |
undef $PortObj; # closes port AND frees memory in perl |
The F<PortName> maps to both the Registry I<Device Name> and the |
I<Properties> associated with that device. A single I<Physical> port |
can be accessed using two or more I<Device Names>. But the options |
and setup data will differ significantly in the two cases. A typical |
example is a Modem on port "COM2". Both of these F<PortNames> open |
the same I<Physical> hardware: |
$P1 = new Win32API::CommPort ("COM2"); |
$P2 = new Win32API::CommPort ("\\\\.\\Nanohertz Modem model K-9"); |
$P1 is a "generic" serial port. $P2 includes all of $P1 plus a variety |
of modem-specific added options and features. The "raw" API calls return |
different size configuration structures in the two cases. Win32 uses the |
"\\.\" prefix to identify "named" devices. Since both names use the same |
I<Physical> hardware, they can not both be used at the same time. The OS |
will complain. Consider this A Good Thing. |
Version 0.16 adds B<pulse> methods for the I<RTS, BREAK, and DTR> bits. The |
B<pulse> methods assume the bit is in the opposite state when the method |
is called. They set the requested state, delay the specified number of |
milliseconds, set the opposite state, and again delay the specified time. |
These methods are designed to support devices, such as the X10 "FireCracker" |
control and some modems, which require pulses on these lines to signal |
specific events or data. Since the 5.00402 Perl distribution from CPAN does |
not support sub-second time delays readily, these methods are not supported |
on that version of Perl. |
$PortObj->pulse_break_on($milliseconds); |
$PortObj->pulse_rts_on($milliseconds); |
$PortObj->pulse_rts_off($milliseconds); |
$PortObj->pulse_dtr_on($milliseconds); |
$PortObj->pulse_dtr_off($milliseconds); |
Version 0.16 also adds I<experimental> support for the rest of the option bits |
available through the I<Device Control Block>. They have not been extensively |
tested and these settings are NOT saved in the B<configuration file> by |
I<Win32::SerialPort>. Please let me know if one does not work as advertised. |
[Win32 API bit designation] |
$PortObj->ignore_null(0); # discard \000 bytes on input [fNull] |
$PortObj->ignore_no_dsr(0); # discard input bytes unless DSR |
# [fDsrSensitivity] |
$PortObj->subst_pe_char(0); # replace parity errors with B<is_error_char> |
# when B<is_parity_enable> [fErrorChar] |
$PortObj->abort_on_error(0); # cancel read/write [fAbortOnError] |
# next one set by $PortObj->is_handshake("dtr"); |
$PortObj->output_dsr(0); # use DSR handshake on output [fOutxDsrFlow] |
# next one set by $PortObj->is_handshake("rts"); |
$PortObj->output_cts(0); # use CTS handshake on output [fOutxCtsFlow] |
# next two set by $PortObj->is_handshake("xoff"); |
$PortObj->input_xoff(0); # use Xon/Xoff handshake on input [fInX] |
$PortObj->output_xoff(0); # use Xon/Xoff handshake on output [fOutX] |
$PortObj->tx_on_xoff(0); # continue output even after input xoff sent |
# [fTXContinueOnXoff] |
The B<get_tick_count> method is a wrapper around the I<Win32::GetTickCount()> |
function. It matches a corresponding method in I<Device::SerialPort> which |
does not have access to the I<Win32::> namespace. It still returns time |
in milliseconds - but can be used in cross-platform scripts. |
=head2 Configuration and Capability Methods |
The Win32 Serial Comm API provides extensive information concerning |
the capabilities and options available for a specific port (and |
instance). "Modem" ports have different capabilties than "RS-232" |
ports - even if they share the same Hardware. Many traditional modem |
actions are handled via TAPI. "Fax" ports have another set of options - |
and are accessed via MAPI. Yet many of the same low-level API commands |
and data structures are "common" to each type ("Modem" is implemented |
as an "RS-232" superset). In addition, Win95 supports a variety of |
legacy hardware (e.g fixed 134.5 baud) while WinNT has hooks for ISDN, |
16-data-bit paths, and 256Kbaud. |
=over 8 |
Binary selections will accept as I<true> any of the following: |
C<("YES", "Y", "ON", "TRUE", "T", "1", 1)> (upper/lower/mixed case) |
Anything else is I<false>. |
There are a large number of possible configuration and option parameters. |
To facilitate checking option validity in scripts, most configuration |
methods can be used in two different ways: |
=item method called with an argument |
The parameter is set to the argument, if valid. An invalid argument |
returns I<false> (undef) and the parameter is unchanged. After B<init_done>, |
the port will be updated immediately if allowed. Otherwise, the value |
will be applied when B<update_DCB> is called. |
=item method called with no argument in scalar context |
The current value is returned. If the value is not initialized either |
directly or by default, return "undef" which will parse to I<false>. |
For binary selections (true/false), return the current value. All |
current values from "multivalue" selections will parse to I<true>. |
Current values may differ from requested values until B<init_done>. |
There is no way to see requests which have not yet been applied. |
Setting the same parameter again overwrites the first request. Test |
the return value of the setting method to check "success". |
=item Asynchronous (Background) I/O |
This version now handles Polling (do if Ready), Synchronous (block until |
Ready), and Asynchronous Modes (begin and test if Ready) with the timeout |
choices provided by the API. No effort has yet been made to interact with |
Windows events. But background I/O has been used successfully with the |
Perl Tk modules and callbacks from the event loop. |
=item Timeouts |
The API provides two timing models. The first applies only to reading and |
essentially determines I<Read Not Ready> by checking the time between |
consecutive characters. The B<ReadFile> operation returns if that time |
exceeds the value set by B<is_read_interval>. It does this by timestamping |
each character. It appears that at least one character must by received in |
I<every> B<read> I<call to the API> to initialize the mechanism. The timer |
is then reset by each succeeding character. If no characters are received, |
the read will block indefinitely. |
Setting B<is_read_interval> to C<0xffffffff> will do a non-blocking read. |
The B<ReadFile> returns immediately whether or not any characters are |
actually read. This replicates the behavior of the API. |
The other model defines the total time allowed to complete the operation. |
A fixed overhead time is added to the product of bytes and per_byte_time. |
A wide variety of timeout options can be defined by selecting the three |
parameters: fixed, each, and size. |
Read_Total = B<is_read_const_time> + (B<is_read_char_time> * bytes_to_read) |
Write_Total = B<is_write_const_time> + (B<is_write_char_time> * bytes_to_write) |
When reading a known number of characters, the I<Read_Total> mechanism is |
recommended. This mechanism I<MUST> be used with |
I<Win32::SerialPort tied FileHandles> because the tie methods can make |
multiple internal API calls. The I<Read_Interval> mechanism is suitable for |
a B<read_bg> method that expects a response of variable or unknown size. You |
should then also set a long I<Read_Total> timeout as a "backup" in case |
no bytes are received. |
=back |
=head2 Exports |
Nothing is exported by default. The following tags can be used to have |
large sets of symbols exported: |
=over 4 |
=item :PARAM |
Utility subroutines and constants for parameter setting and test: |
LONGsize SHORTsize nocarp yes_true |
OS_Error internal_buffer |
=item :STAT |
Serial communications status constants. Included are the constants for |
ascertaining why a transmission is blocked: |
BM_fCtsHold BM_fDsrHold BM_fRlsdHold BM_fXoffHold |
BM_fXoffSent BM_fEof BM_fTxim BM_AllBits |
Which incoming bits are active: |
MS_CTS_ON MS_DSR_ON MS_RING_ON MS_RLSD_ON |
What hardware errors have been detected: |
CE_RXOVER CE_OVERRUN CE_RXPARITY CE_FRAME |
CE_BREAK CE_TXFULL CE_MODE |
Offsets into the array returned by B<status:> |
ST_BLOCK ST_INPUT ST_OUTPUT ST_ERROR |
=item :RAW |
The constants and wrapper methods for low-level API calls. Details of |
these methods may change with testing. Some may be inherited from |
Win32API::File when that becomes available. |
$result=ClearCommError($handle, $Error_BitMask_p, $CommStatus); |
$result=ClearCommBreak($handle); |
$result=SetCommBreak($handle); |
$result=GetCommModemStatus($handle, $ModemStatus); |
$result=GetCommProperties($handle, $CommProperties); |
$result=GetCommState($handle, $DCB_Buffer); |
$result=SetCommState($handle, $DCB_Buffer); |
$result=SetupComm($handle, $in_buf_size, $out_buf_size); |
$result=ReadFile($handle, $buffer, $wanted, $got, $template); |
$result=WriteFile($handle, $buffer, $size, $count, $template); |
$result=GetCommTimeouts($handle, $CommTimeOuts); |
$result=SetCommTimeouts($handle, $CommTimeOuts); |
$result=EscapeCommFunction($handle, $Func_ID); |
$result=GetCommConfig($handle, $CommConfig, $Size); |
$result=SetCommConfig($handle, $CommConfig, $Size); |
$result=PurgeComm($handle, $flags); |
$result=GetCommMask($handle, $Event_Bitmask); |
$result=SetCommMask($handle, $Event_Bitmask); |
$hEvent=CreateEvent($security, $reset_req, $initial, $name); |
$handle=CreateFile($file, $access, $share, $security, |
$creation, $flags, $template); |
$result=CloseHandle($handle); |
$result=ResetEvent($hEvent); |
$result=TransmitCommChar($handle, $char); |
$result=WaitCommEvent($handle, $Event_Bitmask, $lpOverlapped); |
$result=GetOverlappedResult($handle, $lpOverlapped, $count, $bool); |
Flags used by B<PurgeComm:> |
PURGE_TXABORT PURGE_RXABORT PURGE_TXCLEAR PURGE_RXCLEAR |
Function IDs used by EscapeCommFunction: |
SETXOFF SETXON SETRTS CLRRTS |
SETDTR CLRDTR SETBREAK CLRBREAK |
Events used by B<WaitCommEvent:> |
EV_RXCHAR EV_RXFLAG EV_TXEMPTY EV_CTS |
EV_DSR EV_RLSD EV_BREAK EV_ERR |
EV_RING EV_PERR EV_RX80FULL EV_EVENT1 |
EV_EVENT2 |
Errors specific to B<GetOverlappedResult:> |
ERROR_IO_INCOMPLETE ERROR_IO_PENDING |
=item :COMMPROP |
The constants for the I<CommProperties structure> returned by |
B<GetCommProperties>. Included mostly for completeness. |
BAUD_USER BAUD_075 BAUD_110 BAUD_134_5 |
BAUD_150 BAUD_300 BAUD_600 BAUD_1200 |
BAUD_1800 BAUD_2400 BAUD_4800 BAUD_7200 |
BAUD_9600 BAUD_14400 BAUD_19200 BAUD_38400 |
BAUD_56K BAUD_57600 BAUD_115200 BAUD_128K |
PST_FAX PST_LAT PST_MODEM PST_PARALLELPORT |
PST_RS232 PST_RS422 PST_X25 PST_NETWORK_BRIDGE |
PST_RS423 PST_RS449 PST_SCANNER PST_TCPIP_TELNET |
PST_UNSPECIFIED |
PCF_INTTIMEOUTS PCF_PARITY_CHECK PCF_16BITMODE |
PCF_DTRDSR PCF_SPECIALCHARS PCF_RLSD |
PCF_RTSCTS PCF_SETXCHAR PCF_TOTALTIMEOUTS |
PCF_XONXOFF |
SP_BAUD SP_DATABITS SP_HANDSHAKING SP_PARITY |
SP_RLSD SP_STOPBITS SP_SERIALCOMM SP_PARITY_CHECK |
DATABITS_5 DATABITS_6 DATABITS_7 DATABITS_8 |
DATABITS_16 DATABITS_16X |
STOPBITS_10 STOPBITS_15 STOPBITS_20 |
PARITY_SPACE PARITY_NONE PARITY_ODD PARITY_EVEN |
PARITY_MARK |
COMMPROP_INITIALIZED |
=item :DCB |
The constants for the I<Device Control Block> returned by B<GetCommState> |
and updated by B<SetCommState>. Again, included mostly for completeness. |
But there are some combinations of "FM_f" settings which are not currently |
supported by high-level commands. If you need one of those, please report |
the lack as a bug. |
CBR_110 CBR_300 CBR_600 CBR_1200 |
CBR_2400 CBR_4800 CBR_9600 CBR_14400 |
CBR_19200 CBR_38400 CBR_56000 CBR_57600 |
CBR_115200 CBR_128000 CBR_256000 |
DTR_CONTROL_DISABLE DTR_CONTROL_ENABLE DTR_CONTROL_HANDSHAKE |
RTS_CONTROL_DISABLE RTS_CONTROL_ENABLE RTS_CONTROL_HANDSHAKE |
RTS_CONTROL_TOGGLE |
EVENPARITY MARKPARITY NOPARITY ODDPARITY |
SPACEPARITY |
ONESTOPBIT ONE5STOPBITS TWOSTOPBITS |
FM_fBinary FM_fParity FM_fOutxCtsFlow |
FM_fOutxDsrFlow FM_fDtrControl FM_fDsrSensitivity |
FM_fTXContinueOnXoff FM_fOutX FM_fInX |
FM_fErrorChar FM_fNull FM_fRtsControl |
FM_fAbortOnError FM_fDummy2 |
=item :ALL |
All of the above. Except for the I<test suite>, there is not really a good |
reason to do this. |
=back |
=head1 NOTES |
The object returned by B<new> is NOT a I<Filehandle>. You |
will be disappointed if you try to use it as one. |
e.g. the following is WRONG!!____C<print $PortObj "some text";> |
I<Win32::SerialPort> supports accessing ports via I<Tied Filehandles>. |
An important note about Win32 filenames. The reserved device names such |
as C< COM1, AUX, LPT1, CON, PRN > can NOT be used as filenames. Hence |
I<"COM2.cfg"> would not be usable for B<$Configuration_File_Name>. |
This module uses Win32::API extensively. The raw API calls are B<very> |
unforgiving. You will certainly want to start perl with the B<-w> switch. |
If you can, B<use strict> as well. Try to ferret out all the syntax and |
usage problems BEFORE issuing the API calls (many of which modify tuning |
constants in hardware device drivers....not where you want to look for bugs). |
Thanks to Ken White for testing on NT. |
=head1 KNOWN LIMITATIONS |
The current version of the module has been designed for testing using |
the ActiveState and Core (GS 5.004_02) ports of Perl for Win32 without |
requiring a compiler or using XS. In every case, compatibility has been |
selected over performance. Since everything is (sometimes convoluted but |
still pure) Perl, you can fix flaws and change limits if required. But |
please file a bug report if you do. This module has been tested with |
each of the binary perl versions for which Win32::API is supported: AS |
builds 315, 316, and 500-509 and GS 5.004_02. It has only been tested on |
Intel hardware. |
=over 4 |
=item Tutorial |
With all the options, this module needs a good tutorial. It doesn't |
have a complete one yet. A I<"How to get started"> tutorial appeared |
B<The Perl Journal #13> (March 1999). The demo programs are a good |
starting point for additional examples. |
=item Buffers |
The size of the Win32 buffers are selectable with B<is_buffers>. But each read |
method currently uses a fixed internal buffer of 4096 bytes. This can be |
changed in the module source. The read-only B<internal_buffer> method will |
give the current size. There are other fixed internal buffers as well. But |
no one has needed to change those. The XS version will support dynamic buffer |
sizing. |
=item Modems |
Lots of modem-specific options are not supported. The same is true of |
TAPI, MAPI. I<API Wizards> are welcome to contribute. |
=item API Options |
Lots of options are just "passed through from the API". Some probably |
shouldn't be used together. The module validates the obvious choices when |
possible. For something really fancy, you may need additional API |
documentation. Available from I<Micro$oft Pre$$>. |
=back |
=head1 BUGS |
ActiveState ports of Perl for Win32 before build 500 do not support the |
tools for building extensions and so will not support later versions of |
this extension. In particular, the automated install and test scripts in |
this distribution work differently with ActiveState builds 3xx. |
There is no parameter checking on the "raw" API calls. You probably should |
be familiar with using the calls in "C" before doing much experimenting. |
On Win32, a port must B<close> before it can be reopened again by the same |
process. If a physical port can be accessed using more than one name (see |
above), all names are treated as one. The perl script can also be run |
multiple times within a single batch file or shell script. The I<Makefile.PL> |
spawns subshells with backticks to run the test suite on Perl 5.003 - ugly, |
but it works. |
On NT, a B<read_done> or B<write_done> returns I<False> if a background |
operation is aborted by a purge. Win95 returns I<True>. |
EXTENDED_OS_ERROR ($^E) is not supported by the binary ports before 5.005. |
It "sort-of-tracks" B<$!> in 5.003 and 5.004, but YMMV. |
A few NT systems seem to set B<can_parity_enable> true, but do not actually |
support setting B<is_parity_enable>. This may be a characteristic of certain |
third-party serial drivers. Or a Microsoft bug. I have not been able to |
reproduce it on my system. |
__Please send comments and bug reports to wcbirthisel@alum.mit.edu. |
=head1 AUTHORS |
Bill Birthisel, wcbirthisel@alum.mit.edu, http://members.aol.com/Bbirthisel/. |
Tye McQueen, tye@metronet.com, http://www.metronet.com/~tye/. |
=head1 SEE ALSO |
Wi32::SerialPort - High-level user interface/front-end for this module |
Win32API::File I<when available> |
Win32::API - Aldo Calpini's "Magic", http://www.divinf.it/dada/perl/ |
Perltoot.xxx - Tom (Christiansen)'s Object-Oriented Tutorial |
=head1 COPYRIGHT |
Copyright (C) 1999, Bill Birthisel. All rights reserved. |
This module is free software; you can redistribute it and/or modify it |
under the same terms as Perl itself. |
=head2 COMPATIBILITY |
Most of the code in this module has been stable since version 0.12. |
Except for items indicated as I<Experimental>, I do not expect functional |
changes which are not fully backwards compatible. However, Version 0.16 |
removes the "dummy (0, 1) list" which was returned by many binary methods |
in case they were called in list context. I do not know of any use outside |
the test suite for that feature. |
Version 0.12 added an I<Install.PL> script to put modules into the documented |
Namespaces. The script uses I<MakeMaker> tools not available in |
ActiveState 3xx builds. Users of those builds will need to install |
differently (see README). Programs in the test suite are modified for |
the current version. Additions to the configurtion files generated by |
B<save> prevent those created by Version 0.15 from being used by earlier |
Versions. 4 November 1999. |
=cut |
/MissionCockpit/tags/V0.2.5/perl/site/lib/threads/shared.pm |
---|
0,0 → 1,616 |
package threads::shared; |
use 5.008; |
use strict; |
use warnings; |
use Scalar::Util qw(reftype refaddr blessed); |
our $VERSION = '1.28'; |
my $XS_VERSION = $VERSION; |
$VERSION = eval $VERSION; |
# Declare that we have been loaded |
$threads::shared::threads_shared = 1; |
# Load the XS code, if applicable |
if ($threads::threads) { |
require XSLoader; |
XSLoader::load('threads::shared', $XS_VERSION); |
*is_shared = \&_id; |
} else { |
# String eval is generally evil, but we don't want these subs to |
# exist at all if 'threads' is not loaded successfully. |
# Vivifying them conditionally this way saves on average about 4K |
# of memory per thread. |
eval <<'_MARKER_'; |
sub share (\[$@%]) { return $_[0] } |
sub is_shared (\[$@%]) { undef } |
sub cond_wait (\[$@%];\[$@%]) { undef } |
sub cond_timedwait (\[$@%]$;\[$@%]) { undef } |
sub cond_signal (\[$@%]) { undef } |
sub cond_broadcast (\[$@%]) { undef } |
_MARKER_ |
} |
### Export ### |
sub import |
{ |
# Exported subroutines |
my @EXPORT = qw(share is_shared cond_wait cond_timedwait |
cond_signal cond_broadcast shared_clone); |
if ($threads::threads) { |
push(@EXPORT, 'bless'); |
} |
# Export subroutine names |
my $caller = caller(); |
foreach my $sym (@EXPORT) { |
no strict 'refs'; |
*{$caller.'::'.$sym} = \&{$sym}; |
} |
} |
# Predeclarations for internal functions |
my ($make_shared); |
### Methods, etc. ### |
sub threads::shared::tie::SPLICE |
{ |
require Carp; |
Carp::croak('Splice not implemented for shared arrays'); |
} |
# Create a thread-shared clone of a complex data structure or object |
sub shared_clone |
{ |
if (@_ != 1) { |
require Carp; |
Carp::croak('Usage: shared_clone(REF)'); |
} |
return $make_shared->(shift, {}); |
} |
### Internal Functions ### |
# Used by shared_clone() to recursively clone |
# a complex data structure or object |
$make_shared = sub { |
my ($item, $cloned) = @_; |
# Just return the item if: |
# 1. Not a ref; |
# 2. Already shared; or |
# 3. Not running 'threads'. |
return $item if (! ref($item) || is_shared($item) || ! $threads::threads); |
# Check for previously cloned references |
# (this takes care of circular refs as well) |
my $addr = refaddr($item); |
if (exists($cloned->{$addr})) { |
# Return the already existing clone |
return $cloned->{$addr}; |
} |
# Make copies of array, hash and scalar refs and refs of refs |
my $copy; |
my $ref_type = reftype($item); |
# Copy an array ref |
if ($ref_type eq 'ARRAY') { |
# Make empty shared array ref |
$copy = &share([]); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
push(@$copy, map { $make_shared->($_, $cloned) } @$item); |
} |
# Copy a hash ref |
elsif ($ref_type eq 'HASH') { |
# Make empty shared hash ref |
$copy = &share({}); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
foreach my $key (keys(%{$item})) { |
$copy->{$key} = $make_shared->($item->{$key}, $cloned); |
} |
} |
# Copy a scalar ref |
elsif ($ref_type eq 'SCALAR') { |
$copy = \do{ my $scalar = $$item; }; |
share($copy); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
} |
# Copy of a ref of a ref |
elsif ($ref_type eq 'REF') { |
# Special handling for $x = \$x |
if ($addr == refaddr($$item)) { |
$copy = \$copy; |
share($copy); |
$cloned->{$addr} = $copy; |
} else { |
my $tmp; |
$copy = \$tmp; |
share($copy); |
# Add to clone checking hash |
$cloned->{$addr} = $copy; |
# Recursively copy and add contents |
$tmp = $make_shared->($$item, $cloned); |
} |
} else { |
require Carp; |
Carp::croak("Unsupported ref type: ", $ref_type); |
} |
# If input item is an object, then bless the copy into the same class |
if (my $class = blessed($item)) { |
bless($copy, $class); |
} |
# Clone READONLY flag |
if ($ref_type eq 'SCALAR') { |
if (Internals::SvREADONLY($$item)) { |
Internals::SvREADONLY($$copy, 1) if ($] >= 5.008003); |
} |
} |
if (Internals::SvREADONLY($item)) { |
Internals::SvREADONLY($copy, 1) if ($] >= 5.008003); |
} |
return $copy; |
}; |
1; |
__END__ |
=head1 NAME |
threads::shared - Perl extension for sharing data structures between threads |
=head1 VERSION |
This document describes threads::shared version 1.28 |
=head1 SYNOPSIS |
use threads; |
use threads::shared; |
my $var :shared; |
my %hsh :shared; |
my @ary :shared; |
my ($scalar, @array, %hash); |
share($scalar); |
share(@array); |
share(%hash); |
$var = $scalar_value; |
$var = $shared_ref_value; |
$var = shared_clone($non_shared_ref_value); |
$var = shared_clone({'foo' => [qw/foo bar baz/]}); |
$hsh{'foo'} = $scalar_value; |
$hsh{'bar'} = $shared_ref_value; |
$hsh{'baz'} = shared_clone($non_shared_ref_value); |
$hsh{'quz'} = shared_clone([1..3]); |
$ary[0] = $scalar_value; |
$ary[1] = $shared_ref_value; |
$ary[2] = shared_clone($non_shared_ref_value); |
$ary[3] = shared_clone([ {}, [] ]); |
{ lock(%hash); ... } |
cond_wait($scalar); |
cond_timedwait($scalar, time() + 30); |
cond_broadcast(@array); |
cond_signal(%hash); |
my $lockvar :shared; |
# condition var != lock var |
cond_wait($var, $lockvar); |
cond_timedwait($var, time()+30, $lockvar); |
=head1 DESCRIPTION |
By default, variables are private to each thread, and each newly created |
thread gets a private copy of each existing variable. This module allows you |
to share variables across different threads (and pseudo-forks on Win32). It |
is used together with the L<threads> module. |
This module supports the sharing of the following data types only: scalars |
and scalar refs, arrays and array refs, and hashes and hash refs. |
=head1 EXPORT |
The following functions are exported by this module: C<share>, |
C<shared_clone>, C<is_shared>, C<cond_wait>, C<cond_timedwait>, C<cond_signal> |
and C<cond_broadcast> |
Note that if this module is imported when L<threads> has not yet been loaded, |
then these functions all become no-ops. This makes it possible to write |
modules that will work in both threaded and non-threaded environments. |
=head1 FUNCTIONS |
=over 4 |
=item share VARIABLE |
C<share> takes a variable and marks it as shared: |
my ($scalar, @array, %hash); |
share($scalar); |
share(@array); |
share(%hash); |
C<share> will return the shared rvalue, but always as a reference. |
Variables can also be marked as shared at compile time by using the |
C<:shared> attribute: |
my ($var, %hash, @array) :shared; |
Shared variables can only store scalars, refs of shared variables, or |
refs of shared data (discussed in next section): |
my ($var, %hash, @array) :shared; |
my $bork; |
# Storing scalars |
$var = 1; |
$hash{'foo'} = 'bar'; |
$array[0] = 1.5; |
# Storing shared refs |
$var = \%hash; |
$hash{'ary'} = \@array; |
$array[1] = \$var; |
# The following are errors: |
# $var = \$bork; # ref of non-shared variable |
# $hash{'bork'} = []; # non-shared array ref |
# push(@array, { 'x' => 1 }); # non-shared hash ref |
=item shared_clone REF |
C<shared_clone> takes a reference, and returns a shared version of its |
argument, performing a deep copy on any non-shared elements. Any shared |
elements in the argument are used as is (i.e., they are not cloned). |
my $cpy = shared_clone({'foo' => [qw/foo bar baz/]}); |
Object status (i.e., the class an object is blessed into) is also cloned. |
my $obj = {'foo' => [qw/foo bar baz/]}; |
bless($obj, 'Foo'); |
my $cpy = shared_clone($obj); |
print(ref($cpy), "\n"); # Outputs 'Foo' |
For cloning empty array or hash refs, the following may also be used: |
$var = &share([]); # Same as $var = shared_clone([]); |
$var = &share({}); # Same as $var = shared_clone({}); |
=item is_shared VARIABLE |
C<is_shared> checks if the specified variable is shared or not. If shared, |
returns the variable's internal ID (similar to |
L<refaddr()|Scalar::Util/"refaddr EXPR">). Otherwise, returns C<undef>. |
if (is_shared($var)) { |
print("\$var is shared\n"); |
} else { |
print("\$var is not shared\n"); |
} |
When used on an element of an array or hash, C<is_shared> checks if the |
specified element belongs to a shared array or hash. (It does not check |
the contents of that element.) |
my %hash :shared; |
if (is_shared(%hash)) { |
print("\%hash is shared\n"); |
} |
$hash{'elem'} = 1; |
if (is_shared($hash{'elem'})) { |
print("\$hash{'elem'} is in a shared hash\n"); |
} |
=item lock VARIABLE |
C<lock> places a B<advisory> lock on a variable until the lock goes out of |
scope. If the variable is locked by another thread, the C<lock> call will |
block until it's available. Multiple calls to C<lock> by the same thread from |
within dynamically nested scopes are safe -- the variable will remain locked |
until the outermost lock on the variable goes out of scope. |
C<lock> follows references exactly I<one> level: |
my %hash :shared; |
my $ref = \%hash; |
lock($ref); # This is equivalent to lock(%hash) |
Note that you cannot explicitly unlock a variable; you can only wait for the |
lock to go out of scope. This is most easily accomplished by locking the |
variable inside a block. |
my $var :shared; |
{ |
lock($var); |
# $var is locked from here to the end of the block |
... |
} |
# $var is now unlocked |
As locks are advisory, they do not prevent data access or modification by |
another thread that does not itself attempt to obtain a lock on the variable. |
You cannot lock the individual elements of a container variable: |
my %hash :shared; |
$hash{'foo'} = 'bar'; |
#lock($hash{'foo'}); # Error |
lock(%hash); # Works |
If you need more fine-grained control over shared variable access, see |
L<Thread::Semaphore>. |
=item cond_wait VARIABLE |
=item cond_wait CONDVAR, LOCKVAR |
The C<cond_wait> function takes a B<locked> variable as a parameter, unlocks |
the variable, and blocks until another thread does a C<cond_signal> or |
C<cond_broadcast> for that same locked variable. The variable that |
C<cond_wait> blocked on is relocked after the C<cond_wait> is satisfied. If |
there are multiple threads C<cond_wait>ing on the same variable, all but one |
will re-block waiting to reacquire the lock on the variable. (So if you're only |
using C<cond_wait> for synchronisation, give up the lock as soon as possible). |
The two actions of unlocking the variable and entering the blocked wait state |
are atomic, the two actions of exiting from the blocked wait state and |
re-locking the variable are not. |
In its second form, C<cond_wait> takes a shared, B<unlocked> variable followed |
by a shared, B<locked> variable. The second variable is unlocked and thread |
execution suspended until another thread signals the first variable. |
It is important to note that the variable can be notified even if no thread |
C<cond_signal> or C<cond_broadcast> on the variable. It is therefore |
important to check the value of the variable and go back to waiting if the |
requirement is not fulfilled. For example, to pause until a shared counter |
drops to zero: |
{ lock($counter); cond_wait($count) until $counter == 0; } |
=item cond_timedwait VARIABLE, ABS_TIMEOUT |
=item cond_timedwait CONDVAR, ABS_TIMEOUT, LOCKVAR |
In its two-argument form, C<cond_timedwait> takes a B<locked> variable and an |
absolute timeout as parameters, unlocks the variable, and blocks until the |
timeout is reached or another thread signals the variable. A false value is |
returned if the timeout is reached, and a true value otherwise. In either |
case, the variable is re-locked upon return. |
Like C<cond_wait>, this function may take a shared, B<locked> variable as an |
additional parameter; in this case the first parameter is an B<unlocked> |
condition variable protected by a distinct lock variable. |
Again like C<cond_wait>, waking up and reacquiring the lock are not atomic, |
and you should always check your desired condition after this function |
returns. Since the timeout is an absolute value, however, it does not have to |
be recalculated with each pass: |
lock($var); |
my $abs = time() + 15; |
until ($ok = desired_condition($var)) { |
last if !cond_timedwait($var, $abs); |
} |
# we got it if $ok, otherwise we timed out! |
=item cond_signal VARIABLE |
The C<cond_signal> function takes a B<locked> variable as a parameter and |
unblocks one thread that's C<cond_wait>ing on that variable. If more than one |
thread is blocked in a C<cond_wait> on that variable, only one (and which one |
is indeterminate) will be unblocked. |
If there are no threads blocked in a C<cond_wait> on the variable, the signal |
is discarded. By always locking before signaling, you can (with care), avoid |
signaling before another thread has entered cond_wait(). |
C<cond_signal> will normally generate a warning if you attempt to use it on an |
unlocked variable. On the rare occasions where doing this may be sensible, you |
can suppress the warning with: |
{ no warnings 'threads'; cond_signal($foo); } |
=item cond_broadcast VARIABLE |
The C<cond_broadcast> function works similarly to C<cond_signal>. |
C<cond_broadcast>, though, will unblock B<all> the threads that are blocked in |
a C<cond_wait> on the locked variable, rather than only one. |
=back |
=head1 OBJECTS |
L<threads::shared> exports a version of L<bless()|perlfunc/"bless REF"> that |
works on shared objects such that I<blessings> propagate across threads. |
# Create a shared 'Foo' object |
my $foo :shared = shared_clone({}); |
bless($foo, 'Foo'); |
# Create a shared 'Bar' object |
my $bar :shared = shared_clone({}); |
bless($bar, 'Bar'); |
# Put 'bar' inside 'foo' |
$foo->{'bar'} = $bar; |
# Rebless the objects via a thread |
threads->create(sub { |
# Rebless the outer object |
bless($foo, 'Yin'); |
# Cannot directly rebless the inner object |
#bless($foo->{'bar'}, 'Yang'); |
# Retrieve and rebless the inner object |
my $obj = $foo->{'bar'}; |
bless($obj, 'Yang'); |
$foo->{'bar'} = $obj; |
})->join(); |
print(ref($foo), "\n"); # Prints 'Yin' |
print(ref($foo->{'bar'}), "\n"); # Prints 'Yang' |
print(ref($bar), "\n"); # Also prints 'Yang' |
=head1 NOTES |
L<threads::shared> is designed to disable itself silently if threads are not |
available. This allows you to write modules and packages that can be used |
in both threaded and non-threaded applications. |
If you want access to threads, you must C<use threads> before you |
C<use threads::shared>. L<threads> will emit a warning if you use it after |
L<threads::shared>. |
=head1 BUGS AND LIMITATIONS |
When C<share> is used on arrays, hashes, array refs or hash refs, any data |
they contain will be lost. |
my @arr = qw(foo bar baz); |
share(@arr); |
# @arr is now empty (i.e., == ()); |
# Create a 'foo' object |
my $foo = { 'data' => 99 }; |
bless($foo, 'foo'); |
# Share the object |
share($foo); # Contents are now wiped out |
print("ERROR: \$foo is empty\n") |
if (! exists($foo->{'data'})); |
Therefore, populate such variables B<after> declaring them as shared. (Scalar |
and scalar refs are not affected by this problem.) |
It is often not wise to share an object unless the class itself has been |
written to support sharing. For example, an object's destructor may get |
called multiple times, once for each thread's scope exit. Another danger is |
that the contents of hash-based objects will be lost due to the above |
mentioned limitation. See F<examples/class.pl> (in the CPAN distribution of |
this module) for how to create a class that supports object sharing. |
Does not support C<splice> on arrays! |
Taking references to the elements of shared arrays and hashes does not |
autovivify the elements, and neither does slicing a shared array/hash over |
non-existent indices/keys autovivify the elements. |
C<share()> allows you to C<< share($hashref->{key}) >> and |
C<< share($arrayref->[idx]) >> without giving any error message. But the |
C<< $hashref->{key} >> or C<< $arrayref->[idx] >> is B<not> shared, causing |
the error "lock can only be used on shared values" to occur when you attempt |
to C<< lock($hasref->{key}) >> or C<< lock($arrayref->[idx]) >> in another |
thread. |
Using L<refaddr()|Scalar::Util/"refaddr EXPR">) is unreliable for testing |
whether or not two shared references are equivalent (e.g., when testing for |
circular references). Use L<is_shared()/"is_shared VARIABLE">, instead: |
use threads; |
use threads::shared; |
use Scalar::Util qw(refaddr); |
# If ref is shared, use threads::shared's internal ID. |
# Otherwise, use refaddr(). |
my $addr1 = is_shared($ref1) || refaddr($ref1); |
my $addr2 = is_shared($ref2) || refaddr($ref2); |
if ($addr1 == $addr2) { |
# The refs are equivalent |
} |
L<each()|perlfunc/"each HASH"> does not work properly on shared references |
embedded in shared structures. For example: |
my %foo :shared; |
$foo{'bar'} = shared_clone({'a'=>'x', 'b'=>'y', 'c'=>'z'}); |
while (my ($key, $val) = each(%{$foo{'bar'}})) { |
... |
} |
Either of the following will work instead: |
my $ref = $foo{'bar'}; |
while (my ($key, $val) = each(%{$ref})) { |
... |
} |
foreach my $key (keys(%{$foo{'bar'}})) { |
my $val = $foo{'bar'}{$key}; |
... |
} |
View existing bug reports at, and submit any new bugs, problems, patches, etc. |
to: L<http://rt.cpan.org/Public/Dist/Display.html?Name=threads-shared> |
=head1 SEE ALSO |
L<threads::shared> Discussion Forum on CPAN: |
L<http://www.cpanforum.com/dist/threads-shared> |
Annotated POD for L<threads::shared>: |
L<http://annocpan.org/~JDHEDDEN/threads-shared-1.28/shared.pm> |
Source repository: |
L<http://code.google.com/p/threads-shared/> |
L<threads>, L<perlthrtut> |
L<http://www.perl.com/pub/a/2002/06/11/threads.html> and |
L<http://www.perl.com/pub/a/2002/09/04/threads.html> |
Perl threads mailing list: |
L<http://lists.cpan.org/showlist.cgi?name=iThreads> |
=head1 AUTHOR |
Artur Bergman E<lt>sky AT crucially DOT netE<gt> |
Documentation borrowed from the old Thread.pm. |
CPAN version produced by Jerry D. Hedden E<lt>jdhedden AT cpan DOT orgE<gt>. |
=head1 LICENSE |
threads::shared is released under the same license as Perl. |
=cut |
/MissionCockpit/tags/V0.2.5/track.pl |
---|
0,0 → 1,478 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# mktrack.pl - Tracking Antenne |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-02-14 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-06-14 0.1.1 rw Tilt-Servo added |
# 2009-08-15 0.1.2 rw Flip Pan/Tilt servo for >180 degree |
# config servo direction and range |
# optional get antenna home position from Map-config |
# Signal handler replaced by command-queue |
# |
############################################################################### |
$Version{'track.pl'} = "0.1.1 - 2009-08-15"; |
# Packages |
use Time::HiRes qw(usleep gettimeofday); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Math::Trig; |
use Geo::Ellipsoid; # http://search.cpan.org/dist/Geo-Ellipsoid-1.12/lib/Geo/Ellipsoid.pm |
# http://www.kompf.de/gps/distcalc.html |
# http://www.herrmann-w.de/Geocaching/Downloads/Richt.XLS |
# http://williams.best.vwh.net/avform.htm |
# http://williams.best.vwh.net/gccalc.html |
# http://de.wikipedia.org/wiki/Orthodrome |
if ( $^O =~ /Win32/i ) |
{ |
require Win32::SerialPort; # http://search.cpan.org/dist/Win32-SerialPort |
} |
else |
{ |
require Device::SerialPort; # http://search.cpan.org/~cook/Device-SerialPort-1.04/SerialPort.pm |
} |
require "mkcomm.pl"; # MK communication |
# Sharing for Threads |
share (@ServoPos); |
share (%MkTrack); |
# Queue for receiving commands |
$TrackQueue = Thread::Queue->new(); |
# |
# Parameter |
# |
# System Timer |
$SysTimerResolution = 1000; # Resolution in us |
# Com Port for Pololu Mikro-Servoboard |
# http://www.shop.robotikhardware.de/shop/catalog/product_info.php?cPath=65&products_id=118 |
my $ComPort = $Cfg->{'track'}->{'Port'} || "COM8"; |
my $ServoPanCtrl = $Cfg->{'track'}->{'ServoPanCtrl'} || (0x00 | 29); |
my $ServoTiltCtrl = $Cfg->{'track'}->{'ServoTiltCtrl'} || (0x20 | 27); |
$MkTrack{'ServoPanCtrl'} = $ServoPanCtrl; |
$MkTrack{'ServoTiltCtrl'} = $ServoPanCtrl; |
# Servo parameter |
$ServoPan = 0; # Servo channel Pan |
$ServoTilt = 1; # Servo channel Tilt |
$MkTrack{'ServoPan'} = $ServoPan; |
$MkTrack{'ServoTilt'} = $ServoTilt; |
@ServoSpeed = (100/40, 100/40, 100/40, 100/40, 100/40, 100/40, 100/40, 100/40); # ms/degree |
$ServoConstPpm = 20; # PPM protocol overhead in ms |
@ServoTest = ( [ 90, 0 ], # Pan, Tilt in degrees for servo test |
[ 180, 0 ], |
[ 180, 90 ], |
[ 90, 0 ], |
[ 0, 0 ], |
[ 0, 90 ], |
[ 90, 0 ], |
[ 90, 180 ], |
[ 90, 0 ], ); |
# Tracking |
$TrackInterval = 50; # in ms |
# |
# Timer |
# |
sub SetTimer_ms() |
{ |
return $SysTimerCount_ms + $_[0]; |
} |
sub CheckTimer_ms() |
{ |
my $Diff = $_[0] - $SysTimerCount_ms; |
return ($Diff <= 0); |
} |
# |
# Servo |
# |
sub ServoInit() |
{ |
# open COM-Port |
undef $ServoPort; |
if ( $^O =~ m/Win32/ ) |
{ |
$ServoPort = Win32::SerialPort->new ($ComPort) || die "Error open $ComPort\n"; |
} |
else |
{ |
$ServoPort = Device::SerialPort->new ($ComPort) || die "Error open $ComPort\n"; |
} |
# Set COM parameters |
$ServoPort->baudrate(38400); |
$ServoPort->parity("none"); |
$ServoPort->databits(8); |
$ServoPort->stopbits(1); |
$ServoPort->handshake('none'); |
$ServoPort->write_settings; |
# Byte 1: sync - Pololu Mode |
# Byte 2: device |
# Byte 3: command |
# Byte 4: Servo num |
# Byte 5: data |
# Bit 6: Servo on/off |
# Bit 5: Direction |
# Bit 4-0: Servo Range |
# Pan servo #0 |
my $Output = pack('C*', 0x80, 0x01, 0x00, 0, 0x40 | $ServoPanCtrl ); |
$ServoPort->write($Output); |
# Tilt servo #1 |
my $Output = pack('C*', 0x80, 0x01, 0x00, 1, 0x40 | $ServoTiltCtrl ); |
$ServoPort->write($Output); |
@ServoStartTime = (0, 0, 0, 0, 0, 0, 0, 0); # Timestamp of last ServoMove() call |
@ServoEndTime = (0, 0, 0, 0, 0, 0, 0, 0); # Timestamp of estimated arrival at end position |
@ServoPos = (0, 0, 0, 0, 0, 0, 0, 0); # Current servo position 0..180 degree |
} |
sub ServoMove() |
{ |
my ($Num, $Angel, $Time) = @_; |
my $Overhead = 0; |
if ( $Angel != $ServoPos[$Num] ) |
{ |
if ( $Angel < 0) {$Angel = 0;} |
if ( $Angel > 180) {$Angel = 180;} |
my $Pos = int ($Angel * 127/180 + 0.5); # angel 0..180 degree to servo position 0..127 |
# output to COM port |
# Byte 1: sync - Pololu Mode |
# Byte 2: device |
# Byte 3: command |
# Byte 4: Servo num |
# Byte 5: servo position 0..127 |
my $Output = pack('C*', 0x80, 0x01, 0x02, $Num, $Pos ); |
$ServoPort->write($Output); |
$Overhead += $ServoConstPpm; # PPM protocol overhead |
} |
# set timer stuff for travel time predicion |
my $LastAngel = $ServoPos[$Num]; |
my $EstimatedTime = abs($Angel - $LastAngel) * $ServoSpeed[$Num] + $Overhead; |
if ( $Time > 0 ) |
{ |
# Parameter override |
$EstimatedTime = $Time; |
} |
$ServoStartTime[$Num] = $SysTimerCount_ms; |
$ServoEndTime[$Num] = $SysTimerCount_ms + $EstimatedTime; |
$ServoPos[$Num] = $Angel; |
return $ServoEndTime[$Num]; |
} |
# Check, if servo has reached end position |
sub ServoCheck() |
{ |
my $Num = $_[0]; |
return &CheckTimer_ms($ServoEndTime[$Num]); |
} |
sub ServoClose() |
{ |
# close COM-Port |
undef $ServoPort; |
} |
# |
# Track it |
# |
sub TrackAntennaGps() |
{ |
# |
# State maschine |
# |
$MkTrack{'IsRunning'} = "Running"; |
my $State = "ColdStart"; |
while (1) |
{ |
if ( $State eq "ColdStart" ) |
{ |
&ServoInit(); |
# initialize system-timer |
$SysTimerCount_ms = 0; |
$SysTimerError = 0; |
($t0_s, $t0_us) = gettimeofday; |
$ServoTestIndex = 0; |
$State = "InitServoTest"; |
} |
# |
# Start servo test |
# doesn't really make much sense, but looks cool:-) |
# |
elsif ( $State eq "InitServoTest") |
{ |
if ( &ServoCheck ($ServoPan) and &ServoCheck ($ServoTilt) ) |
{ |
my $PanPos = $ServoTest[$ServoTestIndex][0]; |
my $TiltPos = $ServoTest[$ServoTestIndex][1]; |
$ServoTestIndex ++; |
if ( defined $PanPos and defined $TiltPos ) |
{ |
&ServoMove ($ServoPan, $PanPos, 1000); # override 1s travel time |
&ServoMove ($ServoTilt, $TiltPos, 1000); # override 1s travel time |
} |
else |
{ |
# complete |
$ServoTestIndex = 0; |
$State = "WaitGps"; |
} |
} |
} |
# |
# Servo test finisched |
# |
# Wait for GPS Home position and compass |
# |
elsif ( $State eq "WaitGps" ) |
{ |
if ( &ServoCheck ($ServoPan) ) |
{ |
lock (%MkOsd); # until end of block |
lock (%MkTrack); |
if ( $MkOsd{'_Timestamp'} >= time-2 and |
$MkOsd{'SatsInUse'} >= 6 ) |
{ |
# gültige OSD daten vom MK und guter Satellitenempfang |
# take GPS and compass from map definition or MK as antenna home-position |
$MkTrack{'HomePos_Lon'} = $Map{'Track_Lon'} || $MkOsd{'HomePos_Lon'}; |
$MkTrack{'HomePos_Lat'} = $Map{'Track_Lat'} || $MkOsd{'HomePos_Lat'}; |
$MkTrack{'HomePos_Alt'} = $Map{'Track_Alt'} || $MkOsd{'HomePos_Alt'}; |
if ( $MkTrack{'CompassHeading'} eq "" ) |
{ |
# nur beim ersten mal |
$MkTrack{'CompassHeading'} = $Map{'Track_Bearing'} || $MkOsd{'CompassHeading'}; |
} |
$TrackTimer = &SetTimer_ms($TrackInterval); |
$State = "TrackGps"; |
} |
} |
} |
# |
# GPS Fix Home position |
# Track now |
# |
elsif ( $State eq "TrackGps" ) |
{ |
if ( &CheckTimer_ms($TrackTimer) and &ServoCheck($ServoPan) ) |
{ |
$TrackTimer = &SetTimer_ms($TrackInterval); # reload Timer |
lock (%MkOsd); # until end of block |
lock (%MkTrack); |
if ( $MkOsd{'_Timestamp'} >= time -2 and |
$MkOsd{'SatsInUse'} >= 4 ) |
{ |
# valid OSD data from the MK and sufficient satellites |
my $Track_Geo = Geo::Ellipsoid->new( 'units' => 'degrees', |
'distance_units' => 'meter', |
'ellipsoid' => 'WGS84', |
); |
my ($Dist, $Bearing) = $Track_Geo->to($MkTrack{'HomePos_Lat'}, $MkTrack{'HomePos_Lon'}, |
$MkOsd{'CurPos_Lat'}, $MkOsd{'CurPos_Lon'}); |
my $Dir_h = $MkTrack{'CompassHeading'}; |
my $Dir_c = $MkOsd{'CompassHeading'}; |
if ( $Dist < 4 ) # meter |
{ |
# Too close to Home-Position. Set antenna to middle position |
$Bearing = $Dir_h; |
} |
$MkTrack{'Bearing'} = sprintf ("%d", $Bearing); |
$MkTrack{'Dist'} = sprintf ("%d", $Dist); |
$MkTrack{'CurPos_Lon'} = $MkOsd{'CurPos_Lon'}; |
$MkTrack{'CurPos_Lat'} = $MkOsd{'CurPos_Lat'}; |
$MkTrack{'CurPos_Alt'} = $MkOsd{'CurPos_Alt'}; |
# antenna pan direction: 0..180 degree, centre = 90 |
my $AngelPan = $Bearing - $Dir_h + 90; |
$AngelPan = $AngelPan % 360; |
# antenna tilt direction: 0..180 degree, centre is up, 0 is front |
my $AngelTilt = rad2deg(atan2(($MkOsd{'CurPos_Alt'} - $MkTrack{'HomePos_Alt'}), $Dist)); |
if ( $AngelTilt < 0 ) { $AngelTilt = 0; } |
if ( $AngelTilt > 180 ) { $AngelTilt = 180; } |
if ( $AngelPan >= 180 ) |
{ |
# Flip Pan/Tilt |
$AngelPan = $AngelPan - 180; |
$AngelTilt = 180 - $AngelTilt; |
} |
$MkTrack{'AngelPan'} = $AngelPan; |
$MkTrack{'AngelTilt'} = $AngelTilt; |
&ServoMove ($ServoPan, $AngelPan); |
&ServoMove ($ServoTilt, $AngelTilt); |
# Timestamp, wann der Datensatz geschtieben wurde |
$MkTrack{'_Timestamp'} = time; |
} |
} |
} |
else |
{ |
# Restart |
$State = "ColdStart"; |
} |
# |
# check command queue |
# |
while ( $TrackQueue->pending() > 0 ) |
{ |
my $Cmd = $TrackQueue->dequeue(1); |
if ( $Cmd =~ /EXIT/i ) |
{ |
&TrackExit(); |
} |
} |
# |
# update system-timer |
# |
($t1_s, $t1_us) = gettimeofday; |
$SysTimerSleep_us = ($t0_s - $t1_s) * 1000000 + $t0_us - $t1_us + $SysTimerCount_ms * $SysTimerResolution; |
if ($SysTimerSleep_us > 0) |
{ |
usleep ($SysTimerSleep_us); |
} |
else |
{ |
$SysTimerError ++; |
} |
$SysTimerCount_ms ++; |
} |
} |
sub TrackExit() |
{ |
$MkTrack{'IsRunning'} = ""; |
$State = "ColdStart"; |
# move all Servo to neutral position |
&ServoMove ($ServoPan, 90); |
&ServoMove ($ServoTilt, 0); |
sleep 2; |
# &ServoClose(); |
# if ( defined threads->self() ) |
# { |
# threads->exit(); |
# } |
# exit; |
} |
# |
# Main Program |
# |
if ( $0 =~ /track.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
# Kommunikation zum MK herstellen |
# Input: %MkOsd, %MkTarget, %MkNcDebug |
# Ouput: Thread-Queue: $MkSendQueue |
$mk_thr = threads->create (\&MkCommLoop) -> detach(); |
&TrackAntennaGps(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/translate.pl |
---|
0,0 → 1,586 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# translate.pl - Translation fuer MK Datensaetze |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# |
# 2009-02-23 0.0.1 rw created |
# 2009-04-01 0.1.0 rw RC1 |
# 2009-05-06 0.1.1 rw NC 0.15c |
# 2009-05-17 0.1.2 rw Waypoint Player |
# 2009-06-11 0.1.3 rw DE/EN support. English by Mark Griffin |
# 2009-07-25 0.1.4 rw KML Player |
# 2009-07-26 0.1.5 rw MK System messages |
# 2009-08-08 0.1.7 rw TTS |
# |
############################################################################### |
$Version{'translate.pl'} = "0.1.7 - 2009-08-08"; |
use Win32::Locale; # http://search.cpan.org/~sburke/Win32-Locale-0.04/Locale.pm |
%Translate_DE = ( |
# NC Debug |
"Analog_00" => "Angel Nick", |
"Analog_01" => "Angel Roll", |
"Analog_02" => "ACC Nick", |
"Analog_03" => "ACC Roll", |
"Analog_05" => "MK-Flags", |
"Analog_06" => "NC-Flags", |
"Analog_09" => "GPS Data", |
"Analog_10" => "Compass Heading", |
"Analog_11" => "Gyro Heading", |
"Analog_12" => "SPI Error", |
"Analog_13" => "SPI OK", |
"Analog_14" => "I2C Error", |
"Analog_15" => "I2C OK", |
"Analog_16" => "FC Kalman K", |
"Analog_17" => "ACC Speed North", |
"Analog_18" => "ACC Speed East", |
"Analog_19" => "GPS ACC", |
"Analog_20" => "Max Drift", |
"Analog_21" => "Speed North", |
"Analog_22" => "Speed East", |
"Analog_23" => "P-Part", |
"Analog_24" => "I-Part", |
"Analog_25" => "D-Part", |
"Analog_26" => "PID-Part", |
"Analog_27" => "Distance North", |
"Analog_28" => "Distance East", |
"Analog_29" => "GPS Nick", |
"Analog_30" => "GPS Roll", |
"Analog_31" => "Empfangene Satellitten", |
# NC OSD |
"Altimeter" => "Höhe (Luftdruck)", |
"AngleNick" => "Winkel Nick", |
"AngleRoll" => "Winkel Roll", |
"CompassHeading" => "Richtung Kompass", |
"CurPos_Alt" => "Position Höhe", |
"CurPos_Lat" => "Position Latitude", |
"CurPos_Lon" => "Position Longitude", |
"CurPos_Stat" => "Position Status", |
"Errorcode" => "Fehler Code", |
"FlyingTime" => "Flugzeit", |
"GroundSpeed" => "Geschw. über Grund", |
"Heading" => "Richtung", |
"HomePosDev_Bearing" => "Homeposition Richtung", |
"HomePosDev_Dist" => "Homeposition Entfernung", |
"HomePos_Alt" => "Homeposition Höhe", |
"HomePos_Lat" => "Homeposition Latitude", |
"HomePos_Lon" => "Homeposition Longitude", |
"HomePos_Stat" => "Homeposition Status", |
"MKFlags" => "MK Flags", |
"NCFlags" => "NC Flags", |
"OperatingRadius" => "Operating Radius", |
"RC_Quality" => "RC Signalstärke", |
"SatsInUse" => "Empfangene Satellitten", |
"TargetHoldTime" => "Wartezeit am Ziel", |
"TargetPosDev_Bearing" => "Ziel Richtung", |
"TargetPosDev_Dist" => "Ziel Entfernung", |
"TargetPos_Alt" => "Ziel Höhe", |
"TargetPos_Lat" => "Ziel Latitude", |
"TargetPos_Lon" => "Ziel Longitude", |
"TargetPos_Stat" => "Ziel Status", |
"TopSpeed" => "Geschwindigkeit vertikal", |
"UBat" => "Batterie Spannung", |
"Variometer" => "Variometer", |
"WaypointIndex" => "Wegpunkt Index", |
"WaypointNumber" => "Wegpunkt Nummer", |
"_Timestamp" => "_Zeitstempel", |
# NC Target |
"EventFlag" => "Event Flag", |
"Richtung" => "Richtung", |
"HoldTime" => "Wartezeit", |
"Pos_Alt" => "Position Höhe", |
"Pos_Lat" => "Position Latitude", |
"Pos_Lon" => "Position Longitude", |
"Pos_Stat" => "Position Status", |
"ToleranceRadius" => "Toleranz Radius", |
# Configuration |
"geserver" => "Google Earth Server", |
"logging" => "Logging", |
"map" => "Karte", |
"mkcockpit" => "Mission Cockpit", |
"mkcomm" => "MK Kommunikation", |
"Port" => "Port *", |
"track" => "Tracking Antenne", |
"waypoint" => "Wegpunkte", |
"HttpPort" => "HTTP Port *", |
"CsvLogDir" => "CSV Log-Verzeichnis *", |
"GpxLogDir" => "GPX Log-Verzeichnis *", |
"KmlLogDir" => "KML Log-Verzeichnis *", |
"MapDefault" => "Kartendefinition Hintergrundbild *", |
"MapDir" => "Verzeichnis fuer Karten *", |
"Active" => "Aktiv *", |
"AltFactor" => "Faktor Höhe(Luftdruck) nach Meter", |
"DefaultEventFlag" => "Default Event-Flag", |
"DefaultHeading" => "Default Heading", |
"DefaultHoldtime" => "Default Holdtime", |
"DefaultToleranceRadius"=> "Default Toleranz Radius", |
"WpDir" => "Verzeichnis Wegpunkte *", |
"ColorAirfield" => "Farbe Flugfeldbegrenzung *", |
"ColorHomeDist" => "Farbe Text Entfernung Home *", |
"ColorHomeLine" => "Farbe Linie Entfernung Home *", |
"ColorKmlTrack" => "Farbe KML Spur", |
"ColorMkSatGood" => "Farbe MK guter Sat-Empfang", |
"ColorMkSatLow" => "Farbe MK schlechter Sat-Empfang", |
"ColorMkSatNo" => "Farbe MK kein Sat-Empfang", |
"ColorOsd" => "Farbe OSD *", |
"ColorSpeedVector" => "Farbe Speed-Vektor *", |
"ColorTargetDist" => "Farbe Text Entfernung Ziel *", |
"ColorTargetLine" => "Farbe Linie Entfernung Ziel *", |
"ColorVariometer" => "Farbe Variometer-Skala *", |
"ColorVariometerPointer"=> "Farbe Variometer-Zeiger *", |
"ColorWpConnector" => "Farbe Wegpunkt-Connector", |
"ColorWpResend" => "Farbe Wp-Conn. geaendert", |
"ColorWpNumber" => "Farbe Wegpunkt Nummer", |
"ColorFootprint" => "Farbe Footprint", |
"FootprintLength" => "Länge Footprint (in s)", |
"IconFox" => "Icon Fuchsjagd *", |
"IconHeartLarge" => "Icon Heartbeat gross *", |
"IconHeartSmall" => "Icon Heartbeat klein *", |
"IconSatellite" => "Icon Satellit *", |
"IconTarget" => "Icon Ziel *", |
"IconWaypoint" => "Icon Wegpunkt *", |
"Intervall" => "Intervall (in s) *", |
"UBatWarning" => "Batterie Warnung (in V) ", |
"IconFirst" => "Icon erster WP *", |
"IconHome" => "Icon Home *", |
"IconLast" => "Icon letzter WP *", |
"IconNext" => "Icon nächster WP *", |
"IconPause" => "Icon Pause *", |
"IconPlay" => "Icon Play *", |
"IconPrev" => "Icon vorheriger WP *", |
"IconStop" => "Icon Stop WP-Player *", |
"KmlDir" => "Verzeichnis KML-Files *", |
"KmlTimeBase" => "KML Player Zeitbasis (s) *", |
"PauseMoveDist" => "Pause-Verschiebe-Länge (m) *", |
"tts" => "Text To Speech", |
"StartScenario" => "Start Szenario", |
"KmlFile" => "KML Dateiname *", |
"WpFile" => "Waypoint Dateiname *", |
"PlayerMode" => "Player Modus (Play, Pause, Home, Stop) *", |
"PlayerRandomMode" => "Random Modus (STD, RND, MAP) *", |
"PlayerWptKmlMode" => "Event- oder zeitgesteuert (WPT, KML) *", |
"AudioMute" => "Audio stumm schalten (y/n) *", |
"ServoPanCtrl" => "Servo Pan Control *", |
"ServoTiltCtrl" => "Servo Tilt Control *", |
# Waypoint |
"MapX" => "X-Position auf Karte", |
"MapY" => "Y-Position auf Karte", |
"Event_Flag" => "Event Flag", |
"Holdtime" => "Wartezeit am Wegpunkt", |
# GUI (MkCockpit.pl) |
"File" => "~Datei", |
"Preferences" => "Einstellungen", |
"Exit" => "Ende", |
"Debug" => "D~ebug", |
"NcOsdDataset" => "NC ~OSD Datensatz (O)", |
"NcTargetDataset" => "NC ~Target Datensatz (s)", |
"NcDebugDataset" => "NC ~Debug Datensatz (D)", |
"NcOther" => "NC ~Sonstiges", |
"TrackingDebugDataset" => "Tracking ~Antenne Debug Datensatz", |
"Help" => "~Hilfe", |
"Version" => "Version", |
"About" => "Über", |
"AboutMissionCockpit" => "Über Mission Cockpit", |
"StatusLine" => "Statuszeile", |
"Map" => "Karte", |
"MapDebugDataset" => "Map Datensatz", |
"Balloon-MK-Arrow" => "MikroKopter", |
"Balloon-MK-Home-Line" => "Hier gehts nach Hause", |
"Balloon-MK-Home-Dist" => "Entfernung nach Hause", |
"Balloon-MK-Target-Line" => "Hier gehts zum Ziel", |
"Balloon-MK-Target-Dist" => "Entfernung zum Ziel", |
"Balloon-MK-Speed" => "Geschwindigkeits-Vektor", |
"Balloon-Map-Variometer" => "Variometer", |
"Balloon-Map-Variometer-Pointer" => "Variometer", |
"Balloon-Map-Variometer-Skala" => "Variometer", |
"Balloon-Fox" => "Ziel für Fuchsjagd", |
"Balloon-Heartbeat" => "Aktivität Datenübertragung zum MK", |
"Balloon-Satellite" => "Guter Satelliten-Empfang", |
"Balloon-Waypoint" => "Wegpunkt", |
"Balloon-Map-Border" => "Flugplatz", |
"Balloon-Waypoint-Connector" => "Verbinder Wegpunkte", |
"Balloon-Wp-PlayPause" => "Play/Pause (Leertaste)", |
"Balloon-Wp-Stop" => "Stop Player(s)", |
"Balloon-Wp-First" => "Zum ersten Waypoint (f)", |
"Balloon-Wp-Last" => "Zum letzten Waypoint (l)", |
"Balloon-Wp-Next" => "Zum nächsten Waypoint (n)", |
"Balloon-Wp-Prev" => "Zum vorgerigen Waypoint (p)", |
"Balloon-Wp-Home" => "Zur Home-Position (h)", |
"Balloon-Wp-WptKml" => "Waypoint oder KML Mode (w,k)", |
"Balloon-Wp-WptRandom" => "Random Mode (r)", |
"Balloon-Wp-Record" => "Aufnahme (a)", |
"TargetCoordSent" => "Ziel-Koordinaten gesendet", |
"WpMoved" => "Wegpunkt verschoben", |
"WpAddAndSend" => "Wegpunkt hinzufügen und senden", |
"WpSavedAndSent" => "Wegpunkt gespeichert und gesendet", |
"WpProperties" => "Wegpunkt Eigenschaften", |
"WpResendAll" => "Alle Wegpunkte erneut senden", |
"WpAllSent" => "Alle Wegpunkte gesendet", |
"WpLoadAndSend" => "Wegpunkte laden und senden", |
"WpLoad" => "Wegpunkte laden", |
"WpLoadedAndSent" => "Wegpunkte geladen und gesendet", |
"WpSave" => "Wegpunkte speichern", |
"WpSaved" => "Wegpunkte in gespeichert", |
"WpDelete" => "Wegpunkt löschen", |
"WpDeleted" => "Wegpunkt gelöscht", |
"WpAllDeleteAndSend" => "Alle Wegpunkte löschen und senden", |
"WpAllDeleted" => "Alle Wegpunkte gelöscht", |
"WpFlyImmediately" => "Ziel sofort anfliegen", |
"Abort" => "Abbruch", |
"RestartRequired" => "*) Aenderungen werden erst nach Programm-Neustart wirksam!", |
"KmlLoadAndPlay" => "KML Datei laden", |
"KmlLoad" => "KML laden", |
"KmlLoaded" => "KML geladen", |
# MK System Meldungen |
"MsgNoSatReception" => "Kein SAT Empfang", |
"MsgWeakSatReception" => "Schwacher SAT Empfang", |
"MsgBatWarning" => "Akku Warnung", |
"MsgNoData" => "Kein Daten-Link", |
"MsgRangeLimit" => "Reichweiten Warnung", |
"MsgRcWarning" => "RC Reichweiten Warnung", |
"MsgRcError" => "Kein RC Empfang", |
"MsgMotorOff" => "Motor ist aus", |
"MsgNotFlying", => "MK ist am Boden", |
"MsgCalibrate", => "Kalibrierung", |
"MsgStart" => "Motor start ...", |
"MsgEmergencyLanding" => "Notlandung", |
"MsgOutsideBorder", => "MK ausserhalb Flugfeld", |
"MsgCrossingBorder", => "Mk kreuzt Flugfeldbegrenzung", |
# TTS |
"TtsBattery" => "Batterie, %d komma %d Volt", |
"TtsFlightTimeMinSec" => "Flugzeit, %d Minuten, %d Sekunden", |
"TtsFlightTimeSec" => "Flugzeit, %d Sekunden", |
"TtsAltitude" => "Höhe, %d Meter", |
"TtsSatellite" => "Sattelliten, %d", |
"TtsBatteryWarning" => "Niedrige, Batterie Spannung", |
"TtsRcWeak" => "schwacher, RC Empfang", |
"TtsRcNo" => "Kein, RC Empfang", |
"TtsCrossingBorder" => "Kreuzt, Flug feld Begrenzung", |
"TtsOutsideAirfield" => "Ausserhalb, Flug feld", |
"TtsRange" => "Reichweiten Warnung", |
"TtsNoDataLink" => "Kein, Daten Link", |
"TtsNextTarget" => "Fliege zum nächsten Ziel", |
"TtsTargetReached" => "Ziel erreicht", |
"TtsFun" => "Huiiii, das macht Spass!", |
); |
%Translate_EN = ( |
# NC Debug |
"Analog_00" => "Angel Nick", |
"Analog_01" => "Angel Roll", |
"Analog_02" => "ACC Nick", |
"Analog_03" => "ACC Roll", |
"Analog_05" => "MK-Flags", |
"Analog_06" => "NC-Flags", |
"Analog_09" => "GPS Data", |
"Analog_10" => "Compass Heading", |
"Analog_11" => "Gyro Heading", |
"Analog_12" => "SPI Error", |
"Analog_13" => "SPI OK", |
"Analog_14" => "I2C Error", |
"Analog_15" => "I2C OK", |
"Analog_16" => "FC Kalman K", |
"Analog_17" => "ACC Speed North", |
"Analog_18" => "ACC Speed East", |
"Analog_19" => "GPS ACC", |
"Analog_20" => "Max Drift", |
"Analog_21" => "Speed North", |
"Analog_22" => "Speed East", |
"Analog_23" => "P-Part", |
"Analog_24" => "I-Part", |
"Analog_25" => "D-Part", |
"Analog_26" => "PID-Part", |
"Analog_27" => "Distance North", |
"Analog_28" => "Distance East", |
"Analog_29" => "GPS Nick", |
"Analog_30" => "GPS Roll", |
"Analog_31" => "Satellite Receive", |
# NC OSD |
"Altimeter" => "Altitude (air)", |
"AngleNick" => "Nick angle", |
"AngleRoll" => "Roll angle", |
"CompassHeading" => "Compass Heading", |
"CurPos_Alt" => "Position Höhe", |
"CurPos_Lat" => "Position Latitude", |
"CurPos_Lon" => "Position Longitude", |
"CurPos_Stat" => "Position Status", |
"Errorcode" => "Error Code", |
"FlyingTime" => "Flying time", |
"GroundSpeed" => "Ground speed", |
"Heading" => "Heading", |
"HomePosDev_Bearing" => "Homeposition Bearing", |
"HomePosDev_Dist" => "Homeposition Distance", |
"HomePos_Alt" => "Homeposition Altitude", |
"HomePos_Lat" => "Homeposition Latitude", |
"HomePos_Lon" => "Homeposition Longitude", |
"HomePos_Stat" => "Homeposition Status", |
"MKFlags" => "MK Flags", |
"NCFlags" => "NC Flags", |
"OperatingRadius" => "Operating Radius", |
"RC_Quality" => "RC Signal quality", |
"SatsInUse" => "Satellites in use", |
"TargetHoldTime" => "Target hold time", |
"TargetPosDev_Bearing" => "Target Richtung", |
"TargetPosDev_Dist" => "Target Distance", |
"TargetPos_Alt" => "Target Altitude", |
"TargetPos_Lat" => "Target Latitude", |
"TargetPos_Lon" => "Target Longitude", |
"TargetPos_Stat" => "Target Status", |
"TopSpeed" => "Vertical Speed", |
"UBat" => "Battery Voltage", |
"Variometer" => "Variometer", |
"WaypointIndex" => "Waypoint Index", |
"WaypointNumber" => "Waypoint Number", |
"_Timestamp" => "_Timestamp", |
# NC Target |
"EventFlag" => "Event Flag", |
"Richtung" => "Direction", |
"HoldTime" => "Hold Time", |
"Pos_Alt" => "Position Altitude", |
"Pos_Lat" => "Position Latitude", |
"Pos_Lon" => "Position Longitude", |
"Pos_Stat" => "Position Status", |
"ToleranceRadius" => "Tolerance Radius", |
# Configuration |
"geserver" => "Google Earth Server", |
"logging" => "Logging", |
"map" => "Map", |
"mkcockpit" => "Mission Cockpit", |
"mkcomm" => "MK Communication", |
"Port" => "Port *", |
"track" => "Tracking Antenna", |
"waypoint" => "Waypoint", |
"HttpPort" => "HTTP Port *", |
"CsvLogDir" => "CSV Log directory *", |
"GpxLogDir" => "GPX Log directory *", |
"KmlLogDir" => "KML Log directory *", |
"MapDefault" => "Map default Background image *", |
"MapDir" => "Map Directory *", |
"Active" => "Active *", |
"AltFactor" => "Altitude factor (air) in Meter", |
"DefaultEventFlag" => "Default Event-Flag", |
"DefaultHeading" => "Default Heading", |
"DefaultHoldtime" => "Default Holdtime", |
"DefaultToleranceRadius"=> "Default Tolerance Radius", |
"WpDir" => "Waypoint directory *", |
"ColorAirfield" => "Color Airfield boundary *", |
"ColorHomeDist" => "Color Text Distance Home *", |
"ColorHomeLine" => "Color Line Distance Home *", |
"ColorKmlTrack" => "Color KML Track", |
"ColorMkSatGood" => "Color MK good Sat reception", |
"ColorMkSatLow" => "Color MK weak Sat reception", |
"ColorMkSatNo" => "Color MK no Sat reception", |
"ColorOsd" => "Color OSD *", |
"ColorSpeedVector" => "Color Speed-Vector *", |
"ColorTargetDist" => "Color Text Target distance *", |
"ColorTargetLine" => "Color Linie Target distance *", |
"ColorVariometer" => "Color Variometer Scale *", |
"ColorVariometerPointer"=> "Color Variometer pointer *", |
"ColorWpConnector" => "Color Waypoint connector", |
"ColorWpResend" => "Color Wp-Conn. changed", |
"ColorWpNumber" => "Color Waypoint Number", |
"ColorFootprint" => "Color Footprint", |
"FootprintLength" => "Länge Footprint (in s)", |
"IconFox" => "Icon Fox *", |
"IconHeartLarge" => "Icon Heartbeat large *", |
"IconHeartSmall" => "Icon Heartbeat small *", |
"IconSatellite" => "Icon Satellite *", |
"IconTarget" => "Icon Target *", |
"IconWaypoint" => "Icon Waypoint *", |
"Intervall" => "Interval (in s) *", |
"UBatWarning" => "Battery Warning (in V) ", |
"IconFirst" => "Icon first WP *", |
"IconHome" => "Icon Home *", |
"IconLast" => "Icon last WP *", |
"IconNext" => "Icon next WP *", |
"IconPause" => "Icon Pause *", |
"IconPlay" => "Icon Play *", |
"IconPrev" => "Icon previous WP *", |
"IconStop" => "Icon Stop WP-Player *", |
"KmlDir" => "Directory KML-Files *", |
"KmlTimeBase" => "KML Player Timebase (s) *", |
"PauseMoveDist" => "Pause Move Distance (m) *", |
"tts" => "Text To Speech", |
"StartScenario" => "Start Scenario", |
"KmlFile" => "KML Filename *", |
"WpFile" => "Waypoint Filename *", |
"PlayerMode" => "Player Mode (Play, Pause, Home, Stop) *", |
"PlayerRandomMode" => "Random Mode (STD, RND, MAP) *", |
"PlayerWptKmlMode" => "Event- or time controlled (WPT, KML) *", |
"AudioMute" => "Mute Audio (y/n) *", |
"ServoPanCtrl" => "Servo Pan Control *", |
"ServoTiltCtrl" => "Servo Tilt Control *", |
# Waypoint |
"MapX" => "X-Position on the map", |
"MapY" => "Y-Position on the map", |
"Event_Flag" => "Event Flag", |
"Holdtime" => "Waiting time at Waypoint", |
# GUI (MkCockpit.pl) |
"File" => "~File", |
"Preferences" => "Preferences", |
"Exit" => "E~xit", |
"Debug" => "D~ebug", |
"NcOsdDataset" => "NC ~OSD Record (O)", |
"NcTargetDataset" => "NC ~Target Record (s)", |
"NcDebugDataset" => "NC ~Debug Record (D)", |
"NcOther" => "NC ~Other", |
"TrackingDebugDataset" => "Tracking ~Antenna Debug Record", |
"Help" => "~Help", |
"Version" => "Version", |
"About" => "About", |
"AboutMissionCockpit" => "About Mission Cockpit", |
"StatusLine" => "Status line", |
"Map" => "Map", |
"MapDebugDataset" => "Map Record", |
"Balloon-MK-Arrow" => "MikroKopter", |
"Balloon-MK-Home-Line" => "This way to Home", |
"Balloon-MK-Home-Dist" => "Distance to Home", |
"Balloon-MK-Target-Line" => "This way to the Target", |
"Balloon-MK-Target-Dist" => "Distance to Target", |
"Balloon-MK-Speed" => "Speed vector", |
"Balloon-Map-Variometer" => "Variometer", |
"Balloon-Map-Variometer-Pointer" => "Variometer", |
"Balloon-Map-Variometer-Skala" => "Variometer", |
"Balloon-Fox" => "Target for Fox hunting", |
"Balloon-Heartbeat" => "MK data activity", |
"Balloon-Satellite" => "Good satellite reception", |
"Balloon-Waypoint" => "Waypoint", |
"Balloon-Map-Border" => "Airfield", |
"Balloon-Waypoint-Connector" => "Waypoint connector", |
"Balloon-Wp-PlayPause" => "Play/Pause (Space)", |
"Balloon-Wp-Stop" => "Stop Player(s)", |
"Balloon-Wp-First" => "Go to 1st Waypoint (f)", |
"Balloon-Wp-Last" => "Go to last Waypoint (l)", |
"Balloon-Wp-Next" => "Go to next Waypoint (n)", |
"Balloon-Wp-Prev" => "Go to previous Waypoint (p)", |
"Balloon-Wp-Home" => "Coming Home (h)", |
"Balloon-Wp-WptKml" => "Waypoint or KML Mode (w,k)", |
"Balloon-Wp-WptRandom" => "Random Mode (r)", |
"Balloon-Wp-Record" => "Record (a)", |
"TargetCoordSent" => "Target coordinates sent", |
"WpMoved" => "Waypoint moved", |
"WpAddAndSend" => "Add and send Waypoint", |
"WpSavedAndSent" => "Waypoint saved and sent", |
"WpProperties" => "Waypoint preferneces", |
"WpResendAll" => "Resend all Wayoints", |
"WpAllSent" => "All Waypoints sent", |
"WpLoadAndSend" => "Load and send Waypoints", |
"WpLoad" => "Load Waypoints", |
"WpLoadedAndSent" => "Waypoints loaded and sent", |
"WpSave" => "Save Waypoints", |
"WpSaved" => "Waypoints saved", |
"WpDelete" => "Delete Waypoint", |
"WpDeleted" => "Waypoint deleted", |
"WpAllDeleteAndSend" => "Delete and send all Waypoints", |
"WpAllDeleted" => "All Waypoints deleted", |
"WpFlyImmediately" => "Fly immediately to Target", |
"Abort" => "Abort", |
"RestartRequired" => "*) Restart of Program required!", |
"KmlLoadAndPlay" => "Load KML file", |
"KmlLoad" => "KML load", |
"KmlLoaded" => "KML file loaded", |
# MK System Messages |
"MsgNoSatReception" => "No SAT Reception", |
"MsgWeakSatReception" => "Weak SAT Reception", |
"MsgBatWarning" => "Battery Warning", |
"MsgNoData" => "No Data-Link", |
"MsgRangeLimit" => "Range Limit Warning", |
"MsgRcWarning" => "RC Warning", |
"MsgRcError" => "No RC Reception", |
"MsgMotorOff" => "Engine is OFF", |
"MsgNotFlying", => "MK on Ground", |
"MsgCalibrate", => "Calibration", |
"MsgStart" => "STart Engines ...", |
"MsgEmergencyLanding" => "Emergency Landing", |
"MsgOutsideBorder", => "MK outside Airfield", |
"MsgCrossingBorder", => "Mk crossing Airfield Border", |
# TTS |
"TtsBattery" => "Battery, %d dot %d Volt", |
"TtsFlightTimeMinSec" => "Flight Time, %d Minutes, %d Seconds", |
"TtsFlightTimeSec" => "Flight Time, %d Seconds", |
"TtsAltitude" => "Altitude, %d Meter", |
"TtsSatellite" => "Satellite, %d", |
"TtsBatteryWarning" => "Batterie, Warning", |
"TtsRcWeak" => "weak, Remote Control Reception", |
"TtsRcNo" => "No, Remote Control Reception", |
"TtsCrossingBorder" => "Crossing, Airfield, Border", |
"TtsOutsideAirfield" => "Outside, Airfield", |
"TtsRange" => "Range Warning", |
"TtsNoDataLink" => "No Data Link", |
"TtsNextTarget" => "Fly to next Target", |
"TtsTargetReached" => "Target reached", |
"TtsFun" => "yes, this is fun!", |
); |
# automatic language selection according to LOCALE setting |
my $Lang = Win32::Locale::get_language(); |
if ( $Lang =~ /de/i ) |
{ |
%Translate = %Translate_DE; |
} |
else |
{ |
%Translate = %Translate_EN; |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/tts.pl |
---|
0,0 → 1,180 |
#!/usr/bin/perl |
#!/usr/bin/perl -d:ptkdb |
############################################################################### |
# |
# tts.pl - Text To Speech |
# |
# Copyright (C) 2009 Rainer Walther (rainerwalther-mail@web.de) |
# |
# Creative Commons Lizenz mit den Zusaetzen (by, nc, sa) |
# |
# Es ist Ihnen gestattet: |
# * das Werk vervielfältigen, verbreiten und öffentlich zugänglich machen |
# * Abwandlungen bzw. Bearbeitungen des Inhaltes anfertigen |
# |
# Zu den folgenden Bedingungen: |
# * Namensnennung. |
# Sie müssen den Namen des Autors/Rechteinhabers in der von ihm festgelegten Weise nennen. |
# * Keine kommerzielle Nutzung. |
# Dieses Werk darf nicht für kommerzielle Zwecke verwendet werden. |
# * Weitergabe unter gleichen Bedingungen. |
# Wenn Sie den lizenzierten Inhalt bearbeiten oder in anderer Weise umgestalten, |
# verändern oder als Grundlage für einen anderen Inhalt verwenden, |
# dürfen Sie den neu entstandenen Inhalt nur unter Verwendung von Lizenzbedingungen |
# weitergeben, die mit denen dieses Lizenzvertrages identisch oder vergleichbar sind. |
# |
# Im Falle einer Verbreitung müssen Sie anderen die Lizenzbedingungen, unter welche dieses |
# Werk fällt, mitteilen. Am Einfachsten ist es, einen Link auf diese Seite einzubinden. |
# |
# Jede der vorgenannten Bedingungen kann aufgehoben werden, sofern Sie die Einwilligung |
# des Rechteinhabers dazu erhalten. |
# |
# Diese Lizenz lässt die Urheberpersönlichkeitsrechte unberührt. |
# |
# Weitere Details zur Lizenzbestimmung gibt es hier: |
# Kurzform: http://creativecommons.org/licenses/by-nc-sa/3.0/de/ |
# Komplett: http://creativecommons.org/licenses/by-nc-sa/3.0/de/legalcode |
# |
############################################################################### |
# 2009-08-08 0.0.1 rw created |
# |
############################################################################### |
$Version{'tts.pl'} = "0.0.1 - 2009-08-08"; |
# Packages |
use threads; # http://search.cpan.org/~jdhedden/threads-1.72/threads.pm |
# http://perldoc.perl.org/threads.html |
use threads::shared; # http://search.cpan.org/~jdhedden/threads-shared-1.28/shared.pm |
use Thread::Queue; # http://search.cpan.org/dist/Thread-Queue-2.11/lib/Thread/Queue.pm |
use Time::HiRes qw(usleep); # http://search.cpan.org/~jhi/Time-HiRes-1.9719/HiRes.pm |
# eSpeak software required, download from: http://espeak.sourceforge.net/ |
# Queues for Sending Mesages to TTS Thread |
$TtsSendQueueLow = Thread::Queue->new(); # for low prio messages |
$TtsSendQueueMedium = Thread::Queue->new(); # for medium prio messages |
$TtsSendQueueHigh = Thread::Queue->new(); # for high prio messages |
$TtsMute = 0; # Mute audio switch |
# Main loop, never ending |
sub TtsLoop() |
{ |
# say hello |
# Parameter |
local $Program = $Cfg->{'tts'}->{'Program'} || "C:/Program Files/eSpeak/command_line/espeak.exe"; |
local $Options = $Cfg->{'tts'}->{'Options'} || "-v de -a 200 -b"; |
local $Welcome = $Cfg->{'tts'}->{'Welcome'} || "Starte Mischn Kockpit"; |
if ( ! -f $Program ) |
{ |
print "TTS: Program \"$Program\" does not exist. Exit\n"; |
return; |
} |
# say hello |
&TtsCall ($Welcome); |
while ( 1 ) |
{ |
# process all High prio Messages |
while ( $TtsSendQueueHigh->pending() > 0 ) |
{ |
my $Text = $TtsSendQueueHigh->dequeue(1); |
&TtsCall($Text); |
} |
# process all Medium prio Messages |
while ( $TtsSendQueueMedium->pending() > 0 and |
$TtsSendQueueHigh->pending() == 0 ) |
{ |
my $Text = $TtsSendQueueMedium->dequeue(1); |
&TtsCall($Text); |
} |
# Check Low prio Messages one by one |
if ( $TtsSendQueueLow->pending() > 0 and |
$TtsSendQueueMedium->pending() == 0 and |
$TtsSendQueueHigh->pending() == 0 ) |
{ |
my $Text = $TtsSendQueueLow->dequeue(1); |
&TtsCall($Text); |
} |
usleep (100000); # 100ms |
} |
} |
# call TTS program |
sub TtsCall() |
{ |
my ($Text) = @_; |
my $Cmd = "\"$Program\" $Options \"$Text\""; |
system $Cmd; |
} |
# Add Text to TTS-Queue |
sub TtsSpeak () |
{ |
my ($Prio, $Text) = @_; |
if ( ! $TtsMute and $Cfg->{'tts'}->{'Active'} =~ /y/i ) |
{ |
if ( $Prio eq 'HIGH' ) |
{ |
$TtsSendQueueHigh->enqueue( $Text); |
} |
elsif ( $Prio eq 'MEDIUM' ) |
{ |
$TtsSendQueueMedium->enqueue( $Text); |
} |
else |
{ |
$TtsSendQueueLow->enqueue( $Text); |
} |
} |
} |
# Clear pending Messages |
sub TtsClear () |
{ |
my ($Prio) = @_; |
while ($Prio eq 'HIGH' and $TtsSendQueueHigh->pending() >0 ) |
{ |
$TtsSendQueueHigh->dequeue(); |
} |
while ($Prio eq 'MEDIUM' and $TtsSendQueueMedium->pending() >0 ) |
{ |
$TtsSendQueueMedium->dequeue(); |
} |
while ($Prio eq 'LOW' and $TtsSendQueueLow->pending() >0 ) |
{ |
$TtsSendQueueLow->dequeue(); |
} |
} |
# |
# Hauptprgramm |
# |
if ( $0 =~ /tts.pl$/i ) |
{ |
# Program wurde direkt aufgerufen |
&TtsLoop(); |
# should never exit |
} |
1; |
__END__ |
/MissionCockpit/tags/V0.2.5/waypoints/mk.xml |
---|
0,0 → 1,122 |
<Waypoints> |
<WP-0000 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.71" |
MapY="0.67" |
Pos_Alt="" |
Pos_Lat="49.6837414446281" |
Pos_Lon="10.9459311414637" |
Tag="Waypoint-1239375886.2" |
ToleranceRadius="3" /> |
<WP-0001 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.47" |
MapY="0.68" |
Pos_Alt="" |
Pos_Lat="49.684656513215" |
Pos_Lon="10.9465540413906" |
Tag="Waypoint-1239375890.7" |
ToleranceRadius="3" /> |
<WP-0002 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.43625" |
MapY="0.501666666666667" |
Pos_Alt="" |
Pos_Lat="49.6845423570467" |
Pos_Lon="10.9474221184355" |
Tag="Waypoint-1239375893.5" |
ToleranceRadius="3" /> |
<WP-0003 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.49375" |
MapY="0.558333333333333" |
Pos_Alt="" |
Pos_Lat="49.6844029200217" |
Pos_Lon="10.9470164120763" |
Tag="Waypoint-1239375896.1" |
ToleranceRadius="3" /> |
<WP-0004 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.53875" |
MapY="0.481666666666667" |
Pos_Alt="" |
Pos_Lat="49.6841302979111" |
Pos_Lon="10.9472243787302" |
Tag="Waypoint-1239375900.0" |
ToleranceRadius="3" /> |
<WP-0005 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.55875" |
MapY="0.663333333333333" |
Pos_Alt="" |
Pos_Lat="49.6843006077667" |
Pos_Lon="10.9463800092622" |
Tag="Waypoint-1239375903.7" |
ToleranceRadius="3" /> |
<WP-0006 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.59" |
MapY="0.648333333333333" |
Pos_Alt="" |
Pos_Lat="49.6841629520505" |
Pos_Lon="10.9463583820715" |
Tag="Waypoint-1239375909.8" |
ToleranceRadius="3" /> |
<WP-0007 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.57125" |
MapY="0.481666666666667" |
Pos_Alt="" |
Pos_Lat="49.6840082126091" |
Pos_Lon="10.9471341454465" |
Tag="Waypoint-1239375914.6" |
ToleranceRadius="3" /> |
<WP-0008 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.5875" |
MapY="0.561666666666667" |
Pos_Alt="" |
Pos_Lat="49.6840552537022" |
Pos_Lon="10.9467416509168" |
Tag="Waypoint-1239375916.8" |
ToleranceRadius="3" /> |
<WP-0009 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.63125" |
MapY="0.466666666666667" |
Pos_Alt="" |
Pos_Lat="49.6837625584122" |
Pos_Lon="10.9470326951553" |
Tag="Waypoint-1239375924.3" |
ToleranceRadius="3" /> |
<WP-0010 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.60125" |
MapY="0.561666666666667" |
Pos_Alt="" |
Pos_Lat="49.6840036020774" |
Pos_Lon="10.9467034758118" |
Tag="Waypoint-1239375927.4" |
ToleranceRadius="3" /> |
<WP-0011 Event_Flag="0" |
Heading="0" |
Holdtime="10" |
MapX="0.65125" |
MapY="0.653333333333333" |
Pos_Alt="" |
Pos_Lat="49.6839396219786" |
Pos_Lon="10.9461666201847" |
Tag="Waypoint-1239375935.4" |
ToleranceRadius="3" /> |
</Waypoints> |