File Coverage

File:blib/lib/Geo/Coder/Free/Utils.pm
Coverage:66.7%

linestmtbrancondsubpodtimecode
1package Geo::Coder::Free::Utils;
2
3# VWF is licensed under GPL2.0 for personal use only
4# njh@nigelhorne.com
5
6=encoding utf-8
7
8 - 21
=head1 NAME

Geo::Coder::Free::Utils - Random subroutines for Geo::Coder::Free

=head1 DESCRIPTION

Utility module for cache management, geospatial calculations, and shared
address-normalization helpers used by multiple backends.

=head1 VERSION

Version 0.51

=cut
22
23our $VERSION = '0.51';
24
25
20
20
20
136627
23
use v5.20;
26
20
20
20
20
31
10
207
use strict;
27
20
20
20
20
26
41
366
use warnings;
28
20
20
20
20
50
13
1141
use feature qw(signatures);
29
20
20
20
20
88
33
294
no warnings qw(experimental::signatures);
30
31
20
20
20
20
33
17
584
use Exporter qw(import);
32our @EXPORT = qw(create_disc_cache create_memory_cache distance _abbreviate _normalize);
33our @EXPORT_OK = qw(_abbreviate _normalize);
34
35
20
20
20
20
4280
560733
289
use CHI;
36
20
20
20
20
5149
855384
294
use Geo::Coder::Abbreviations;
37
20
20
20
20
13314
155964
577
use DBI;
38
20
20
20
20
3411
1536
68
use Error::Simple;
39
20
20
20
20
358
15
45
use Module::Runtime qw(require_module); # Safe dynamic loading; avoids string eval
40
20
20
20
20
739
16842
273
use Params::Get 0.13;
41
20
20
20
20
28
13
358
use Try::Tiny;
42
20
20
20
20
29
11
335
use Carp qw(croak carp);
43
20
20
20
20
33
13
291
use Scalar::Util qw(looks_like_number);
44
20
20
20
20
3794
105879
941
use Math::Trig qw(deg2rad rad2deg asin great_circle_distance);
45
46# Constants for distance calculations
47use constant {
48
20
29944
        EARTH_RADIUS_MILES => 3959,
49        EARTH_RADIUS_KM => 6371,
50        EARTH_RADIUS_NM => 3440,
51        KM_PER_MILE => 1.609344,
52        NM_PER_MILE => 0.8684
53
20
20
20
45
16
};
54
55 - 108
=head1 SUBROUTINES/METHODS

=head2 FORMAL SPECIFICATION

        [STRING, HASH, LOGGER, CHI_CACHE, COORDINATE]

        CacheConfig ::= ⟨⟨ driver : STRING;
                                         servers : seq STRING;
                                         root_dir : STRING;
                                         connect : STRING ⟩⟩

        CacheArgs ::= ⟨⟨ config : HASH;
                                        logger : LOGGER;
                                        namespace : STRING;
                                        root_dir : STRING ⟩⟩

        Point ::= ⟨⟨ latitude : COORDINATE;
                                longitude : COORDINATE ⟩⟩
        where
          latitude ∈ {x : ℝ | -90 ≤ x ≤ 90} ∧
          longitude ∈ {x : ℝ | -180 ≤ x ≤ 180}

        Unit ::= K | N | M

        CreateCache : CacheArgs → CHI_CACHE

        âˆ€ args : CacheArgs •
          let driver == args.config.driver ∨ default_driver •
          validate_driver_config(driver, args.config) ∧
          âˆƒ cache : CHI_CACHE • cache = CHI.new(build_chi_args(driver, args))

        Distance : Point × Point × Unit → ℝ₊

        âˆ€ p1, p2 : Point; u : Unit •
          let d == great_circle_distance(p1, p2) •
          d ≥ 0 ∧
          (u = K ⟹ result = d × 1.609344) ∧
          (u = N ⟹ result = d × 0.8684) ∧
          (u = M ⟹ result = d)

=head2 create_disc_cache

Initialize a disc-based cache using the CHI module.
Supports multiple cache drivers, including BerkeleyDB, DBI, and Redis.

Parameters:
- config: Configuration hash reference (required)
- logger: Logger object (optional)
- namespace: Cache namespace (optional)
- root_dir: Root directory override (optional)

Returns: CHI cache object

=cut
109
110sub create_disc_cache {
111
13
13
1
118837
        my $args = Params::Get::get_params(undef, @_);
112
13
156
        return _create_cache('disc_cache', $args);
113}
114
115 - 128
=head2 create_memory_cache

