Geo::Gpx - Create and parse GPX files.

  # 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();

  use Geo::Gpx;
  my $gpx = Geo::Gpx->new( @waypoints );
  my $xml = $gpx->xml;

 my $gpx = Geo::Gpx->new( xml => $gpx_document );

 my $gpx = Geo::Gpx->new( input => $fh );

  my $gpx = Geo::Gpx->new();
  $gpx->waypoints( \@wpt );

  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        => '<<Chez moi>>',
    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 );

  my $iter = $gpx->iterate_points();
  while ( my $pt = $iter->() ) {
    print "Point: ", join( ', ', $pt->{lat}, $pt->{lon} ), "\n";
  }

  my $gpx = Geo::Gpx->new( xml => $some_xml );
  my $bounds = $gpx->bounds();

  $bounds = {
    minlat => 57.120939,
    minlon => -2.9839832,
    maxlat => 57.781729,
    maxlon => -1.230902
  };

  my $gpx10 = $gpx->xml( '1.0' );
  my $gpx11 = $gpx->xml( '1.1' );

  my %json = map { $_ => $self->$_ }
   qw(name desc author keywords copyright
   time link waypoints tracks routes version );
  $json{bounds} = $self->bounds( $iter );

  my $name = $gpx->name();

  $gpx->name( 'My big adventure' );

  my $desc = $gpx->desc();

  $gpx->desc('Got lost, wandered around for ages, got cold, got hungry.');

  my $author = $gpx->author();
  $author = {
    link => {
      text => 'Hexten',
      href => 'http://hexten.net/'
    },
    email => {
      domain => 'hexten.net',
      id => 'andy'
    },
    name => 'Andy Armstrong'
  },

  $gpx->author({
    name => 'Me!'
  });

  $gpx->keywords(['bleak', 'cold', 'scary']);
  my $k = $gpx->keywords();
  print join(', ', @{$k}), "\n";

  bleak, cold, scary

  $gpx->copyright('(c) You Know Who');
  print $gpx->copyright(), "\n";

  You Know Who

  $link = {
    'text' => 'Hexten',
    'href' => 'http://hexten.net/'
  };

  $gpx->link({ href => 'http://google.com/', text => 'Google' });

  my $wpt = {
    # All standard GPX fields
    lat           => 54.786989,
    lon           => -2.344214,
    ele           => 512,
    time          => 1164488503,
    magvar        => 0,
    geoidheight   => 0,
    name          => 'My house & home',
    cmt           => 'Where I live',
    desc          => '<<Chez moi>>',
    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->waypoints([ { lat => 57.0, lon => -2 },
                    { lat => 57.2, lon => -2.1 } ]);

  my $routes = [
    {
      'name' => 'Route 1'
      'points' => [
        {
          'lat' => '54.3286193447719',
          'name' => 'WPT1',
          'lon' => '-2.38972155527137'
        },
        {
          'lat' => '54.6634365629388',
          'name' => 'WPT2',
          'lon' => '-2.55373552512617'
        },
        {
          'lat' => '54.7289259665049',
          'name' => 'WPT3',
          'lon' => '-3.05196861273443'
        }
      ],
    },
    {
      'name' => 'Route 2'
      'points' => [
        {
          'lat' => '54.4165154835049',
          'name' => 'WPT4',
          'lon' => '-2.56153453279676'
        },
        {
          'lat' => '54.6670126167344',
          'name' => 'WPT5',
          'lon' => '-2.69526089464403'
        }
      ],
    }
  ];

  $gpx->routes($routes);

  my $tracks = [
    {
      'name' => 'Track 1',
      'segments' => [
        {
          'points' => [
            {
              'lat' => '54.5182217145253',
              'lon' => '-2.62191579018834'
            },
            {
              'lat' => '54.1507759448355',
              'lon' => '-3.05774931478646'
            },
            {
              'lat' => '54.6016296784874',
              'lon' => '-3.40418920968631'
            }
          ]
        },
        {
          'points' => [
            {
              'lat' => '54.6862790450185',
              'lon' => '-3.68760108982739'
            }
          ]
        }
      ]
    },
    {
      'name' => 'Track 2',
      'segments' => [
        {
          'points' => [
            {
              'lat' => '54.9927807628549',
              'lon' => '-4.04712811256436'
            },
            {
              'lat' => '55.1148395198045',
              'lon' => '-4.33623533555793'
            },
            {
              'lat' => '54.6214174046189',
              'lon' => '-4.26293674042878'
            },
            {
              'lat' => '55.0540816059084',
              'lon' => '-4.42261020671926'
            },
            {
              'lat' => '55.4451622411372',
              'lon' => '-4.32873765338'
            }
          ]
        }
      ]
    }
  ];

  print $gpx->version();

  1.0

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;

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 );
    },
  };
}

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();
}

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;
    }
   }
}

sub iterate_waypoints {
  my $self = shift;
  return _iterate_points( $self->{waypoints} );
}

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 );

}

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 );
}

sub iterate_points {
  my $self = shift;

  return _iterate_iterators(
    $self->iterate_waypoints(),
    $self->iterate_routepoints(),
    $self->iterate_trackpoints()
  );
}

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, '>', @_, '</', $name, ">\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 <wpt></wpt> 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;
}

sub xml {
  my $self = shift;
  my $version = shift || $self->{version} || '1.0';

  my @ret = ();

  push @ret, qq{<?xml version="1.0" encoding="utf-8"?>\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{<gpx xmlns:xsd="http://www.w3.org/2001/XMLSchema" },
   qq{xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" },
   qq{version="$version" creator="Geo::Gpx" },
   qq{xsi:schemaLocation="$schema" }, qq{xmlns="$ns">\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{</gpx>\n};

  return join( '', @ret );
}

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

sub gpx {
  my $self = shift;
  return $self->xml( @_ );
}

sub loc {
  my $self = shift;
  my @ret  = ();
  push @ret, qq{<?xml version="1.0" encoding="ISO-8859-1"?>\n};
  push @ret, qq{<loc version="1.0" src="Groundspeak">\n};

  if ( exists( $self->{waypoints} ) ) {
    for my $wpt ( @{ $self->{waypoints} } ) {
      push @ret, $wpt->loc();
    }
  }

  push @ret, qq{</loc>\n};

  return join( '', @ret );
}

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__