File Coverage

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

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.03

=cut
22
23our $VERSION = '0.03';
24
25
18
18
18
134895
25
use v5.20;
26
18
18
18
18
26
14
147
use strict;
27
18
18
18
18
24
13
369
use warnings;
28
18
18
18
18
33
25
1373
use feature qw(signatures);
29
18
18
18
18
40
16
238
no warnings qw(experimental::signatures);
30
31
18
18
18
18
27
18
451
use Exporter qw(import);
32our @EXPORT = qw(create_disc_cache create_memory_cache distance _abbreviate _normalize);
33our @EXPORT_OK = qw(_abbreviate _normalize);
34
35
18
18
18
18
4857
559643
284
use CHI;
36
18
18
18
18
63
16
470
use Data::Dumper;
37
18
18
18
18
5821
807104
317
use Geo::Coder::Abbreviations;
38
18
18
18
18
15706
135452
664
use DBI;
39
18
18
18
18
4701
1123
73
use Error::Simple;
40
18
18
18
18
300
11
99
use Module::Runtime qw(require_module); # Safe dynamic loading; avoids string eval
41
18
18
18
18
886
17040
252
use Params::Get 0.13;
42
18
18
18
18
35
12
387
use Try::Tiny;
43
18
18
18
18
26
15
325
use Carp qw(croak carp);
44
18
18
18
18
45
14
293
use Scalar::Util qw(looks_like_number);
45
18
18
18
18
4179
95734
899
use Math::Trig qw(deg2rad rad2deg asin great_circle_distance);
46
47# Constants for distance calculations
48use constant {
49
18
26376
        EARTH_RADIUS_MILES => 3959,
50        EARTH_RADIUS_KM => 6371,
51        EARTH_RADIUS_NM => 3440,
52        KM_PER_MILE => 1.609344,
53        NM_PER_MILE => 0.8684
54
18
18
18
60
22
};
55
56 - 109
=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
110
111sub create_disc_cache {
112
13
13
1
115809
        my $args = Params::Get::get_params(undef, @_);
113
13
244
        return _create_cache('disc_cache', $args);
114}
115
116 - 129
=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
130
131sub create_memory_cache {
132
9
9
1
10138
        my $args = Params::Get::get_params(undef, @_);
133
9
140
        return _create_cache('memory_cache', $args);
134}
135
136# Private helper functions
137
138
22
22
22
22
22
34
25
20
14
sub _create_cache($cache_type, $args) {
139
22
27
        my $config = $args->{'config'};
140
22
100
62
        throw Error::Simple('config is not optional') unless($config);
141
142
18
39
        _validate_cache_config($config, $cache_type);
143
144
12
13
        my $logger = $args->{'logger'};
145
12
100
33
        my $cache_config = $config->{$cache_type} || {};
146
12
14
        my $driver = $cache_config->{driver};
147
148        # Set default driver with fallback strategy
149
12
100
37
        unless (defined $driver) {
150
2
7
                $driver = _get_default_driver($cache_type, $logger);
151
2
50
5
                if ($logger) {
152
0
0
                        $logger->info("No driver specified for $cache_type, using $driver");
153                }
154        }
155
156        # Validate driver is available
157
12
100
26
        unless (_is_driver_available($driver)) {
158
2
6
                my $fallback = _get_fallback_driver($cache_type);
159
2
50
3
                if ($logger) {
160
0
0
                        $logger->warn("Driver $driver not available, falling back to $fallback");
161                }
162
2
3
                $driver = $fallback;
163        }
164
165        # Build CHI arguments
166
12
49
        my %chi_args = _build_chi_args($driver, $cache_config, $args, $logger, $cache_type);
167
168        # Create cache with error handling
169
8
9
        my $cache;
170        try {
171
8
8
416
                $cache = CHI->new(%chi_args);
172        } catch {
173
0
0
0
                my $error = "Failed to create $cache_type cache with driver $driver: $_";
174
0
0
0
                $logger->error($error) if $logger;
175
0
0
                throw Error::Simple($error);
176
8
53
        };
177
178
8
99903
        return $cache;
179}
180
181
18
18
18
18
18
18
15
15
17
sub _validate_cache_config($config, $cache_type) {
182
18
100
29
        return unless exists $config->{$cache_type};
183
184
16
18
        my $cache_config = $config->{$cache_type};
185
16
100
36
        croak('Cache configuration must be a hash reference')
186                unless ref($cache_config) eq 'HASH';
187
188        # Validate driver if specified
189
14
50
33
        if (exists $cache_config->{driver}) {
190
14
14
                my $driver = $cache_config->{driver};
191
14
37
                my @valid_drivers = qw(Memory BerkeleyDB DBI Redis Memcached SharedMem File Null);
192                croak "Invalid driver '$driver'. Valid drivers: " . join(', ', @valid_drivers)
193
14
112
100
14
92
                        unless grep { $_ eq $driver } @valid_drivers;
194        }
195
196        # Validate numeric parameters
197
13
20
        for my $param (qw(port shm_size max_size)) {
198
37
100
45
                next unless exists $cache_config->{$param};
199
2
3
                my $value = $cache_config->{$param};
200
2
100
50
14
                croak "$param must be a positive integer"
201                        unless defined $value && $value =~ /^\d+$/ && $value > 0;
202        }
203
204        # Validate port range
205
12
100
24
        if (exists $cache_config->{port}) {
206
1
2
                my $port = $cache_config->{port};
207
1
50
33
8
                croak('Port must be between 1 and 65535')
208                        unless $port >= 1 && $port <= 65535;
209        }
210
211        # Validate memory parameters
212
11
50
50
30
        if(exists($cache_config->{'datastore'}) && exists($cache_config->{'global'}) && (my $driver = $cache_config->{'driver'})) {
213                # CHI catches this as well, but putting it here helps to track the error
214
1
4
                croak('Memory cache cannot have both global and datastore');
215        }
216}
217
218
2
2
2
2
2
53
12
1
1
sub _get_default_driver($cache_type, $logger) {
219        # Allow override for testing
220
2
4
        my $env_var = 'TEST_' . uc($cache_type) . '_DRIVER';
221
2
50
5
        return $ENV{$env_var} if $ENV{$env_var};
222
223        # Production defaults
224
2
100
4
        return $cache_type eq 'disc_cache' ? 'BerkeleyDB' : 'Memory';
225}
226
227
2
2
2
2
3
2
1
sub _get_fallback_driver($cache_type) {
228
2
50
5
        return $cache_type eq 'disc_cache' ? 'File' : 'Memory';
229}
230
231
12
12
12
12
10
11
9
sub _is_driver_available($driver) {
232
12
100
91
        return 1 if $driver =~ /^(Memory|Null)$/;
233
234
7
33
        my %driver_modules = (
235                'DBI' => 'CHI::Driver::DBI',
236                'BerkeleyDB' => 'CHI::Driver::BerkeleyDB',
237                'File' => 'CHI::Driver::File',
238                'Memcached' => 'CHI::Driver::Memcached',
239                'SharedMem' => 'CHI::Driver::SharedMem',
240                'Redis' => 'CHI::Driver::Redis'
241        );
242
243
7
50
15
        return 1 unless exists $driver_modules{$driver};
244
245
7
100
46
        if($driver_modules{$driver}->can('new')) {
246
1
3
                return 1;
247        }
248        # SECURITY — string-eval elimination:
249        #   eval "require $module_name" is a string eval; if $driver ever escaped
250        #   the hash-key whitelist (e.g. through a future regression in the caller),
251        #   it could execute arbitrary code.  A block eval with require_module() is
252        #   semantically identical but has no string-eval surface.
253
6
6
8
24
        eval { require_module($driver_modules{$driver}) };
254
6
100
54519
        if($@) {
255
2
4
                return 0;
256        }
257
4
28
        $driver_modules{$driver}->import();
258
4
18
        return 1;
259}
260
261
12
12
12
12
12
12
12
12
13
13
10
10
7
13
8
sub _build_chi_args($driver, $cache_config, $args, $logger, $cache_type) {
262        my %chi_args = (
263                driver => $driver,
264
12
100
43
                namespace => $args->{'namespace'} || 'default'
265        );
266
267        # Configure error handling
268
12
50
33
27
        if ($logger && $logger->can('error')) {
269
0
0
0
0
0
                $chi_args{on_get_error} = sub { $logger->warn("Cache get error: $_[0]") };
270
0
0
0
0
0
                $chi_args{on_set_error} = sub { $logger->error("Cache set error: $_[0]") };
271        } else {
272
12
22
                $chi_args{on_get_error} = 'warn';
273
12
18
                $chi_args{on_set_error} = 'die';
274        }
275
276        # Driver-specific configuration
277
12
50
50
50
100
50
100
70
        if ($driver eq 'Redis') {
278
0
0
                _configure_redis(\%chi_args, $cache_config, $args, $logger);
279        } elsif ($driver eq 'DBI') {
280
0
0
                _configure_dbi(\%chi_args, $cache_config, $args, $logger);
281        } elsif ($driver eq 'SharedMem') {
282
0
0
                _configure_shared_memory(\%chi_args, $cache_config, $args);
283        } elsif ($driver eq 'Memory') {
284
1
3
                _configure_memory(\%chi_args, $cache_config);
285        } elsif ($driver eq 'Memcached') {
286
0
0
                _configure_memcached(\%chi_args, $cache_config, $args, $logger);
287        } elsif ($driver !~ /^(Null)$/) {
288
7
15
                _configure_file_based(\%chi_args, $cache_config, $args);
289        }
290
291
8
21
        return %chi_args;
292}
293
294
0
0
0
0
0
0
0
0
0
0
0
0
0
sub _configure_redis($chi_args, $config, $args, $logger) {
295        # Parse server configuration
296
0
0
        my @servers = _parse_server_config($config, $logger);
297
0
0
0
        if (@servers) {
298
0
0
                $chi_args->{servers} = \@servers;
299
0
0
                $chi_args->{server} = $servers[0];   # Primary server
300        }
301
302        # Redis-specific options with sensible defaults
303        $chi_args->{redis_options} = {
304                reconnect => $config->{reconnect} || 60,
305                every => $config->{every} || 1_000_000,
306                encoding => $config->{encoding} || 'utf8',
307
0
0
0
0
0
0
0
0
                %{$config->{redis_options} || {}}
308        };
309}
310
311
0
0
0
0
0
0
0
0
0
0
0
0
0
sub _configure_dbi($chi_args, $config, $args, $logger) {
312
0
0
        my $connect_string = $config->{connect};
313
0
0
0
        croak "DBI driver requires 'connect' parameter" unless $connect_string;
314
315
0
0
        my $dbh;
316        try {
317
0
0
0
                $dbh = DBI->connect($connect_string, '', '', {
318                        RaiseError => 1,
319                        PrintError => 0,
320                        AutoCommit => 1
321                });
322        } catch {
323
0
0
0
                my $error = "Failed to connect to database: $_";
324
0
0
0
                $logger->error($error) if $logger;
325
0
0
                croak $error;
326
0
0
        };
327
328
0
0
        $chi_args->{dbh} = $dbh;
329
0
0
0
        $chi_args->{create_table} = $config->{create_table} // 1;
330}
331
332
0
0
0
0
0
0
0
0
0
0
0
sub _configure_shared_memory($chi_args, $config, $args) {
333        $chi_args->{shm_key} = $args->{'shm_key'} || $config->{shm_key}
334
0
0
0
                || croak "SharedMem driver requires 'shm_key' parameter";
335
336
0
0
0
        $chi_args->{shm_size} = $args->{'shm_size'} || $config->{shm_size} || 16 * 1024;
337
0
0
0
        $chi_args->{max_size} = $args->{'max_size'} || $config->{max_size} || 1024;
338}
339
340
1
1
sub _configure_memory($chi_args, $config)
341
1
1
1
1
1
1
1
{
342
1
50
2
        if(exists $config->{'global'}) {
343
0
0
                $chi_args->{'global'} = $config->{'global'};
344        } else {
345
1
2
                $chi_args->{'datastore'} = {};
346        }
347}
348
349
0
0
0
0
0
0
0
0
0
0
0
0
0
sub _configure_memcached($chi_args, $config, $args, $logger) {
350
0
0
        my @servers = _parse_server_config($config, $logger);
351
0
0
0
        if (@servers) {
352
0
0
                $chi_args->{servers} = \@servers;
353        } else {
354                # Default to localhost
355
0
0
                $chi_args->{servers} = ['127.0.0.1:11211'];
356
0
0
0
                $logger->debug('Using default Memcached server: 127.0.0.1:11211') if $logger;
357        }
358}
359
360
7
7
7
7
7
7
10
5
6
6
7
sub _configure_file_based($chi_args, $config, $args) {
361
7
67
40
        my $root_dir = $ENV{'root_dir'} || $args->{'root_dir'} || $config->{root_dir} || $args->{'config'}->{root_dir};
362
363
7
100
77
        croak "File-based cache drivers require 'root_dir' parameter" unless $root_dir;
364
4
100
67
77
        croak "Root directory '$root_dir' does not exist or is not writable"
365                unless -d $root_dir && -w $root_dir;
366
367
3
5
        $chi_args->{root_dir} = $root_dir;
368}
369
370
0
0
0
0
0
0
0
0
0
sub _parse_server_config($config, $logger) {
371        # Handle host/server naming inconsistency
372
0
0
0
        my $server_config = $config->{server} || $config->{host};
373
0
0
0
        return () unless $server_config;
374
375
0
0
        my @servers;
376
0
0
        for my $server_entry (split /,/, $server_config) {
377
0
0
                $server_entry =~ s/^\s+|\s+$//g;        # trim whitespace
378
379                # If no port specified, add default port
380
0
0
0
                unless ($server_entry =~ /:/) {
381
0
0
0
                        my $port = $config->{port} || croak "Port not specified for server '$server_entry'";
382
0
0
                        $server_entry .= ":$port";
383                }
384
385                # Validate server format
386
0
0
0
                if ($server_entry =~ /^([a-zA-Z0-9.-]+):(\d+)$/) {
387
0
0
                        my ($host, $port) = ($1, $2);
388
0
0
0
0
                        croak "Invalid port number: $port" unless $port > 0 && $port <= 65535;
389
0
0
                        push @servers, $server_entry;
390
0
0
0
                        $logger->debug("Added server: $server_entry") if $logger;
391                } else {
392
0
0
                        croak "Invalid server format: '$server_entry' (expected host:port)";
393                }
394        }
395
396
0
0
        return @servers;
397}
398
399 - 413
=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
414
415
61
61
61
61
61
61
61
61
1
46213
48
31
39
35
52
28
sub distance($lat1, $lon1, $lat2, $lon2, $unit = 'M') {
416        # Input validation
417
61
98
        for my $coord_ref ([\$lat1, 'lat1'], [\$lon1, 'lon1'], [\$lat2, 'lat2'], [\$lon2, 'lon2']) {
418
215
119
                my ($coord, $name) = @$coord_ref;
419
215
100
184
                croak "$name must be defined" unless defined $$coord;
420
208
100
215
                croak "$name must be numeric" unless looks_like_number($$coord);
421        }
422
423        # Range validation
424
47
100
100
130
        croak('Latitude must be between -90 and 90 degrees')
425                if abs($lat1) > 90 || abs($lat2) > 90;
426
38
100
100
81
        croak('Longitude must be between -180 and 180 degrees')
427                if abs($lon1) > 180 || abs($lon2) > 180;
428
429        # Handle identical points
430
30
100
100
45
        return 0 if $lat1 == $lat2 && $lon1 == $lon2;
431
432        # Validate unit
433
25
100
40
        $unit = uc($unit || 'M');
434
25
100
50
        croak "Unknown unit '$unit'. Use 'K', 'N', or 'M'"
435                unless $unit =~ /^[KNM]$/;
436
437        # Use optimized calculation with appropriate radius
438
22
100
100
41
        my $radius = $unit eq 'K' ? EARTH_RADIUS_KM :
439                                 $unit eq 'N' ? EARTH_RADIUS_NM :
440                                 EARTH_RADIUS_MILES;
441
442        # Haversine formula
443
22
40
        my $dlat = deg2rad($lat2 - $lat1);
444
22
135
        my $dlon = deg2rad($lon2 - $lon1);
445
22
97
        my $a = sin($dlat/2)**2 + cos(deg2rad($lat1)) * cos(deg2rad($lat2)) * sin($dlon/2)**2;
446
22
162
        my $c = 2 * asin(sqrt($a));
447
448
22
93
        return $radius * $c;
449}
450
451# Singleton shared across all callers; lazy-initialised on first use.
452my $abbreviations;
453
454 - 464
=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
465
466sub _normalize {
467
19
19
17782
        my $street = uc(shift);
468
19
67
78
        $abbreviations ||= Geo::Coder::Abbreviations->new();
469
470
19
219859
        my @words = split /\s+/, $street;
471
19
100
100
48
        if (@words >= 3) {
472
8
5
                my $a;
473
8
100
100
100
41
                if (lc($words[-2]) ne 'cross' && ($a = $abbreviations->abbreviate($words[-2]))) {
474
2
10
                        $words[-2] = $a;
475                } elsif ($a = $abbreviations->abbreviate($words[-1])) {
476
4
29
                        $words[-1] = $a;
477                }
478
8
42
                $street = join ' ', @words;
479        } elsif (@words == 2) {
480
9
100
27
                if (my $a = $abbreviations->abbreviate($words[-1])) {
481
8
76
                        $street = "$words[0] $a";
482                }
483        }
484
19
33
        $street =~ s/^0+//;
485
19
47
        return $street;
486}
487
488 - 496
=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
497
498sub _abbreviate {
499
15
15
5922
        my $type = uc(shift);
500
15
67
53
        $abbreviations ||= Geo::Coder::Abbreviations->new();
501
15
67
9050
        return $abbreviations->abbreviate($type) || $type;
502}
503
5041;
505