Initialize a memory-based cache using the CHI module.
Supports multiple cache drivers, including SharedMem, Memory, and Redis.

Parameters:
- config: Configuration hash reference (required)
- logger: Logger object (optional)
- namespace: Cache namespace (optional)
- root_dir: Root directory override (optional)

Returns: CHI cache object

=cut
129
130sub create_memory_cache {
131
9
9
1
8693
        my $args = Params::Get::get_params(undef, @_);
132
9
125
        return _create_cache('memory_cache', $args);
133}
134
135# Private helper functions
136
137
22
22
22
22
22
13
16
13
10
sub _create_cache($cache_type, $args) {
138
22
20
        my $config = $args->{'config'};
139
22
100
43
        throw Error::Simple('config is not optional') unless($config);
140
141
18
23
        _validate_cache_config($config, $cache_type);
142
143
12
10
        my $logger = $args->{'logger'};
144
12
100
16
        my $cache_config = $config->{$cache_type} || {};
145
12
11
        my $driver = $cache_config->{driver};
146
147        # Set default driver with fallback strategy
148
12
100
11
        unless (defined $driver) {
149
2
2
                $driver = _get_default_driver($cache_type, $logger);
150
2
50
3
                if ($logger) {
151
0
0
                        $logger->info("No driver specified for $cache_type, using $driver");
152                }
153        }
154
155        # Validate driver is available
156
12
100
26
        unless (_is_driver_available($driver)) {
157
2
3
                my $fallback = _get_fallback_driver($cache_type);
158
2
50
3
                if ($logger) {
159
0
0
                        $logger->warn("Driver $driver not available, falling back to $fallback");
160                }
161
2
2
                $driver = $fallback;
162        }
163
164        # Build CHI arguments
165
12
20
        my %chi_args = _build_chi_args($driver, $cache_config, $args, $logger, $cache_type);
166
167        # Create cache with error handling
168
8
12
        my $cache;
169        try {
170
8
8
308
                $cache = CHI->new(%chi_args);
171        } catch {
172
0
0
0
                my $error = "Failed to create $cache_type cache with driver $driver: $_";
173
0
0
0
                $logger->error($error) if $logger;
174
0
0
                throw Error::Simple($error);
175
8
30
        };
176
177
8
94817
        return $cache;
178}
179
180
18
18
18
18
18
12
10
14
4
sub _validate_cache_config($config, $cache_type) {
181
18
100
25
        return unless exists $config->{$cache_type};
182
183
16
13
        my $cache_config = $config->{$cache_type};
184
16
100
27
        croak('Cache configuration must be a hash reference')
185                unless ref($cache_config) eq 'HASH';
186
187        # Validate driver if specified
188
14
50
30
        if (exists $cache_config->{driver}) {
189
14
12
                my $driver = $cache_config->{driver};
190
14
23
                my @valid_drivers = qw(Memory BerkeleyDB DBI Redis Memcached SharedMem File Null);
191                croak "Invalid driver '$driver'. Valid drivers: " . join(', ', @valid_drivers)
192
14
112
100
13
83
                        unless grep { $_ eq $driver } @valid_drivers;
193        }
194
195        # Validate numeric parameters
196
13
16
        for my $param (qw(port shm_size max_size)) {
197
37
100
32
                next unless exists $cache_config->{$param};
198
2
2
                my $value = $cache_config->{$param};
199
2
100
50
13
                croak "$param must be a positive integer"
200                        unless defined $value && $value =~ /^\d+$/ && $value > 0;
201        }
202
203        # Validate port range
204
12
100
53
        if (exists $cache_config->{port}) {
205
1
1
                my $port = $cache_config->{port};
206
1
50
33
6
                croak('Port must be between 1 and 65535')
207                        unless $port >= 1 && $port <= 65535;
208        }
209
210        # Validate memory parameters
211
11
50
50
18
        if(exists($cache_config->{'datastore'}) && exists($cache_config->{'global'}) && (my $driver = $cache_config->{'driver'})) {
212                # CHI catches this as well, but putting it here helps to track the error
213
1
4
                croak('Memory cache cannot have both global and datastore');
214        }
215}
216
217
2
2
2
2
2
2
2
8
1
sub _get_default_driver($cache_type, $logger) {
218        # Allow override for testing
219
2
3
        my $env_var = 'TEST_' . uc($cache_type) . '_DRIVER';
220
2
50
4
        return $ENV{$env_var} if $ENV{$env_var};
221
222        # Production defaults
223
2
100
4
        return $cache_type eq 'disc_cache' ? 'BerkeleyDB' : 'Memory';
224}
225
226
2
2
2
2
2
1
2
sub _get_fallback_driver($cache_type) {
227
2
50
3
        return $cache_type eq 'disc_cache' ? 'File' : 'Memory';
228}
229
230
12
12
12
12
8
8
6
sub _is_driver_available($driver) {
231
12
100
29
        return 1 if $driver =~ /^(Memory|Null)$/;
232
233
7
23
        my %driver_modules = (
234                'DBI' => 'CHI::Driver::DBI',
235                'BerkeleyDB' => 'CHI::Driver::BerkeleyDB',
236                'File' => 'CHI::Driver::File',
237                'Memcached' => 'CHI::Driver::Memcached',
238                'SharedMem' => 'CHI::Driver::SharedMem',
239                'Redis' => 'CHI::Driver::Redis'
240        );
241
242
7
50
8
        return 1 unless exists $driver_modules{$driver};
243
244
7
100
31
        if($driver_modules{$driver}->can('new')) {
245
1
3
                return 1;
246        }
247        # SECURITY - string-eval elimination:
248        #   eval "require $module_name" is a string eval; if $driver ever escaped
249        #   the hash-key whitelist (e.g. through a future regression in the caller),
250        #   it could execute arbitrary code.  A block eval with require_module() is
251        #   semantically identical but has no string-eval surface.
252
6
6
5
12
        eval { require_module($driver_modules{$driver}) };
253
6
100
49952
        if($@) {
254
2
4
                return 0;
255        }
256
4
16
        $driver_modules{$driver}->import();
257
4
8
        return 1;
258}
259
260
12
12
12
12
12
12
12
12
7
9
7
6
9
3
9
sub _build_chi_args($driver, $cache_config, $args, $logger, $cache_type) {
261        my %chi_args = (
262                driver => $driver,
263
12
100
26
                namespace => $args->{'namespace'} || 'default'
264        );
265
266        # Configure error handling
267
12
50
33
20
        if ($logger && $logger->can('error')) {
268
0
0
0
0
0
                $chi_args{on_get_error} = sub { $logger->warn("Cache get error: $_[0]") };
269
0
0
0
0
0
                $chi_args{on_set_error} = sub { $logger->error("Cache set error: $_[0]") };
270        } else {
271
12
10
                $chi_args{on_get_error} = 'warn';
272
12
12
                $chi_args{on_set_error} = 'die';
273        }
274
275        # Driver-specific configuration
276
12
50
50
50
100
50
100
43
        if ($driver eq 'Redis') {
277
0
0
                _configure_redis(\%chi_args, $cache_config, $args, $logger);
278        } elsif ($driver eq 'DBI') {
279
0
0
                _configure_dbi(\%chi_args, $cache_config, $args, $logger);
280        } elsif ($driver eq 'SharedMem') {
281
0
0
                _configure_shared_memory(\%chi_args, $cache_config, $args);
282        } elsif ($driver eq 'Memory') {
283
1
2
                _configure_memory(\%chi_args, $cache_config);
284        } elsif ($driver eq 'Memcached') {
285
0
0
                _configure_memcached(\%chi_args, $cache_config, $args, $logger);
286        } elsif ($driver !~ /^(Null)$/) {
287
7
11
                _configure_file_based(\%chi_args, $cache_config, $args);
288        }
289
290
8
20
        return %chi_args;
291}
292
293
0
0
0
0
0
0
0
0
0
0
0
0
0
sub _configure_redis($chi_args, $config, $args, $logger) {
294        # Parse server configuration
295
0
0
        my @servers = _parse_server_config($config, $logger);
296
0
0
0
        if (@servers) {
297
0
0
                $chi_args->{servers} = \@servers;
298
0
0
                $chi_args->{server} = $servers[0];   # Primary server
299        }
300
301        # Redis-specific options with sensible defaults
302        $chi_args->{redis_options} = {
303                reconnect => $config->{reconnect} || 60,
304                every => $config->{every} || 1_000_000,
305                encoding => $config->{encoding} || 'utf8',
306
0
0
0
0
0
0
0
0
                %{$config->{redis_options} || {}}
307        };
308}
309
310
0
0
0
0
0
0
0
0
0
0
0
0
0
sub _configure_dbi($chi_args, $config, $args, $logger) {
311
0
0
        my $connect_string = $config->{connect};
312
0
0
0
        croak "DBI driver requires 'connect' parameter" unless $connect_string;
313
314
0
0
        my $dbh;
315        try {
316
0
0
0
                $dbh = DBI->connect($connect_string, '', '', {
317                        RaiseError => 1,
318                        PrintError => 0,
319                        AutoCommit => 1
320                });
321        } catch {
322
0
0
0
                my $error = "Failed to connect to database: $_";
323
0
0
0
                $logger->error($error) if $logger;
324
0
0
                croak $error;
325
0
0
        };
326
327
0
0
        $chi_args->{dbh} = $dbh;
328
0
0
0
        $chi_args->{create_table} = $config->{create_table} // 1;
329}
330
331
0
0
0
0
0
0
0
0
0
0
0
sub _configure_shared_memory($chi_args, $config, $args) {
332        $chi_args->{shm_key} = $args->{'shm_key'} || $config->{shm_key}
333
0
0
0
                || croak "SharedMem driver requires 'shm_key' parameter";
334
335
0
0
0
        $chi_args->{shm_size} = $args->{'shm_size'} || $config->{shm_size} || 16 * 1024;
336
0
0
0
        $chi_args->{max_size} = $args->{'max_size'} || $config->{max_size} || 1024;
337}
338
339
1
1
sub _configure_memory($chi_args, $config)
340
1
1
1
1
0
1
0
{
341
1
50
1
        if(exists $config->{'global'}) {
342
0
0
                $chi_args->{'global'} = $config->{'global'};
343        } else {
344
1
1
                $chi_args->{'datastore'} = {};
345        }
346}
347
348
0
0
0
0
0
0
0
0
0
0
0
0
0
sub _configure_memcached($chi_args, $config, $args, $logger) {
349
0
0
        my @servers = _parse_server_config($config, $logger);
350
0
0
0
        if (@servers) {
351
0
0
                $chi_args->{servers} = \@servers;
352        } else {
353                # Default to localhost
354
0
0
                $chi_args->{servers} = ['127.0.0.1:11211'];
355
0
0
0
                $logger->debug('Using default Memcached server: 127.0.0.1:11211') if $logger;
356        }
357}
358
359
7
7
7
7
7
7
5
5
3
7
1
sub _configure_file_based($chi_args, $config, $args) {
360
7
67
33
        my $root_dir = $ENV{'root_dir'} || $args->{'root_dir'} || $config->{root_dir} || $args->{'config'}->{root_dir};
361
362
7
100
43
        croak "File-based cache drivers require 'root_dir' parameter" unless $root_dir;
363
4
100
67
47
        croak "Root directory '$root_dir' does not exist or is not writable"
364                unless -d $root_dir && -w $root_dir;
365
366
3
4
        $chi_args->{root_dir} = $root_dir;
367}
368
369
0
0
0
0
0
0
0
0
0
sub _parse_server_config($config, $logger) {
370        # Handle host/server naming inconsistency
371
0
0
0
        my $server_config = $config->{server} || $config->{host};
372
0
0
0
        return () unless $server_config;
373
374
0
0
        my @servers;
375
0
0
        for my $server_entry (split /,/, $server_config) {
376
0
0
                $server_entry =~ s/^\s+|\s+$//g;        # trim whitespace
377
378                # If no port specified, add default port
379
0
0
0
                unless ($server_entry =~ /:/) {
380
0
0
0
                        my $port = $config->{port} || croak "Port not specified for server '$server_entry'";
381
0
0
                        $server_entry .= ":$port";
382                }
383
384                # Validate server format
385
0
0
0
                if ($server_entry =~ /^([a-zA-Z0-9.-]+):(\d+)$/) {
386
0
0
                        my ($host, $port) = ($1, $2);
387
0
0
0
0
                        croak "Invalid port number: $port" unless $port > 0 && $port <= 65535;
388
0
0
                        push @servers, $server_entry;
389
0
0
0
                        $logger->debug("Added server: $server_entry") if $logger;
390                } else {
391
0
0
                        croak "Invalid server format: '$server_entry' (expected host:port)";
392                }
393        }
394
395
0
0
        return @servers;
396}
397
398 - 412
=head2 distance

