package Geo::Gpx; use warnings; use strict; use Carp; use DateTime::Format::ISO8601; use DateTime; use HTML::Entities qw( encode_entities encode_entities_numeric ); use Scalar::Util qw( blessed ); use Time::Local; use XML::Descent; =head1 NAME Geo::Gpx - Create and parse GPX files. =head1 VERSION This document describes Geo::Gpx version 0.26 =head1 SYNOPSIS # Version 0.10 compatibility use Geo::Gpx; my $gpx = Geo::Gpx->new( @waypoints ); my $xml = $gpx->xml; # New API, generate GPX my $gpx = Geo::Gpx->new(); $gpx->waypoints( \@wpt ); my $xml = $gpx->xml( '1.0' ); # Parse GPX my $gpx = Geo::Gpx->new( xml => $xml ); my $waypoints = $gpx->waypoints(); my $tracks = $gpx->tracks(); # Parse GPX from open file my $gpx = Geo::Gpx->new( input => $fh ); my $waypoints = $gpx->waypoints(); my $tracks = $gpx->tracks(); =head1 DESCRIPTION The original goal of this module was to produce GPX/XML files which were parseable by both GPX Spinner and EasyGPS. As of version 0.13 it has been extended to support general parsing and generation of GPX data. GPX 1.0 and 1.1 are supported. =cut use vars qw ($VERSION); $VERSION = '0.26'; # Values that are encoded as attributes my %AS_ATTR = ( wpt => qr{^lat|lon$}, rtept => qr{^lat|lon$}, trkpt => qr{^lat|lon$}, email => qr{^id|domain$}, link => qr{^href$} ); my %KEY_ORDER = ( wpt => [ qw( ele time magvar geoidheight name cmt desc src link sym type fix sat hdop vdop pdop ageofdgpsdata dgpsid extensions ) ], ); # Map hash keys to GPX names my %XMLMAP = ( waypoints => { waypoints => 'wpt' }, routes => { routes => 'rte', points => 'rtept' }, tracks => { tracks => 'trk', segments => 'trkseg', points => 'trkpt' } ); my @META; my @ATTR; BEGIN { @META = qw( name desc author time keywords copyright link ); @ATTR = qw( waypoints tracks routes version ); # Generate accessors for my $attr ( @META, @ATTR ) { no strict 'refs'; *{ __PACKAGE__ . '::' . $attr } = sub { my $self = shift; $self->{$attr} = shift if @_; return $self->{$attr}; }; } } sub _parse_time { my ( $self, $str ) = @_; my $dt = DateTime::Format::ISO8601->parse_datetime( $str ); return $self->{use_datetime} ? $dt : $dt->epoch; } sub _format_time { my ( $self, $tm, $legacy ) = @_; unless ( blessed $tm && $tm->can( 'strftime' ) ) { return $self->_format_time( DateTime->from_epoch( epoch => $tm, time_zone => 'UTC' ), $legacy ); } my $ts = $tm->strftime( $legacy ? '%Y-%m-%dT%H:%M:%S.%7N%z' : '%Y-%m-%dT%H:%M:%S%z' ); $ts =~ s/(\d{2})$/:$1/; return $ts; } # For backwards compatibility sub _init_legacy { my $self = shift; $self->{keywords} = [qw(cache geocache groundspeak)]; $self->{author} = { name => 'Groundspeak', email => { id => 'contact', domain => 'groundspeak.com' } }; $self->{desc} = 'GPX file generated by Geo::Gpx'; $self->{schema} = [ qw( http://www.groundspeak.com/cache/1/0 http://www.groundspeak.com/cache/1/0/cache.xsd ) ]; require Geo::Cache; $self->{handler} = { create => sub { return Geo::Cache->new( @_ ); }, time => sub { return $self->_format_time( $_[0], 1 ); }, }; } sub _init_shiny_new { my ( $self, $args ) = @_; $self->{use_datetime} = $args->{use_datetime} || 0; $self->{schema} = []; $self->{handler} = { create => sub { return {@_}; }, time => sub { return $self->_format_time( $_[0], 0 ); }, }; } =head1 INTERFACE =head2 C The original purpose of C was to allow an array of L objects to be converted into a GPX file. This behaviour is maintained by this release: use Geo::Gpx; my $gpx = Geo::Gpx->new( @waypoints ); my $xml = $gpx->xml; New applications can use C to parse a GPX file : my $gpx = Geo::Gpx->new( xml => $gpx_document ); or from an open filehandle : my $gpx = Geo::Gpx->new( input => $fh ); or can create an empty container to which waypoints, routes and tracks can then be added: my $gpx = Geo::Gpx->new(); $gpx->waypoints( \@wpt ); The following additional options can be specified: =over =item C< use_datetime > If true time values in parsed GPX will be L objects rather than epoch times. =back =cut sub new { my ( $class, @args ) = @_; my $self = bless( {}, $class ); # CORE::time because we have our own time method. $self->{time} = CORE::time(); # Has to handle same calling convention as previous # version. if ( blessed $args[0] && $args[0]->isa( 'Geo::Cache' ) ) { $self->_init_legacy(); $self->{waypoints} = \@args; } elsif ( @args % 2 == 0 ) { my %args = @args; $self->_init_shiny_new( \%args ); if ( exists $args{input} ) { $self->_parse( $args{input} ); } elsif ( exists $args{xml} ) { $self->_parse( \$args{xml} ); } } else { croak( "Invalid arguments" ); } return $self; } # Not a method sub _trim { my $str = shift; $str =~ s/^\s+//; $str =~ s/\s+$//; $str =~ s/\s+/ /g; return $str; } sub _parse { my $self = shift; my $source = shift; my $p = XML::Descent->new( { Input => $source } ); $p->on( gpx => sub { my ( $elem, $attr ) = @_; $p->context( $self ); my $version = $self->{version} = ( $attr->{version} || '1.0' ); my $parse_deep = sub { my ( $elem, $attr ) = @_; my $ob = $attr; # Get attributes $p->context( $ob ); $p->walk(); return $ob; }; # Parse a point my $parse_point = sub { my ( $elem, $attr ) = @_; my $pt = $parse_deep->( $elem, $attr ); return $self->{handler}->{create}->( %{$pt} ); }; $p->on( '*' => sub { my ( $elem, $attr, $ctx ) = @_; $ctx->{$elem} = _trim( $p->text() ); }, time => sub { my ( $elem, $attr, $ctx ) = @_; my $tm = $self->_parse_time( _trim( $p->text() ) ); $ctx->{$elem} = $tm if defined $tm; } ); if ( _cmp_ver( $version, '1.1' ) >= 0 ) { # Handle 1.1 metadata $p->on( metadata => sub { $p->walk(); }, [ 'link', 'email', 'author' ] => sub { my ( $elem, $attr, $ctx ) = @_; $ctx->{$elem} = $parse_deep->( $elem, $attr ); } ); } else { # Handle 1.0 metadata $p->on( url => sub { my ( $elem, $attr, $ctx ) = @_; $ctx->{link}->{href} = _trim( $p->text() ); }, urlname => sub { my ( $elem, $attr, $ctx ) = @_; $ctx->{link}->{text} = _trim( $p->text() ); }, author => sub { my ( $elem, $attr, $ctx ) = @_; $ctx->{author}->{name} = _trim( $p->text() ); }, email => sub { my ( $elem, $attr, $ctx ) = @_; my $em = _trim( $p->text() ); if ( $em =~ m{^(.+)\@(.+)$} ) { $ctx->{author}->{email} = { id => $1, domain => $2 }; } } ); } $p->on( bounds => sub { my ( $elem, $attr, $ctx ) = @_; $ctx->{$elem} = $parse_deep->( $elem, $attr ); }, keywords => sub { my ( $elem, $attr ) = @_; $self->{keywords} = [ map { _trim( $_ ) } split( /,/, $p->text() ) ]; }, wpt => sub { my ( $elem, $attr ) = @_; push @{ $self->{waypoints} }, $parse_point->( $elem, $attr ); }, [ 'trkpt', 'rtept' ] => sub { my ( $elem, $attr, $ctx ) = @_; push @{ $ctx->{points} }, $parse_point->( $elem, $attr ); }, rte => sub { my ( $elem, $attr ) = @_; my $rt = $parse_deep->( $elem, $attr ); push @{ $self->{routes} }, $rt; }, trk => sub { my ( $elem, $attr ) = @_; my $tk = {}; $p->context( $tk ); $p->on( trkseg => sub { my ( $elem, $attr ) = @_; my $seg = $parse_deep->( $elem, $attr ); push @{ $tk->{segments} }, $seg; } ); $p->walk(); push @{ $self->{tracks} }, $tk; } ); $p->walk(); } ); $p->walk(); } =head2 C Add one or more waypoints. Each waypoint must be a reference to a hash. Each waypoint must include the keys C and C and may include others: my $wpt = { lat => 54.786989, lon => -2.344214, ele => 512, time => 1164488503, magvar => 0, geoidheight => 0, name => 'My house & home', cmt => 'Where I live', desc => '<>', src => 'Testing', link => { href => 'http://hexten.net/', text => 'Hexten', type => 'Blah' }, sym => 'pin', type => 'unknown', fix => 'dgps', sat => 3, hdop => 10, vdop => 10, pdop => 10, ageofdgpsdata => 45, dgpsid => 247 }; $gpx->add_waypoint( $wpt ); Time values may either be an epoch offset or a L. If you wish to specify the timezone use a L. =cut sub add_waypoint { my $self = shift; for my $wpt ( @_ ) { eval { keys %$wpt }; croak "waypoint argument must be a hash reference" if $@; croak "'lat' and 'lon' keys are mandatory in waypoint hash" unless exists $wpt->{lon} && exists $wpt->{lat}; push @{ $self->{waypoints} }, $wpt; } } # Not a method sub _iterate_points { my $pts = shift || []; # array ref unless ( defined $pts ) { return sub { return; }; } my $max = scalar( @{$pts} ); my $pos = 0; return sub { return if $pos >= $max; return $pts->[ $pos++ ]; }; } # Not a method sub _iterate_iterators { my @its = @_; return sub { for ( ;; ) { return undef unless @its; my $next = $its[0]->(); return $next if defined $next; shift @its; } } } =head2 C Get an iterator that visits all the waypoints in a C. =cut sub iterate_waypoints { my $self = shift; return _iterate_points( $self->{waypoints} ); } =head2 C Get an iterator that visits all the routepoints in a C. =cut sub iterate_routepoints { my $self = shift; my @iter = (); if ( exists( $self->{routes} ) ) { for my $rte ( @{ $self->{routes} } ) { push @iter, _iterate_points( $rte->{points} ); } } return _iterate_iterators( @iter ); } =head2 C Get an iterator that visits all the trackpoints in a C. =cut sub iterate_trackpoints { my $self = shift; my @iter = (); if ( exists( $self->{tracks} ) ) { for my $trk ( @{ $self->{tracks} } ) { if ( exists( $trk->{segments} ) ) { for my $seg ( @{ $trk->{segments} } ) { push @iter, _iterate_points( $seg->{points} ); } } } } return _iterate_iterators( @iter ); } =head2 C Get an iterator that visits all the points in a C. For example my $iter = $gpx->iterate_points(); while ( my $pt = $iter->() ) { print "Point: ", join( ', ', $pt->{lat}, $pt->{lon} ), "\n"; } =cut sub iterate_points { my $self = shift; return _iterate_iterators( $self->iterate_waypoints(), $self->iterate_routepoints(), $self->iterate_trackpoints() ); } =head2 C Compute the bounding box of all the points in a C returning the result as a hash reference. For example: my $gpx = Geo::Gpx->new( xml => $some_xml ); my $bounds = $gpx->bounds(); returns a structure like this: $bounds = { minlat => 57.120939, minlon => -2.9839832, maxlat => 57.781729, maxlon => -1.230902 }; C<$iterator> defaults to C<$self-Eiterate_points>. =cut sub bounds { my ( $self, $iter ) = @_; $iter ||= $self->iterate_points; my $bounds = {}; while ( my $pt = $iter->() ) { $bounds->{minlat} = $pt->{lat} if !defined $bounds->{minlat} || $pt->{lat} < $bounds->{minlat}; $bounds->{maxlat} = $pt->{lat} if !defined $bounds->{maxlat} || $pt->{lat} > $bounds->{maxlat}; $bounds->{minlon} = $pt->{lon} if !defined $bounds->{minlon} || $pt->{lon} < $bounds->{minlon}; $bounds->{maxlon} = $pt->{lon} if !defined $bounds->{maxlon} || $pt->{lon} > $bounds->{maxlon}; } return $bounds; } sub _enc { return encode_entities_numeric( $_[0] ); } sub _tag { my $name = shift; my $attr = shift || {}; my @tag = ( '<', $name ); # Sort keys so the tests can depend on hash output order for my $n ( sort keys %{$attr} ) { my $v = $attr->{$n}; push @tag, ' ', $n, '="', _enc( $v ), '"'; } if ( @_ ) { push @tag, '>', @_, '\n"; } else { push @tag, " />\n"; } return join( '', @tag ); } sub _xml { my $self = shift; my $name = shift; my $value = shift; my $name_map = shift || {}; my $tag = $name_map->{$name} || $name; if ( blessed $value && $value->can( 'xml' ) ) { # Handles legacy Gpx::Cache objects that can # render themselves. Note that Gpx::Cache->xml # adds the wrapper - so this won't # work correctly for trkpt and rtept return $value->xml( $name ); } elsif ( defined( my $enc = $self->{encoder}->{$name} ) ) { return $enc->( $name, $value ); } elsif ( ref $value eq 'HASH' ) { my $attr = {}; my @cont = ( "\n" ); my $as_attr = $AS_ATTR{$name}; # Shallow copy so we can delete keys as we output them my %v = %{$value}; for my $k ( @{ $KEY_ORDER{$name} || [] }, sort keys %v ) { if ( defined( my $vv = delete $v{$k} ) ) { if ( defined $as_attr && $k =~ $as_attr ) { $attr->{$k} = $vv; } else { push @cont, $self->_xml( $k, $vv, $name_map ); } } } return _tag( $tag, $attr, @cont ); } elsif ( ref $value eq 'ARRAY' ) { return join '', map { $self->_xml( $tag, $_, $name_map ) } @{$value}; } else { return _tag( $tag, {}, _enc( $value ) ); } } sub _cmp_ver { my ( $v1, $v2 ) = @_; my @v1 = split( /[.]/, $v1 ); my @v2 = split( /[.]/, $v2 ); while ( @v1 && @v2 ) { my $cmp = ( shift @v1 <=> shift @v2 ); return $cmp if $cmp; } return @v1 <=> @v2; } =head2 C Generate GPX XML. my $gpx10 = $gpx->xml( '1.0' ); my $gpx11 = $gpx->xml( '1.1' ); If the version is omitted it defaults to the value of the C attibute. Parsing a GPX document sets the version. If the C attribute is unset defaults to 1.0. C version 0.10 used L to render each of the points. L generates a number of hardwired values to suit the original application of that module which aren't appropriate for general purpose GPX manipulation. Legacy mode is triggered by passing a list of L points to the constructor; this should probably be avoided for new applications. =cut sub xml { my $self = shift; my $version = shift || $self->{version} || '1.0'; my @ret = (); push @ret, qq{\n}; $self->{encoder} = { time => sub { my ( $n, $v ) = @_; return _tag( $n, {}, _enc( $self->{handler}->{time}->( $v ) ) ); }, keywords => sub { my ( $n, $v ) = @_; return _tag( $n, {}, _enc( join( ', ', @{$v} ) ) ); } }; # Limit to the latest version we know about if ( _cmp_ver( $version, '1.1' ) >= 0 ) { $version = '1.1'; } else { # Modify encoder $self->{encoder}->{link} = sub { my ( $n, $v ) = @_; my @v = (); push @v, $self->_xml( 'url', $v->{href} ) if exists( $v->{href} ); push @v, $self->_xml( 'urlname', $v->{text} ) if exists( $v->{text} ); return join( '', @v ); }; $self->{encoder}->{email} = sub { my ( $n, $v ) = @_; if ( exists( $v->{id} ) && exists( $v->{domain} ) ) { return _tag( 'email', {}, _enc( join( '@', $v->{id}, $v->{domain} ) ) ); } else { return ''; } }; $self->{encoder}->{author} = sub { my ( $n, $v ) = @_; my @v = (); push @v, _tag( 'author', {}, _enc( $v->{name} ) ) if exists( $v->{name} ); push @v, $self->_xml( 'email', $v->{email} ) if exists( $v->{email} ); return join( '', @v ); }; } # Turn version into path element ( my $vpath = $version ) =~ s{[.]}{/}g; my $ns = "http://www.topografix.com/GPX/$vpath"; my $schema = join( ' ', $ns, "$ns/gpx.xsd", @{ $self->{schema} } ); push @ret, qq{\n}; my @meta = (); for my $fld ( @META ) { if ( exists( $self->{$fld} ) ) { push @meta, $self->_xml( $fld, $self->{$fld} ); } } my $bounds = $self->bounds( $self->iterate_points() ); if ( %{$bounds} ) { push @meta, _tag( 'bounds', $bounds ); } # Version 1.1 nests metadata in a metadata tag if ( _cmp_ver( $version, '1.1' ) >= 0 ) { push @ret, _tag( 'metadata', {}, "\n", @meta ); } else { push @ret, @meta; } for my $k ( sort keys %XMLMAP ) { if ( exists( $self->{$k} ) ) { push @ret, $self->_xml( $k, $self->{$k}, $XMLMAP{$k} ); } } push @ret, qq{\n}; return join( '', @ret ); } =head2 C For compatability with L modules. Converts this object to a hash with keys that correspond to the above methods. Generated ala: my %json = map { $_ => $self->$_ } qw(name desc author keywords copyright time link waypoints tracks routes version ); $json{bounds} = $self->bounds( $iter ); With one difference: the keys will only be set if they are defined. =cut sub TO_JSON { my $self = shift; my %json; #= map {$_ => $self->$_} ... for my $key ( @META, @ATTR ) { my $val = $self->$key; $json{$key} = $val if defined $val; } if ( my $bounds = $self->bounds ) { $json{bounds} = $self->bounds; } return \%json; } #### Legacy methods from 0.10 =head2 C Synonym for C. Provided for compatibility with version 0.10. =cut sub gpx { my $self = shift; return $self->xml( @_ ); } =head2 C Provided for compatibility with version 0.10. =cut sub loc { my $self = shift; my @ret = (); push @ret, qq{\n}; push @ret, qq{\n}; if ( exists( $self->{waypoints} ) ) { for my $wpt ( @{ $self->{waypoints} } ) { push @ret, $wpt->loc(); } } push @ret, qq{\n}; return join( '', @ret ); } =head2 C Provided for compatibility with version 0.10. =cut sub gpsdrive { my $self = shift; my @ret = (); if ( exists( $self->{waypoints} ) ) { for my $wpt ( @{ $self->{waypoints} } ) { push @ret, $wpt->gpsdrive(); } } return join( '', @ret ); } 1; __END__ =head2 C Accessor for the element of a GPX. To get the name: my $name = $gpx->name(); and to set it: $gpx->name( 'My big adventure' ); =head2 C Accessor for the element of a GPX. To get the the description: my $desc = $gpx->desc(); and to set it: $gpx->desc('Got lost, wandered around for ages, got cold, got hungry.'); =head2 C Accessor for the author structure of a GPX. The author information is stored in a hash that reflects the structure of a GPX 1.1 document: my $author = $gpx->author(); $author = { link => { text => 'Hexten', href => 'http://hexten.net/' }, email => { domain => 'hexten.net', id => 'andy' }, name => 'Andy Armstrong' }, When setting the author data a similar structure must be supplied: $gpx->author({ name => 'Me!' }); The bizarre encoding of email addresses as id and domain is a feature of GPX. =head2 C Accessor for the