diff -Nru libgeo-gpx-perl-1.09/Build.PL libgeo-gpx-perl-1.10/Build.PL --- libgeo-gpx-perl-1.09/Build.PL 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/Build.PL 2023-11-25 17:04:01.000000000 +0000 @@ -1,5 +1,5 @@ -# This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v6.029. +# This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v6.030. use strict; use warnings; @@ -19,7 +19,7 @@ "Patrick Joly " ], "dist_name" => "Geo-Gpx", - "dist_version" => "1.09", + "dist_version" => "1.10", "license" => "perl", "module_name" => "Geo::Gpx", "recursive_test_files" => 1, diff -Nru libgeo-gpx-perl-1.09/Changes libgeo-gpx-perl-1.10/Changes --- libgeo-gpx-perl-1.09/Changes 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/Changes 2023-11-25 17:04:01.000000000 +0000 @@ -1,5 +1,18 @@ Revision history for Geo-Gpx +1.10 [2023-11-25] + New methods for waypoints: + - waypoint_rename(), waypoints_print(), + - waypoints_clip() -- only supported on systems with the xclip utility + + New methods for tracks: + - track_rename(), track_delete(), tracks_delete_all(), tracks_print() + + New method for routes: + - routes_delete_all + + Fixed error when a filehandle is used as input + 1.09 [2022-12-06] Fixed bug in parsing absolute and relative paths in MSWin32 diff -Nru libgeo-gpx-perl-1.09/Install libgeo-gpx-perl-1.10/Install --- libgeo-gpx-perl-1.09/Install 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/Install 2023-11-25 17:04:01.000000000 +0000 @@ -1,6 +1,12 @@ INSTALLATION -To install this module, run the following commands: +Recommended Installation Method: + +The easiest way to install this distribution is from the Perl cpan shell. + + cpan[1]> install Geo::Gpx + +To install from the source files in the module's directory, run the following commands: perl Makefile.PL make @@ -14,7 +20,9 @@ ./Build test ./Build install - The Build.PL file is not maintained in the github repository. If you obtained the code from GitHub and would like to install with Module::Build, download the source tarball of the module from CPAN.org instead; it contains Build.PL (see https://metacpan.org/pod/Geo::Gpx). +Installing from the Github Repository: + +If you cloned or downloaded a release from the Github repository, please install using the Makefile.PL provided. The Build.PL file is not maintained on Github, it is automatically generated by the Dist::Zilla distribution management tool when releasing a new version on CPAN. Installation using Dist::Zilla is for code maitainers and is not supported. DEPENDENCIES See the README.md diff -Nru libgeo-gpx-perl-1.09/MANIFEST libgeo-gpx-perl-1.10/MANIFEST --- libgeo-gpx-perl-1.09/MANIFEST 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/MANIFEST 2023-11-25 17:04:01.000000000 +0000 @@ -1,4 +1,4 @@ -# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.029. +# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.030. Build.PL Changes Install diff -Nru libgeo-gpx-perl-1.09/META.json libgeo-gpx-perl-1.10/META.json --- libgeo-gpx-perl-1.09/META.json 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/META.json 2023-11-25 17:04:01.000000000 +0000 @@ -4,7 +4,7 @@ "Patrick Joly " ], "dynamic_config" : 0, - "generated_by" : "Dist::Zilla version 6.029, CPAN::Meta::Converter version 2.150010", + "generated_by" : "Dist::Zilla version 6.030, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], @@ -59,9 +59,9 @@ "web" : "https://github.com/patjoly/geo-gpx" } }, - "version" : "1.09", + "version" : "1.10", "x_generated_by_perl" : "v5.36.0", - "x_serialization_backend" : "Cpanel::JSON::XS version 4.32", + "x_serialization_backend" : "Cpanel::JSON::XS version 4.36", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later" } diff -Nru libgeo-gpx-perl-1.09/META.yml libgeo-gpx-perl-1.10/META.yml --- libgeo-gpx-perl-1.09/META.yml 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/META.yml 2023-11-25 17:04:01.000000000 +0000 @@ -11,7 +11,7 @@ ExtUtils::MakeMaker: '0' Module::Build: '0.28' dynamic_config: 0 -generated_by: 'Dist::Zilla version 6.029, CPAN::Meta::Converter version 2.150010' +generated_by: 'Dist::Zilla version 6.030, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -31,7 +31,7 @@ resources: homepage: https://github.com/patjoly/geo-gpx repository: https://github.com/patjoly/geo-gpx.git -version: '1.09' +version: '1.10' x_generated_by_perl: v5.36.0 -x_serialization_backend: 'YAML::Tiny version 1.73' +x_serialization_backend: 'YAML::Tiny version 1.74' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' diff -Nru libgeo-gpx-perl-1.09/Makefile.PL libgeo-gpx-perl-1.10/Makefile.PL --- libgeo-gpx-perl-1.09/Makefile.PL 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/Makefile.PL 2023-11-25 17:04:01.000000000 +0000 @@ -1,4 +1,4 @@ -# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.029. +# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.030. use strict; use warnings; @@ -36,7 +36,7 @@ "File::Spec" => 0, "Test::More" => 0 }, - "VERSION" => "1.09", + "VERSION" => "1.10", "test" => { "TESTS" => "t/*.t" } diff -Nru libgeo-gpx-perl-1.09/README.md libgeo-gpx-perl-1.10/README.md --- libgeo-gpx-perl-1.09/README.md 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/README.md 2023-11-25 17:04:01.000000000 +0000 @@ -39,7 +39,9 @@ Without arguments, returns the array reference of waypoints. - With an argument, returns a reference to the waypoint whose `name` field is an exact match with _$name_ or the one at integer index _$int_ (1-indexed). Returns `undef` if none are found such that this method can be used to check if a specific point exists (i.e. no exception is raised if _$name_ or _$int_ do not exist) . + With an argument, returns a reference to the waypoint whose `name` field is an exact match with _$name_. If an integer is specified instead of the `name` key/value pair, returns the waypoint at position _$int_ in the array reference (1-indexed with negative integers also counting from the end of the array). + + Returns `undef` if no corresponding waypoints are found such that this method can be used to check if a specific point exists (i.e. no exception is raised if _$name_ or _$int_ do not exist) . - waypoints\_add( $point or \\%point \[, $point or \\%point, … \] ) @@ -57,9 +59,14 @@ returns an array of waypoints whose _$field_ (e.g. `name`, `desc`, …) matches _$regex_. By default, the regex is case-sensitive; specify `qr/(?i:search_string_here)/` to ignore case. -- waypoints\_count() +- waypoints\_clip( $name | $regex | LIST ) +- way\_clip( ) - returns the number of waypoints in the object. + Sends the coordinates of the waypoint(s) whose name is either `$name` or matches `$regex` to the clipboard (all points found are sent to the clipboard) and returns an array of points found. By default, the regex is case-sensitive; specify `qr/(?i:...)/` to ignore case. + + Alternatively, an array of `Geo::GXP::Points` can be provided. `way_clip()` is a short-hand for this method (convenient when used interactively in the debugger). + + This method is only supported on unix-based systems that have the `xclip` utility installed (see DEPENDENCIES). - waypoints\_delete\_all() @@ -67,7 +74,11 @@ - waypoint\_delete( $name ) - delete the waypoint whose `name` is an exact match, case sensitively. Returns true if successful, `undef` if the name cannot be found. + delete the waypoint whose `name` field is an exact match for _$name_ (case sensitively). Returns true if successful, `undef` if the name cannot be found. + +- waypoint\_rename( $name, $new\_name ) + + rename the waypoint whose `name` field is an exact match for _$name_ (case sensitively) to _$new\_name_. Returns the point's new name if successful, `undef` otherwise. - waypoints\_merge( $gpx, $regex ) @@ -81,9 +92,17 @@ From any [Geo::Gpx::Point](https://metacpan.org/pod/Geo%3A%3AGpx%3A%3APoint) or [Geo::TCX::Trackpoint](https://metacpan.org/pod/Geo%3A%3ATCX%3A%3ATrackpoint) object, return the waypoint that is closest to it. If called in list context, returns a two-element array consisting of that waypoint, and the distance from the coordinate (in meters). +- waypoints\_print() + + print the list of waypoints to screen, along with their names and descriptions if defined. Returns true. + +- waypoints\_count() + + returns the number of waypoints in the object. + - routes( integer or name => 'name' ) - Returns the array reference of routes when called without argument. Optionally accepts a single integer referring to the route number from routes aref (1-indexed) or a key value pair with the name of the route to be returned. + Returns the array reference of routes when called without argument. Optionally accepts a single integer referring to the route number from routes aref (1-indexed with negative integers also counting from the end of the array) or a key value pair with the name of the route to be returned. - routes\_add( $route or $points\_aref \[, name => $route\_name ) @@ -91,13 +110,17 @@ `name` and all other meta fields supported by routes can be provided and will overwrite any existing fields in _$route_. +- routes\_delete\_all() + + delete all routes. Returns true. + - routes\_count() returns the number of routes in the object. - tracks( integer or name => 'name' ) - Returns the array reference of tracks when called without argument. Optionally accepts a single integer referring to the track number from tracks aref (1-indexed) or a key value pair with the name of the track to be returned. + Returns the array reference of tracks when called without argument. Optionally accepts a single integer referring to the track number from the tracks aref (1-indexed with negative integers also counting from the end of the array) or a key value pair with the name of the track to be returned. - tracks\_add( $track or $points\_aref \[, $points\_aref, … \] \[, name => $track\_name \] ) @@ -107,6 +130,24 @@ A new track can also be created based an array reference(s) of [Geo::Gpx::Point](https://metacpan.org/pod/Geo%3A%3AGpx%3A%3APoint) objects and added to the `Geo::Gpx` instance. If more than one array reference is supplied, the resulting track will contain as many segments as the number of aref's provided. +- tracks\_delete\_all() + + delete all tracks. Returns true. + +- track\_delete( $name ) + + delete the track whose `name` field is an exact match for _$name_ (case sensitively). Returns true if successful, `undef` if the name cannot be found. + +- track\_rename( $name, $new\_name ) + + rename the track whose `name` field is an exact match for _$name_ (case sensitively) to _$new\_name_. Returns the track's new name if successful, `undef` otherwise. + + Alternatively, an integer may be specified as the first argument, referring to the track number from tracks aref (1-indexed). This is a convenience as it is quite common for tracks to be named with the timestamp fo the first point. + +- tracks\_print() + + print the list of tracks to screen, by their `name` field. Returns true. + - tracks\_count() returns the number of tracks in the object. @@ -123,7 +164,7 @@ my $iter = $gpx->iterate_points(); while ( my $pt = $iter->() ) { - print "Point: ", join( ', ', $pt->{lat}, $pt->{lon} ), "\n"; + print "Point: ", join( ', ', $pt->{lat}, $pt->{lon} ), "\n"; } - bounds( $iterator ) @@ -155,8 +196,8 @@ For compatibility with [JSON](https://metacpan.org/pod/JSON) modules. Convert 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 ); + 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. @@ -224,6 +265,8 @@ [Scalar::Util](https://metacpan.org/pod/Scalar%3A%3AUtil), [XML::Descent](https://metacpan.org/pod/XML%3A%3ADescent) +The `waypoints_clip()` method is only supported on unix-based systems that have the `xclip` utility installed. + # SEE ALSO [JSON](https://metacpan.org/pod/JSON) @@ -244,7 +287,7 @@ # VERSION -1.09 +1.10 # LICENSE AND COPYRIGHT diff -Nru libgeo-gpx-perl-1.09/debian/changelog libgeo-gpx-perl-1.10/debian/changelog --- libgeo-gpx-perl-1.09/debian/changelog 2022-12-07 10:28:18.000000000 +0000 +++ libgeo-gpx-perl-1.10/debian/changelog 2023-11-25 18:31:33.000000000 +0000 @@ -1,3 +1,14 @@ +libgeo-gpx-perl (1.10-1) unstable; urgency=medium + + * New upstream release. + (closes: #1056346) + * Bump Standards-Version to 4.6.2, no changes. + * Bump debhelper compat to 13. + * Enable Salsa CI. + * Add xclip to Suggests for waypoints_clip(). + + -- Bas Couwenberg Sat, 25 Nov 2023 19:31:33 +0100 + libgeo-gpx-perl (1.09-1) unstable; urgency=medium * New upstream release. diff -Nru libgeo-gpx-perl-1.09/debian/control libgeo-gpx-perl-1.10/debian/control --- libgeo-gpx-perl-1.09/debian/control 2022-12-04 14:56:34.000000000 +0000 +++ libgeo-gpx-perl-1.10/debian/control 2023-11-25 18:30:45.000000000 +0000 @@ -3,7 +3,8 @@ Uploaders: Bas Couwenberg Section: perl Priority: optional -Build-Depends: debhelper-compat (= 12), libmodule-build-perl +Build-Depends: debhelper-compat (= 13), + libmodule-build-perl Build-Depends-Indep: libdatetime-format-iso8601-perl, libdatetime-perl, libgeo-coordinates-transform-perl, @@ -13,7 +14,7 @@ libtest-xml-perl, libxml-descent-perl, perl -Standards-Version: 4.6.1 +Standards-Version: 4.6.2 Vcs-Browser: https://salsa.debian.org/perl-team/modules/packages/libgeo-gpx-perl Vcs-Git: https://salsa.debian.org/perl-team/modules/packages/libgeo-gpx-perl.git Homepage: https://metacpan.org/release/Geo-Gpx @@ -29,6 +30,7 @@ libxml-descent-perl, ${perl:Depends}, ${misc:Depends} +Suggests: xclip Description: Perl module for creating and parsing GPX files The original goal of Geo::Gpx was to produce GPX/XML files which were parseable by both GPX Spinner and EasyGPS. As of version 0.13 it has been diff -Nru libgeo-gpx-perl-1.09/debian/salsa-ci.yml libgeo-gpx-perl-1.10/debian/salsa-ci.yml --- libgeo-gpx-perl-1.09/debian/salsa-ci.yml 1970-01-01 00:00:00.000000000 +0000 +++ libgeo-gpx-perl-1.10/debian/salsa-ci.yml 2023-08-26 07:57:58.000000000 +0000 @@ -0,0 +1,6 @@ +--- +include: + - https://salsa.debian.org/salsa-ci-team/pipeline/raw/master/recipes/debian.yml + +variables: + SALSA_CI_ENABLE_BUILD_PACKAGE_TWICE: 1 diff -Nru libgeo-gpx-perl-1.09/lib/Geo/Gpx/Point.pm libgeo-gpx-perl-1.10/lib/Geo/Gpx/Point.pm --- libgeo-gpx-perl-1.09/lib/Geo/Gpx/Point.pm 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/lib/Geo/Gpx/Point.pm 2023-11-25 17:04:01.000000000 +0000 @@ -2,7 +2,7 @@ use strict; use warnings; -our $VERSION = '1.09'; +our $VERSION = '1.10'; =encoding utf8 @@ -329,7 +329,7 @@ =head1 VERSION -1.09 +1.10 =head1 SEE ALSO diff -Nru libgeo-gpx-perl-1.09/lib/Geo/Gpx.pm libgeo-gpx-perl-1.10/lib/Geo/Gpx.pm --- libgeo-gpx-perl-1.09/lib/Geo/Gpx.pm 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/lib/Geo/Gpx.pm 2023-11-25 17:04:01.000000000 +0000 @@ -3,13 +3,13 @@ use warnings; use strict; -our $VERSION = '1.09'; +our $VERSION = '1.10'; use Carp; use DateTime::Format::ISO8601; use DateTime; use HTML::Entities qw( encode_entities encode_entities_numeric ); -use Scalar::Util qw( blessed ); +use Scalar::Util qw( blessed looks_like_number ); use XML::Descent; use File::Basename; use Cwd qw(cwd abs_path); @@ -23,16 +23,16 @@ =head1 SYNOPSIS - my ($gpx, $waypoints, $tracks); + my ($gpx, $waypoints, $tracks); - # From a filename, an open file, or an XML string: + # From a filename, an open file, or an XML string: - $gpx = Geo::Gpx->new( input => $fname ); - $gpx = Geo::Gpx->new( input => $fh ); - $gpx = Geo::Gpx->new( xml => $xml ); + $gpx = Geo::Gpx->new( input => $fname ); + $gpx = Geo::Gpx->new( input => $fh ); + $gpx = Geo::Gpx->new( xml => $xml ); - my $waypoints = $gpx->waypoints(); - my $tracks = $gpx->tracks(); + my $waypoints = $gpx->waypoints(); + my $tracks = $gpx->tracks(); =head1 DESCRIPTION @@ -40,86 +40,75 @@ =cut -# 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 %AS_ATTR = ( # values that are encoded as attributes + 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; + wpt => [ + qw( + ele time magvar geoidheight name cmt desc src link sym type fix + sat hdop vdop pdop ageofdgpsdata dgpsid extensions + ) + ], + ); + +my %XMLMAP = ( # map hash keys to GPX names + waypoints => { waypoints => 'wpt' }, + routes => { + routes => 'rte', + points => 'rtept' + }, + tracks => { + tracks => 'trk', + segments => 'trkseg', + points => 'trkpt' + } + ); +my (@META, @ATTR); BEGIN { - @META = qw( name desc author time keywords copyright link ); - @ATTR = qw( version ); + @META = qw( name desc author time keywords copyright link ); + @ATTR = qw( version ); - # Generate accessors - for my $attr ( @META, @ATTR ) { - no strict 'refs'; - *{ __PACKAGE__ . '::' . $attr } = sub { - my $self = shift; - $self->{$attr} = shift if @_; - return $self->{$attr}; - }; - } + # Generate accessors + for my $attr ( @META, @ATTR ) { + no strict 'refs'; + *{ __PACKAGE__ . '::' . $attr } = sub { + my $self = shift; + $self->{$attr} = shift if @_; + return $self->{$attr}; + } + } } sub _time_string_to_epoch { - my $dt = DateTime::Format::ISO8601->parse_datetime( shift ); - return $dt->epoch + my $dt = DateTime::Format::ISO8601->parse_datetime( shift ); + return $dt->epoch } sub _time_epoch_to_string { - my $dt = DateTime->from_epoch( epoch => shift, time_zone => 'UTC' ); - my $str = $dt->strftime( '%Y-%m-%dT%H:%M:%S%z' ); - $str =~ s/(\d{2})$/:$1/; - $str =~ s/\+00:00$/Z/; - return $str + my $dt = DateTime->from_epoch( epoch => shift, time_zone => 'UTC' ); + my $str = $dt->strftime( '%Y-%m-%dT%H:%M:%S%z' ); + $str =~ s/(\d{2})$/:$1/; + $str =~ s/\+00:00$/Z/; + return $str } sub _init_shiny_new { - my ( $self, $args ) = @_; - - $self->{schema} = []; - - $self->{waypoints} = []; # these need to be defined for the *_count accessors - $self->{routes} = []; - $self->{tracks} = []; - - $self->{handler} = { - create => sub { - return {@_}; - }, - time => sub { - return _time_epoch_to_string( $_[0] ); - }, - }; + my ( $self, $args ) = @_; + $self->{schema} = []; + $self->{waypoints} = []; + $self->{routes} = []; + $self->{tracks} = []; + $self->{handler} = { + create => sub { return {@_}; }, + time => sub { return _time_epoch_to_string( $_[0] ); } + } } =head2 Constructor @@ -137,173 +126,164 @@ =cut sub new { - my ( $class, @args ) = @_; - my $self = bless( {}, $class ); + my ( $class, @args ) = @_; + my $self = bless( {}, $class ); - # CORE::time because we have our own time method. - $self->{time} = CORE::time(); + # CORE::time because we have our own time method. + $self->{time} = CORE::time(); - if ( @args % 2 == 0 ) { - my %args = @args; - $self->_init_shiny_new( \%args ); - - if ( exists $args{input} ) { - my ($fh, $arg); - $arg = $args{input}; - $arg =~ s/~/$ENV{'HOME'}/ if $arg =~ /^~/; - if (-f $arg) { - open( $fh , '<', $arg ) or die "can't open file $arg $!"; - $self->_parse( $fh ); - $self->set_filename($arg) - } else { $self->_parse( $args{input} ) } - } - elsif ( exists $args{xml} ) { - $self->_parse( \$args{xml} ); - } - $self->set_wd( $args{work_dir} || $args{wd} ); - } - else { - croak( "Invalid arguments" ); - } - return $self + if ( @args % 2 == 0 ) { + my %args = @args; + $self->_init_shiny_new( \%args ); + + if ( exists $args{input} ) { + my ($fh, $arg); + $arg = $args{input}; + $arg =~ s/~/$ENV{'HOME'}/ if $arg =~ /^~/; + if (-f $arg and $arg !~ /^GLOB/) { + open( $fh , '<', $arg ) or die "can't open file $arg $!"; + $self->_parse( $fh ); + $self->set_filename($arg) + } else { $self->_parse( $args{input} ) } + } elsif ( exists $args{xml} ) { + $self->_parse( \$args{xml} ) + } + $self->set_wd( $args{work_dir} || $args{wd} ) + } + 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; + 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 } ); + my $self = shift; + my $source = shift; - $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 Geo::Gpx::Point->new( %{$pt} ) - }; - - $p->on( - '*' => sub { - my ( $elem, $attr, $ctx ) = @_; - $ctx->{$elem} = _trim( $p->text() ); - }, - time => sub { - my ( $elem, $attr, $ctx ) = @_; - my $tm = _time_string_to_epoch( _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 { + my $p = XML::Descent->new( { Input => $source } ); - # 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( + 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 Geo::Gpx::Point->new( %{$pt} ) + }; + + $p->on( + '*' => sub { + my ( $elem, $attr, $ctx ) = @_; + $ctx->{$elem} = _trim( $p->text() ) + }, + time => sub { + my ( $elem, $attr, $ctx ) = @_; + my $tm = _time_string_to_epoch( _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->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(); - push @{ $self->{tracks} }, $tk; - } - ); - - $p->walk(); - } - ); - - $p->walk(); + ); + $p->walk() } =over 4 @@ -318,13 +298,12 @@ =cut -sub clone { +sub clone { # actually it can clone anything my $clone; eval(Data::Dumper->Dump([ shift ], ['$clone'])); confess $@ if $@; return $clone } -# actually it can clone anything =head2 Methods @@ -334,7 +313,9 @@ Without arguments, returns the array reference of waypoints. -With an argument, returns a reference to the waypoint whose C field is an exact match with I<$name> or the one at integer index I<$int> (1-indexed). Returns C if none are found such that this method can be used to check if a specific point exists (i.e. no exception is raised if I<$name> or I<$int> do not exist) . +With an argument, returns a reference to the waypoint whose C field is an exact match with I<$name>. If an integer is specified instead of the C key/value pair, returns the waypoint at position I<$int> in the array reference (1-indexed with negative integers also counting from the end of the array). + +Returns C if no corresponding waypoints are found such that this method can be used to check if a specific point exists (i.e. no exception is raised if I<$name> or I<$int> do not exist) . =back @@ -351,7 +332,10 @@ $waypoint = $pt if $pt->name eq $_[1] } } else { - $waypoint = $aref->[ ($_[0] - 1) ] + my $index = $_[0]; + croak 'waypoints are 1-indexed, please specify a non-zero integer' if $index==0; + $index -= 1 if $index > 0; # such that -1, -2, still count from end + $waypoint = $aref->[ $index ] } return $waypoint } @@ -375,19 +359,24 @@ =cut sub waypoints_add { - my $self = shift; + 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}; - 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} }, Geo::Gpx::Point->new( %$wpt ); - } - #TODO: Should return 1 + my $pt = Geo::Gpx::Point->new( %$wpt ); + + if (defined $pt->name ) { + my $new_name = $pt->name; + croak "there already is a waypoint named $new_name, please select another name" if $self->waypoints( 'name' => $new_name ); + } + push @{ $self->{waypoints} }, $pt + } + #TODO: Should return 1 } =over 4 @@ -414,15 +403,47 @@ =over 4 -=item waypoints_count() +=item waypoints_clip( $name | $regex | LIST ) -returns the number of waypoints in the object. +=item way_clip( ) + +Sends the coordinates of the waypoint(s) whose name is either C<$name> or matches C<$regex> to the clipboard (all points found are sent to the clipboard) and returns an array of points found. By default, the regex is case-sensitive; specify C to ignore case. + +Alternatively, an array of C can be provided. C is a short-hand for this method (convenient when used interactively in the debugger). + +This method is only supported on unix-based systems that have the C utility installed (see DEPENDENCIES). =back =cut -sub waypoints_count { return scalar @{ shift->{waypoints} } } +sub way_clip { waypoints_clip( @_ ) } +sub waypoints_clip { + my $gpx = shift; + + my @points; + if ( blessed $_[0] and $_[0]->isa('Geo::Gpx::Point' )) { + @points = @_ + } else { + my $first_arg = shift; + if ( ref( $first_arg ) eq 'Regexp' ) { + @points = $gpx->waypoints_search( name => $first_arg ) + } else { + my $match = $gpx->waypoints( name => $first_arg ); + push @points, $match if $match + } + croak 'no point matches the supplied regex' unless @points + } + my @points_reversed = reverse @points; + + for my $pt (@points_reversed) { + croak 'way_clip() expects list of Geo::Gpx::Point objects' unless $pt->isa('Geo::Gpx::Point'); + my $coords = $pt->lat . ', '; + $coords .= $pt->lon; + system("echo $coords | xclip -selection clipboard") + } + return @points +} =over 4 @@ -445,7 +466,7 @@ =item waypoint_delete( $name ) -delete the waypoint whose C is an exact match, case sensitively. Returns true if successful, C if the name cannot be found. +delete the waypoint whose C field is an exact match for I<$name> (case sensitively). Returns true if successful, C if the name cannot be found. =back @@ -470,6 +491,36 @@ =over 4 +=item waypoint_rename( $name, $new_name ) + +rename the waypoint whose C field is an exact match for I<$name> (case sensitively) to I<$new_name>. Returns the point's new name if successful, C otherwise. + +=back + +=cut + +sub waypoint_rename { + my $gpx = shift; + croak 'waypoint_rename() expects $name and $new_name as arguments' unless @_ == 2; + my ($name, $new_name) = @_; + my $ret_val; + + croak "there already is a waypoint named $new_name, please select another name" if $gpx->waypoints( 'name' => $new_name ); + + my $iter = $gpx->iterate_waypoints(); + while ( my $pt = $iter->() ) { + if (defined $pt->name) { + if ($pt->name eq $name) { + $ret_val = $pt->name( $new_name ); + last + } + } + } + return $ret_val +} + +=over 4 + =item waypoints_merge( $gpx, $regex ) Merge waypoints with those contained in the L instance provide as argument. Waypoints are compared based on their respective C fields, which must exist in I<$gpx> (if names are missing in the current instance, all points will be merged). @@ -539,9 +590,45 @@ =over 4 +=item waypoints_print() + +print the list of waypoints to screen, along with their names and descriptions if defined. Returns true. + +=back + +=cut + +sub waypoints_print { + my $gpx = shift; + croak 'waypoints_print() expects no arguments' if @_; + + my $iter = $gpx->iterate_waypoints(); + while ( my $pt = $iter->() ) { + my ($name, $desc); + $name = defined $pt->name ? $pt->name : 'Unnamed'; + $desc = defined $pt->desc ? $pt->desc : 'No description'; + print $name, ': ', $desc, "\n\t", $pt->lat, " ", $pt->lon, "\n" + } + return 1 +} + +=over 4 + +=item waypoints_count() + +returns the number of waypoints in the object. + +=back + +=cut + +sub waypoints_count { return scalar @{ shift->{waypoints} } } + +=over 4 + =item routes( integer or name => 'name' ) -Returns the array reference of routes when called without argument. Optionally accepts a single integer referring to the route number from routes aref (1-indexed) or a key value pair with the name of the route to be returned. +Returns the array reference of routes when called without argument. Optionally accepts a single integer referring to the route number from routes aref (1-indexed with negative integers also counting from the end of the array) or a key value pair with the name of the route to be returned. =back @@ -557,7 +644,11 @@ } croak "no route named $_[1] in route list" unless $route } else { - $route = $o->{routes}[($_[0] - 1)]; + my $index = $_[0]; + croak 'routes are 1-indexed, please specify a non-zero integer' if $index==0; + + $index -= 1 if $index > 0; # such that -1, -2, still count from end + $route = $o->{routes}[ $index ]; croak "route $_[0] not found" unless $route } return $route @@ -611,6 +702,23 @@ =over 4 +=item routes_delete_all() + +delete all routes. Returns true. + +=back + +=cut + +sub routes_delete_all { + my $gpx = shift; + croak 'routes_delete_all() expects no arguments' if @_; + $gpx->{routes} = []; + return 1 +} + +=over 4 + =item routes_count() returns the number of routes in the object. @@ -625,7 +733,7 @@ =item tracks( integer or name => 'name' ) -Returns the array reference of tracks when called without argument. Optionally accepts a single integer referring to the track number from tracks aref (1-indexed) or a key value pair with the name of the track to be returned. +Returns the array reference of tracks when called without argument. Optionally accepts a single integer referring to the track number from the tracks aref (1-indexed with negative integers also counting from the end of the array) or a key value pair with the name of the track to be returned. =back @@ -641,7 +749,11 @@ } croak "no track named $_[1] in track list" unless $track } else { - $track = $o->{tracks}[($_[0] - 1)]; + my $index = $_[0]; + croak 'tracks are 1-indexed, please specify a non-zero integer' if $index==0; + + $index -= 1 if $index > 0; # such that -1, -2, still count from end + $track = $o->{tracks}[ $index ]; croak "track $_[0] not found" unless $track } return $track @@ -704,7 +816,7 @@ # let's try a default behaviour of adding time of first point if name is not defined (could provide option to turn this off) if ( ! defined $c->{name} ) { my $first_pt_time = $c->{segments}[0]{points}[0]->time; - $c->{name} = _time_epoch_to_string( $first_pt_time ) if $first_pt_time; + $c->{name} = _time_epoch_to_string( $first_pt_time ) if $first_pt_time } push @{ $o->{tracks} }, $c; return 1 @@ -712,6 +824,98 @@ =over 4 +=item tracks_delete_all() + +delete all tracks. Returns true. + +=back + +=cut + +sub tracks_delete_all { + my $gpx = shift; + croak 'tracks_delete_all() expects no arguments' if @_; + $gpx->{tracks} = []; + return 1 +} + +=over 4 + +=item track_delete( $name ) + +delete the track whose C field is an exact match for I<$name> (case sensitively). Returns true if successful, C if the name cannot be found. + +=back + +=cut + +sub track_delete { + my ($gpx, $name) = @_; + my ($index, $found_match) = (0, undef); + for my $t ( @{ $gpx->{tracks} } ) { + if ($t->{name} eq $name) { + $found_match = 1; + last + } + ++$index + } + splice @{$gpx->{tracks}}, $index, 1 if $found_match; + return $found_match +} + +=over 4 + +=item track_rename( $name, $new_name ) + +rename the track whose C field is an exact match for I<$name> (case sensitively) to I<$new_name>. Returns the track's new name if successful, C otherwise. + +Alternatively, an integer may be specified as the first argument, referring to the track number from tracks aref (1-indexed). This is a convenience as it is quite common for tracks to be named with the timestamp fo the first point. + +=back + +=cut + +sub track_rename { + my $gpx = shift; + croak 'track_rename() expects $name (or an integer) and $new_name as arguments' unless @_ == 2; + my ($first_arg, $new_name) = @_; + + for my $t ( @{ $gpx->{tracks} } ) { + croak "there already is a track named $new_name, please select another name" if $t->{name} eq $new_name + } + + my $track; + my $is_index = looks_like_number( $first_arg ); + $track = $is_index ? $gpx->tracks( $first_arg ) : $gpx->tracks( name => $first_arg ); + + if (defined $track) { + return $track->{name} = $new_name + } + return undef +} + +=over 4 + +=item tracks_print() + +print the list of tracks to screen, by their C field. Returns true. + +=back + +=cut + +sub tracks_print { + my $gpx = shift; + croak 'tracks_print() expects no arguments' if @_; + + for my $t ( @{ $gpx->{tracks} } ) { + print $t->{name}, "\n" + } + return 1 +} + +=over 4 + =item tracks_count() returns the number of tracks in the object. @@ -722,35 +926,29 @@ sub tracks_count { return scalar @{ shift->{tracks} } } -# Not a method sub _iterate_points { - my $pts = shift || []; # array ref - - unless ( defined $pts ) { + my $pts = shift || []; # array ref + unless ( defined $pts ) { + return sub { return } + } + my $max = scalar( @{$pts} ); + my $pos = 0; return sub { - return; - }; - } - - my $max = scalar( @{$pts} ); - my $pos = 0; - return sub { - return if $pos >= $max; - return $pts->[ $pos++ ]; - }; + 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; - } - } + my @its = @_; + return sub { + for ( ;; ) { + return undef unless @its; + my $next = $its[0]->(); + return $next if defined $next; + shift @its + } + } } =over 4 @@ -766,62 +964,56 @@ =cut sub iterate_waypoints { - my $self = shift; - return _iterate_points( $self->{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} ); + my $self = shift; + my @iter = (); + if ( exists( $self->{routes} ) ) { + for my $rte ( @{ $self->{routes} } ) { + push @iter, _iterate_points( $rte->{points} ) + } } - } - - return _iterate_iterators( @iter ); - + 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} ); + 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 ); + return _iterate_iterators( @iter ) } =item iterate_points() Get an iterator for all of the points in a C instance, including waypoints, trackpoints, and routepoints. - my $iter = $gpx->iterate_points(); - while ( my $pt = $iter->() ) { - print "Point: ", join( ', ', $pt->{lat}, $pt->{lon} ), "\n"; - } + my $iter = $gpx->iterate_points(); + while ( my $pt = $iter->() ) { + print "Point: ", join( ', ', $pt->{lat}, $pt->{lon} ), "\n"; + } =back =cut sub iterate_points { - my $self = shift; - - return _iterate_iterators( - $self->iterate_waypoints(), - $self->iterate_routepoints(), - $self->iterate_trackpoints() - ); + my $self = shift; + return _iterate_iterators( + $self->iterate_waypoints(), + $self->iterate_routepoints(), + $self->iterate_trackpoints() + ) } =over 4 @@ -847,102 +1039,87 @@ =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}; - } + my ( $self, $iter ) = @_; + $iter ||= $self->iterate_points; - return $bounds; + 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] ); + 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"; - } + 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 ), '"' + } - return join( '', @tag ); + 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; - my $is_geo_gpx_point = blessed $value and $value->isa('Geo::Gpx::Point'); - - if ( defined( my $enc = $self->{encoder}->{$name} ) ) { - return $enc->( $name, $value ); - } - elsif ( ref $value eq 'HASH' or $is_geo_gpx_point ) { - 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 ) ); - } + my $self = shift; + my $name = shift; + my $value = shift; + my $name_map = shift || {}; + + my $tag = $name_map->{$name} || $name; + my $is_geo_gpx_point = blessed $value and $value->isa('Geo::Gpx::Point'); + + if ( defined( my $enc = $self->{encoder}->{$name} ) ) { + return $enc->( $name, $value ) + } elsif ( ref $value eq 'HASH' or $is_geo_gpx_point ) { + 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; + 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 } =item xml( $version ) @@ -954,118 +1131,104 @@ =cut sub xml { - my $self = shift; - my $version = shift || $self->{version} || '1.0'; - - my @ret = (); - - push @ret, qq{\n}; + 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} ) ) ); - } - }; + $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} ) + } + } - # 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; - } - - my @existing_keys; # waypoints should be generated first, applications like MapSource croak if not - for my $k ( sort keys %XMLMAP ) { - if ( exists( $self->{$k} ) ) { - if ($k eq 'waypoints') { unshift @existing_keys, $k } - else { push @existing_keys, $k } - } - } - - for my $k ( @existing_keys ) { - push @ret, $self->_xml( $k, $self->{$k}, $XMLMAP{$k} ); - } + my $bounds = $self->bounds( $self->iterate_points() ); + if ( %{$bounds} ) { + push @meta, _tag( 'bounds', $bounds ) + } - push @ret, qq{\n}; + # 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 + } - return join( '', @ret ); + my @existing_keys; # waypoints should be generated first, applications like MapSource croak if not + for my $k ( sort keys %XMLMAP ) { + if ( exists( $self->{$k} ) ) { + if ($k eq 'waypoints') { unshift @existing_keys, $k } + else { push @existing_keys, $k } + } + } + for my $k ( @existing_keys ) { + push @ret, $self->_xml( $k, $self->{$k}, $XMLMAP{$k} ) + } + push @ret, qq{\n}; + return join( '', @ret ) } =item TO_JSON For compatibility with L modules. Convert 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 ); + 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. @@ -1074,21 +1237,21 @@ =cut sub TO_JSON { - my $self = shift; - my %json; #= map {$_ => $self->$_} ... - my @keys = (@META, @ATTR); - push @keys, 'waypoints' if $self->waypoints_count; - push @keys, 'routes' if $self->routes_count; - push @keys, 'tracks' if $self->tracks_count; - - for my $key ( @keys ) { - my $val = $self->$key; - $json{$key} = $val if defined $val; - } - if ( my $bounds = $self->bounds ) { - $json{bounds} = $self->bounds; - } - return \%json; + my $self = shift; + my %json; #= map {$_ => $self->$_} ... + my @keys = (@META, @ATTR); + push @keys, 'waypoints' if $self->waypoints_count; + push @keys, 'routes' if $self->routes_count; + push @keys, 'tracks' if $self->tracks_count; + + for my $key ( @keys ) { + my $val = $self->$key; + $json{$key} = $val if defined $val + } + if ( my $bounds = $self->bounds ) { + $json{bounds} = $self->bounds + } + return \%json } =over 4 @@ -1278,6 +1441,8 @@ L, L +The C<< waypoints_clip() >> method is only supported on unix-based systems that have the C utility installed. + =head1 SEE ALSO L @@ -1298,7 +1463,7 @@ =head1 VERSION -1.09 +1.10 =head1 LICENSE AND COPYRIGHT diff -Nru libgeo-gpx-perl-1.09/t/00-report-prereqs.t libgeo-gpx-perl-1.10/t/00-report-prereqs.t --- libgeo-gpx-perl-1.09/t/00-report-prereqs.t 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/t/00-report-prereqs.t 2023-11-25 17:04:01.000000000 +0000 @@ -3,7 +3,7 @@ use strict; use warnings; -# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.028 +# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.029 use Test::More tests => 1; @@ -109,20 +109,24 @@ my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { - next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; - my $file = $mod; - $file =~ s{::}{/}g; - $file .= ".pm"; - my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; - my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; + if ($mod eq 'perl') { + push @reports, ['perl', $want, $]]; + next; + } + my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; + my $file = $mod; + $file =~ s{::}{/}g; + $file .= ".pm"; + my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; + if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; diff -Nru libgeo-gpx-perl-1.09/t/01_main.t libgeo-gpx-perl-1.10/t/01_main.t --- libgeo-gpx-perl-1.09/t/01_main.t 2022-12-07 02:14:25.000000000 +0000 +++ libgeo-gpx-perl-1.10/t/01_main.t 2023-11-25 17:04:01.000000000 +0000 @@ -2,7 +2,7 @@ use strict; use warnings; -use Test::More tests => 20; +use Test::More tests => 31; use Geo::Gpx; use File::Temp qw/ tempfile tempdir /; use Cwd qw(cwd abs_path); @@ -38,6 +38,11 @@ my $o_trk_only2 = Geo::Gpx->new( input => "$fname_trk2" ); isa_ok ($o_trk_only2, 'Geo::Gpx'); +# new(): from filehandle +open( my $fh , '<', $fname_wpt1 ) or die "can't open file $fname_wpt1 $!"; +my $o_from_fh = Geo::Gpx->new( input => $fh ); +isa_ok ($o_from_fh, 'Geo::Gpx'); + # NextSteps: create a new empty gpx file, add the waypoints, add a track, then add another track (do we have a method to add another track like waypoints_add() # @@ -121,9 +126,26 @@ isa_ok ($closest, 'Geo::Gpx::Point'); is($dist, 241.593745, " waypoints_closest_to(): check the distance to the closest waypoint"); +# waypoint_rename(): +is( $o_wpt_only1->waypoint_rename('LP1', 'LP1_renamed'), 'LP1_renamed', " waypoint_rename(): check if rename is successful"); +is( $o_wpt_only1->waypoint_rename('LP1', 'Another name'), undef, " waypoint_rename(): check return value if unsuccessful"); + # waypoint_delete(): -$o_wpt_only1->waypoint_delete('LP1'); -$o_wpt_only1->waypoints_count; # was 3 should now be 2 +is( $o_wpt_only1->waypoint_delete('LP1'), undef, " waypoint_delete(): check return value if waypoint name is not found"); +$o_wpt_only1->waypoint_rename('LP1_renamed', 'LP1'); +is( $o_wpt_only1->waypoint_delete('LP1'), 1, " waypoint_delete(): check if waypoint deletion is successful"); +is( $o_wpt_only1->waypoints_count, 2, " waypoint_delete(): had 3 points, should now have 2"); + +# track_rename(): +is( $o_ta->track_rename('A track with one segment', 'Single segment track'), 'Single segment track', " track_rename(): check if rename is successful"); +# is( $o_ta->track_rename( -0, 'Really just one'), 'Really just one', " track_rename(): check if rename is successful"); +# ... counting from the end is undocumented and will change in the future i.e. -1 will refer to last not -0 +# is( $o_ta->track_rename('A track with one segment', 'LP1_renamed'), undef, " track_rename(): check return value if unsuccessful"); +# ... this one croaks instead of returing undef, I think waypoint_rename() should behave the same way and croak + +# track_delete(): +$o_ta->track_delete( 'Single segment track' ); +is($o_ta->tracks_count, 1, " tracks_delete(): test the number of tracks remaining"); # save(): a few saves $o->set_wd( $tmp_dir ); @@ -137,5 +159,13 @@ my $saved_then_read = Geo::Gpx->new( input => $tmp_dir . '/test_save.gpx' ); isa_ok ($saved_then_read, 'Geo::Gpx'); +# delete_all's +$o->waypoints_delete_all; +is( $o->waypoints_count, 0, " waypoints_delete_all(): count should now be 0"); +$o_ta->tracks_delete_all; +is( $o_ta->tracks_count, 0, " waypoints_delete_all(): count should now be 0"); +$o_ta->routes_delete_all; +is( $o_ta->routes_count, 0, " waypoints_delete_all(): count should now be 0"); + print "so debugger doesn't exit\n";