Calculate the great circle distance between two points on Earth using the Haversine formula.
More accurate than the original implementation, especially for short distances.

Parameters:
- lat1, lon1: Latitude and longitude of first point (decimal degrees)
- lat2, lon2: Latitude and longitude of second point (decimal degrees)
- unit: 'K' for kilometers, 'N' for nautical miles, 'M' or undef for statute miles

Returns: Distance in specified units

Throws: Error on invalid input parameters

=cut
413
414
61
61
61
61
61
61
61
61
1
48491
55
40
28
35
38
26
sub distance($lat1, $lon1, $lat2, $lon2, $unit = 'M') {
415        # Input validation
416
61
94
        for my $coord_ref ([\$lat1, 'lat1'], [\$lon1, 'lon1'], [\$lat2, 'lat2'], [\$lon2, 'lon2']) {
417
215
129
                my ($coord, $name) = @$coord_ref;
418
215
100
200
                croak "$name must be defined" unless defined $$coord;
419
208
100
215
                croak "$name must be numeric" unless looks_like_number($$coord);
420        }
421
422        # Range validation
423
47
100
100
146
        croak('Latitude must be between -90 and 90 degrees')
424                if abs($lat1) > 90 || abs($lat2) > 90;
425
38
100
100
96
        croak('Longitude must be between -180 and 180 degrees')
426                if abs($lon1) > 180 || abs($lon2) > 180;
427
428        # Handle identical points
429
30
100
100
42
        return 0 if $lat1 == $lat2 && $lon1 == $lon2;
430
431        # Validate unit
432
25
100
35
        $unit = uc($unit || 'M');
433
25
100
47
        croak "Unknown unit '$unit'. Use 'K', 'N', or 'M'"
434                unless $unit =~ /^[KNM]$/;
435
436        # Use optimized calculation with appropriate radius
437
22
100
100
30
        my $radius = $unit eq 'K' ? EARTH_RADIUS_KM :
438                                 $unit eq 'N' ? EARTH_RADIUS_NM :
439                                 EARTH_RADIUS_MILES;
440
441        # Haversine formula
442
22
29
        my $dlat = deg2rad($lat2 - $lat1);
443
22
108
        my $dlon = deg2rad($lon2 - $lon1);
444
22
87
        my $a = sin($dlat/2)**2 + cos(deg2rad($lat1)) * cos(deg2rad($lat2)) * sin($dlon/2)**2;
445
22
138
        my $c = 2 * asin(sqrt($a));
446
447
22
87
        return $radius * $c;
448}
449
450# Singleton shared across all callers; lazy-initialised on first use.
451my $abbreviations;
452
453 - 463
=head2 _normalize

