| File: | blib/lib/HTML/OSM.pm |
| Coverage: | 95.0% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package HTML::OSM; | |||||
| 2 | ||||||
| 3 | 14 14 14 | 1160099 11 232 | use strict; | |||
| 4 | 14 14 14 | 25 9 333 | use warnings; | |||
| 5 | ||||||
| 6 | 14 14 14 | 1326 43531 41 | use autodie qw(:all); | |||
| 7 | 14 14 14 | 67869 39 171 | use B (); | |||
| 8 | 14 14 14 | 25 9 379 | use Carp qw(carp croak); | |||
| 9 | 14 14 14 | 2770 334159 240 | use CHI; | |||
| 10 | 14 14 14 | 49 17 479 | use JSON::MaybeXS qw(decode_json encode_json); | |||
| 11 | 14 14 14 | 4570 290055 341 | use LWP::UserAgent; | |||
| 12 | 14 14 14 | 4315 1026817 317 | use Object::Configure 0.15; | |||
| 13 | 14 14 14 | 71 103 319 | use Params::Get 0.13; | |||
| 14 | 14 14 14 | 39 111 220 | use Params::Validate::Strict 0.28; | |||
| 15 | 14 14 14 | 26 16 52 | use POSIX qw(localeconv setlocale LC_NUMERIC); | |||
| 16 | 14 14 14 | 549 20 237 | use Readonly; | |||
| 17 | 14 14 14 | 29 1259 276 | use Scalar::Util qw(blessed); | |||
| 18 | 14 14 14 | 37 14 58 | use Time::HiRes qw(time); | |||
| 19 | 14 14 14 | 781 14 39195 | use URI::Escape qw(uri_escape_utf8); | |||
| 20 | ||||||
| 21 - 29 | =head1 NAME HTML::OSM - Generate an interactive OpenStreetMap with Leaflet.js =head1 VERSION Version 0.12 =cut | |||||
| 30 | ||||||
| 31 | our $VERSION = '0.12'; | |||||
| 32 | ||||||
| 33 | # CDN URLs pinned to tested versions. Override via constructor params to use | |||||
| 34 | # a self-hosted copy or a different version. | |||||
| 35 | Readonly::Scalar my $LEAFLET_CSS_URL => 'https://unpkg.com/leaflet@1.9.4/dist/leaflet.css'; | |||||
| 36 | Readonly::Scalar my $LEAFLET_JS_URL => 'https://unpkg.com/leaflet@1.9.4/dist/leaflet.js'; | |||||
| 37 | Readonly::Scalar my $CLUSTER_JS_URL => 'https://unpkg.com/leaflet.markercluster@1.5.3/dist/leaflet.markercluster.js'; | |||||
| 38 | Readonly::Scalar my $CLUSTER_CSS_URL => 'https://unpkg.com/leaflet.markercluster@1.5.3/dist/MarkerCluster.css'; | |||||
| 39 | Readonly::Scalar my $CLUSTER_DEFAULT_CSS_URL => 'https://unpkg.com/leaflet.markercluster@1.5.3/dist/MarkerCluster.Default.css'; | |||||
| 40 | Readonly::Scalar my $HEATMAP_JS_URL => 'https://unpkg.com/leaflet.heat@0.2.0/dist/leaflet-heat.js'; | |||||
| 41 | Readonly::Scalar my $GPX_JS_URL => 'https://cdnjs.cloudflare.com/ajax/libs/leaflet-gpx/1.7.0/gpx.min.js'; | |||||
| 42 | Readonly::Scalar my $TILE_URL => 'https://{s}.tile.openstreetmap.org/{z}/{x}/{y}.png'; | |||||
| 43 | Readonly::Scalar my $TILE_ATTRIBUTION => '© <a href="https://www.openstreetmap.org/copyright">OpenStreetMap</a> contributors'; | |||||
| 44 | Readonly::Scalar my $NOMINATIM_HOST => 'nominatim.openstreetmap.org/search'; | |||||
| 45 | ||||||
| 46 | # Rendering defaults, also used when a stored value is unusable at render time | |||||
| 47 | Readonly::Scalar my $DEFAULT_ZOOM => 12; | |||||
| 48 | Readonly::Scalar my $DEFAULT_HEIGHT => '400px'; | |||||
| 49 | Readonly::Scalar my $DEFAULT_WIDTH => '600px'; | |||||
| 50 | Readonly::Scalar my $DEFAULT_RADIUS => 25; | |||||
| 51 | Readonly::Scalar my $DEFAULT_BLUR => 15; | |||||
| 52 | ||||||
| 53 | # A CSS length: a number with an optional unit, or 'auto' | |||||
| 54 | Readonly::Scalar my $CSS_LENGTH => qr/\A(?:auto|[0-9]+(?:\.[0-9]+)?(?:px|%|em|rem|ex|ch|vh|vw|vmin|vmax|pt|pc|cm|mm|in)?)\z/; | |||||
| 55 | ||||||
| 56 | # WGS-84 valid ranges | |||||
| 57 | Readonly::Scalar my $LAT_MIN => -90; | |||||
| 58 | Readonly::Scalar my $LAT_MAX => 90; | |||||
| 59 | Readonly::Scalar my $LON_MIN => -180; | |||||
| 60 | Readonly::Scalar my $LON_MAX => 180; | |||||
| 61 | Readonly::Scalar my $ZOOM_MIN => 0; | |||||
| 62 | Readonly::Scalar my $ZOOM_MAX => 19; | |||||
| 63 | ||||||
| 64 | # The highest maxZoom Leaflet supports on a tile layer | |||||
| 65 | Readonly::Scalar my $MAX_ZOOM_LIMIT => 28; | |||||
| 66 | ||||||
| 67 | # Circle markers: Leaflet's default path colour, and a hex colour check | |||||
| 68 | Readonly::Scalar my $DEFAULT_CIRCLE_RADIUS => 8; | |||||
| 69 | Readonly::Scalar my $DEFAULT_CIRCLE_COLOUR => '#3388ff'; | |||||
| 70 | Readonly::Scalar my $HEX_COLOUR => qr/\A#(?:[0-9a-fA-F]{3}|[0-9a-fA-F]{6})\z/; | |||||
| 71 | ||||||
| 72 - 217 | =head1 SYNOPSIS
use HTML::OSM;
my $map = HTML::OSM->new(
coordinates => [
[37.7749, -122.4194, 'San Francisco'],
[undef, undef, 'Paris'],
],
zoom => 10,
);
my ($head, $body) = $map->onload_render();
=over 4
=item * Caching
Geocode results are cached via L<CHI> (default: in-memory, 1-day TTL).
Supply your own C<cache> object to persist across processes.
=item * Rate-Limiting
Set C<min_interval> (seconds) to throttle outbound Nominatim calls
and comply with the API fair-use policy.
=item * Tile server
C<tile_url> replaces the OpenStreetMap tile layer, so a map can use an
internal tile server or run on an air-gapped network. It accepts the same
Leaflet placeholders as the default, for example
C<http://tiles.internal/{z}/{x}/{y}.png>. The attribution remains the
OpenStreetMap credit, which is the usual requirement for OSM-derived tiles.
The in-page search box still calls Nominatim when a reader uses it; set
C<< search => 0 >> to leave it out.
=item * Maximum zoom
C<max_zoom> (0 to 28) stops readers zooming in further than the tile server
has tiles for. Without it, Leaflet allows zooming past the server's coverage
and the map shows empty grey tiles. When it is not given, no limit is set.
=item * Tile attribution
C<tile_attribution> replaces the credit shown in the corner of the map.
Set it when the tiles come from a provider that asks for a different
credit. The value is HTML that Leaflet renders as it is, so pass only
trusted text.
=item * Nominatim contact address
C<email> is added to every Nominatim request the module makes, as the
Nominatim usage policy asks of heavy users. It is not put into the rendered
page, so the in-page search box sends no address.
=item * Search box
By default the rendered page has a search box that sends whatever the reader
types to Nominatim, and a button that clears the markers it adds. Set
C<< search => 0 >> to leave both out, so that nothing typed on the page leaves
the reader's machine. The "Reset Map" button is always included.
=back
=head1 DESCRIPTION
C<HTML::OSM> builds an interactive map from OpenStreetMap tiles and the
Leaflet.js library. Give it points as latitude and longitude, as place
names, or as geocoder result objects. It can also draw GeoJSON shapes,
heatmaps, GPX tracks and choropleth (colour-filled region) layers, and can
group nearby markers into clusters.
Place names are turned into coordinates by an injected geocoder or, without
one, by the Nominatim service. The answers are cached, and requests can be
spaced out with C<min_interval>.
C<onload_render()> returns two HTML fragments: one for the page's
C<< <head> >> and one for its C<< <body> >>. The interface follows
L<HTML::GoogleMaps::V3>, so code written for that module needs few changes.
=head1 SUBROUTINES/METHODS
=head2 new
Construct a new C<HTML::OSM> object.
my $map = HTML::OSM->new(%params);
my $map = HTML::OSM->new(\%params);
Both method-style (C<< HTML::OSM->new(...) >>) and function-style
(C<HTML::OSM::new(...)>) calls are supported.
Calling C<< $existing_obj->new(%overrides) >> performs a shallow clone,
merging C<%overrides> onto the existing object's state without re-validating.
=head3 API SPECIFICATION
=head4 INPUT
{
cache => { type => object, can => [get, set], optional },
cluster => { type => boolean, optional },
cluster_css_url => { type => string, optional },
cluster_default_css_url => { type => string, optional },
cluster_js_url => { type => string, optional },
config_file => { type => string, optional },
coordinates => { type => arrayref, optional },
css_url => { type => string, optional },
email => { type => string, optional },
geocoder => { type => object, can => geocode, optional },
gpx_js_url => { type => string, optional },
heatmap_js_url => { type => string, optional },
height => { type => string, optional },
host => { type => string, optional },
js_url => { type => string, optional },
logger => { type => object, optional },
max_zoom => { type => integer, min => 0, max => 28, optional },
min_interval => { type => number, min => 0, optional },
search => { type => boolean, optional },
tile_attribution => { type => string, optional },
tile_url => { type => string, optional },
ua => { type => object, optional },
width => { type => string, optional },
zoom => { type => integer, min => 0, max => 19, optional },
}
=head4 OUTPUT
{ type => object, isa => 'HTML::OSM' }
=head3 MESSAGES
| Message | Meaning / Resolution |
|------------------------------------------------|-----------------------------------------------|
| (validation error from Params::Validate::Strict) | A param has the wrong type or is out of range |
=head3 PSEUDOCODE
1. If $class is neither a package name nor a blessed ref, treat as
function-style call: prepend $class back onto @_ and use __PACKAGE__.
2. If $class is a blessed ref (clone call): merge override params onto a
shallow copy and return immediately, bypassing schema validation.
3. Validate all supplied args against the declared schema.
4. Merge config-file settings via Object::Configure.
5. Resolve the cache: caller-supplied object, or in-memory CHI instance.
6. Bless and return with Readonly CDN constants as defaults.
=cut | |||||
| 218 | ||||||
| 219 | sub new | |||||
| 220 | { | |||||
| 221 | 9200 | 1818853 | my $class = shift; | |||
| 222 | ||||||
| 223 | # Function-style call: HTML::OSM::new(key => val). | |||||
| 224 | # Perl places the first argument where the class name should be, | |||||
| 225 | # so we put it back and set the class explicitly. | |||||
| 226 | 9200 | 49771 | if(defined($class) && !blessed($class) && !UNIVERSAL::isa($class, __PACKAGE__)) { | |||
| 227 | 3 | 11 | unshift @_, $class; | |||
| 228 | 3 | 4 | $class = __PACKAGE__; | |||
| 229 | } | |||||
| 230 | ||||||
| 231 | # Clone path: $obj->new(%overrides) â shallow-merge onto the existing | |||||
| 232 | # object without re-running schema validation so subclasses can extend. | |||||
| 233 | 9200 | 18668 | if(blessed($class)) { | |||
| 234 | 21 | 48 | my $extra = Params::Get::get_params(undef, \@_) || {}; | |||
| 235 | 21 21 21 | 284 43 158 | return bless { %{$class}, %{$extra} }, ref($class); | |||
| 236 | } | |||||
| 237 | ||||||
| 238 | 9179 | 13164 | $class //= __PACKAGE__; | |||
| 239 | ||||||
| 240 | 9179 | 25384 | my $params = Params::Validate::Strict::validate_strict({ | |||
| 241 | args => Params::Get::get_params(undef, \@_) || {}, | |||||
| 242 | schema => { | |||||
| 243 | cache => { type => 'object', can => [qw(get set)], optional => 1 }, | |||||
| 244 | cluster => { type => 'boolean', optional => 1 }, | |||||
| 245 | cluster_css_url => { type => 'string', optional => 1 }, | |||||
| 246 | cluster_default_css_url => { type => 'string', optional => 1 }, | |||||
| 247 | cluster_js_url => { type => 'string', optional => 1 }, | |||||
| 248 | config_file => { type => 'string', optional => 1 }, | |||||
| 249 | coordinates => { type => 'arrayref', optional => 1 }, | |||||
| 250 | css_url => { type => 'string', optional => 1 }, | |||||
| 251 | email => { type => 'string', optional => 1 }, | |||||
| 252 | geocoder => { type => 'object', can => 'geocode', optional => 1 }, | |||||
| 253 | gpx_js_url => { type => 'string', optional => 1 }, | |||||
| 254 | heatmap_js_url => { type => 'string', optional => 1 }, | |||||
| 255 | height => { type => 'string', optional => 1 }, | |||||
| 256 | host => { type => 'string', optional => 1 }, | |||||
| 257 | js_url => { type => 'string', optional => 1 }, | |||||
| 258 | logger => { type => 'object', optional => 1 }, | |||||
| 259 | max_zoom => { type => 'integer', min => $ZOOM_MIN, max => $MAX_ZOOM_LIMIT, optional => 1 }, | |||||
| 260 | min_interval => { type => 'number', min => 0, optional => 1 }, | |||||
| 261 | search => { type => 'boolean', optional => 1 }, | |||||
| 262 | tile_attribution => { type => 'string', optional => 1 }, | |||||
| 263 | tile_url => { type => 'string', optional => 1 }, | |||||
| 264 | ua => { type => 'object', optional => 1 }, | |||||
| 265 | width => { type => 'string', optional => 1 }, | |||||
| 266 | zoom => { type => 'integer', min => $ZOOM_MIN, max => $ZOOM_MAX, optional => 1 }, | |||||
| 267 | }, | |||||
| 268 | }); | |||||
| 269 | ||||||
| 270 | # Config file values override programmatic defaults (separation of config and code). | |||||
| 271 | 5189 | 2518833 | $params = Object::Configure::configure($class, $params); | |||
| 272 | ||||||
| 273 | # Inject the resolved cache so the bless hash spreads it correctly. | |||||
| 274 | 5189 | 11145567 | $params->{cache} //= CHI->new( | |||
| 275 | driver => 'Memory', | |||||
| 276 | global => 1, | |||||
| 277 | expires_in => '1 day', | |||||
| 278 | ); | |||||
| 279 | ||||||
| 280 | return bless { | |||||
| 281 | # Defaults â spread of %{$params} below overrides each one when supplied. | |||||
| 282 | coordinates => [], | |||||
| 283 | height => $DEFAULT_HEIGHT, | |||||
| 284 | host => $NOMINATIM_HOST, | |||||
| 285 | width => $DEFAULT_WIDTH, | |||||
| 286 | zoom => $DEFAULT_ZOOM, | |||||
| 287 | min_interval => 0, | |||||
| 288 | last_request => 0, | |||||
| 289 | cluster => 0, | |||||
| 290 | search => 1, | |||||
| 291 | css_url => $LEAFLET_CSS_URL, | |||||
| 292 | js_url => $LEAFLET_JS_URL, | |||||
| 293 | cluster_js_url => $CLUSTER_JS_URL, | |||||
| 294 | cluster_css_url => $CLUSTER_CSS_URL, | |||||
| 295 | cluster_default_css_url => $CLUSTER_DEFAULT_CSS_URL, | |||||
| 296 | heatmap_js_url => $HEATMAP_JS_URL, | |||||
| 297 | gpx_js_url => $GPX_JS_URL, | |||||
| 298 | tile_url => $TILE_URL, | |||||
| 299 | tile_attribution => $TILE_ATTRIBUTION, | |||||
| 300 | 5189 5189 | 4015032 58747 | %{$params}, | |||
| 301 | }, $class; | |||||
| 302 | } | |||||
| 303 | ||||||
| 304 - 360 | =head2 add_marker
Add a point marker to the map.
$map->add_marker([51.5074, -0.1278], html => 'London');
$map->add_marker('Paris, France', html => 'Paris');
$map->add_marker($geo_coder_result);
Returns 1 on success, 0 if the point cannot be resolved or is out of range.
An empty address, or an arrayref that does not hold exactly two elements,
also returns 0.
=head3 API SPECIFICATION
=head4 INPUT
point : arrayref [lat, lon] | string address | object with latitude()/longitude()
html : string (optional popup label)
icon : string (optional icon URL)
=head4 OUTPUT
{ type => integer, enum => [0, 1] }
=head3 MESSAGES
| Message | Meaning / Resolution |
|-----------------------------------------|---------------------------------------------|
| add_marker(): unknown point type: TYPE | Point is a ref type with no lat/lon methods |
| Skipping invalid coordinate: (LAT, LON) | Warning: the point is not numeric or is out of range; 0 is returned |
=head3 EXAMPLES
# Coordinate array with a popup label
$map->add_marker([51.5074, -0.1278], html => 'London');
# String address geocoded via the injected geocoder or Nominatim
$map->add_marker('Paris, France', html => 'Paris');
# Custom icon URL with a popup
$map->add_marker(
[40.7128, -74.0060],
html => 'New York',
icon => 'https://example.com/pin.png',
);
# Geo::Coder result object that implements latitude()/longitude()
my $result = $geocoder->geocode('Berlin, Germany');
$map->add_marker($result, html => 'Berlin');
# Accumulate several markers, warn on geocode failure
for my $city (@cities) {
$map->add_marker($city->{coords}, html => $city->{name})
or warn "Could not place $city->{name}";
}
=cut | |||||
| 361 | ||||||
| 362 | sub add_marker | |||||
| 363 | { | |||||
| 364 | 225 | 3795 | my $self = shift; | |||
| 365 | ||||||
| 366 | 225 | 496 | my ($lat, $lon, $params) = $self->_point_args('add_marker', @_); | |||
| 367 | 220 | 455 | return 0 unless defined($lat); | |||
| 368 | ||||||
| 369 | 187 187 | 137 435 | push @{$self->{coordinates}}, [$lat, $lon, $params->{'html'}, $params->{'icon'}]; | |||
| 370 | 187 | 335 | return 1; | |||
| 371 | } | |||||
| 372 | ||||||
| 373 - 426 | =head2 add_circle_marker
Add a filled circle whose size in pixels can show a quantity, such as the
population of a town.
$map->add_circle_marker([51.5074, -0.1278],
html => 'London',
radius => 12,
colour => '#e45c3a',
);
The point may be anything C<add_marker()> accepts. The radius is in screen
pixels, so a circle stays the same size as the reader zooms in and out.
With C<< cluster => 1 >>, circles join the same cluster group as the pin
markers.
Returns 1 on success, 0 if the point cannot be resolved or is out of range.
=head3 API SPECIFICATION
=head4 INPUT
point : arrayref [lat, lon] | string address | object with latitude()/longitude()
html : string (optional popup label)
radius : number > 0 and < 1e6 (optional, default 8)
colour : string hex #rrggbb or #rgb, any case (optional, default '#3388ff')
=head4 OUTPUT
{ type => integer, enum => [0, 1] }
=head3 MESSAGES
| Message | Meaning / Resolution |
|-----------------------------------------------------|---------------------------------------------|
| add_circle_marker(): radius must be a positive number | radius is 0, negative, 1e6 or more, or not a plain number |
| add_circle_marker(): invalid colour: VALUE | colour is not a #rgb or #rrggbb hex string |
| add_circle_marker(): unknown point type: TYPE | Point is a ref type with no lat/lon methods |
| Skipping invalid coordinate: (LAT, LON) | Warning: the point is not numeric or is out of range; 0 is returned |
=head3 EXAMPLES
# Bubble whose area shows the population
$map->add_circle_marker([$lat, $lon],
html => "$city ($pop)",
radius => sqrt($pop / $max_pop) * 30,
colour => '#e45c3a',
);
# Mixed map: pins for offices, circles for market size
$map->add_marker([$lat1, $lon1], html => 'HQ');
$map->add_circle_marker([$lat2, $lon2], html => 'Market A', radius => 20);
=cut | |||||
| 427 | ||||||
| 428 | sub add_circle_marker | |||||
| 429 | { | |||||
| 430 | 37 | 5433 | my $self = shift; | |||
| 431 | ||||||
| 432 | 37 | 52 | my ($lat, $lon, $params) = $self->_point_args('add_circle_marker', @_); | |||
| 433 | ||||||
| 434 | # Check the options even when the point is unusable, so a bad radius or | |||||
| 435 | # colour is reported whatever the data | |||||
| 436 | 36 | 53 | my $radius = $params->{'radius'} // $DEFAULT_CIRCLE_RADIUS; | |||
| 437 | 36 | 33 | my $checked = _positive_number($radius, undef); | |||
| 438 | 36 | 29 | if(!defined($checked)) { | |||
| 439 | 8 | 6 | my $msg = 'add_circle_marker(): radius must be a positive number'; | |||
| 440 | 8 | 16 | $self->{logger}->error($msg) if $self->{logger}; | |||
| 441 | 8 | 2861 | croak $msg; | |||
| 442 | } | |||||
| 443 | ||||||
| 444 | 28 | 34 | my $colour = $params->{'colour'} // $DEFAULT_CIRCLE_COLOUR; | |||
| 445 | 28 | 71 | if(ref($colour) || $colour !~ $HEX_COLOUR) { | |||
| 446 | 7 | 7 | my $msg = "add_circle_marker(): invalid colour: $colour"; | |||
| 447 | 7 | 14 | $self->{logger}->error($msg) if $self->{logger}; | |||
| 448 | 7 | 2662 | croak $msg; | |||
| 449 | } | |||||
| 450 | ||||||
| 451 | 21 | 21 | return 0 unless defined($lat); | |||
| 452 | ||||||
| 453 | 18 18 | 30 41 | push @{$self->{circle_markers}}, [$lat, $lon, $params->{'html'}, $checked, lc($colour)]; | |||
| 454 | 18 | 41 | return 1; | |||
| 455 | } | |||||
| 456 | ||||||
| 457 - 500 | =head2 add_geojson
Add a GeoJSON layer to the map.
$map->add_geojson(\%data, style => { color => '#ff0000' }, popup => 'name');
The first argument may be a hashref/arrayref (GeoJSON structure) or a JSON string.
Returns 1 on success.
=head3 API SPECIFICATION
=head4 INPUT
data : hashref | arrayref | string (JSON)
style : hashref Leaflet path-style options (color, weight, fillColor, fillOpacity)
popup : string Feature property name whose value becomes the popup text
=head4 OUTPUT
{ type => integer, value => 1 }
=head3 MESSAGES
| Message | Meaning / Resolution |
|----------------------|---------------------------------|
| (JSON parse error) | data string is not valid JSON |
=head3 EXAMPLES
# Pre-parsed GeoJSON structure with style and popup property
$map->add_geojson(
{ type => 'FeatureCollection', features => \@features },
style => { color => '#ff0000', weight => 2, fillOpacity => 0.4 },
popup => 'name',
);
# Raw JSON string - decoded automatically
$map->add_geojson('{"type":"FeatureCollection","features":[]}');
# Multiple GeoJSON layers with different styles on the same map
$map->add_geojson(\%country_borders, style => { color => '#333333', fillOpacity => 0 });
$map->add_geojson(\%river_data, style => { color => '#0099ff', weight => 1 });
=cut | |||||
| 501 | ||||||
| 502 | sub add_geojson | |||||
| 503 | { | |||||
| 504 | 46 | 290 | my $self = shift; | |||
| 505 | 46 | 43 | my $data = shift; | |||
| 506 | 46 | 83 | my $params = Params::Get::get_params(undef, \@_) || {}; | |||
| 507 | ||||||
| 508 | # Accept either a pre-parsed structure or a raw JSON string | |||||
| 509 | 46 | 605 | $data = decode_json($data) if !ref($data); | |||
| 510 | ||||||
| 511 | 41 41 | 33 100 | push @{$self->{geojson}}, { data => $data, opts => $params }; | |||
| 512 | 41 | 75 | return 1; | |||
| 513 | } | |||||
| 514 | ||||||
| 515 - 559 | =head2 add_heatmap
Add a heatmap layer to the map.
$map->add_heatmap([[51.5, -0.1, 0.8], [51.6, -0.2, 0.5]], radius => 25);
Each point is C<[$lat, $lon]> or C<[$lat, $lon, $intensity]> (intensity: 0-1).
Requires the Leaflet.heat plugin (C<heatmap_js_url>).
Returns 1 on success.
=head3 API SPECIFICATION
=head4 INPUT
points : arrayref of ([lat, lon] | [lat, lon, intensity])
radius : number default 25 (a value that is not a positive number uses the default)
blur : number default 15 (a value that is not a positive number uses the default)
=head4 OUTPUT
{ type => integer, value => 1 }
=head3 MESSAGES
| Message | Meaning / Resolution |
|-----------------------------------------|-----------------------------------|
| add_heatmap: points must be an arrayref | First argument is not an arrayref |
=head3 EXAMPLES
# Basic heatmap - [lat, lon] per point
$map->add_heatmap([
[51.5074, -0.1278],
[51.6000, -0.2000],
[51.4000, 0.0000],
]);
# With intensity values (0..1) and custom radius/blur
$map->add_heatmap(
[ [51.5, -0.1, 0.9], [51.6, -0.2, 0.5], [51.4, 0.0, 0.2] ],
radius => 30,
blur => 20,
);
=cut | |||||
| 560 | ||||||
| 561 | sub add_heatmap | |||||
| 562 | { | |||||
| 563 | 34 | 1111 | my $self = shift; | |||
| 564 | 34 | 33 | my $points = shift; | |||
| 565 | 34 | 53 | my $params = Params::Get::get_params(undef, \@_) || {}; | |||
| 566 | ||||||
| 567 | 34 | 573 | croak 'add_heatmap: points must be an arrayref' unless ref($points) eq 'ARRAY'; | |||
| 568 | ||||||
| 569 | 22 22 | 18 53 | push @{$self->{heatmap_layers}}, { points => $points, opts => $params }; | |||
| 570 | 22 | 37 | return 1; | |||
| 571 | } | |||||
| 572 | ||||||
| 573 - 608 | =head2 add_gpx
Add a GPX track to the map from a URL.
$map->add_gpx('https://example.com/track.gpx');
The map view is auto-fitted to the track bounds after loading.
Requires the leaflet-gpx plugin (C<gpx_js_url>).
Returns 1 on success.
=head3 API SPECIFICATION
=head4 INPUT
url : string URL of the GPX file (required)
=head4 OUTPUT
{ type => integer, value => 1 }
=head3 MESSAGES
| Message | Meaning / Resolution |
|--------------------------|--------------------------|
| add_gpx: url is required | No URL argument supplied |
=head3 EXAMPLES
# Add a GPX track from a public URL; the map auto-fits to its bounds
$map->add_gpx('https://example.com/route.gpx');
# Multiple tracks on the same map
$map->add_gpx('https://example.com/morning-run.gpx');
$map->add_gpx('https://example.com/evening-walk.gpx');
=cut | |||||
| 609 | ||||||
| 610 | sub add_gpx | |||||
| 611 | { | |||||
| 612 | 26 | 260 | my $self = shift; | |||
| 613 | 26 | 50 | my $params = Params::Get::get_params('url', \@_); | |||
| 614 | 22 | 335 | my $url = $params->{'url'}; | |||
| 615 | ||||||
| 616 | 22 | 111 | croak 'add_gpx: url is required' unless $url; | |||
| 617 | ||||||
| 618 | 18 18 | 15 26 | push @{$self->{gpx_tracks}}, $url; | |||
| 619 | 18 | 37 | return 1; | |||
| 620 | } | |||||
| 621 | ||||||
| 622 - 678 | =head2 add_choropleth
Add a choropleth (data-driven colour fill) layer to the map.
$map->add_choropleth(
\@geojson_features,
{ England => 100, Scotland => 80, Wales => 60 },
key => 'name',
scale => ['#ffffcc', '#a1dab4', '#41b6c4', '#2c7fb8', '#253494'],
);
Colours are pre-computed in Perl and baked into the emitted JavaScript.
No extra browser plugin is required.
Returns 1 on success.
=head3 API SPECIFICATION
=head4 INPUT
features : arrayref of GeoJSON Feature hashrefs (required)
values : hashref { feature_property_value => numeric_value } (required)
key : string feature property to match against values (default: 'name')
scale : arrayref hex-colour strings low-to-high (default: 5-step YlGnBu)
=head4 OUTPUT
{ type => integer, value => 1 }
=head3 MESSAGES
| Message | Meaning / Resolution |
|---------------------------------------------|-----------------------------------|
| add_choropleth: features must be an arrayref | First argument is not an arrayref |
| add_choropleth: values must be a hashref | Second argument is not a hashref |
=head3 EXAMPLES
# Default 5-step YlGnBu scale, key property "name"
$map->add_choropleth(
\@geojson_features,
{ England => 100, Scotland => 80, Wales => 60 },
);
# Custom 3-step scale and a different GeoJSON property as the key
$map->add_choropleth(
\@geojson_features,
{ England => 100, Scotland => 80, Wales => 60 },
key => 'country',
scale => ['#f7fbff', '#6baed6', '#08519c'],
);
# choropleth-only map - center() must be called explicitly
$map->center([54.0, -2.0]);
$map->add_choropleth(\@uk_features, \%population_by_region);
my ($head, $body) = $map->onload_render();
=cut | |||||
| 679 | ||||||
| 680 | sub add_choropleth | |||||
| 681 | { | |||||
| 682 | 49 | 1919 | my $self = shift; | |||
| 683 | 49 | 43 | my $features = shift; | |||
| 684 | 49 | 36 | my $values = shift; | |||
| 685 | 49 | 81 | my $params = Params::Get::get_params(undef, \@_) || {}; | |||
| 686 | ||||||
| 687 | 49 | 698 | croak 'add_choropleth: features must be an arrayref' unless ref($features) eq 'ARRAY'; | |||
| 688 | 42 | 117 | croak 'add_choropleth: values must be a hashref' unless ref($values) eq 'HASH'; | |||
| 689 | ||||||
| 690 | 37 | 83 | my $key = $params->{key} || 'name'; | |||
| 691 | 37 | 104 | my $scale = $params->{scale} || ['#ffffcc', '#a1dab4', '#41b6c4', '#2c7fb8', '#253494']; | |||
| 692 | ||||||
| 693 | # Compute colour index for each feature in Perl so the browser needs no | |||||
| 694 | # extra maths â the resulting lookup object is baked into the JS. | |||||
| 695 | 37 27 37 | 33 32 58 | my @sorted_vals = sort { $a <=> $b } values %{$values}; | |||
| 696 | 37 | 123 | my ($min, $max) = ($sorted_vals[0] // 0, $sorted_vals[-1] // 0); | |||
| 697 | 37 | 54 | $max = $min + 1 if $max == $min; # avoid division by zero for single-value sets | |||
| 698 | ||||||
| 699 | 37 | 28 | my %colors; | |||
| 700 | 37 92 | 26 116 | while(my ($k, $v) = each %{$values}) { | |||
| 701 | 55 55 | 51 63 | my $idx = int(($v - $min) / ($max - $min) * $#{$scale}); | |||
| 702 | 55 1 55 | 37 1 51 | $idx = $#{$scale} if $idx > $#{$scale}; | |||
| 703 | 55 | 59 | $colors{$k} = $scale->[$idx]; | |||
| 704 | } | |||||
| 705 | ||||||
| 706 | 37 37 | 31 113 | push @{$self->{choropleth_layers}}, { | |||
| 707 | features => $features, | |||||
| 708 | values => $values, | |||||
| 709 | colors => \%colors, | |||||
| 710 | key => $key, | |||||
| 711 | }; | |||||
| 712 | 37 | 74 | return 1; | |||
| 713 | } | |||||
| 714 | ||||||
| 715 - 761 | =head2 center
Set the map centre to a given point.
$map->center([40.7128, -74.0060]);
$map->center($geo_object);
$map->center('Berlin, Germany');
Returns 1 on success, 0 if the point cannot be resolved or is out of range.
An empty address also returns 0.
=head3 API SPECIFICATION
=head4 INPUT
point : arrayref [lat, lon] | object with latitude()/longitude() | string address
=head4 OUTPUT
{ type => integer, enum => [0, 1] }
=head3 MESSAGES
| Message | Meaning / Resolution |
|----------------------------------------------------|---------------------------------|
| center(): usage: point => [ latitude, longitude ] | No point argument supplied |
| center(): point must have latitude and longitude | Arrayref has != 2 elements |
| center(): unknown point type: TYPE | Ref type has no lat/lon methods |
| Skipping invalid coordinate: (LAT, LON) | Warning: point is not numeric or is out of range; 0 is returned |
=head3 EXAMPLES
# Coordinate array
$map->center([40.7128, -74.0060]);
# Object that implements latitude()/longitude() (e.g. a Geo::Coder result)
$map->center($geocoder->geocode('Berlin, Germany'));
# String address resolved via the injected geocoder or Nominatim
$map->center('Eiffel Tower, Paris, France');
# Required when rendering without point markers (GeoJSON-only, choropleth, etc.)
$map->center([54.0, -2.0]);
$map->add_geojson(\%uk_regions, popup => 'name');
my ($head, $body) = $map->onload_render();
=cut | |||||
| 762 | ||||||
| 763 | sub center | |||||
| 764 | { | |||||
| 765 | 70 | 2413 | my $self = shift; | |||
| 766 | 70 | 148 | my $params = Params::Get::get_params('point', \@_); | |||
| 767 | 65 | 986 | my $point = $params->{'point'}; | |||
| 768 | ||||||
| 769 | 65 | 132 | croak 'center(): usage: point => [ latitude, longitude ]' unless defined($point); | |||
| 770 | ||||||
| 771 | 63 | 60 | my ($lat, $lon); | |||
| 772 | ||||||
| 773 | 63 | 175 | if(ref($point) eq 'ARRAY') { | |||
| 774 | croak 'center(): point must have latitude and longitude' | |||||
| 775 | 51 51 | 37 202 | if scalar(@{$point}) != 2; | |||
| 776 | 44 44 | 39 59 | ($lat, $lon) = @{$point}; | |||
| 777 | } elsif(ref($point) && $point->can('latitude')) { | |||||
| 778 | 2 | 4 | ($lat, $lon) = ($point->latitude(), $point->longitude()); | |||
| 779 | } elsif(!ref($point)) { | |||||
| 780 | # An empty address cannot be resolved | |||||
| 781 | 6 | 11 | return 0 unless length($point); | |||
| 782 | 5 | 15 | ($lat, $lon) = $self->_fetch_coordinates($point); | |||
| 783 | } else { | |||||
| 784 | 4 | 8 | my $msg = 'center(): unknown point type: ' . ref($point); | |||
| 785 | 4 | 18 | $self->{logger}->error($msg) if $self->{logger}; | |||
| 786 | 4 | 1486 | croak $msg; | |||
| 787 | } | |||||
| 788 | ||||||
| 789 | 51 | 194 | return 0 unless defined($lat) && defined($lon); | |||
| 790 | ||||||
| 791 | # Store the text form with a '.' decimal point, whatever the locale | |||||
| 792 | 48 | 99 | ($lat, $lon) = (_num_str($lat), _num_str($lon)); | |||
| 793 | 48 | 125 | return 0 unless _validate($lat, $lon); | |||
| 794 | ||||||
| 795 | 44 | 84 | $self->{'center'} = [$lat, $lon]; | |||
| 796 | 44 | 86 | return 1; | |||
| 797 | } | |||||
| 798 | ||||||
| 799 - 839 | =head2 zoom
Get or set the zoom level (0 = world, 19 = building).
$map->zoom(10);
my $z = $map->zoom();
=head3 API SPECIFICATION
=head4 INPUT
{ zoom => { type => integer, min => 0, max => 19, optional => 1 } }
=head4 OUTPUT
{ type => integer, min => 0, max => 19 }
=head3 MESSAGES
| Message | Meaning / Resolution |
|------------------------------|-------------------------------------------|
| (Params::Validate::Strict) | zoom is not an integer or is out of range |
=head3 EXAMPLES
# Setter: store the zoom level
$map->zoom(14);
# Getter: retrieve the current level
my $level = $map->zoom();
print "Current zoom: $level\n"; # 14
# Setter return value equals the new level
my $confirmed = $map->zoom(10);
die 'unexpected' unless $confirmed == 10;
# Chain: set via new(), read back via zoom()
my $m = HTML::OSM->new(zoom => 6);
$m->zoom($m->zoom() + 2); # nudge up by 2
=cut | |||||
| 840 | ||||||
| 841 | sub zoom | |||||
| 842 | { | |||||
| 843 | 1265 | 5842 | my $self = shift; | |||
| 844 | ||||||
| 845 | 1265 | 1681 | if(scalar(@_)) { | |||
| 846 | 1234 | 3620 | my $params = Params::Validate::Strict::validate_strict({ | |||
| 847 | args => Params::Get::get_params('zoom', \@_), | |||||
| 848 | schema => { | |||||
| 849 | zoom => { optional => 1, type => 'integer', min => $ZOOM_MIN, max => $ZOOM_MAX }, | |||||
| 850 | }, | |||||
| 851 | }); | |||||
| 852 | 490 | 62598 | $self->{'zoom'} = $params->{'zoom'} if defined($params->{'zoom'}); | |||
| 853 | } | |||||
| 854 | ||||||
| 855 | 521 | 1595 | return $self->{'zoom'}; | |||
| 856 | } | |||||
| 857 | ||||||
| 858 - 962 | =head2 onload_render
Render the map and return a two-element list suitable for embedding in HTML.
my ($head_html, $body_html) = $map->onload_render();
C<$head_html> contains the Leaflet CSS, JavaScript, and plugin assets.
Place it inside C<< <head>...</head> >>.
C<$body_html> contains the search box (unless C<< search => 0 >>), control
buttons, map C<< <div> >>, and the initialisation C<< <script> >>.
Place it inside C<< <body>...</body> >> where the map should appear.
The rendered page provides:
=over 4
=item * A Nominatim-powered search box that adds temporary markers.
Left out when C<< search => 0 >>.
=item * A "Clear search markers" button that removes those temporary markers,
leaving static markers (added via C<add_marker>) intact.
Left out when C<< search => 0 >>.
=item * A "Reset Map" button that returns the view to the initial centre and zoom.
=back
Values that reach the object without going through C<new()>'s checks (from a
config file or a clone) are checked again here. A C<zoom> that is not an
integer from 0 to 19 is replaced by 12, and a C<width> or C<height> that is
not a CSS length (such as C<600px>, C<100%> or C<auto>) is replaced by the
default. A C<max_zoom> that is not an integer from 0 to 28 is ignored. Each
replacement gives a warning.
=head3 API SPECIFICATION
=head4 INPUT
(none - uses object state)
=head4 OUTPUT
{ type => list, elements => [string, string] }
=head3 MESSAGES
| Message | Meaning / Resolution |
|--------------------------------------------------|---------------------------------------------|
| No map data provided | No markers, circle markers, GeoJSON, heatmap, GPX, or choropleth added yet |
| center() must be called when no point markers are provided | Non-marker-only render needs explicit centre |
| Skipping invalid coordinate: (LAT, LON) | Warning: a marker is not numeric or out of range; it is left off the map |
| onload_render: invalid zoom 'Z', using 12 | Warning: zoom from a config file or clone is out of range |
| onload_render: invalid max_zoom 'Z', ignoring it | Warning: max_zoom from a config file or clone is not an integer from 0 to 28 |
| onload_render: invalid width 'W', using 600px | Warning: width is not a CSS length |
| onload_render: invalid height 'H', using 400px | Warning: height is not a CSS length |
| _fetch_coordinates: failed to decode Nominatim response: ERROR | Warning: Nominatim returned something that is not JSON; the marker is skipped |
| _fetch_coordinates: unrecognised geocoder result type: TYPE | Warning: the injected geocoder returned an unknown type; the marker is skipped |
=head3 EXAMPLES
# Minimal: one marker, embed in a CGI response
use HTML::OSM;
my $map = HTML::OSM->new(zoom => 12);
$map->add_marker([51.5074, -0.1278], html => 'London');
my ($head, $body) = $map->onload_render();
print "Content-Type: text/html\n\n";
print "<html><head>$head</head><body>$body</body></html>\n";
# Mixed layers: markers + GeoJSON, explicit center
$map->center([51.5, -0.1]);
$map->add_geojson(\%borough_data, popup => 'name', style => { color => '#333' });
$map->add_marker([51.5074, -0.1278], html => 'City of London');
my ($head_html, $body_html) = $map->onload_render();
# Template Toolkit integration
$tt->process('map.tt', {
map_head => scalar(($map->onload_render())[0]),
map_body => scalar(($map->onload_render())[1]),
});
=head3 PSEUDOCODE
1. Gather all data layers; croak if none populated.
2. Geocode/validate each coordinate tuple; discard invalids with a warning.
A tuple with no coordinates and no address is discarded.
Check circle markers the same way.
Re-check zoom, max_zoom, width and height; fall back with a warning.
3. Determine map centre: caller-supplied > computed midpoint of the bounds
of the pin and circle markers.
Croak if neither is available.
4. Build <head>: Leaflet CSS + JS; inject cluster/heatmap/GPX plugin assets
only when the corresponding layer type is present.
5. Build <body>: search box and clear-search button (when search is on),
reset button, map <div>.
6. Initialise Leaflet map, tile layer (with maxZoom when max_zoom is set),
and the searchMarkers array when search is on.
7. Emit JS for each pin and circle marker (via one clusterGroup when
cluster is set).
8. Emit JS for each GeoJSON, heatmap, GPX, and choropleth layer.
9. Attach event listeners: reset-view, and when search is on,
clear-search-markers and search-on-Enter.
10. Return ($head, $body).
=cut | |||||
| 963 | ||||||
| 964 | sub onload_render | |||||
| 965 | { | |||||
| 966 | 204 | 4635 | my $self = shift; | |||
| 967 | ||||||
| 968 | 204 | 416 | my $height = _css_length('height', $self->{'height'}, $DEFAULT_HEIGHT); | |||
| 969 | 204 | 299 | my $width = _css_length('width', $self->{'width'}, $DEFAULT_WIDTH); | |||
| 970 | 204 | 212 | my $zoom = $self->{'zoom'}; | |||
| 971 | 204 | 307 | my $coordinates = $self->{coordinates} || []; | |||
| 972 | 204 | 420 | my $geojson_layers = $self->{geojson} || []; | |||
| 973 | 204 | 375 | my $heatmap_layers = $self->{heatmap_layers} || []; | |||
| 974 | 204 | 393 | my $gpx_tracks = $self->{gpx_tracks} || []; | |||
| 975 | 204 | 385 | my $choropleth_layers = $self->{choropleth_layers} || []; | |||
| 976 | 204 | 396 | my $circle_markers = $self->{circle_markers} || []; | |||
| 977 | ||||||
| 978 | 204 | 544 | unless(@$coordinates || @$geojson_layers || @$heatmap_layers | |||
| 979 | || @$gpx_tracks || @$choropleth_layers | |||||
| 980 | || @$circle_markers) { | |||||
| 981 | 8 | 42 | $self->{logger}->error('No map data provided') if $self->{logger}; | |||
| 982 | 8 | 3508 | croak 'No map data provided'; | |||
| 983 | } | |||||
| 984 | ||||||
| 985 | # Config-file and clone values skip new()'s schema, so check zoom again | |||||
| 986 | # before it is put into the JavaScript. | |||||
| 987 | 196 | 876 | if(!defined($zoom) || $zoom !~ /\A[0-9]+\z/ || $zoom < $ZOOM_MIN || $zoom > $ZOOM_MAX) { | |||
| 988 | 2 | 58 | carp sprintf("onload_render: invalid zoom '%s', using %d", $zoom // 'undef', $DEFAULT_ZOOM); | |||
| 989 | 2 | 454 | $zoom = $DEFAULT_ZOOM; | |||
| 990 | } | |||||
| 991 | ||||||
| 992 | # Geocode address strings; validate and discard bad numeric pairs. | |||||
| 993 | 196 | 145 | my @valid_coordinates; | |||
| 994 | 196 | 267 | for my $coord (@$coordinates) { | |||
| 995 | 169 | 205 | my ($lat, $lon, $label, $icon_url) = @$coord; | |||
| 996 | 169 | 314 | if(!defined $lat || !defined $lon) { | |||
| 997 | # No coordinates and no address: nothing to look up | |||||
| 998 | 4 | 12 | next unless defined($label) && length($label); | |||
| 999 | 3 | 7 | ($lat, $lon) = $self->_fetch_coordinates($label); | |||
| 1000 | } | |||||
| 1001 | # Validate ALL coordinates here â including geocoder-returned ones. | |||||
| 1002 | # A compromised geocoder or Nominatim response could return a crafted | |||||
| 1003 | # lat/lon string that would inject JS if embedded without validation. | |||||
| 1004 | 168 | 258 | next unless defined($lat) && defined($lon); | |||
| 1005 | 168 | 194 | ($lat, $lon) = (_num_str($lat), _num_str($lon)); | |||
| 1006 | 168 | 173 | next unless _validate($lat, $lon); | |||
| 1007 | 162 | 254 | push @valid_coordinates, [$lat, $lon, $label, $icon_url]; | |||
| 1008 | } | |||||
| 1009 | ||||||
| 1010 | # add_circle_marker checked these, but a clone can bring in anything | |||||
| 1011 | 196 | 158 | my @valid_circles; | |||
| 1012 | 196 | 185 | for my $circle (@$circle_markers) { | |||
| 1013 | 20 | 30 | my ($lat, $lon, $label, $radius, $colour) = @$circle; | |||
| 1014 | 20 | 26 | next unless defined($lat) && defined($lon); | |||
| 1015 | 20 | 18 | ($lat, $lon) = (_num_str($lat), _num_str($lon)); | |||
| 1016 | 20 | 20 | next unless _validate($lat, $lon); | |||
| 1017 | 19 | 24 | $radius = _positive_number($radius, $DEFAULT_CIRCLE_RADIUS); | |||
| 1018 | 19 | 52 | $colour = $DEFAULT_CIRCLE_COLOUR unless defined($colour) && !ref($colour) && $colour =~ $HEX_COLOUR; | |||
| 1019 | 19 | 39 | push @valid_circles, [$lat, $lon, $label, $radius, lc($colour)]; | |||
| 1020 | } | |||||
| 1021 | ||||||
| 1022 | # Only an integer in Leaflet's range is put into the tile layer options | |||||
| 1023 | 196 | 238 | my $max_zoom = $self->{'max_zoom'}; | |||
| 1024 | 196 | 266 | if(defined($max_zoom) && ($max_zoom !~ /\A[0-9]+\z/ || $max_zoom > $MAX_ZOOM_LIMIT)) { | |||
| 1025 | 4 | 90 | carp "onload_render: invalid max_zoom '$max_zoom', ignoring it"; | |||
| 1026 | 4 | 496 | undef $max_zoom; | |||
| 1027 | } | |||||
| 1028 | 196 | 264 | my $max_zoom_js = defined($max_zoom) ? ",\n\t\t\t\tmaxZoom: $max_zoom" : ''; | |||
| 1029 | ||||||
| 1030 | # A config file can give the words 'false', 'no' or 'off' | |||||
| 1031 | 196 | 182 | my $search = $self->{'search'}; | |||
| 1032 | 196 | 354 | $search = 0 if defined($search) && $search =~ /\A(?:false|no|off)\z/i; | |||
| 1033 | ||||||
| 1034 | # Determine map centre: caller-set wins; else compute from marker bounds. | |||||
| 1035 | 196 | 166 | my ($center_lat, $center_lon); | |||
| 1036 | 196 | 375 | if($self->{'center'}) { | |||
| 1037 | 37 37 | 21 57 | ($center_lat, $center_lon) = @{$self->{'center'}}; | |||
| 1038 | } elsif(@valid_coordinates || @valid_circles) { | |||||
| 1039 | 151 | 207 | my ($min_lat, $min_lon, $max_lat, $max_lon) = (90, 180, -90, -180); | |||
| 1040 | 151 | 179 | for my $c (@valid_coordinates, @valid_circles) { | |||
| 1041 | # Convert with _num_val: some perls read '51.5074' as 51 under de_DE | |||||
| 1042 | 174 | 198 | my ($lat, $lon) = (_num_val($c->[0]), _num_val($c->[1])); | |||
| 1043 | 174 | 218 | $min_lat = $lat if $lat < $min_lat; | |||
| 1044 | 174 | 182 | $max_lat = $lat if $lat > $max_lat; | |||
| 1045 | 174 | 160 | $min_lon = $lon if $lon < $min_lon; | |||
| 1046 | 174 | 210 | $max_lon = $lon if $lon > $max_lon; | |||
| 1047 | } | |||||
| 1048 | 151 | 152 | $center_lat = ($min_lat + $max_lat) / 2; | |||
| 1049 | 151 | 139 | $center_lon = ($min_lon + $max_lon) / 2; | |||
| 1050 | } else { | |||||
| 1051 | 8 | 119 | croak 'center() must be called when no point markers are provided'; | |||
| 1052 | } | |||||
| 1053 | # The midpoint is a new number, so it needs the same treatment as markers | |||||
| 1054 | 188 | 172 | ($center_lat, $center_lon) = (_num_str($center_lat), _num_str($center_lon)); | |||
| 1055 | ||||||
| 1056 | # --- <head> --- | |||||
| 1057 | 188 1316 | 326 1159 | my %url = map { $_ => _html_attr($self->{$_}) } | |||
| 1058 | qw(css_url js_url cluster_css_url cluster_default_css_url cluster_js_url heatmap_js_url gpx_js_url); | |||||
| 1059 | 188 | 289 | my $head = qq{ | |||
| 1060 | <link rel="stylesheet" href="$url{css_url}" /> | |||||
| 1061 | <script src="$url{js_url}"></script> | |||||
| 1062 | }; | |||||
| 1063 | ||||||
| 1064 | 188 | 248 | if($self->{cluster}) { | |||
| 1065 | 10 | 23 | $head .= qq{ | |||
| 1066 | <link rel="stylesheet" href="$url{cluster_css_url}" /> | |||||
| 1067 | <link rel="stylesheet" href="$url{cluster_default_css_url}" /> | |||||
| 1068 | <script src="$url{cluster_js_url}"></script> | |||||
| 1069 | }; | |||||
| 1070 | } | |||||
| 1071 | 188 | 223 | $head .= qq{\t\t<script src="$url{heatmap_js_url}"></script>\n} if @$heatmap_layers; | |||
| 1072 | 188 | 220 | $head .= qq{\t\t<script src="$url{gpx_js_url}"></script>\n} if @$gpx_tracks; | |||
| 1073 | ||||||
| 1074 | 188 | 196 | if($search) { | |||
| 1075 | 176 | 241 | $head .= qq{ | |||
| 1076 | <style> | |||||
| 1077 | #map { width: $width; height: $height; } | |||||
| 1078 | #search-box { margin: 10px; padding: 5px; } | |||||
| 1079 | #reset-button, #clear-search-button { margin: 10px; padding: 5px; cursor: pointer; } | |||||
| 1080 | </style> | |||||
| 1081 | }; | |||||
| 1082 | } else { | |||||
| 1083 | 12 | 23 | $head .= qq{ | |||
| 1084 | <style> | |||||
| 1085 | #map { width: $width; height: $height; } | |||||
| 1086 | #reset-button { margin: 10px; padding: 5px; cursor: pointer; } | |||||
| 1087 | </style> | |||||
| 1088 | }; | |||||
| 1089 | } | |||||
| 1090 | ||||||
| 1091 | # --- <body> --- | |||||
| 1092 | 188 | 311 | my $tile_url = _js_string($self->{tile_url}); | |||
| 1093 | 188 | 215 | my $tile_attribution = _js_string($self->{tile_attribution}); | |||
| 1094 | 188 | 173 | my $body = ''; | |||
| 1095 | 188 | 222 | if($search) { | |||
| 1096 | 176 | 148 | $body .= qq{ | |||
| 1097 | <input type="text" id="search-box" placeholder="Enter location"> | |||||
| 1098 | <button id="clear-search-button">Clear search markers</button>}; | |||||
| 1099 | } | |||||
| 1100 | 188 | 291 | $body .= qq{ | |||
| 1101 | <button id="reset-button">Reset Map</button> | |||||
| 1102 | <div id="map"></div> | |||||
| 1103 | <script> | |||||
| 1104 | var map = L.map('map').setView([$center_lat, $center_lon], $zoom); | |||||
| 1105 | L.tileLayer('$tile_url', { | |||||
| 1106 | attribution: '$tile_attribution'$max_zoom_js | |||||
| 1107 | }).addTo(map); | |||||
| 1108 | }; | |||||
| 1109 | 188 | 223 | $body .= "\n\t\t\tvar searchMarkers = [];\n" if $search; | |||
| 1110 | ||||||
| 1111 | # Point and circle markers â optionally grouped into one cluster layer. | |||||
| 1112 | 188 | 270 | my $clustered = $self->{cluster} && (@valid_coordinates || @valid_circles); | |||
| 1113 | 188 | 213 | $body .= "\t\t\tvar clusterGroup = L.markerClusterGroup();\n" if $clustered; | |||
| 1114 | 188 | 196 | if(@valid_coordinates) { | |||
| 1115 | ||||||
| 1116 | 143 | 128 | for my $coord (@valid_coordinates) { | |||
| 1117 | 162 | 149 | my ($lat, $lon, $label, $icon_url) = @$coord; | |||
| 1118 | 162 | 116 | my $js_label = _js_string($label); | |||
| 1119 | 162 | 246 | if($icon_url) { | |||
| 1120 | 4 | 4 | my $js_icon = _js_string($icon_url); | |||
| 1121 | my $add_cmd = $self->{cluster} | |||||
| 1122 | 4 | 7 | ? 'clusterGroup.addLayer(m);' | |||
| 1123 | : 'm.addTo(map);'; | |||||
| 1124 | 4 | 9 | $body .= qq{ | |||
| 1125 | (function() { | |||||
| 1126 | var icon = L.icon({ iconUrl: '$js_icon', iconAnchor: [16,32], popupAnchor: [0,-32] }); | |||||
| 1127 | var m = L.marker([$lat, $lon], { icon: icon }).bindPopup('$js_label'); | |||||
| 1128 | $add_cmd | |||||
| 1129 | })(); | |||||
| 1130 | }; | |||||
| 1131 | } elsif($self->{cluster}) { | |||||
| 1132 | 12 | 17 | $body .= "\t\t\tclusterGroup.addLayer(L.marker([$lat, $lon]).bindPopup('$js_label'));\n"; | |||
| 1133 | } else { | |||||
| 1134 | 146 | 205 | $body .= "\t\t\tL.marker([$lat, $lon]).addTo(map).bindPopup('$js_label');\n"; | |||
| 1135 | } | |||||
| 1136 | } | |||||
| 1137 | } | |||||
| 1138 | ||||||
| 1139 | 188 | 222 | for my $circle (@valid_circles) { | |||
| 1140 | 19 | 23 | my ($lat, $lon, $label, $radius, $colour) = @$circle; | |||
| 1141 | 19 | 32 | my $popup = (defined($label) && length($label)) | |||
| 1142 | ? ".bindPopup('" . _js_string($label) . "')" | |||||
| 1143 | : ''; | |||||
| 1144 | 19 | 21 | my $circle_js = "L.circleMarker([$lat, $lon], { radius: $radius, color: '$colour', fillColor: '$colour', fillOpacity: 0.7 })$popup"; | |||
| 1145 | 19 | 17 | if($self->{cluster}) { | |||
| 1146 | 2 | 4 | $body .= "\t\t\tclusterGroup.addLayer($circle_js);\n"; | |||
| 1147 | } else { | |||||
| 1148 | 17 | 18 | $body .= "\t\t\t$circle_js.addTo(map);\n"; | |||
| 1149 | } | |||||
| 1150 | } | |||||
| 1151 | ||||||
| 1152 | 188 | 179 | $body .= "\t\t\tmap.addLayer(clusterGroup);\n" if $clustered; | |||
| 1153 | ||||||
| 1154 | # GeoJSON layers. | |||||
| 1155 | 188 | 232 | for my $layer (@$geojson_layers) { | |||
| 1156 | 23 | 35 | my $json = _html_json($layer->{data}); | |||
| 1157 | 22 | 37 | my $opts = $layer->{opts} || {}; | |||
| 1158 | 22 | 17 | my $style_js = ''; | |||
| 1159 | 22 | 18 | my $popup_js = ''; | |||
| 1160 | 22 | 32 | if(my $style = $opts->{style}) { | |||
| 1161 | 11 | 10 | $style_js = 'style: ' . _html_json($style) . ','; | |||
| 1162 | } | |||||
| 1163 | 22 | 31 | if(my $prop = $opts->{popup}) { | |||
| 1164 | 4 | 6 | my $js_prop = _js_string($prop); | |||
| 1165 | 4 | 5 | $popup_js = "onEachFeature: function(f,l){ if(f.properties && f.properties['$js_prop']){ l.bindPopup(String(f.properties['$js_prop'])); } },"; | |||
| 1166 | } | |||||
| 1167 | 22 | 36 | $body .= "\t\t\tL.geoJSON($json, { $style_js $popup_js }).addTo(map);\n"; | |||
| 1168 | } | |||||
| 1169 | ||||||
| 1170 | # Heatmap layers. | |||||
| 1171 | 187 | 219 | for my $layer (@$heatmap_layers) { | |||
| 1172 | 13 | 20 | my $pts = _html_json($layer->{points}); | |||
| 1173 | 13 | 20 | my $opts = $layer->{opts} || {}; | |||
| 1174 | # Only plain positive numbers reach the JavaScript | |||||
| 1175 | 13 | 23 | my $radius = _positive_number($opts->{radius}, $DEFAULT_RADIUS); | |||
| 1176 | 13 | 21 | my $blur = _positive_number($opts->{blur}, $DEFAULT_BLUR); | |||
| 1177 | 13 | 28 | $body .= "\t\t\tL.heatLayer($pts, { radius: $radius, blur: $blur }).addTo(map);\n"; | |||
| 1178 | } | |||||
| 1179 | ||||||
| 1180 | # GPX tracks â browser fetches the file; fitBounds called on load. | |||||
| 1181 | 187 | 223 | for my $url (@$gpx_tracks) { | |||
| 1182 | 10 | 11 | my $js_url = _js_string($url); | |||
| 1183 | 10 | 13 | $body .= "\t\t\tnew L.GPX('$js_url', { async: true }).on('loaded', function(e){ map.fitBounds(e.target.getBounds()); }).addTo(map);\n"; | |||
| 1184 | } | |||||
| 1185 | ||||||
| 1186 | # Choropleth layers â colours are pre-baked; no browser-side scale maths. | |||||
| 1187 | 187 | 222 | for my $layer (@$choropleth_layers) { | |||
| 1188 | 21 | 65 | my $fc_json = _html_json({ type => 'FeatureCollection', features => $layer->{features} }); | |||
| 1189 | 21 | 38 | my $colors_json = _html_json($layer->{colors}); | |||
| 1190 | 21 | 29 | my $values_json = _html_json($layer->{values}); | |||
| 1191 | 21 | 24 | my $js_key = _js_string($layer->{key}); | |||
| 1192 | 21 | 43 | $body .= qq{ | |||
| 1193 | (function() { | |||||
| 1194 | var choroplethColors = $colors_json; | |||||
| 1195 | var choroplethValues = $values_json; | |||||
| 1196 | L.geoJSON($fc_json, { | |||||
| 1197 | style: function(f) { | |||||
| 1198 | var k = f.properties && f.properties['$js_key']; | |||||
| 1199 | return { fillColor: choroplethColors[k] || '#cccccc', | |||||
| 1200 | weight: 2, opacity: 1, color: 'white', | |||||
| 1201 | dashArray: '3', fillOpacity: 0.7 }; | |||||
| 1202 | }, | |||||
| 1203 | onEachFeature: function(f, l) { | |||||
| 1204 | var k = f.properties && f.properties['$js_key']; | |||||
| 1205 | if(k && choroplethValues[k] !== undefined) { | |||||
| 1206 | l.bindPopup(k + ': ' + choroplethValues[k]); | |||||
| 1207 | } | |||||
| 1208 | } | |||||
| 1209 | }).addTo(map); | |||||
| 1210 | })(); | |||||
| 1211 | }; | |||||
| 1212 | } | |||||
| 1213 | ||||||
| 1214 | # Event handlers. | |||||
| 1215 | 187 | 220 | $body .= qq{ | |||
| 1216 | document.getElementById('reset-button').addEventListener('click', function() { | |||||
| 1217 | map.setView([$center_lat, $center_lon], $zoom); | |||||
| 1218 | }); | |||||
| 1219 | }; | |||||
| 1220 | ||||||
| 1221 | 187 | 210 | if($search) { | |||
| 1222 | 175 | 161 | $body .= qq{ | |||
| 1223 | document.getElementById('clear-search-button').addEventListener('click', function() { | |||||
| 1224 | searchMarkers.forEach(function(m) { map.removeLayer(m); }); | |||||
| 1225 | searchMarkers = []; | |||||
| 1226 | }); | |||||
| 1227 | ||||||
| 1228 | document.getElementById('search-box').addEventListener('keyup', function(event) { | |||||
| 1229 | if(event.key === 'Enter') { | |||||
| 1230 | var query = event.target.value.trim(); | |||||
| 1231 | if(!query) { alert('Please enter a valid location.'); return; } | |||||
| 1232 | fetch('https://nominatim.openstreetmap.org/search?format=json&q=' + encodeURIComponent(query)) | |||||
| 1233 | .then(function(r) { return r.json(); }) | |||||
| 1234 | .then(function(data) { | |||||
| 1235 | if(data.length > 0) { | |||||
| 1236 | var lat = data[0].lat, lon = data[0].lon; | |||||
| 1237 | map.setView([lat, lon], 14); | |||||
| 1238 | searchMarkers.push(L.marker([lat, lon]).addTo(map).bindPopup(query).openPopup()); | |||||
| 1239 | } else { | |||||
| 1240 | alert('No results found. Try a different location.'); | |||||
| 1241 | } | |||||
| 1242 | }) | |||||
| 1243 | .catch(function(err) { | |||||
| 1244 | console.error('Search error:', err); | |||||
| 1245 | alert('Failed to fetch location. Please check your internet connection.'); | |||||
| 1246 | }); | |||||
| 1247 | } | |||||
| 1248 | }); | |||||
| 1249 | }; | |||||
| 1250 | } | |||||
| 1251 | 187 | 144 | $body .= "\t\t</script>\n"; | |||
| 1252 | ||||||
| 1253 | 187 | 1011 | return ($head, $body); | |||
| 1254 | } | |||||
| 1255 | ||||||
| 1256 | # _point_args: Split a marker method's arguments into a point and options, | |||||
| 1257 | # and resolve the point to coordinates. | |||||
| 1258 | # Purpose: add_marker and add_circle_marker take the same kinds of point. | |||||
| 1259 | # Entry: $self, $caller (method name for messages), then the caller's @_. | |||||
| 1260 | # Exit: ($lat, $lon, \%params) with dot-decimal, range-checked coordinates; | |||||
| 1261 | # (undef, undef, \%params) when the point cannot be used. | |||||
| 1262 | # Side Effects: May call the geocoder; croaks on an unknown point type; _validate carps. | |||||
| 1263 | sub _point_args | |||||
| 1264 | { | |||||
| 1265 | 262 | 470 | my ($self, $caller, @args) = @_; | |||
| 1266 | 262 | 233 | my ($params, $point); | |||
| 1267 | ||||||
| 1268 | 262 | 729 | if(ref($args[0]) eq 'ARRAY') { | |||
| 1269 | 221 | 213 | $point = shift @args; | |||
| 1270 | 221 | 412 | $params = Params::Get::get_params(undef, \@args) || {}; | |||
| 1271 | # Single-element arrayref is a wrapped address string | |||||
| 1272 | 221 221 | 2690 372 | $point = $point->[0] if scalar(@{$point}) == 1; | |||
| 1273 | } elsif(blessed($args[0]) && $args[0]->can('latitude')) { | |||||
| 1274 | # Geo object as first positional arg: extract before Params::Get sees it, | |||||
| 1275 | # otherwise Params::Get mistakes the blessed hashref for the params hash. | |||||
| 1276 | 6 | 22 | $point = shift @args; | |||
| 1277 | 6 | 13 | $params = Params::Get::get_params(undef, \@args) || {}; | |||
| 1278 | } elsif(defined($args[0]) && !ref($args[0]) && scalar(@args) % 2 != 0) { | |||||
| 1279 | # Plain string as first positional arg, optionally followed by key-value pairs. | |||||
| 1280 | # An odd total count signals a leading positional; even count means all key-value. | |||||
| 1281 | 22 | 26 | $point = shift @args; | |||
| 1282 | 22 | 45 | $params = Params::Get::get_params(undef, \@args) || {}; | |||
| 1283 | } else { | |||||
| 1284 | 13 | 32 | $params = Params::Get::get_params('point', @args); | |||
| 1285 | 12 | 183 | $point = $params->{'point'}; | |||
| 1286 | } | |||||
| 1287 | 261 | 684 | $params ||= {}; | |||
| 1288 | ||||||
| 1289 | 261 | 247 | my ($lat, $lon); | |||
| 1290 | ||||||
| 1291 | 261 | 418 | if(ref($point) eq 'ARRAY') { | |||
| 1292 | 218 218 | 183 301 | return (undef, undef, $params) if scalar(@{$point}) != 2; | |||
| 1293 | 211 211 | 185 222 | ($lat, $lon) = @{$point}; | |||
| 1294 | } elsif(!ref($point)) { | |||||
| 1295 | # An empty or missing address cannot be resolved | |||||
| 1296 | 32 | 89 | return (undef, undef, $params) unless defined($point) && length($point); | |||
| 1297 | 27 | 64 | ($lat, $lon) = $self->_fetch_coordinates($point); | |||
| 1298 | } elsif($point->can('latitude')) { | |||||
| 1299 | 6 | 11 | ($lat, $lon) = ($point->latitude(), $point->longitude()); | |||
| 1300 | } else { | |||||
| 1301 | 5 | 11 | my $msg = "$caller(): unknown point type: " . ref($point); | |||
| 1302 | 5 | 20 | $self->{logger}->error($msg) if $self->{logger}; | |||
| 1303 | 5 | 1941 | croak $msg; | |||
| 1304 | } | |||||
| 1305 | ||||||
| 1306 | 244 | 663 | return (undef, undef, $params) unless defined($lat) && defined($lon); | |||
| 1307 | ||||||
| 1308 | # Store the text form with a '.' decimal point, whatever the locale | |||||
| 1309 | 234 | 387 | ($lat, $lon) = (_num_str($lat), _num_str($lon)); | |||
| 1310 | 234 | 443 | return (undef, undef, $params) unless _validate($lat, $lon); | |||
| 1311 | ||||||
| 1312 | 219 | 381 | return ($lat, $lon, $params); | |||
| 1313 | } | |||||
| 1314 | ||||||
| 1315 | # _fetch_coordinates: Resolve a place-name string to a (lat, lon) pair. | |||||
| 1316 | # Purpose: Centralise all geocoding logic â try the injected geocoder first, | |||||
| 1317 | # fall back to a direct Nominatim HTTP call with caching and rate-limiting. | |||||
| 1318 | # Entry: $self, $location (non-empty string). | |||||
| 1319 | # Exit: ($lat, $lon) strings on success; (undef, undef) on failure. | |||||
| 1320 | # Side Effects: May sleep to honour min_interval; writes to $self->{cache}. | |||||
| 1321 | sub _fetch_coordinates | |||||
| 1322 | { | |||||
| 1323 | 56 | 6931 | my ($self, $location) = @_; | |||
| 1324 | ||||||
| 1325 | 56 | 104 | croak 'address not given to _fetch_coordinates' unless $location; | |||
| 1326 | ||||||
| 1327 | # Prefer an injected geocoder (e.g. Geo::Coder::List) to avoid HTTP. | |||||
| 1328 | 54 | 175 | if(my $geocoder = $self->{'geocoder'}) { | |||
| 1329 | 34 | 61 | my $rc = $geocoder->geocode($location); | |||
| 1330 | 34 | 290 | return (undef, undef) unless defined $rc; | |||
| 1331 | ||||||
| 1332 | 26 | 82 | if(blessed($rc) && $rc->can('latitude')) { | |||
| 1333 | 2 | 3 | return ($rc->latitude(), $rc->longitude()); | |||
| 1334 | } | |||||
| 1335 | 24 | 52 | if(ref($rc) eq 'HASH') { | |||
| 1336 | return ($rc->{lat}, $rc->{lon}) | |||||
| 1337 | 21 | 90 | if defined($rc->{lat}) && defined($rc->{lon}); | |||
| 1338 | return ($rc->{geometry}{location}{lat}, $rc->{geometry}{location}{lng}) | |||||
| 1339 | 4 | 13 | if defined($rc->{geometry}{location}{lat}); | |||
| 1340 | } | |||||
| 1341 | # Some geocoders return a flat [lat, lon] arrayref | |||||
| 1342 | 5 2 | 8 4 | return @{$rc} if ref($rc) eq 'ARRAY'; | |||
| 1343 | ||||||
| 1344 | # Unrecognised return type â treat as failure | |||||
| 1345 | 3 | 40 | carp '_fetch_coordinates: unrecognised geocoder result type: ' . ref($rc); | |||
| 1346 | 3 | 616 | return (undef, undef); | |||
| 1347 | } | |||||
| 1348 | ||||||
| 1349 | # Direct Nominatim path: apply caching and rate-limiting. | |||||
| 1350 | 20 | 53 | my $cache_key = 'osm:' . uri_escape_utf8($location); | |||
| 1351 | 20 | 397 | if(my $cached = $self->{cache}->get($cache_key)) { | |||
| 1352 | 4 | 472 | return ($cached->{lat}, $cached->{lon}); | |||
| 1353 | } | |||||
| 1354 | ||||||
| 1355 | # Honour the minimum interval between outbound requests. | |||||
| 1356 | 16 | 927 | my $elapsed = time() - $self->{last_request}; | |||
| 1357 | 16 | 36 | if($elapsed < $self->{min_interval}) { | |||
| 1358 | 3 | 999178 | Time::HiRes::sleep($self->{min_interval} - $elapsed); | |||
| 1359 | } | |||||
| 1360 | ||||||
| 1361 | # Configure only a UA we create; a caller's UA is used as supplied | |||||
| 1362 | 16 | 34 | my $ua = $self->{'ua'}; | |||
| 1363 | 16 | 53 | if(!$ua) { | |||
| 1364 | 2 | 18 | $ua = LWP::UserAgent->new(agent => __PACKAGE__ . "/$VERSION"); | |||
| 1365 | 2 | 9 | $ua->default_header(accept_encoding => 'gzip,deflate'); | |||
| 1366 | 2 | 7 | $ua->env_proxy(1); | |||
| 1367 | } | |||||
| 1368 | ||||||
| 1369 | 16 | 33 | my $url = 'https://' . $self->{'host'} . '?format=json&q=' . uri_escape_utf8($location); | |||
| 1370 | 16 | 191 | $url .= '&email=' . uri_escape_utf8($self->{'email'}) if $self->{'email'}; | |||
| 1371 | 16 | 47 | my $response = $ua->get($url); | |||
| 1372 | 16 | 157 | $self->{'last_request'} = time(); | |||
| 1373 | ||||||
| 1374 | 16 | 34 | if($response->is_success()) { | |||
| 1375 | # eval guard: Nominatim normally returns valid JSON, but a maintenance | |||||
| 1376 | # page or rate-limit response could return HTML with a 200 OK. Dying | |||||
| 1377 | # inside _fetch_coordinates would bubble uncaught to add_marker / onload_render. | |||||
| 1378 | 13 13 | 35 46 | my $data = eval { decode_json($response->decoded_content()) }; | |||
| 1379 | 13 | 338 | if($@) { | |||
| 1380 | 2 | 46 | carp "_fetch_coordinates: failed to decode Nominatim response: $@"; | |||
| 1381 | 2 | 433 | return (undef, undef); | |||
| 1382 | } | |||||
| 1383 | 11 | 29 | $data = $data->[0] if ref($data) eq 'ARRAY'; | |||
| 1384 | 11 | 38 | if(ref($data) eq 'HASH' && defined($data->{lat})) { | |||
| 1385 | 10 | 31 | $self->{'cache'}->set($cache_key, $data); | |||
| 1386 | 10 | 2442 | return ($data->{lat}, $data->{lon}); | |||
| 1387 | } | |||||
| 1388 | } | |||||
| 1389 | ||||||
| 1390 | 4 | 12 | return (undef, undef); | |||
| 1391 | } | |||||
| 1392 | ||||||
| 1393 | # _validate: Check that a (lat, lon) pair is numeric and within WGS-84 bounds. | |||||
| 1394 | # Purpose: Single guard point for all coordinate ingestion; emits a carp when | |||||
| 1395 | # both values are defined but wrong so the caller can log without dying. | |||||
| 1396 | # Entry: ($lat, $lon) â any scalar, including undef. | |||||
| 1397 | # Exit: 1 if valid, 0 if not. | |||||
| 1398 | # Side Effects: carp when coordinates are defined but out-of-range/non-numeric. | |||||
| 1399 | sub _validate | |||||
| 1400 | { | |||||
| 1401 | 509 1018 | 29816 718 | my ($lat, $lon) = map { _num_str($_) } @_; | |||
| 1402 | ||||||
| 1403 | # Require at least one digit (rejects empty string â unlike \d* which matches ''). | |||||
| 1404 | # Leading-decimal notation (e.g. -.5167) is valid per Changes 0.05. | |||||
| 1405 | # \z (not $) prevents a trailing \n from sneaking through: $ matches before | |||||
| 1406 | # a final newline, which would make "0\n" valid and embed a newline in JS. | |||||
| 1407 | 509 | 648 | my $numeric = qr/^-?(?:\d+(?:\.\d+)?|\.\d+)\z/; | |||
| 1408 | ||||||
| 1409 | # Range checks use _num_val, which does not depend on the locale | |||||
| 1410 | 509 | 3273 | my $ok = defined($lat) && defined($lon) | |||
| 1411 | && $lat =~ $numeric && $lon =~ $numeric | |||||
| 1412 | && _num_val($lat) >= $LAT_MIN && _num_val($lat) <= $LAT_MAX | |||||
| 1413 | && _num_val($lon) >= $LON_MIN && _num_val($lon) <= $LON_MAX; | |||||
| 1414 | ||||||
| 1415 | 509 | 1327 | carp(sprintf 'Skipping invalid coordinate: (%s, %s)', | |||
| 1416 | $lat // 'undef', $lon // 'undef') | |||||
| 1417 | if !$ok && defined($lat) && defined($lon); | |||||
| 1418 | ||||||
| 1419 | 509 | 7155 | return $ok ? 1 : 0; | |||
| 1420 | } | |||||
| 1421 | ||||||
| 1422 | # _html_json: Encode data as JSON and make the result safe for embedding in a | |||||
| 1423 | # <script> block. JSON encoders do not escape '/' by default, so a value like | |||||
| 1424 | # '</script>' would close the enclosing script tag and allow HTML injection. | |||||
| 1425 | # Escaping every '</' as '<\/' prevents this without altering the decoded value. | |||||
| 1426 | # Encoding runs under the C numeric locale: some encoders print numbers through | |||||
| 1427 | # the C library or Perl's own stringification, and under a locale such as | |||||
| 1428 | # de_DE 0.5 could come out as 0,5, which JSON reads as two numbers. | |||||
| 1429 | # Entry: Any Perl data structure accepted by encode_json. | |||||
| 1430 | # Exit: JSON string safe for direct insertion inside a <script> block. | |||||
| 1431 | # Side Effects: LC_NUMERIC is switched to 'C' for the encode and then restored. | |||||
| 1432 | sub _html_json | |||||
| 1433 | { | |||||
| 1434 | 117 | 102125 | my $data = shift; | |||
| 1435 | ||||||
| 1436 | 117 | 78 | my $saved_error = $@; | |||
| 1437 | 117 | 174 | my $saved_locale = setlocale(LC_NUMERIC); | |||
| 1438 | 117 | 284 | setlocale(LC_NUMERIC, 'C'); | |||
| 1439 | 117 117 | 61 619 | my $j = eval { encode_json($data) }; | |||
| 1440 | 117 | 1564 | my $err = $@; | |||
| 1441 | 117 | 579 | setlocale(LC_NUMERIC, $saved_locale) if defined($saved_locale); | |||
| 1442 | 117 | 150 | die $err unless defined($j); | |||
| 1443 | 115 | 77 | $@ = $saved_error; | |||
| 1444 | ||||||
| 1445 | 115 | 86 | $j =~ s|</|<\\/|g; | |||
| 1446 | 115 | 120 | return $j; | |||
| 1447 | } | |||||
| 1448 | ||||||
| 1449 | # _js_string: Escape a Perl string for safe embedding in a JS single-quoted literal. | |||||
| 1450 | # Purpose: Prevent JS injection via user-supplied labels, URLs, or property names. | |||||
| 1451 | # Entry: Any scalar (undef becomes ''). | |||||
| 1452 | # Exit: Escaped string safe for insertion between JS single quotes. | |||||
| 1453 | sub _js_string | |||||
| 1454 | { | |||||
| 1455 | 601 | 116810 | my $s = shift // ''; | |||
| 1456 | 601 | 431 | $s =~ s/\\/\\\\/g; # escape backslash first to avoid double-escaping | |||
| 1457 | 601 | 379 | $s =~ s/'/\\'/g; # escape our JS string delimiter | |||
| 1458 | 601 | 366 | $s =~ s/\r?\n/\\n/g; # newlines would break the JS string | |||
| 1459 | 601 | 349 | $s =~ s/\r/\\r/g; # a lone carriage return also ends a JS string | |||
| 1460 | 601 | 535 | $s =~ s|</|<\\/|g; # prevent </script> injection | |||
| 1461 | 601 | 488 | return $s; | |||
| 1462 | } | |||||
| 1463 | ||||||
| 1464 | # _html_attr: Escape a Perl string for safe embedding in a double-quoted HTML attribute. | |||||
| 1465 | # Purpose: Stop a configured CDN URL from closing the attribute or the tag. | |||||
| 1466 | # Entry: Any scalar (undef becomes ''). | |||||
| 1467 | # Exit: String with &, <, > and " replaced by entities. | |||||
| 1468 | sub _html_attr | |||||
| 1469 | { | |||||
| 1470 | 1320 | 4887 | my $s = shift // ''; | |||
| 1471 | 1320 | 839 | $s =~ s/&/&/g; # escape ampersand first to avoid double-escaping | |||
| 1472 | 1320 | 697 | $s =~ s/</</g; | |||
| 1473 | 1320 | 676 | $s =~ s/>/>/g; | |||
| 1474 | 1320 | 676 | $s =~ s/"/"/g; | |||
| 1475 | 1320 | 1197 | return $s; | |||
| 1476 | } | |||||
| 1477 | ||||||
| 1478 | # _css_length: Check a width or height before it is put into the <style> block. | |||||
| 1479 | # Purpose: Values from a config file or a clone skip new()'s schema, so a value | |||||
| 1480 | # such as '1px}</style><script>' could otherwise reach the page. | |||||
| 1481 | # Entry: ($name, $value, $default) - name is used only in the warning. | |||||
| 1482 | # Exit: $value when it is a CSS length; otherwise $default. | |||||
| 1483 | # Side Effects: carp when a non-empty value is replaced. | |||||
| 1484 | sub _css_length | |||||
| 1485 | { | |||||
| 1486 | 418 | 5732 | my ($name, $value, $default) = @_; | |||
| 1487 | ||||||
| 1488 | 418 | 667 | return $default unless defined($value) && length($value); | |||
| 1489 | 414 | 1364 | return $value if $value =~ $CSS_LENGTH; | |||
| 1490 | ||||||
| 1491 | 4 | 47 | carp "onload_render: invalid $name '$value', using $default"; | |||
| 1492 | 4 | 667 | return $default; | |||
| 1493 | } | |||||
| 1494 | ||||||
| 1495 | # _positive_number: Return $value as text when it is a positive number. | |||||
| 1496 | # Purpose: Heatmap options go straight into the JavaScript, so anything that | |||||
| 1497 | # is not a plain number must not reach it. The check works on the | |||||
| 1498 | # text form so it does not depend on the locale (see _num_val). | |||||
| 1499 | # Entry: ($value, $default). | |||||
| 1500 | # Exit: $value as a dot-decimal string, or $default when $value is missing, | |||||
| 1501 | # not a plain decimal number, <= 0 or >= 1e6. | |||||
| 1502 | sub _positive_number | |||||
| 1503 | { | |||||
| 1504 | 98 | 5920 | my ($value, $default) = @_; | |||
| 1505 | ||||||
| 1506 | 98 | 139 | return $default unless defined($value) && !ref($value); | |||
| 1507 | ||||||
| 1508 | 77 | 53 | my $str = _num_str($value); | |||
| 1509 | 77 | 115 | $str =~ s/\A\s+|\s+\z//g; | |||
| 1510 | # Plain decimals only: rejects signs, exponents, 'Inf' and 'NaN' | |||||
| 1511 | 77 | 115 | return $default unless $str =~ /\A(?:[0-9]+(?:\.[0-9]+)?|\.[0-9]+)\z/; | |||
| 1512 | ||||||
| 1513 | 61 | 42 | my $number = _num_val($str); | |||
| 1514 | 61 | 77 | return $default unless $number > 0 && $number < 1e6; | |||
| 1515 | 56 | 39 | return _num_str($number); | |||
| 1516 | } | |||||
| 1517 | ||||||
| 1518 | # _num_str: Return a number as text with '.' as the decimal point. | |||||
| 1519 | # Purpose: Perl should print numbers with a '.' whatever the locale, but some | |||||
| 1520 | # builds (seen with Perl 5.38.0 on macOS) use the LC_NUMERIC decimal | |||||
| 1521 | # point, so 51.5074 prints as '51,5074' under de_DE. That fails | |||||
| 1522 | # _validate, and in JavaScript '[51,5074, -0,1278]' is four numbers. | |||||
| 1523 | # Entry: Any scalar. | |||||
| 1524 | # Exit: A value Perl holds as a number comes back as text with a '.' | |||||
| 1525 | # decimal point; anything else (strings, undef, refs) is unchanged. | |||||
| 1526 | sub _num_str | |||||
| 1527 | { | |||||
| 1528 | 4768 | 6345 | my $value = shift; | |||
| 1529 | ||||||
| 1530 | 4768 | 4888 | return $value if !defined($value) || ref($value); | |||
| 1531 | ||||||
| 1532 | # Only a value Perl holds as a number can have been printed with a locale | |||||
| 1533 | # decimal point; a string such as '51,5' never gets these flags. | |||||
| 1534 | 4762 | 4820 | my $flags = B::svref_2object(\$value)->FLAGS; | |||
| 1535 | 4762 | 5014 | return $value unless $flags & (B::SVf_IOK() | B::SVf_NOK()); | |||
| 1536 | ||||||
| 1537 | 998 | 1818 | my $str = "$value"; | |||
| 1538 | 998 | 6468 | my $radix = (localeconv() || {})->{decimal_point}; | |||
| 1539 | 998 | 3458 | $str =~ s/\Q$radix\E/./ if defined($radix) && length($radix) && $radix ne '.'; | |||
| 1540 | 998 | 691 | $str =~ tr/,/./; # Perl never groups digits, so a comma can only be a decimal point | |||
| 1541 | 998 | 1085 | return $str; | |||
| 1542 | } | |||||
| 1543 | ||||||
| 1544 | # _num_val: Convert a decimal string such as '-0.1278' to a number. | |||||
| 1545 | # Purpose: The perls that print numbers with the locale's decimal point also | |||||
| 1546 | # read them that way, so under de_DE '51.5074' + 0 is 51. Building | |||||
| 1547 | # the value from its whole and fractional digit strings uses only | |||||
| 1548 | # integer conversion, which no locale affects. | |||||
| 1549 | # Entry: A number, or a string in the form _validate accepts. | |||||
| 1550 | # Exit: The numeric value. Anything else falls back to Perl's own conversion. | |||||
| 1551 | sub _num_val | |||||
| 1552 | { | |||||
| 1553 | 2292 | 4175 | my $str = _num_str(shift); | |||
| 1554 | ||||||
| 1555 | 2292 | 3342 | my ($sign, $whole, $frac) = $str =~ /\A(-?)([0-9]*)(?:\.([0-9]+))?\z/; | |||
| 1556 | 2292 | 2436 | if(!defined($sign) || (!length($whole) && !defined($frac))) { | |||
| 1557 | 14 14 14 | 63 10 1112 | no warnings 'numeric'; | |||
| 1558 | 2 | 7 | return 0 + $str; | |||
| 1559 | } | |||||
| 1560 | ||||||
| 1561 | 2290 | 1750 | my $value = length($whole) ? 0 + $whole : 0; | |||
| 1562 | 2290 | 2030 | $value += $frac / (10 ** length($frac)) if defined($frac); | |||
| 1563 | 2290 | 3276 | return $sign ? -$value : $value; | |||
| 1564 | } | |||||
| 1565 | ||||||
| 1566 - 1754 | =head1 LIMITATIONS
=over 4
=item * B<Per-marker removal>: Markers added via C<add_marker()> cannot yet be
removed individually by clicking them. The "Clear search markers" button only
removes markers added by the in-page Nominatim search box.
=item * B<Clone validation>: The clone path (C<< $obj->new(%overrides) >>)
bypasses the Params::Validate::Strict schema so subclasses and internal callers
can merge arbitrary state. Callers are responsible for passing valid overrides.
=item * B<Config-file params unvalidated>: Keys injected by
L<Object::Configure> from a config file are not re-run through the schema, so
a malformed config file can introduce invalid types at runtime.
C<onload_render()> checks C<zoom>, C<max_zoom>, C<width> and C<height> again and
HTML-escapes the CDN URLs, so a bad value cannot inject markup into the page.
=item * B<One map per page>: The rendered HTML uses fixed element IDs
(C<map>, C<search-box>, C<clear-search-button> and C<reset-button>), so two
maps on the same page will clash.
=item * B<Clustered circle markers>: With C<< cluster => 1 >>, circle markers
are grouped with the pin markers, so at low zoom levels a cluster count is
shown in place of the circles' sizes. Leave C<cluster> off for a bubble map
whose sizes should always be visible.
=item * B<Private-method encapsulation>: C<_fetch_coordinates>, C<_validate>,
and C<_js_string> are named with a leading underscore by convention only.
Using L<Sub::Private> in C<enforce> mode would make the contract explicit, but
that module is not yet listed as a dependency to avoid breaking white-box tests
in C<t/mock.t>.
=item * B<Routing>: Turn-by-turn routing (Leaflet Routing Machine / OSRM) is
explicitly out of scope for this module and will not be added here.
=back
=head1 AUTHOR
Nigel Horne, C<< <njh at nigelhorne.com> >>
=head1 BUGS
Please report bugs at L<https://github.com/nigelhorne/HTML-OSM/issues>.
=head1 SEE ALSO
=over 4
=item * L<https://wiki.openstreetmap.org/wiki/API>
=item * L<HTML::GoogleMaps::V3> - the interface this module mirrors for compatibility.
=item * L<https://leafletjs.com/>
=item * L<Configure an Object at Runtime|Object::Configure>
=item * L<Test Dashboard|https://nigelhorne.github.io/HTML-OSM/coverage/>
=back
=head1 SUPPORT
This module is provided as-is without any warranty.
Please report problems and ask questions at
L<https://github.com/nigelhorne/HTML-OSM/issues>.
You can find documentation for this module with the perldoc command.
perldoc HTML::OSM
You can also look for information at MetaCPAN:
L<https://metacpan.org/dist/HTML-OSM>.
=head2 TODO
Allow per-marker removal via clicking on a marker.
=encoding utf-8
=head1 FORMAL SPECIFICATION
=head2 new
HTML_OSM
coordinates : iseq (â x â x S x S)
zoom : Z
cluster : B
----------------------------------------
ZOOM_MIN <= zoom <= ZOOM_MAX
new â
params? : Params
osm! : HTML_OSM
----------------------------------------
osm!.zoom = params?.zoom ⨠12
osm!.cluster = params?.cluster ⨠false
=head2 add_marker
AddMarker
ÎHTML_OSM
point? : (â x â) ⪠S ⪠GeoObject
result! : {0, 1}
-----------------------------------------
result! = 1 ⺠point? resolves to (lat, lon) â ValidCoord
result! = 1 â¹ coordinates' = coordinates ⢠â¨(lat, lon, label, icon)â©
=head2 add_geojson
AddGeoJSON
ÎHTML_OSM
data? : GeoJSONStruct ⪠S
style? : StyleMap ⪠{â
}
popup? : S ⪠{â
}
-----------------------------------------
geojson' = geojson ⢠â¨{data, style, popup}â©
=head2 add_heatmap
AddHeatmap
ÎHTML_OSM
points? : iseq (â x â x [0,1])
-----------------------------------------
heatmap_layers' = heatmap_layers ⢠â¨{points, radius, blur}â©
=head2 add_gpx
AddGPX
ÎHTML_OSM
url? : S | url? â ''
-----------------------------------------
gpx_tracks' = gpx_tracks ⢠â¨url?â©
=head2 add_choropleth
AddChoropleth
ÎHTML_OSM
features? : iseq GeoFeature
values? : S --> â
key? : S
scale? : iseq S
-----------------------------------------
Let min = min(ran values?), max = max(ran values?) ⪠{min+1}
â k â dom values? â¢
color(k) = scale?[floor((values?(k)-min)/(max-min) * (#scale?-1))]
choropleth_layers' = choropleth_layers ⢠â¨{features, values, colors, key}â©
=head2 center
Center
ÎHTML_OSM
point? : (â x â) ⪠S ⪠GeoObject
result! : {0, 1}
-----------------------------------------
result! = 1 ⺠point? resolves to (lat, lon) â ValidCoord
result! = 1 â¹ center' = (lat, lon)
=head2 zoom
Zoom
ÎHTML_OSM
zoom? : Z ⪠{â
}
zoom! : Z
-----------------------------------------
zoom? â â
â¹ ZOOM_MIN <= zoom? <= ZOOM_MAX
zoom! = (zoom? â â
⧠zoom' = zoom?) ⨠zoom
=head2 onload_render
OnloadRender
HTML_OSM
head! : S
body! : S
-----------------------------------------
(#coordinates + #geojson + #heatmap_layers + #gpx_tracks + #choropleth_layers) > 0
center â â
⨠â valid â coordinates ⢠valid â ValidCoord
=head1 LICENSE AND COPYRIGHT
Copyright 2025-2026 Nigel Horne.
This program is released under the following licence: GPL2
If you use it,
please let me know.
=cut | |||||
| 1755 | ||||||
| 1756 | 1; | |||||
| 1757 | ||||||