gpx2gpx: new option --trk-attrib

With doc and tests.

miscsrc/gpx2gpx

@@ -15,6 +15,9 @@ use warnings;
 use Getopt::Long;
 use XML::LibXML;
 
+use constant XMLNS_SRT     => 'http://rezic.de/gpxext/1';
+use constant XMLPREFIX_SRT => 'srt';
+
 my $v;
 my @opdefs;
 
@@ -47,6 +50,10 @@ GetOptions
 	 push @opdefs, { op => 'trkpts_delete', args => [$xpath] };
 	 $need_xpath_context_functions = 1;
      },
+     'trk-attrib=s' => sub {
+	 my($key, $val) = split /=/, $_[1], 2;
+	 push @opdefs, { op => 'trk_attrib', args => [$key, $val] };
+     },
     )
     or die "usage?";
 my $file = shift;
@@ -205,6 +212,39 @@ sub trkpts_delete {
     }
 }
 
+sub maybe_add_xmlns {
+    my($doc, $ns_uri, $ns_prefix) = @_;
+    my $root = $doc->documentElement;
+    my $ns_attr = "xmlns:$ns_prefix";
+    my $ns_attr_value = $root->getAttribute($ns_attr);
+    if (!$ns_attr_value) {
+	$root->setAttribute($ns_attr, $ns_uri);
+    } elsif ($ns_attr_value ne $ns_uri) {
+	die "xmlns:$ns_prefix already exists, but instead to $ns_uri it points to $ns_attr_value";
+    }
+}
+
+# It's called "trk_attrib", but it is adding an element to the first <trkseg> element
+sub trk_attrib {
+    my($key, $val) = @_;
+    if ($key =~ /^@{[ XMLPREFIX_SRT ]}:(.*)/) {
+	maybe_add_xmlns($doc, XMLNS_SRT, XMLPREFIX_SRT);
+	my($trkseg) = $doc->findnodes('/*[local-name(.)="gpx"]/*[local-name(.)="trk"]/*[local-name(.)="trkseg"]');
+	if (!$trkseg) {
+	    die "GPX file does not have a <trkseg> element.\n";
+	}
+	my $new_elem = XML::LibXML::Element->new($key);
+	$new_elem->appendText($val);
+	if ($trkseg->hasChildNodes) {
+	    $trkseg->insertBefore($new_elem, $trkseg->firstChild);
+	} else {
+	    $trkseg->appendChild($new_elem);
+	}
+    } else {
+	die "Key '$key' must be prefixed by " . XMLPREFIX_SRT . ", other prefixes or prefix-less track attributes are not allowed.\n";
+    }
+}
+
 __END__
 
 =head1 NAME
@@ -256,6 +296,20 @@ Additional functions are registered into the XPath engine:
 
 =back
 
+=head3 C<--trk-attrib srt:I<attrib>=I<value>>
+
+Add a custom element below the first C<< <trkseg> >>. Currently only
+elements with a C<srt> prefix are allowed. Possible attributes are for
+example:
+
+=over
+
+=item C<--trk-attrib srt:vehicle=bike>
+
+=item C<--trk-attrib "srt:brand=rental bike">
+
+=back
+
 =head3 C<--trkcat I<file2 file3 ...>>
 
 Concat the primary gpx file and further files. Only trk files are

t/gpx2gpx.t

@@ -13,7 +13,7 @@ use lib $FindBin::RealBin, "$FindBin::RealBin/..";
 use Test::More;
 
 use BBBikeUtil qw(bbbike_root);
-use BBBikeTest qw(eq_or_diff gpxlint_string);
+use BBBikeTest qw(eq_or_diff gpxlint_string xmllint_string);
 
 sub count_trksegs ($);
 sub count_trkpts ($);
@@ -29,6 +29,7 @@ BEGIN {
 plan 'no_plan';
 
 my @script = ($^X, bbbike_root . '/miscsrc/gpx2gpx');
+my @gpx2gpsman = ($^X, bbbike_root . '/miscsrc/gpx2gpsman');
 
 my $src_gpx = <<'EOF';
 <?xml version="1.0" encoding="UTF-8"?>
@@ -172,6 +173,14 @@ require_geo_distance {
     is count_trkpts($dest_gpx), 1, 'two trkpts are gone';
 }
 
+{
+    ok run [@script, '--trk-attrib', 'srt:vehicle=bike', '--trk-attrib', 'srt:brand=rental bike'], '<', \$src_gpx, '>', \my $dest_gpx;
+    ok xmllint_string($dest_gpx); # do not check with gpxlint_string, srt:... is not in the schema
+    ok run [@gpx2gpsman, '-'], '<', \$dest_gpx, '>', \my $dest_gpsman;
+    like $dest_gpsman, qr{^!T:.*srt:vehicle=bike}m, 'found srt:vehicle';
+    like $dest_gpsman, qr{^!T:.*srt:brand=rental bike}m, 'found srt:brand';
+}
+
 sub count_trksegs ($) {
     my $gpx = shift;
     my $count = 0;