Normalise a street name to its abbreviated canonical form.  Uppercases the
input, then abbreviates the second-to-last or last word (whichever is a
recognised street type) using C<Geo::Coder::Abbreviations>.  Leading zeros
are also stripped (C<"04th St"> -> C<"4th St">).

Exported so that C<Local.pm> and C<OpenAddresses.pm> can call it without
importing C<Geo::Coder::Free>.

=cut
464
465sub _normalize {
466
19
19
18907
        my $street = uc(shift);
467
19
67
58
        $abbreviations ||= Geo::Coder::Abbreviations->new();
468
469
19
286078
        my @words = split /\s+/, $street;
470
19
100
100
32
        if (@words >= 3) {
471
8
8
                my $a;
472
8
100
100
100
32
                if (lc($words[-2]) ne 'cross' && ($a = $abbreviations->abbreviate($words[-2]))) {
473
2
11
                        $words[-2] = $a;
474                } elsif ($a = $abbreviations->abbreviate($words[-1])) {
475
4
64
                        $words[-1] = $a;
476                }
477
8
30
                $street = join ' ', @words;
478        } elsif (@words == 2) {
479
9
100
19
                if (my $a = $abbreviations->abbreviate($words[-1])) {
480
8
31
                        $street = "$words[0] $a";
481                }
482        }
483
19
34
        $street =~ s/^0+//;
484
19
32
        return $street;
485}
486
487 - 495
=head2 _abbreviate

Abbreviate a single street-type word (e.g. C<"Street"> -> C<"ST">).  Returns
the original word uppercased if no abbreviation is found.

Exported so that C<Local.pm> and C<OpenAddresses.pm> can call it without
importing C<Geo::Coder::Free>.

=cut
496
497sub _abbreviate {
498
17
17
6651
        my $type = uc(shift);
499
17
67
46
        $abbreviations ||= Geo::Coder::Abbreviations->new();
500
17
67
17240
        return $abbreviations->abbreviate($type) || $type;
501}
502
503
5041;
505