1# -*- perl -*-
2
3#
4# $Id: GPX.pm,v 1.22 2008/11/06 22:06:07 eserte Exp $
5# Author: Slaven Rezic
6#
7# Copyright (C) 2005 Slaven Rezic. All rights reserved.
8# This package is free software; you can redistribute it and/or
9# modify it under the same terms as Perl itself.
10#
11# Mail: slaven@rezic.de
12# WWW:  http://www.rezic.de/eserte/
13#
14
15package Strassen::GPX;
16
17use strict;
18use vars qw($VERSION @ISA);
19$VERSION = sprintf("%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/);
20
21use Strassen::Core;
22
23use vars qw($use_xml_module);
24
25sub _require_XML_LibXML () {
26    eval {
27	require XML::LibXML;
28	1;
29    };
30}
31
32sub _require_XML_Twig () {
33    eval {
34	require XML::Twig;
35	XML::Twig->VERSION("3.26"); # set_root
36	1;
37    };
38}
39
40BEGIN {
41    my @errs;
42    # Prefer XML::LibXML over XML::Twig:
43    # * currently it's somewhat faster when parsing huge gpx files
44    #   (for example, ski.gpx (1.5MB) takes less than 1 second with XML::LibXML,
45    #    and 8 seconds with XML::Twig, on a Athlon64, i386-freebsd,
46    #    perl 5.8.8)
47    # Downside:
48    # * XML::Twig has additional support for gracefully drop encoding to
49    #   avoid using utf-8 or iso-8859-1 if possible
50    if (_require_XML_LibXML) {
51	$use_xml_module = "XML::LibXML";
52    } else {
53	push @errs, $@;
54	if (_require_XML_Twig) {
55	    $use_xml_module = "XML::Twig";
56	} else {
57	    push @errs, $@;
58	    die "No XML::LibXML or XML::Twig 3.26 installed: @errs";
59	}
60    }
61}
62
63use Karte::Polar;
64use Karte::Standard;
65
66@ISA = 'Strassen';
67
68my @COMMON_META_ATTRS = qw(name cmt desc src link number type); # common for rte and trk
69
70sub new {
71    my($class, $filename_or_object, %args) = @_;
72    if (UNIVERSAL::isa($filename_or_object, "Strassen")) {
73	bless $filename_or_object, $class;
74    } else {
75	my $self = {};
76	bless $self, $class;
77
78	if ($filename_or_object) {
79	    my $name = delete $args{name};
80	    my $cat  = delete $args{cat};
81	    $self->gpx2bbd($filename_or_object, name => $name, cat => $cat);
82	}
83
84	$self;
85    }
86}
87
88######################################################################
89# GPX to BBD
90#
91sub gpx2bbd {
92    my($self, $file, %args) = @_;
93
94    if ($use_xml_module eq 'XML::LibXML') {
95	_require_XML_LibXML;
96	my $p = XML::LibXML->new;
97	my $doc = $p->parse_file($file);
98	$self->_gpx2bbd_libxml($doc, %args);
99    } else {
100	_require_XML_Twig;
101	my $twig = XML::Twig->new;
102	$twig->parsefile($file);
103	$self->_gpx2bbd_twig($twig, %args);
104    }
105}
106
107sub gpxdata2bbd {
108    my($self, $data, %args) = @_;
109
110    if ($use_xml_module eq 'XML::LibXML') {
111	_require_XML_LibXML;
112	my $p = XML::LibXML->new;
113	my $doc = $p->parse_string($data);
114	$self->_gpx2bbd_libxml($doc, %args);
115    } else {
116	_require_XML_Twig;
117	my $twig = XML::Twig->new;
118	$twig->parse($data);
119	$self->_gpx2bbd_twig($twig, %args);
120    }
121}
122
123sub _gpx2bbd_libxml {
124    my($self, $doc, %args) = @_;
125
126    my $def_name = delete $args{name};
127    my $def_cat  = delete $args{cat};
128    if (!defined $def_cat) {
129	$def_cat = "X";
130    }
131
132    my $root = $doc->documentElement;
133
134    for my $wpt ($root->childNodes) {
135	next if $wpt->nodeName ne "wpt";
136	my($x, $y) = latlong2xy($wpt);
137	my $name;
138	if (defined $def_name) {
139	    $name = $def_name;
140	} else {
141	    $name = "";
142	    for my $name_node ($wpt->childNodes) {
143		next if $name_node->nodeName ne "name";
144		$name = $name_node->textContent;
145		last;
146	    }
147	}
148	$self->push([$name, ["$x,$y"], $def_cat]);
149    }
150
151    for my $trk ($root->childNodes) {
152	next if $trk->nodeName ne "trk";
153	my $name = $def_name;
154	for my $trk_child ($trk->childNodes) {
155	    if ($trk_child->nodeName eq 'name' && !defined $name) {
156		$name = $trk_child->textContent;
157	    } elsif ($trk_child->nodeName eq 'trkseg') {
158		my @c;
159		for my $trkpt ($trk_child->childNodes) {
160		    next if $trkpt->nodeName ne 'trkpt';
161		    my($x, $y) = latlong2xy($trkpt);
162		    #my $ele = $wpt->findvalue(q{./ele});
163		    #my $time = $wpt->findvalue(q{./time});
164		    push @c, "$x,$y";
165		}
166		if (@c) {
167		    local $^W = 0;
168		    $self->push([$name, [@c], $def_cat]);
169		}
170	    }
171	}
172    }
173
174    for my $rte ($root->childNodes) {
175	next if $rte->nodeName ne "rte";
176	my $name = $def_name;
177	my @c;
178	for my $rte_child ($rte->childNodes) {
179	    if ($rte_child->nodeName eq 'name' && !defined $name) {
180		$name = $rte_child->textContent;
181	    } elsif ($rte_child->nodeName eq 'rtept') {
182		my($x, $y) = latlong2xy($rte_child);
183		push @c, "$x,$y";
184	    }
185	}
186	if (@c) {
187	    local $^W = 0;
188	    $self->push([$name, [@c], $def_cat]);
189	}
190    }
191}
192
193sub _gpx2bbd_twig {
194    my($self, $twig, %args) = @_;
195
196    my $def_name = delete $args{name};
197    my $def_cat  = delete $args{cat};
198    if (!defined $def_cat) {
199	$def_cat = "X";
200    }
201
202    my($root) = $twig->children;
203    for my $wpt_or_trk ($root->children) {
204	if ($wpt_or_trk->name eq 'wpt') {
205	    my $wpt = $wpt_or_trk;
206	    my($x, $y) = latlong2xy_twig($wpt);
207	    my $name;
208	    if (defined $def_name) {
209		$name = $def_name;
210	    } else {
211		$name = "";
212		for my $name_node ($wpt->children) {
213		    next if $name_node->name ne "name";
214		    $name = $name_node->children_text;
215		    last;
216		}
217	    }
218	    $self->push([$name, ["$x,$y"], $def_cat]);
219	} elsif ($wpt_or_trk->name eq 'trk') {
220	    my $trk = $wpt_or_trk;
221	    my $name = $def_name;
222	    for my $trk_child ($trk->children) {
223		if ($trk_child->name eq 'name' && !defined $name) {
224		    $name = $trk_child->children_text;
225		} elsif ($trk_child->name eq 'trkseg') {
226		    my @c;
227		    for my $trkpt ($trk_child->children) {
228			next if $trkpt->name ne 'trkpt';
229			my($x, $y) = latlong2xy_twig($trkpt);
230			push @c, "$x,$y";
231		    }
232		    if (@c) {
233			$self->push([$name, [@c], $def_cat]);
234		    }
235		}
236	    }
237	} elsif ($wpt_or_trk->name eq 'rte') {
238	    my $rte = $wpt_or_trk;
239	    my $name = $def_name;
240	    my @c;
241	    for my $rte_child ($rte->children) {
242		if ($rte_child->name eq 'name' && !defined $name) {
243		    $name = $rte_child->children_text;
244		} elsif ($rte_child->name eq 'rtept') {
245		    my($x, $y) = latlong2xy_twig($rte_child);
246		    push @c, "$x,$y";
247		}
248	    }
249	    if (@c) {
250		$self->push([$name, [@c], $def_cat]);
251	    }
252	}
253    }
254}
255
256######################################################################
257# BBD to GPX
258#
259sub bbd2gpx {
260    my($self, %args) = @_;
261
262    my $xy2longlat = \&xy2longlat;
263    my $map = $self->get_global_directive("map");
264    if ($map && $map eq 'polar') {
265	$xy2longlat = \&longlat2longlat;
266    }
267    $args{xy2longlat} = $xy2longlat;
268
269    if ($use_xml_module eq 'XML::LibXML') {
270	_require_XML_LibXML;
271	$self->_bbd2gpx_libxml(%args);
272    } else {
273	_require_XML_Twig;
274	$self->_bbd2gpx_twig(%args);
275    }
276}
277
278sub _bbd2gpx_libxml {
279    my($self, %args) = @_;
280    my $xy2longlat = delete $args{xy2longlat};
281    my $meta = delete $args{-meta} || {};
282    my $as = delete $args{-as} || 'track';
283    my $name = delete $args{-name};
284    my $number = delete $args{-number};
285
286    my $has_encode = eval { require Encode; 1 };
287    if (!$has_encode) {
288	warn "WARN: No Encode.pm module available, non-ascii characters may be broken...\n";
289    }
290    my $has_utf8_upgrade = $] >= 5.008;
291
292
293    $self->init;
294    my @wpt;
295    my @trkseg;
296    while(1) {
297	my $r = $self->next;
298	last if !@{ $r->[Strassen::COORDS] };
299	my $name = $r->[Strassen::NAME];
300	if ($has_utf8_upgrade) {
301	    utf8::upgrade($name); # This smells like an XML::LibXML bug
302	}
303	if (@{ $r->[Strassen::COORDS] } == 1) {
304	    push @wpt,
305		{
306		 name => $name,
307		 coords => [ $xy2longlat->($r->[Strassen::COORDS][0]) ],
308		};
309	} elsif ($as eq 'route') {
310	    my $i = 0;
311	    push @wpt,
312		map {
313		    +{
314		      name => $name.$i++,
315		      coords => [ $xy2longlat->($_) ]
316		     }
317		} @{ $r->[Strassen::COORDS] };
318	} else {
319	    push @trkseg,
320		{
321		 name => $name,
322		 coords => [ map { [ $xy2longlat->($_) ] } @{ $r->[Strassen::COORDS] } ],
323		};
324	}
325    }
326
327    if (!defined $meta->{name} && @trkseg) {
328	$meta->{name} = make_name_from_trkseg(\@trkseg);
329    }
330
331    my $dom = XML::LibXML::Document->new('1.0', 'utf-8');
332    my $gpx = $dom->createElement("gpx");
333    $dom->setDocumentElement($gpx);
334    $gpx->setAttribute("version", "1.1");
335    $gpx->setAttribute("creator", "Strassen::GPX $VERSION (XML::LibXML $XML::LibXML::VERSION) - http://www.bbbike.de");
336    $gpx->setNamespace("http://www.w3.org/2001/XMLSchema-instance","xsi");
337    $gpx->setNamespace("http://www.topografix.com/GPX/1/1");
338    $gpx->setAttribute("xsi:schemaLocation", "http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd");
339
340    if ($as eq 'route') {
341	my $rtexml = $gpx->addNewChild(undef, "rte");
342	_add_meta_attrs_libxml($rtexml, $meta);
343	$rtexml->appendTextChild('name', $name) if defined $name && $name ne '';
344	$rtexml->appendTextChild('number', $number) if defined $number && $number ne '';
345	for my $wpt (@wpt) {
346	    my $rteptxml = $rtexml->addNewChild(undef, "rtept");
347	    $rteptxml->setAttribute("lat", $wpt->{coords}[1]);
348	    $rteptxml->setAttribute("lon", $wpt->{coords}[0]);
349	    $rteptxml->appendTextChild("name", $wpt->{name});
350	}
351    } else {
352	for my $wpt (@wpt) {
353	    my $wptxml = $gpx->addNewChild(undef, "wpt");
354	    $wptxml->setAttribute("lat", $wpt->{coords}[1]);
355	    $wptxml->setAttribute("lon", $wpt->{coords}[0]);
356	    $wptxml->appendTextChild("name", $wpt->{name});
357	}
358	if (@trkseg) {
359	    my $trkxml = $gpx->addNewChild(undef, "trk");
360	    _add_meta_attrs_libxml($trkxml, $meta);
361	    $trkxml->appendTextChild('name', $name) if defined $name && $name ne '';
362	    $trkxml->appendTextChild('number', $number) if defined $number && $number ne '';
363	    for my $trkseg (@trkseg) {
364		my $trksegxml = $trkxml->addNewChild(undef, "trkseg");
365		for my $wpt (@{ $trkseg->{coords} }) {
366		    my $trkptxml = $trksegxml->addNewChild(undef, "trkpt");
367		    $trkptxml->setAttribute("lat", $wpt->[1]);
368		    $trkptxml->setAttribute("lon", $wpt->[0]);
369		}
370	    }
371	}
372    }
373    if ($XML::LibXML::VERSION < 1.63 && $has_encode) {
374	Encode::encode("utf-8", $dom->toString);
375    } else {
376	$dom->toString;
377    }
378}
379
380sub _bbd2gpx_twig {
381    my($self, %args) = @_;
382    my $xy2longlat = delete $args{xy2longlat};
383    my $meta = delete $args{-meta} || {};
384
385    # Try to find minimum needed encoding. This is to help
386    # broken applications (wrt correct XML parsing) like gpsman 6.3.2
387    my $need_utf8;
388    my $need_latin1;
389    my $encoding_checker = ($] >= 5.008 ? eval <<'EOF' :
390sub {
391    my $name = shift;
392    if (!$need_utf8) {
393	if ($name =~ m{[\x{0100}-\x{1ffff}]}) {
394	    $need_utf8 = 1;
395	} elsif (!$need_latin1) {
396	    if ($name =~ m{[\x80-\xff]}) {
397		$need_latin1 = 1;
398	    }
399	}
400    }
401}
402EOF
403			    sub { } # no/limited unicode support with older perls
404			   );
405
406    $self->init;
407    my @wpt;
408    my @trkseg;
409    while(1) {
410	my $r = $self->next;
411	last if !@{ $r->[Strassen::COORDS] };
412	my $name = $r->[Strassen::NAME];
413	$encoding_checker->($name);
414	if (@{ $r->[Strassen::COORDS] } == 1) {
415	    push @wpt, { name => $name,
416			 coords => [ $xy2longlat->($r->[Strassen::COORDS][0]) ],
417		       };
418	} else {
419	    push @trkseg,
420		{
421		 name => $name,
422		 coords => [ map { [ $xy2longlat->($_) ] } @{ $r->[Strassen::COORDS] } ],
423		};
424	}
425    }
426
427    if (!defined $meta->{name} && @trkseg) {
428	$meta->{name} = make_name_from_trkseg(\@trkseg);
429    }
430
431    my $twig = XML::Twig->new($need_utf8   ? (output_encoding => 'utf-8') :
432			      $need_latin1 ? (output_encoding => 'iso-8859-1') :
433			      ()
434			     );
435    my $gpx = XML::Twig::Elt->new(gpx => { version => "1.1",
436					   creator => "Strassen::GPX $VERSION (XML::Twig $XML::Twig::VERSION) - http://www.bbbike.de",
437					   xmlns => "http://www.topografix.com/GPX/1/1",
438					   #$gpx->setNamespace("http://www.w3.org/2001/XMLSchema-instance","xsi");
439					   #"xsi:schemaLocation" => "http://www.topografix.com/GPX/1/1 http://www.topografix.com/GPX/1/1/gpx.xsd",
440					 },
441				 );
442    $twig->set_root($gpx);
443
444    if ($args{-as} && $args{-as} eq 'route') {
445	my $rtexml = XML::Twig::Elt->new("rte");
446	$rtexml->paste(last_child => $gpx);
447	_add_meta_attrs_twig($rtexml, $meta);
448	for my $wpt (@wpt) {
449	    my $rteptxml = XML::Twig::Elt->new("rtept", {lat => $wpt->{coords}[1],
450							 lon => $wpt->{coords}[0],
451							},
452					      );
453	    $rteptxml->paste(last_child => $rtexml);
454	    my $namexml = XML::Twig::Elt->new("name", {}, $wpt->{name});
455	    $namexml->paste(last_child => $rteptxml);
456	}
457    } else {
458	for my $wpt (@wpt) {
459	    my $wptxml = XML::Twig::Elt->new("wpt", {lat => $wpt->{coords}[1],
460						     lon => $wpt->{coords}[0],
461						    },
462					    );
463	    $wptxml->paste(last_child => $gpx);
464	    my $namexml = XML::Twig::Elt->new("name", {}, $wpt->{name});
465	    $namexml->paste(last_child => $wptxml);
466	}
467	if (@trkseg) {
468	    my $trkxml = XML::Twig::Elt->new("trk");
469	    $trkxml->paste(last_child => $gpx);
470	    _add_meta_attrs_twig($trkxml, $meta);
471	    for my $trkseg (@trkseg) {
472		my $trksegxml = XML::Twig::Elt->new("trkseg");
473		$trksegxml->paste(last_child => $trkxml);
474		for my $wpt (@{ $trkseg->{coords} }) {
475		    my $trkptxml = XML::Twig::Elt->new("trkpt", { lat => $wpt->[1],
476								  lon => $wpt->[0],
477								});
478		    $trkptxml->paste(last_child => $trksegxml);
479		}
480	    }
481	}
482    }
483    my $xml = $twig->sprint;
484    $xml;
485}
486
487######################################################################
488# Helpers
489
490sub latlong2xy {
491    my($node) = @_;
492    my $lat = $node->getAttribute('lat');
493    my $lon = $node->getAttribute('lon');
494    my($x, $y) = $Karte::Standard::obj->trim_accuracy($Karte::Polar::obj->map2standard($lon, $lat));
495    ($x, $y);
496}
497
498sub latlong2xy_twig {
499    my($node) = @_;
500    my $lat = $node->att("lat");
501    my $lon = $node->att("lon");
502    my($x, $y) = $Karte::Standard::obj->trim_accuracy($Karte::Polar::obj->map2standard($lon, $lat));
503    ($x, $y);
504}
505
506sub xy2longlat {
507    my($c) = @_;
508    my($lon, $lat) = $Karte::Polar::obj->trim_accuracy($Karte::Polar::obj->standard2map(split /,/, $c));
509    ($lon, $lat);
510}
511
512sub longlat2longlat {
513    my($c) = @_;
514    my($lon, $lat) = split /,/, $c;
515    ($lon, $lat);
516}
517
518sub make_name_from_trkseg {
519    my($trkseg_ref) = @_;
520
521    my $name_from = $trkseg_ref->[0]->{name};
522    my $name_to   = $trkseg_ref->[-1]->{name};
523    my $name = $name_from;
524    if ($name_from ne $name_to) {
525	$name .= " - $name_to";
526    }
527    $name;
528}
529
530sub _add_meta_attrs_libxml {
531    my($node, $meta) = @_;
532    for my $attr (@COMMON_META_ATTRS) {
533	if (defined $meta->{$attr}) {
534	    if ($attr eq 'link') {
535		if (!defined $meta->{link}{href}) {
536		    die "meta->link->href is required if meta->link is given";
537		}
538		my $linknode = $node->addNewChild(undef, "link");
539		$linknode->appendTextChild("text", $meta->{link}{text}) if defined $meta->{link}{text};
540		$linknode->appendTextChild("type", $meta->{link}{type}) if defined $meta->{link}{type};
541		$linknode->setAttribute("href", $meta->{link}{href});
542	    } else {
543		$node->appendTextChild($attr, $meta->{$attr});
544	    }
545	}
546    }
547}
548
549sub _add_meta_attrs_twig {
550    my($node, $meta) = @_;
551    for my $attr (@COMMON_META_ATTRS) {
552	if (defined $meta->{$attr}) {
553	    if ($attr eq 'link') {
554		if (!defined $meta->{link}{href}) {
555		    die "meta->link->href is required if meta->link is given";
556		}
557		my $linknode = XML::Twig::Elt->new("link", {href => $meta->{link}{href}});
558		$linknode->paste(last_child => $node);
559		if (defined $meta->{link}{text}) {
560		    my $textnode = XML::Twig::Elt->new("text", {}, $meta->{link}{text});
561		    $textnode->paste(last_child => $linknode);
562		}
563		if (defined $meta->{link}{type}) {
564		    my $typenode = XML::Twig::Elt->new("type", {}, $meta->{link}{type});
565		    $typenode->paste(last_child => $linknode);
566		}
567	    } else {
568		my $newnode = XML::Twig::Elt->new($attr, {}, $meta->{$attr});
569		$newnode->paste(last_child => $node);
570	    }
571	}
572    }
573}
574
5751;
576
577__END__
578