From 0bc578d6d334c7f1ccaf329cd61bb8bce76b7f59 Mon Sep 17 00:00:00 2001 From: Murilo Ijanc Date: Sun, 26 Jul 2026 14:40:05 -0300 Subject: Initial import --- .gitignore | 14 ++ LICENSE | 15 ++ MANIFEST | 21 ++ Makefile | 69 ++++++ Makefile.PL | 60 +++++ README.md | 293 +++++++++++++++++++++++ lib/Cepis.pm | 184 +++++++++++++++ lib/Cepis/Address.pm | 213 +++++++++++++++++ lib/Cepis/CSV.pm | 165 +++++++++++++ lib/Cepis/Client.pm | 652 +++++++++++++++++++++++++++++++++++++++++++++++++++ lib/Cepis/Error.pm | 226 ++++++++++++++++++ lib/Cepis/Geo.pm | 148 ++++++++++++ lib/Cepis/Health.pm | 138 +++++++++++ t/00-load.t | 42 ++++ t/01-normalize.t | 32 +++ t/02-csv.t | 105 +++++++++ t/03-lookup.t | 187 +++++++++++++++ t/04-retry.t | 147 ++++++++++++ t/05-batch.t | 146 ++++++++++++ t/06-health.t | 58 +++++ t/07-config.t | 63 +++++ t/08-tls.t | 58 +++++ t/lib/TestServer.pm | 298 +++++++++++++++++++++++ 23 files changed, 3334 insertions(+) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 Makefile create mode 100644 Makefile.PL create mode 100644 README.md create mode 100644 lib/Cepis.pm create mode 100644 lib/Cepis/Address.pm create mode 100644 lib/Cepis/CSV.pm create mode 100644 lib/Cepis/Client.pm create mode 100644 lib/Cepis/Error.pm create mode 100644 lib/Cepis/Geo.pm create mode 100644 lib/Cepis/Health.pm create mode 100644 t/00-load.t create mode 100644 t/01-normalize.t create mode 100644 t/02-csv.t create mode 100644 t/03-lookup.t create mode 100644 t/04-retry.t create mode 100644 t/05-batch.t create mode 100644 t/06-health.t create mode 100644 t/07-config.t create mode 100644 t/08-tls.t create mode 100644 t/lib/TestServer.pm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..3b2906d --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ +/blib/ +/Makefile.mm +/Makefile.mm.old +/pm_to_blib +/MYMETA.yml +/MYMETA.json +/META.yml +/META.json +/Cepis-[0-9]*/ +/Cepis-[0-9]*.tar.gz +*.bak +*.old +/cover_db/ +/nytprof.out diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5e9104d --- /dev/null +++ b/LICENSE @@ -0,0 +1,15 @@ +ISC License + +Copyright (c) 2026 Murilo Ijanc + +Permission to use, copy, modify, and/or distribute this software for any +purpose with or without fee is hereby granted, provided that the above +copyright notice and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY +AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM +LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR +OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR +PERFORMANCE OF THIS SOFTWARE. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..115bae1 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,21 @@ +LICENSE +MANIFEST +Makefile.PL +README.md +lib/Cepis.pm +lib/Cepis/Address.pm +lib/Cepis/CSV.pm +lib/Cepis/Client.pm +lib/Cepis/Error.pm +lib/Cepis/Geo.pm +lib/Cepis/Health.pm +t/00-load.t +t/01-normalize.t +t/02-csv.t +t/03-lookup.t +t/04-retry.t +t/05-batch.t +t/06-health.t +t/07-config.t +t/08-tls.t +t/lib/TestServer.pm diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..ab66dd1 --- /dev/null +++ b/Makefile @@ -0,0 +1,69 @@ +# Development tasks. Everything runs through the perl that is on PATH — the +# library and its suite use only core modules, so there is nothing to install +# first. +# +# make list the targets +# make test run the suite with prove +# make lint perl -c over the tree, no files touched +# make build build the distribution tarball +# +# This file is a convenience for working in the repository. It is not shipped: +# the tarball carries only Makefile.PL, so installing follows the usual +# `perl Makefile.PL && make && make test && make install`. That is also why +# `build` below hands FIRST_MAKEFILE to Makefile.PL — without it, ExtUtils:: +# MakeMaker would write over this file. +PERL ?= perl +PROVE ?= prove + +MODULES := $(shell find lib -name '*.pm' | sort) +TESTS := $(shell find t -name '*.t' | sort) +HELPERS := $(shell find t/lib -name '*.pm' | sort) +MM := Makefile.mm +VERSION := $(shell $(PERL) -Ilib -MCepis -e 'print $$Cepis::VERSION') + +.DEFAULT_GOAL := help +.PHONY: help test lint format build check clean + +help: + @echo 'Targets:' + @echo ' test run the test suite' + @echo ' lint perl -c over the tree, plus perlcritic when installed' + @echo ' format apply perltidy, when installed (writes)' + @echo ' build build Cepis-$(VERSION).tar.gz' + @echo ' check lint + test + build, in that order' + @echo ' clean remove build artefacts' + +test: + $(PROVE) -l $(TESTS) + +# Read-only by design, so it is safe in CI and in a pre-commit hook: it reports +# what `make format` would change without changing anything. Perl ships no +# linter or formatter in its core, and this distribution depends on neither, so +# perlcritic is used only when it happens to be installed. +lint: + @set -e; for f in $(MODULES) $(HELPERS) $(TESTS) Makefile.PL; do \ + $(PERL) -Ilib -It/lib -c $$f >/dev/null 2>&1 \ + || { echo "syntax error in $$f"; $(PERL) -Ilib -It/lib -c $$f; exit 1; }; \ + done + @echo 'syntax OK: $(words $(MODULES) $(HELPERS) $(TESTS)) files + Makefile.PL' + @if command -v perlcritic >/dev/null 2>&1; then perlcritic --quiet lib t; else \ + echo 'perlcritic not installed: perl -c syntax checks only'; fi + +format: + @if command -v perltidy >/dev/null 2>&1; then \ + perltidy -b -bext=/ $(MODULES) $(HELPERS) $(TESTS) Makefile.PL; else \ + echo 'perltidy not installed: nothing to format with'; fi + +build: + $(PERL) Makefile.PL FIRST_MAKEFILE=$(MM) >/dev/null + $(MAKE) -f $(MM) dist + +# The order matters: lint is the fastest to fail, build the slowest, so a +# broken run reports the cheapest problem first. +check: lint test build + +clean: + @if [ -f $(MM) ]; then $(MAKE) -f $(MM) distclean >/dev/null 2>&1 || true; fi + rm -rf blib Cepis-[0-9]* + rm -f $(MM) $(MM).old pm_to_blib MYMETA.yml MYMETA.json META.yml META.json + find . -name '*.bak' -delete diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..e4cdf4c --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,60 @@ +use strict; +use warnings; + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => 'Cepis', + VERSION_FROM => 'lib/Cepis.pm', + ABSTRACT_FROM => 'lib/Cepis.pm', + AUTHOR => 'Murilo Ijanc ', + LICENSE => 'open_source', + MIN_PERL_VERSION => '5.014', + + PREREQ_PM => { + 'Carp' => 0, + 'Encode' => 0, + 'Exporter' => '5.57', + 'HTTP::Tiny' => '0.043', + 'JSON::PP' => '2.27300', + 'Scalar::Util' => 0, + 'Time::HiRes' => 0, + 'constant' => 0, + 'overload' => 0, + 'parent' => 0, + }, + + TEST_REQUIRES => { + 'Fcntl' => 0, + 'FindBin' => 0, + 'IO::Socket::INET' => 0, + 'POSIX' => 0, + 'Test::More' => '0.88', + 'lib' => 0, + 'utf8' => 0, + }, + + META_MERGE => { + 'meta-spec' => { version => 2 }, + resources => { + homepage => 'https://cep.is', + repository => { + type => 'git', + url => 'https://git.cep.is/perl.git', + web => 'https://git.cep.is/perl', + }, + }, + prereqs => { + runtime => { + recommends => { + 'IO::Socket::SSL' => '1.968', + 'Net::SSLeay' => '1.49', + }, + }, + }, + no_index => { directory => ['t'] }, + }, + + dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, + clean => { FILES => 'Cepis-*' }, +); diff --git a/README.md b/README.md new file mode 100644 index 0000000..b799f45 --- /dev/null +++ b/README.md @@ -0,0 +1,293 @@ +# Cepis + +Perl client for the [public CEP API at cep.is](https://cep.is). Official +Correios data (DNE), refreshed every two weeks. No non-core dependencies: +`HTTP::Tiny`, `JSON::PP` and `Encode` ship with Perl, and the CSV reader is part +of the distribution. + +```perl +use Cepis; + +my $address = Cepis::lookup('01001-000'); +printf "%s %s %s\n", $address->logradouro, $address->localidade, $address->uf; +# Praça da Sé São Paulo SP +``` + +## Installation + +```sh +perl Makefile.PL +make +make test +make install +``` + +Requires Perl 5.14 or newer — that is when `HTTP::Tiny` and `JSON::PP` entered +the core. + +### HTTPS needs two modules that Perl does not ship + +The library itself needs nothing from CPAN, but **reaching `https://cep.is` +does**. `HTTP::Tiny` speaks TLS only when both of these are installed: + +| module | minimum version | +| --- | --- | +| `IO::Socket::SSL` | 1.968 | +| `Net::SSLeay` | 1.49 | + +Neither is a core module. Without them every call against the default +`base_url` fails, so install them alongside this distribution: + +```sh +cpanm IO::Socket::SSL Net::SSLeay +# or, from your distribution's packages: +# Debian/Ubuntu apt install libio-socket-ssl-perl libnet-ssleay-perl +# Arch pacman -S perl-io-socket-ssl perl-net-ssleay +# Alpine apk add perl-io-socket-ssl perl-net-ssleay +# OpenBSD pkg_add p5-IO-Socket-SSL p5-Net-SSLeay +``` + +The client checks for them before it opens a socket and, when they are missing, +throws `Cepis::Error::Network` immediately with a message naming both — rather +than letting a bare `HTTP::Tiny` internal error surface: + +``` +cannot reach https://cep.is/01001000: HTTP::Tiny has no HTTPS support on this +Perl. It needs IO::Socket::SSL 1.968 or later and Net::SSLeay 1.49 or later, +and neither of those ships with Perl. Install both (...), or point base_url at +an http:// instance. HTTP::Tiny reports: ... +``` + +To check without making a request: + +```perl +my ( $ok, $why ) = Cepis::Client::tls_available(); +``` + +Plain HTTP — a local instance, a test server — works on a stock Perl with +nothing installed. + +## Usage + +### A single lookup + +`lookup` accepts the CEP masked or unmasked and returns a `Cepis::Address`: + +```perl +my $a = Cepis::lookup('01310-100'); + +$a->logradouro; # "Avenida Paulista" +$a->localidade; # "São Paulo" +$a->uf; # "SP" +$a->ibge; # "3550308" +$a->cep; # "01310100" (always unmasked) +$a->formatted_cep; # "01310-100" +``` + +Fields the database does not have for that CEP come back as empty strings, never +`undef`. `$a->field('name')` reads any field of the raw response, including one +the API grew after this release. + +Perl does not distinguish a number from a string, so keep CEPs in strings: the +literal `01001000` loses its leading zero before this library ever sees it. + +### Coordinates + +About 57% of CEPs have a coordinate. When they do not, `geo` is `undef`: + +```perl +my $a = Cepis::lookup('01310100'); + +if ( my $geo = $a->geo ) { + printf "%s %s\n", $geo->lat, $geo->lon; # -23.567202 -46.649659 + print $geo->raio_m, "\n"; # 1084 + print $geo->precisao, "\n"; # "logradouro" +} +``` + +**Check `precisao` before computing distance.** There are two kinds of point, +and the difference between them is tens of kilometres: + +| `precisao` | typical radius | what the point is | +| --- | --- | --- | +| `logradouro` | 110–140 m | the stretch of street — good for maps and distance | +| `localidade` | 7–40 km | the municipality centroid: the CEP *is* the whole city | + +`$geo->is_precise` is the shorthand for `precisao eq 'logradouro'`: + +```perl +my $cost + = $a->geo && $a->geo->is_precise + ? shipping_from( $a->geo->lat, $a->geo->lon ) + : shipping_from_municipality( $a->ibge ); +``` + +### Many CEPs at once + +Do not loop over `lookup`. Use `lookup_many`, which resolves up to 500 CEPs per +request: + +```perl +my @ceps = qw(01001000 99999999 20040020); +my $result = Cepis::lookup_many( \@ceps ); + +for my $i ( 0 .. $#ceps ) { + print defined $result->[$i] + ? "$ceps[$i]: " . $result->[$i]->localidade . "\n" + : "$ceps[$i]: not found\n"; +} +``` + +The returned arrayref has **the same length and the same order** as the input. A +CEP that does not exist, or is malformed, is `undef` at its position — it does +not vanish, and it does not throw. + +A Perl array holds `undef` at any position without shortening, so nothing is +dropped and nothing shifts: `$result->[$i]` always corresponds to `$ceps[$i]`. +That is worth stating because it is not true everywhere — in Lua, for instance, +a nil in a table truncates it. Here `scalar @$result == scalar @ceps` always +holds, and `grep { defined } @$result` is how you discard the misses when the +pairing no longer matters. + +Lists longer than 500 are chunked automatically. + +> **Batches carry no coordinate.** The endpoint behind them is CSV, and the CSV +> has no `geo` column. Every `Cepis::Address` from `lookup_many` has `geo` set +> to `undef`, including for CEPs that do have one. Need `geo`? Use `lookup`, one +> at a time. + +### API health + +Useful for two things: checking the API answers, and knowing **which version of +the database** is live: + +```perl +my $h = Cepis::health(); + +$h->ok; # 1 +$h->dne; # "26071" identifier of the fortnightly database +$h->ceps; # 1596168 +$h->base_gerada_em; # "2026-07-24T03:48:28Z" +``` + +An API reporting itself degraded does not throw — that arrives in `$h->status`. + +## Configuration + +For anything beyond the defaults, build a `Cepis::Client` and reuse it. It keeps +no state between calls: + +```perl +use Cepis::Client; + +my $client = Cepis::Client->new( + base_url => 'https://cep.is', # point at another instance + timeout => 10.0, # seconds per socket operation + max_attempts => 3, # counting the first; 1 disables retrying + backoff_base => 0.5, # base of the exponential wait + backoff_max => 8.0, # cap on each wait + total_timeout => undef, # cap on the whole call, attempts included + user_agent => undef, # defaults to cepis-perl/ +); + +my $address = $client->lookup('01001000'); +``` + +`timeout` bounds each socket operation, not the whole call — that cap is +`total_timeout`, and without it the worst case is `max_attempts * timeout` plus +the sum of the backoffs. + +Retries cover 429, 5xx and network failures, with exponential backoff and full +jitter; 400 and 404 are never retried. + +The module-level functions (`Cepis::lookup`, and so on) share one default +client, reachable as `Cepis::default_client()`. It applies process-wide, +including to third-party libraries that also use this module. Need a different +configuration? Build your own. + +Each client holds one `HTTP::Tiny`, which is not shared between threads. Give +each thread its own client. + +### Pointing at a local instance + +`base_url` is the only setting that usually changes between environments. The +API repo brings a local instance up with `just up`: + +```perl +my $client = Cepis::Client->new( base_url => 'http://localhost:8080' ); +``` + +## Errors + +Every failure is thrown as an object under `Cepis::Error`, so one test catches +the lot. Below that, the split is by **the decision you have to make**, not by +the HTTP status that caused it: + +| error | when | does retrying help? | +| --- | --- | --- | +| `Cepis::Error::InvalidCEP` | not 8 digits | no | +| `Cepis::Error::CEPNotFound` | well-formed, not in the database | no | +| `Cepis::Error::RateLimited` | 429 | yes, later | +| `Cepis::Error::ServerError` | 5xx | yes, later | +| `Cepis::Error::Network` | DNS, connection, timeout, TLS | yes, later | +| `Cepis::Error::InvalidResponse` | unintelligible response | probably not | + +```perl +my $address = eval { Cepis::lookup($cep_from_form) }; +if ( !$address ) { + my $err = $@; + if ( ref $err && $err->isa('Cepis::Error::CEPNotFound') ) { + # ask the user for another CEP + } + elsif ( ref $err && $err->isa('Cepis::Error') ) { + # transient failure: reschedule + } + else { + die $err; + } +} +``` + +Errors stringify to their message, so `warn $err` and `"$err"` do the obvious +thing. `$err->retry_after` carries what the server asked for, in seconds, and +`$err->status` the HTTP status of the last attempt. + +`Cepis::Error::InvalidResponse` almost always means something between you and +the API is answering instead of it — a captive Wi-Fi portal, a corporate proxy, +an HTML error page. Useful as a diagnosis: the problem is not in your code. + +A bad argument to `Cepis::Client->new` is a `croak`, not a `Cepis::Error`: that +is a programming error, not a failed lookup. + +## Development + +Everything runs through `make` and the `perl` on your `PATH`. There is nothing +to install: the distribution and its suite use only core modules, and the tests +bring up a real HTTP server on loopback. + +```sh +make # list the targets +make test # run the suite with prove +make lint # perl -c over lib, t and Makefile.PL +make build # build Cepis-0.1.0.tar.gz +make check # lint, then test, then build +``` + +`prove -l t/` works too. + +Perl ships no linter or formatter in its core, and this distribution depends on +neither. `make lint` is therefore a `perl -c` compile check; if `perlcritic` +happens to be installed it is run as well, and `make format` applies `perltidy` +when that is installed. Neither is installed here, so `make lint` reports the +syntax checks only. + +The `Makefile` in the repository is for development only and is not shipped. +The tarball carries `Makefile.PL`, so installing from it is the usual +`perl Makefile.PL && make && make test && make install`. + +Documentation lives in POD on the public API: `perldoc lib/Cepis.pm`, +`perldoc lib/Cepis/Client.pm`. + +## Licence + +ISC. See [LICENSE](LICENSE). diff --git a/lib/Cepis.pm b/lib/Cepis.pm new file mode 100644 index 0000000..224d80d --- /dev/null +++ b/lib/Cepis.pm @@ -0,0 +1,184 @@ +package Cepis; + +use strict; +use warnings; + +use Exporter 5.57 qw(import); + +use Cepis::Address; +use Cepis::Client; +use Cepis::Error; +use Cepis::Geo; +use Cepis::Health; + +our $VERSION = '0.1.0'; + +our @EXPORT_OK = qw(lookup lookup_many health normalize_cep); + +my $DEFAULT_CLIENT; + +sub default_client { + $DEFAULT_CLIENT = Cepis::Client->new unless defined $DEFAULT_CLIENT; + return $DEFAULT_CLIENT; +} + +sub lookup { + return default_client()->lookup(@_); +} + +sub lookup_many { + return default_client()->lookup_many(@_); +} + +sub health { + return default_client()->health; +} + +sub normalize_cep { + return Cepis::Client::normalize_cep(@_); +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis - Perl client for the public CEP API at cep.is + +=head1 SYNOPSIS + + use Cepis; + + my $address = Cepis::lookup('01001-000'); + print $address->localidade, ' ', $address->uf, "\n"; # São Paulo SP + + my $result = Cepis::lookup_many( [ '01001000', '99999999' ] ); + print defined $result->[1] ? 'found' : 'not found', "\n"; + + my $health = Cepis::health(); + print $health->dne, "\n"; + +=head1 DESCRIPTION + +Looks Brazilian postal codes up against L: official Correios +data (DNE), refreshed every two weeks. Single lookups carry coordinates when the +database has them; batches resolve up to 500 CEPs in one request. + +B L, L and L all ship +with Perl, and the CSV reader is part of this distribution. Reaching +C does need L and L, which do not +ship with Perl — see L. + +For a script, the module-level functions are enough. In an application, build a +L once and reuse it: + + my $client = Cepis::Client->new( timeout => 5.0, total_timeout => 15.0 ); + my $address = $client->lookup('01001000'); + +Pointing at a local instance (the API repo brings one up with C): + + my $client = Cepis::Client->new( base_url => 'http://localhost:8080' ); + +=head2 Errors + +Every failure is thrown as an object under L, so one test catches +the lot, and the split below it is by whether retrying helps: + + my $address = eval { Cepis::lookup($cep_from_form) }; + if ( !$address ) { + my $err = $@; + if ( ref $err && $err->isa('Cepis::Error::CEPNotFound') ) { + # the CEP does not exist: ask the user for another + } + elsif ( ref $err && $err->isa('Cepis::Error') ) { + # network, server, rate limit: retry later + } + else { + die $err; + } + } + +=head2 Field names + +The API surface is English, but the B — C, C, C. What you read in the JSON is +what you read on the object. See L. + +=head2 HTTPS support + +L speaks HTTPS only when L 1.968 or later and +L 1.49 or later are installed, and neither ships with Perl. Without +them, any call against the default C throws +L straight away with a message naming both modules. +C reports the same thing without making a +request. See L. + +=head1 FUNCTIONS + +The module-level functions all go through one shared default client, built on +first use. It applies process-wide, including to third-party libraries that also +use this module, so do not reconfigure it — anyone needing different settings +should build their own L. + +Nothing is exported by default. C, C, C and +C are available on request: + + use Cepis qw(lookup lookup_many); + +=head2 lookup + + my $address = Cepis::lookup('01001-000'); + +Looks up a CEP using the default configuration and returns a +L. Shorthand for C<< Cepis::default_client->lookup($cep) >>; see +L for the errors it throws. + +=head2 lookup_many + + my $result = Cepis::lookup_many( \@ceps ); + +Looks many CEPs up in one batch, using the default configuration, and returns an +arrayref of the same length and order with C for the misses. Shorthand +for L — read that one, especially the warning that +batches carry no coordinate. + +=head2 health + + my $health = Cepis::health(); + +Queries the API's health using the default configuration and returns a +L. Shorthand for L. + +=head2 normalize_cep + + my $number = Cepis::normalize_cep('01001-000'); # "01001000" + +Strips the mask and validates that 8 digits remain, throwing +L otherwise. Makes no request. See +L. + +=head2 default_client + + my $client = Cepis::default_client(); + +The L behind the functions above, built on first use. + +=head1 SEE ALSO + +L, L, L, L, +L + +The API itself is documented at L. + +=head1 AUTHOR + +Murilo Ijanc Emurilo@ijanc.orgE + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/lib/Cepis/Address.pm b/lib/Cepis/Address.pm new file mode 100644 index 0000000..a938d6f --- /dev/null +++ b/lib/Cepis/Address.pm @@ -0,0 +1,213 @@ +package Cepis::Address; + +use strict; +use warnings; + +use Cepis::Geo; + +our $VERSION = '0.1.0'; + +our @FIELDS = qw( + cep logradouro complemento unidade bairro localidade + uf estado regiao ibge gia ddd siafi +); + +{ + no strict 'refs'; + for my $name (@FIELDS) { + *{$name} = sub { return $_[0]->{$name} }; + } +} + +sub from_json { + my ( $class, $data ) = @_; + + my %raw = %{ $data || {} }; + my %self; + for my $name (@FIELDS) { + $self{$name} = _string( $raw{$name} ); + } + $self{geo} = Cepis::Geo->from_json( $raw{geo} ); + $self{raw} = \%raw; + + return bless \%self, $class; +} + +sub geo { return $_[0]->{geo} } +sub raw { return $_[0]->{raw} } + +sub field { + my ( $self, $name ) = @_; + return $self->{raw}{$name}; +} + +sub formatted_cep { + my ($self) = @_; + my $cep = $self->{cep}; + return $cep unless length($cep) == 8; + return substr( $cep, 0, 5 ) . '-' . substr( $cep, 5, 3 ); +} + +sub to_hash { + my ($self) = @_; + my %out = map { $_ => $self->{$_} } @FIELDS; + $out{geo} = $self->{geo} ? $self->{geo}->to_hash : undef; + return \%out; +} + +sub _string { + my ($value) = @_; + return '' unless defined $value; + return '' if ref $value; + return "$value"; +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis::Address - a CEP and everything the database knows about it + +=head1 SYNOPSIS + + my $a = Cepis::lookup('01310-100'); + + $a->logradouro; # "Avenida Paulista" + $a->localidade; # "São Paulo" + $a->uf; # "SP" + $a->ibge; # "3550308" + $a->cep; # "01310100" (always unmasked) + $a->formatted_cep; # "01310-100" + +=head1 DESCRIPTION + +B — C, C, +C. Everything else in this library is English; the fields are the +one deliberate exception. + +The reason is fidelity: what you read in the JSON at +L is exactly what you read on the object. Translating +to C/C would mean maintaining a field-by-field mapping and forcing +anyone reading the API docs alongside this library to translate back in their +head. The values are Portuguese either way — they come from the Correios +database. + +Fields the database does not have for that CEP come back as empty strings, never +C. That is what the API returns, and changing it here would create a +difference between reading the JSON and reading this library. + +L is the exception: it is C when there is no coordinate. There the +difference is real, because the API B the whole field in that case (about +43% of CEPs) rather than sending null. + +=head1 CONSTRUCTOR + +=head2 from_json + + my $address = Cepis::Address->from_json( $hashref ); + +Builds from the decoded JSON object the API returned. + +Unknown fields are ignored during construction but preserved in L. A new +field in the API therefore cannot break this library. + +A malformed C block yields C<< geo => undef >> rather than propagating the +error. + +=head1 ACCESSORS + +=head2 cep + +The 8 digits, unmasked. + +=head2 logradouro + +Street name. + +=head2 complemento + +Complement, such as C<"lado ímpar">. + +=head2 unidade + +Unit, when the CEP belongs to a specific building or post office box range. + +=head2 bairro + +Neighbourhood. + +=head2 localidade + +Municipality name. + +=head2 uf + +Two-letter state code. + +=head2 estado + +Full state name. + +=head2 regiao + +Region of the country, such as C<"Sudeste">. + +=head2 ibge + +IBGE municipality code. + +=head2 gia + +GIA code (São Paulo state tax registry). + +=head2 ddd + +Area code for telephone dialling. + +=head2 siafi + +SIAFI municipality code. + +=head2 geo + +A L object, or C when the database has no coordinate for +this CEP. Addresses coming out of C always have C here — see +L. + +=head2 raw + +The decoded response exactly as it arrived, as a hashref, so a field the API +grows before this library is updated is not lost. + +=head2 field + + $address->field('campo_do_futuro'); + +Reads any field of the raw response by name, including one this release does not +know about. Returns C when the field is absent. + +=head2 formatted_cep + +The CEP with its mask: C<01001-000>. + +The API always returns it unmasked; formatting is presentation, and it lives +here so it does not become a repeated C in every project that uses this. + +=head2 to_hash + +Every named field plus C as a plain hashref, with C itself flattened +to a hashref or C. + +=head1 SEE ALSO + +L, L + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/lib/Cepis/CSV.pm b/lib/Cepis/CSV.pm new file mode 100644 index 0000000..6fabc0c --- /dev/null +++ b/lib/Cepis/CSV.pm @@ -0,0 +1,165 @@ +package Cepis::CSV; + +use strict; +use warnings; + +our $VERSION = '0.1.0'; + +sub parse_rows { + my ($text) = @_; + + return [] unless defined $text && length $text; + $text =~ s/\A\x{FEFF}//; + + my @rows; + my @row; + my $field = ''; + my $quoted = 0; + my $started = 0; + my $length = length $text; + my $i = 0; + + while ( $i < $length ) { + my $char = substr( $text, $i, 1 ); + + if ($quoted) { + if ( $char eq '"' ) { + if ( $i + 1 < $length && substr( $text, $i + 1, 1 ) eq '"' ) { + $field .= '"'; + $i += 2; + next; + } + $quoted = 0; + $i++; + next; + } + $field .= $char; + $i++; + next; + } + + if ( $char eq '"' && $field eq '' ) { + $quoted = 1; + $started = 1; + $i++; + next; + } + + if ( $char eq ',' ) { + push @row, $field; + $field = ''; + $started = 1; + $i++; + next; + } + + if ( $char eq "\r" || $char eq "\n" ) { + $i++; + $i++ + if $char eq "\r" + && $i < $length + && substr( $text, $i, 1 ) eq "\n"; + if ( $started || @row ) { + push @row, $field; + push @rows, [@row]; + } + @row = (); + $field = ''; + $started = 0; + next; + } + + $field .= $char; + $started = 1; + $i++; + } + + if ( $started || @row ) { + push @row, $field; + push @rows, [@row]; + } + + return \@rows; +} + +sub parse_hashes { + my ($text) = @_; + + my $rows = parse_rows($text); + return ( [], [] ) unless @$rows; + + my $header = shift @$rows; + my @out; + for my $row (@$rows) { + my %record; + for my $index ( 0 .. $#$header ) { + my $value = $index <= $#$row ? $row->[$index] : ''; + $record{ $header->[$index] } = defined $value ? $value : ''; + } + push @out, \%record; + } + + return ( $header, \@out ); +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis::CSV - a small RFC 4180 reader + +=head1 SYNOPSIS + + use Cepis::CSV; + + my ( $header, $records ) = Cepis::CSV::parse_hashes($text); + print $records->[0]{localidade}; + +=head1 DESCRIPTION + +Perl ships no CSV parser in its core, and this distribution has no non-core +dependencies, so it carries its own. It handles what RFC 4180 requires and what +the C endpoint actually emits: quoted fields, embedded commas, embedded +newlines, C<""> as an escaped quote, C or C line endings, and a leading +byte order mark. + +The input is a character string, not bytes — decode the response body before +calling in. + +This module is internal to L. It is documented because it is tested +separately, not because it is meant to be a general-purpose CSV library: it has +no writer, no configurable separator and no streaming interface. + +=head1 FUNCTIONS + +=head2 parse_rows + + my $rows = Cepis::CSV::parse_rows($text); + +Returns an arrayref of arrayrefs, one per record, fields in order. Blank lines +are skipped, so a trailing newline does not produce a phantom final record. + +=head2 parse_hashes + + my ( $header, $records ) = Cepis::CSV::parse_hashes($text); + +Treats the first record as a header row and returns it as an arrayref, plus an +arrayref of hashrefs keyed by column name. A record with fewer fields than the +header gets empty strings for the ones it lacks; fields beyond the header are +dropped. + +Returns two empty arrayrefs for empty input. + +=head1 SEE ALSO + +L + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/lib/Cepis/Client.pm b/lib/Cepis/Client.pm new file mode 100644 index 0000000..35eb51b --- /dev/null +++ b/lib/Cepis/Client.pm @@ -0,0 +1,652 @@ +package Cepis::Client; + +use strict; +use warnings; + +use Carp (); +use Encode (); +use HTTP::Tiny; +use JSON::PP (); +use Scalar::Util (); +use Time::HiRes (); + +use Cepis::Address; +use Cepis::CSV; +use Cepis::Error; +use Cepis::Health; + +our $VERSION = '0.1.0'; + +use constant DEFAULT_URL => 'https://cep.is'; +use constant MAX_BATCH => 500; + +my %RETRIABLE_STATUS = map { $_ => 1 } ( 429, 500, 502, 503, 504 ); + +my $JSON = JSON::PP->new->utf8; + +my @MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); +my %MONTH = map { $MONTHS[$_] => $_ + 1 } 0 .. $#MONTHS; + +sub normalize_cep { + my ($value) = @_; + + if ( !defined $value ) { + Cepis::Error::InvalidCEP->throw( + message => 'CEP must be a string, got undef' ); + } + if ( ref $value ) { + Cepis::Error::InvalidCEP->throw( + message => 'CEP must be a string, got a ' . ref($value) . ' reference' ); + } + + my $cleaned = "$value"; + $cleaned =~ s/\A\s+//; + $cleaned =~ s/\s+\z//; + $cleaned =~ s/[-. ]//g; + + if ( $cleaned !~ /\A[0-9]{8}\z/ ) { + Cepis::Error::InvalidCEP->throw( + message => "CEP must be 8 digits, got '$value'" ); + } + + return $cleaned; +} + +sub tls_available { + return ( 1, undef ) unless HTTP::Tiny->can('can_ssl'); + my ( $ok, $why ) = HTTP::Tiny->can_ssl; + return ( 1, undef ) if $ok; + return ( 0, $why ); +} + +sub new { + my ( $class, %args ) = @_; + + my $base_url = _default( $args{base_url}, DEFAULT_URL ); + my $timeout = _default( $args{timeout}, 10.0 ); + my $max_attempts = _default( $args{max_attempts}, 3 ); + my $backoff_base = _default( $args{backoff_base}, 0.5 ); + my $backoff_max = _default( $args{backoff_max}, 8.0 ); + + Carp::croak('max_attempts must be >= 1') + unless Scalar::Util::looks_like_number($max_attempts) && $max_attempts >= 1; + Carp::croak('timeout must be > 0') + unless Scalar::Util::looks_like_number($timeout) && $timeout > 0; + Carp::croak('backoff_base must be >= 0') + unless Scalar::Util::looks_like_number($backoff_base) && $backoff_base >= 0; + Carp::croak('backoff_max must be >= 0') + unless Scalar::Util::looks_like_number($backoff_max) && $backoff_max >= 0; + + $base_url = "$base_url"; + $base_url =~ s{/+\z}{}; + + my $user_agent = _default( $args{user_agent}, + "cepis-perl/$VERSION (+https://cep.is)" ); + + my $self = { + base_url => $base_url, + timeout => 0 + $timeout, + max_attempts => int( 0 + $max_attempts ), + backoff_base => 0 + $backoff_base, + backoff_max => 0 + $backoff_max, + total_timeout => $args{total_timeout}, + user_agent => "$user_agent", + }; + + $self->{http} = HTTP::Tiny->new( + agent => $self->{user_agent}, + timeout => $self->{timeout}, + default_headers => { + 'Accept' => 'application/json, text/csv;q=0.9, */*;q=0.1', + 'Accept-Encoding' => 'identity', + }, + ); + + return bless $self, $class; +} + +sub base_url { return $_[0]->{base_url} } +sub timeout { return $_[0]->{timeout} } +sub max_attempts { return $_[0]->{max_attempts} } +sub backoff_base { return $_[0]->{backoff_base} } +sub backoff_max { return $_[0]->{backoff_max} } +sub total_timeout { return $_[0]->{total_timeout} } +sub user_agent { return $_[0]->{user_agent} } + +sub lookup { + my ( $self, $cep ) = @_; + + my $number = normalize_cep($cep); + my ( $status, $body ) = $self->_request("/$number"); + + if ( $status == 404 ) { + Cepis::Error::CEPNotFound->throw( + message => "CEP $number does not exist in the DNE database" ); + } + if ( $status == 400 ) { + Cepis::Error::InvalidCEP->throw( + message => _error_message( $body, "CEP $number rejected" ) ); + } + + return Cepis::Address->from_json( _json($body) ); +} + +sub lookup_many { + my ( $self, $ceps ) = @_; + + Carp::croak('lookup_many expects an array reference of CEPs') + unless ref $ceps eq 'ARRAY'; + return [] unless @$ceps; + + my @out; + for ( my $start = 0; $start < @$ceps; $start += MAX_BATCH ) { + my $end = $start + MAX_BATCH - 1; + $end = $#$ceps if $end > $#$ceps; + push @out, @{ $self->_lookup_chunk( [ @{$ceps}[ $start .. $end ] ] ) }; + } + + return \@out; +} + +sub health { + my ($self) = @_; + my ( undef, $body ) = $self->_request( '/health', accepted_status => [ 200, 503 ] ); + return Cepis::Health->from_json( _json($body) ); +} + +sub _lookup_chunk { + my ( $self, $ceps ) = @_; + + my $joined = join ',', map { defined $_ ? "$_" : '' } @$ceps; + my ( undef, $body ) = $self->_request( '/csv?ceps=' . _escape($joined) ); + + my ( $header, $records ) = Cepis::CSV::parse_hashes( _decode($body) ); + unless ( grep { $_ eq 'cep' } @$header ) { + Cepis::Error::InvalidResponse->throw( message => + 'response is not the expected CSV — something between you and the ' + . 'API is answering instead of it: ' . _snippet($body) ); + } + + my @out; + for my $record (@$records) { + my $localidade = defined $record->{localidade} ? $record->{localidade} : ''; + $localidade =~ s/\A\s+//; + $localidade =~ s/\s+\z//; + if ( $localidade eq '' ) { + push @out, undef; + next; + } + push @out, Cepis::Address->from_json($record); + } + + push @out, undef while @out < @$ceps; + splice @out, scalar @$ceps if @out > @$ceps; + + return \@out; +} + +sub _request { + my ( $self, $path, %options ) = @_; + + my @accepted = @{ $options{accepted_status} || [200] }; + my %accepted = map { $_ => 1 } @accepted; + + my $url = $self->{base_url} . $path; + _assert_tls($url); + + my $deadline + = defined $self->{total_timeout} + ? _monotonic() + $self->{total_timeout} + : undef; + + my $attempts = $self->{max_attempts}; + my ( $last_status, $last_retry_after, $last_network ); + + for my $attempt ( 1 .. $attempts ) { + last if defined $deadline && _monotonic() >= $deadline; + + my $response = $self->{http}->get($url); + + if ( $response->{status} == 599 ) { + $last_network = $response->{content}; + $last_network = 'unknown transport failure' + unless defined $last_network && length $last_network; + $last_network =~ s/\s+\z//; + $last_status = undef; + $last_retry_after = undef; + } + else { + my $status = $response->{status}; + if ( $accepted{$status} || !$RETRIABLE_STATUS{$status} ) { + return ( $status, $response->{content} ); + } + $last_status = $status; + $last_retry_after = _retry_after_seconds( $response->{headers}{'retry-after'} ); + $last_network = undef; + } + + last if $attempt == $attempts; + + my $wait = $self->_backoff( $attempt, $last_retry_after ); + if ( defined $deadline ) { + my $remaining = $deadline - _monotonic(); + last if $remaining <= 0; + $wait = $remaining if $wait > $remaining; + } + Time::HiRes::sleep($wait) if $wait > 0; + } + + my $suffix = "(after $attempts attempt(s))"; + + if ( defined $last_status && $last_status == 429 ) { + Cepis::Error::RateLimited->throw( + message => "rate limit reached at $url $suffix", + retry_after => $last_retry_after, + ); + } + if ( defined $last_status ) { + Cepis::Error::ServerError->throw( + message => "the API answered $last_status at $url $suffix", + status => $last_status, + ); + } + Cepis::Error::Network->throw( + message => "could not reach $url $suffix: " + . ( defined $last_network ? $last_network : 'no attempt was made' ) ); +} + +sub _assert_tls { + my ($url) = @_; + + return unless $url =~ m{\Ahttps://}i; + + my ( $ok, $why ) = tls_available(); + return if $ok; + + $why = '' unless defined $why; + $why =~ s/\s+/ /g; + $why =~ s/\A\s+//; + $why =~ s/\s+\z//; + + Cepis::Error::Network->throw( message => + "cannot reach $url: HTTP::Tiny has no HTTPS support on this Perl. " + . 'It needs IO::Socket::SSL 1.968 or later and Net::SSLeay 1.49 or ' + . 'later, and neither of those ships with Perl. Install both ' + . '(cpanm IO::Socket::SSL Net::SSLeay, or your distribution\'s ' + . 'perl-IO-Socket-SSL and perl-Net-SSLeay packages), or point ' + . 'base_url at an http:// instance. HTTP::Tiny reports: ' + . ( length $why ? $why : 'no reason given' ) ); +} + +sub _backoff { + my ( $self, $attempt, $retry_after ) = @_; + + if ( defined $retry_after ) { + return $retry_after < $self->{backoff_max} + ? $retry_after + : $self->{backoff_max}; + } + + my $ceiling = $self->{backoff_base} * ( 2**( $attempt - 1 ) ); + $ceiling = $self->{backoff_max} if $ceiling > $self->{backoff_max}; + return rand() * $ceiling; +} + +sub _retry_after_seconds { + my ($value) = @_; + + $value = $value->[0] if ref $value eq 'ARRAY'; + return undef unless defined $value; + + my $text = "$value"; + $text =~ s/\A\s+//; + $text =~ s/\s+\z//; + return undef unless length $text; + + if ( $text =~ /\A[0-9]+(?:\.[0-9]+)?\z/ ) { + return 0 + $text; + } + + my $epoch = _http_date_epoch($text); + return undef unless defined $epoch; + + my $seconds = $epoch - time(); + return $seconds > 0 ? $seconds : 0; +} + +sub _http_date_epoch { + my ($text) = @_; + + my ( $day, $month, $year, $hour, $minute, $second ); + + if ( $text + =~ /\A[A-Za-z]+,\s+(\d{1,2})\s+([A-Za-z]{3})\s+(\d{4})\s+(\d{2}):(\d{2}):(\d{2})\s+GMT\z/ ) + { + ( $day, $month, $year, $hour, $minute, $second ) = ( $1, $2, $3, $4, $5, $6 ); + } + elsif ( $text + =~ /\A[A-Za-z]+,\s+(\d{2})-([A-Za-z]{3})-(\d{2})\s+(\d{2}):(\d{2}):(\d{2})\s+GMT\z/ ) + { + ( $day, $month, $year, $hour, $minute, $second ) = ( $1, $2, $3, $4, $5, $6 ); + $year += $year < 70 ? 2000 : 1900; + } + elsif ( $text + =~ /\A[A-Za-z]+\s+([A-Za-z]{3})\s+([\d ]\d)\s+(\d{2}):(\d{2}):(\d{2})\s+(\d{4})\z/ ) + { + ( $month, $day, $hour, $minute, $second, $year ) = ( $1, $2, $3, $4, $5, $6 ); + $day =~ s/\s//g; + } + else { + return undef; + } + + my $number = $MONTH{ ucfirst lc $month }; + return undef unless defined $number; + + return _days_from_civil( $year + 0, $number, $day + 0 ) * 86400 + + $hour * 3600 + + $minute * 60 + + $second; +} + +sub _days_from_civil { + my ( $year, $month, $day ) = @_; + + $year -= 1 if $month <= 2; + my $era = int( ( $year >= 0 ? $year : $year - 399 ) / 400 ); + my $yoe = $year - $era * 400; + my $doy = int( ( 153 * ( $month + ( $month > 2 ? -3 : 9 ) ) + 2 ) / 5 ) + $day - 1; + my $doe = $yoe * 365 + int( $yoe / 4 ) - int( $yoe / 100 ) + $doy; + + return $era * 146097 + $doe - 719468; +} + +sub _monotonic { + if ( defined &Time::HiRes::clock_gettime && defined &Time::HiRes::CLOCK_MONOTONIC ) { + return Time::HiRes::clock_gettime( Time::HiRes::CLOCK_MONOTONIC() ); + } + return Time::HiRes::time(); +} + +sub _json { + my ($body) = @_; + + my $data = eval { $JSON->decode( defined $body ? $body : '' ) }; + if ( !defined $data ) { + Cepis::Error::InvalidResponse->throw( message => + 'response is not valid JSON — something between you and the API ' + . 'is answering instead of it: ' . _snippet($body) ); + } + if ( ref $data ne 'HASH' ) { + Cepis::Error::InvalidResponse->throw( + message => 'expected a JSON object, got ' . ( ref($data) || 'a scalar' ) ); + } + + return $data; +} + +sub _error_message { + my ( $body, $fallback ) = @_; + + my $data = eval { $JSON->decode( defined $body ? $body : '' ) }; + return $fallback unless ref $data eq 'HASH'; + return $fallback unless defined $data->{mensagem} && !ref $data->{mensagem}; + return "$data->{mensagem}"; +} + +sub _decode { + my ($body) = @_; + return '' unless defined $body; + my $text = Encode::decode( 'UTF-8', $body, Encode::FB_DEFAULT() ); + $text =~ s/\A\x{FEFF}//; + return $text; +} + +sub _snippet { + my ($body) = @_; + my $text = defined $body ? substr( $body, 0, 120 ) : ''; + $text =~ s/([^\x20-\x7E])/sprintf('\\x%02X', ord $1)/ge; + return "'$text'"; +} + +sub _escape { + my ($value) = @_; + my $bytes = Encode::encode( 'UTF-8', "$value" ); + $bytes =~ s/([^A-Za-z0-9\-_.~])/sprintf('%%%02X', ord $1)/ge; + return $bytes; +} + +sub _default { + my ( $value, $fallback ) = @_; + return defined $value ? $value : $fallback; +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis::Client - configurable client for the cep.is API + +=head1 SYNOPSIS + + use Cepis::Client; + + my $client = Cepis::Client->new( + base_url => 'https://cep.is', + timeout => 10.0, + max_attempts => 3, + backoff_base => 0.5, + backoff_max => 8.0, + total_timeout => 15.0, + ); + + my $address = $client->lookup('01001-000'); + my $result = $client->lookup_many( [ '01001000', '99999999' ] ); + my $health = $client->health; + +=head1 DESCRIPTION + +Build one instance and reuse it. The configuration is fixed at construction and +no method keeps state between calls, so a single client can serve a whole +process. It holds one L internally, which keeps the connection alive +between calls; that object is not shared between threads, so give each thread its +own client. + +Retries cover 429, 500, 502, 503, 504 and network failures, with exponential +backoff and full jitter. 400 and 404 are never retried: both are definitive +answers about the request, so retrying returns the same thing more slowly while +burning someone's quota. + +=head2 HTTPS support + +L is a core module and speaks plain HTTP out of the box, but it +speaks B 1.968 or later and L +1.49 or later are installed>, and neither of those ships with Perl. This library +therefore has no non-core dependencies, but the default C of +C needs those two modules present. + +When they are missing, a request to an C URL throws +L immediately, before any attempt is made, with a message +naming both modules. No amount of retrying fixes a missing module, so it does +not retry. + +L reports the same thing without making a request. + +=head1 FUNCTIONS + +=head2 normalize_cep + + my $number = Cepis::Client::normalize_cep('01001-000'); # "01001000" + +Returns the CEP's 8 digits, accepting the mask. C<"01001-000">, C<"01001000">, +C<" 01001-000 "> and C<"01001.000"> all become C<"01001000">. + +Throws L unless exactly 8 digits remain. This runs +B any request: a 7-digit CEP is the caller's bug, and spending a round +trip for the server to say so wastes both sides' time. + +Note that Perl does not distinguish a number from a string, so passing the +literal C<01001000> passes a 7-digit number — the leading zero is gone before +this function ever sees it. Keep CEPs in strings. + +Also reachable as C. + +=head2 tls_available + + my ( $ok, $why ) = Cepis::Client::tls_available(); + +Reports whether L on this Perl can do HTTPS. Returns a true value +and C when it can; false and the reason when it cannot. See +L. + +=head1 CONSTRUCTOR + +=head2 new + + my $client = Cepis::Client->new(%options); + +All options have defaults, so C<< Cepis::Client->new >> is valid. Cs on a +value that cannot work, which is a programming error rather than a +L. + +=over 4 + +=item base_url + +Where the API lives. Defaults to C. Point it at a local instance +(the API repo brings one up on C with C) or at a +test server. It is the only option that usually changes between environments. +Trailing slashes are stripped, so it cannot produce doubled separators that some +proxies normalise and others 404. + +=item timeout + +Seconds to wait B — L applies it to the +connect and to each read, so it is not a cap on the whole call. That cap is +L. Defaults to 10. + +=item max_attempts + +How many attempts in total, counting the first. C<1> disables retrying. The +default of C<3> covers the common case (one transient failure) without turning a +real outage into a long wait. + +=item backoff_base + +Base of the exponential wait, in seconds; defaults to 0.5. The actual wait is +drawn from C<[0, base * 2**(n-1)]> — I. The randomness is not +decoration: without it, N clients that fail together come back together and +reproduce the spike that took the service down. + +=item backoff_max + +Cap on each individual wait, in seconds; defaults to 8. It applies to a +server-sent C too, or a C from a misconfigured +proxy would park the process for an hour. + +=item total_timeout + +Cap on the whole call, attempts and waits included. C (the default) +leaves L as the only bound. Set it in code serving a web request: +without it the worst case is C plus the sum of the +backoffs. + +=item user_agent + +Overrides the C. The default identifies the library and its version, +which is what lets the server diagnose an old client misbehaving. + +=back + +=head1 METHODS + +=head2 lookup + + my $address = $client->lookup('01001-000'); + +Looks up a single CEP and returns a L. Accepts the CEP masked or +unmasked. + +A 400 from the API is surfaced as L carrying the API's +own message: the format already passed local validation, so the server knows +something this client does not. + +Throws L when the CEP is not 8 digits (no request is +made), L when it is well-formed but absent from the +database, L on 429 after every attempt, +L on 5xx after every attempt, +L when the request never completed, and +L when a success status carries an unreadable +body. + +=head2 lookup_many + + my $result = $client->lookup_many( \@ceps ); + +Looks up many CEPs in one request each 500 and returns an B. A CEP that does not exist is +C at its position — it does not vanish from the list, and it does not +throw. That is the right difference from L: in a batch of a thousand, +one bad CEP must not cost the other nine hundred and ninety-nine. + +A malformed CEP is also C, for the same reason, rather than throwing. To +know I one was malformed, validate first with L. + +The result is an arrayref rather than a list precisely because it may contain +C. A Perl array holds C at any position without shortening — no +element is lost and nothing shifts — so C<< $result->[$i] >> always corresponds +to C<< $ceps[$i] >>. Reading the result with C discards the +misses; reading it with C keeps the pairing. + +Input longer than 500 is chunked automatically. Do not loop over L: a +loop of 500 calls pays 500 TLS handshakes, the batch pays one. + +B The endpoint behind it is CSV, and the CSV +has no C column. Every L returned here has C set to +C, including for CEPs that do have one. Need C? Use L, one +at a time. + +The API guarantees one row per requested CEP. Should that ever fail to hold — a +proxy truncating, a cut response — the result is padded with C to the +input length rather than returned short, because a shifted list silently pairs +the wrong address with the wrong CEP. + +=head2 health + + my $health = $client->health; + +Queries C and returns a L: does the API answer, and +with which database. + +Does not throw for an API reporting itself degraded — that arrives in +C<< $health->status >>, and checking health is exactly when you want the +diagnosis rather than an exception. Network failures still throw. + +=head1 ACCESSORS + +C, C, C, C, C, +C and C each return the configured value. + +=head1 CONSTANTS + +=head2 DEFAULT_URL + +C. + +=head2 MAX_BATCH + +C<500>, the most CEPs the API accepts in a single batch request. + +=head1 SEE ALSO + +L, L, L, L + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/lib/Cepis/Error.pm b/lib/Cepis/Error.pm new file mode 100644 index 0000000..080b0a1 --- /dev/null +++ b/lib/Cepis/Error.pm @@ -0,0 +1,226 @@ +package Cepis::Error; + +use strict; +use warnings; + +our $VERSION = '0.1.0'; + +use overload + '""' => sub { $_[0]->message }, + 'bool' => sub { 1 }, + fallback => 1; + +sub new { + my ( $class, %args ) = @_; + my $self = {%args}; + $self->{message} = $class unless defined $self->{message}; + return bless $self, $class; +} + +sub throw { + my $class = shift; + die $class->new(@_); +} + +sub message { return $_[0]->{message} } + +package Cepis::Error::InvalidCEP; + +use strict; +use warnings; +use parent -norequire, 'Cepis::Error'; + +our $VERSION = '0.1.0'; + +package Cepis::Error::CEPNotFound; + +use strict; +use warnings; +use parent -norequire, 'Cepis::Error'; + +our $VERSION = '0.1.0'; + +package Cepis::Error::Network; + +use strict; +use warnings; +use parent -norequire, 'Cepis::Error'; + +our $VERSION = '0.1.0'; + +package Cepis::Error::ServerError; + +use strict; +use warnings; +use parent -norequire, 'Cepis::Error'; + +our $VERSION = '0.1.0'; + +sub status { return $_[0]->{status} } + +package Cepis::Error::RateLimited; + +use strict; +use warnings; +use parent -norequire, 'Cepis::Error'; + +our $VERSION = '0.1.0'; + +sub retry_after { return $_[0]->{retry_after} } + +package Cepis::Error::InvalidResponse; + +use strict; +use warnings; +use parent -norequire, 'Cepis::Error'; + +our $VERSION = '0.1.0'; + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis::Error - exception hierarchy for L + +=head1 SYNOPSIS + + use Cepis; + + my $address = eval { Cepis::lookup($cep_from_form) }; + if ( !$address ) { + my $err = $@; + if ( ref $err && $err->isa('Cepis::Error::CEPNotFound') ) { + # the CEP does not exist: ask the user for another + } + elsif ( ref $err && $err->isa('Cepis::Error') ) { + # network, server, rate limit: retry later + } + else { + die $err; + } + } + +=head1 DESCRIPTION + +Every failure raised by this library is an object thrown with C, and every +one of them inherits from C. One C<< ref $@ && $@->isa('Cepis::Error') >> +therefore catches the lot. + +Below the base class the split is by B, +not by the HTTP status that caused it: + +=over 4 + +=item * + +L and L are problems with +the I. Retrying is pointless — the same CEP will fail again. + +=item * + +L, L and +L are problems with I. Retrying may help, +and the client already retried on its own before throwing any of them. + +=back + +That split is why C is not "the HTTP 404 exception": C +is thrown without any request being made at all, when the CEP is malformed +before it ever leaves the machine. + +Every error stringifies to its message, so C and C<"$@"> do the +obvious thing. + +=head1 CLASSES + +=head2 Cepis::Error + +Base of every error. The only accessor it guarantees is C. + +=over 4 + +=item C<< Cepis::Error->new( message => $text, %fields ) >> + +Builds the object. Extra fields are stored as-is and become available to +subclasses. + +=item C<< Cepis::Error->throw( message => $text, %fields ) >> + +Builds the object and Cs with it. + +=item C<< $err->message >> + +The human-readable message. Also what the object stringifies to. + +=back + +=head2 Cepis::Error::InvalidCEP + +The CEP is not 8 digits. + +Usually thrown B a request ever being made — the client checks the +format before going to the network. It is also thrown when the API answers 400 +to a CEP that passed local validation, in which case it carries the API's own +message. + +=head2 Cepis::Error::CEPNotFound + +The CEP is well-formed but does not exist in the DNE database. + +=head2 Cepis::Error::Network + +The request never completed: DNS, refused connection, timeout, TLS. + +Thrown only after every configured attempt has failed — with one deliberate +exception. When C is C and Perl has no TLS support installed, +this is thrown immediately, before any attempt, with a message naming the two +modules to install. Retrying cannot fix a missing module. See +L. + +=head2 Cepis::Error::ServerError + +The API answered 5xx on every attempt. + +=over 4 + +=item C<< $err->status >> + +The HTTP status seen on the last attempt. + +=back + +=head2 Cepis::Error::RateLimited + +The API, or the edge in front of it, answered 429 on every attempt. + +=over 4 + +=item C<< $err->retry_after >> + +What the server asked for, in seconds, or C if it did not say. The +client already honoured this across the attempts it made; it is exposed for +callers who want to reschedule the work. + +=back + +=head2 Cepis::Error::InvalidResponse + +A success status came back with a body that cannot be parsed. + +In practice this means something between you and the API is answering instead +of it — a captive Wi-Fi portal, a corporate proxy, an HTML error page. Useful +as a diagnosis: the problem is not in your code. + +=head1 SEE ALSO + +L, L + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/lib/Cepis/Geo.pm b/lib/Cepis/Geo.pm new file mode 100644 index 0000000..bee2515 --- /dev/null +++ b/lib/Cepis/Geo.pm @@ -0,0 +1,148 @@ +package Cepis::Geo; + +use strict; +use warnings; + +use Scalar::Util (); + +our $VERSION = '0.1.0'; + +sub from_json { + my ( $class, $data ) = @_; + + return undef unless ref $data eq 'HASH'; + + for my $key (qw(lat lon raio_m precisao)) { + return undef unless defined $data->{$key}; + } + for my $key (qw(lat lon raio_m)) { + return undef unless Scalar::Util::looks_like_number( $data->{$key} ); + } + return undef if ref $data->{precisao}; + + return bless { + lat => 0 + $data->{lat}, + lon => 0 + $data->{lon}, + raio_m => int( 0 + $data->{raio_m} ), + precisao => "$data->{precisao}", + }, $class; +} + +sub lat { return $_[0]->{lat} } +sub lon { return $_[0]->{lon} } +sub raio_m { return $_[0]->{raio_m} } +sub precisao { return $_[0]->{precisao} } + +sub is_precise { return $_[0]->{precisao} eq 'logradouro' ? 1 : 0 } + +sub to_hash { + my ($self) = @_; + return { + lat => $self->{lat}, + lon => $self->{lon}, + raio_m => $self->{raio_m}, + precisao => $self->{precisao}, + }; +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis::Geo - the coordinate of a CEP + +=head1 SYNOPSIS + + my $address = Cepis::lookup('01310100'); + + if ( my $geo = $address->geo ) { + printf "%s %s\n", $geo->lat, $geo->lon; # -23.567202 -46.649659 + print $geo->raio_m, "\n"; # 1084 + print $geo->precisao, "\n"; # logradouro + } + +=head1 DESCRIPTION + +The CEP's coordinate, when the database has one — about 57% of them. When there +is none, C<< $address->geo >> is C; the API omits the whole block rather +than sending null. + +The point is the B of the coordinates of that CEP's addresses, not the +mean: one badly geocoded address 40 km away shifts a mean and does not move a +median. + +B before using C/C for distance.> There are +two kinds of point and the difference between them is tens of kilometres: + +=over 4 + +=item C<"logradouro"> + +The point is a stretch of street. C lands around 100–150 m. Good for +maps and for distance. + +=item C<"localidade"> + +The CEP I the whole municipality (a city-wide general CEP), and the point is +its centroid. C runs from 7 km to 40 km. Computing shipping from this is +wrong by tens of kilometres. + +=back + +C is the radius containing 90% of that CEP's addresses. It exists +precisely so that error cannot pass unnoticed. + +Field names are the API's own, in Portuguese. See L for why. + +=head1 CONSTRUCTOR + +=head2 from_json + + my $geo = Cepis::Geo->from_json( $hashref ); + +Builds from the C block the API returned. Returns C when the block +is missing, is not a hash, or is malformed — a bad C is not worth losing +the whole address over, since the rest of the response is still useful. + +=head1 ACCESSORS + +=head2 lat + +Latitude, as a number. + +=head2 lon + +Longitude, as a number. + +=head2 raio_m + +Radius in metres containing 90% of that CEP's addresses, as an integer. + +=head2 precisao + +Either C<"logradouro"> or C<"localidade">. Read the warning above before using +the coordinate for anything metric. + +=head2 is_precise + +True when the coordinate points at a street rather than a municipality. +Shorthand for C<< $geo->precisao eq 'logradouro' >>, which is the check to make +before using the point to measure distance. + +=head2 to_hash + +The four fields as a plain hashref. + +=head1 SEE ALSO + +L, L + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/lib/Cepis/Health.pm b/lib/Cepis/Health.pm new file mode 100644 index 0000000..6782fd0 --- /dev/null +++ b/lib/Cepis/Health.pm @@ -0,0 +1,138 @@ +package Cepis::Health; + +use strict; +use warnings; + +use Scalar::Util (); + +our $VERSION = '0.1.0'; + +sub from_json { + my ( $class, $data ) = @_; + + my %raw = %{ $data || {} }; + + return bless { + status => _string( $raw{status} ), + dne => _string( $raw{dne} ), + ceps => _integer( $raw{ceps} ), + geo => _integer( $raw{geo} ), + base_gerada_em => _string( $raw{base_gerada_em} ), + raw => \%raw, + }, $class; +} + +sub status { return $_[0]->{status} } +sub dne { return $_[0]->{dne} } +sub ceps { return $_[0]->{ceps} } +sub geo { return $_[0]->{geo} } +sub base_gerada_em { return $_[0]->{base_gerada_em} } +sub raw { return $_[0]->{raw} } + +sub ok { return $_[0]->{status} eq 'ok' ? 1 : 0 } + +sub to_hash { + my ($self) = @_; + return { + status => $self->{status}, + dne => $self->{dne}, + ceps => $self->{ceps}, + geo => $self->{geo}, + base_gerada_em => $self->{base_gerada_em}, + }; +} + +sub _string { + my ($value) = @_; + return '' unless defined $value; + return '' if ref $value; + return "$value"; +} + +sub _integer { + my ($value) = @_; + return 0 unless defined $value; + return 0 unless Scalar::Util::looks_like_number($value); + return int( 0 + $value ); +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +Cepis::Health - the answer of C + +=head1 SYNOPSIS + + my $h = Cepis::health(); + + $h->ok; # 1 + $h->dne; # "26071" identifier of the fortnightly database + $h->ceps; # 1596168 + $h->base_gerada_em; # "2026-07-24T03:48:28Z" + +=head1 DESCRIPTION + +Good for two things: checking that the API answers, and knowing B is live. The DNE database changes every two weeks; L +identifies it. + +An API reporting itself degraded does not raise — that arrives in L. + +=head1 CONSTRUCTOR + +=head2 from_json + + my $health = Cepis::Health->from_json( $hashref ); + +Builds from the decoded JSON object the API returned. + +=head1 ACCESSORS + +=head2 status + +C<"ok"> when the API considers itself healthy, something else otherwise. + +=head2 ok + +True when L is exactly C<"ok">. + +=head2 dne + +Identifier of the DNE database currently loaded. It changes every fortnight. + +=head2 ceps + +How many CEPs the database holds. + +=head2 geo + +How many of those CEPs carry a coordinate. Note that unlike +L this is a count, not an object — that is what the API +sends. + +=head2 base_gerada_em + +When the database was generated, as an ISO 8601 timestamp string. + +=head2 raw + +The decoded response exactly as it arrived, as a hashref. + +=head2 to_hash + +The five named fields as a plain hashref. + +=head1 SEE ALSO + +L, L + +=head1 LICENCE + +ISC. Copyright (c) 2026 Murilo Ijanc Emurilo@ijanc.orgE. + +=cut diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..73c8063 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,42 @@ +use strict; +use warnings; + +use Test::More; + +my @modules = qw( + Cepis + Cepis::Address + Cepis::CSV + Cepis::Client + Cepis::Error + Cepis::Geo + Cepis::Health +); + +use_ok($_) for @modules; + +is( $Cepis::VERSION, '0.1.0', 'Cepis is at version 0.1.0' ); + +for my $module (@modules) { + no strict 'refs'; + is( ${"${module}::VERSION"}, $Cepis::VERSION, "$module carries the same version" ); +} + +for my $class ( + qw( + Cepis::Error::InvalidCEP + Cepis::Error::CEPNotFound + Cepis::Error::Network + Cepis::Error::ServerError + Cepis::Error::RateLimited + Cepis::Error::InvalidResponse + ) + ) +{ + ok( $class->isa('Cepis::Error'), "$class is a Cepis::Error" ); +} + +can_ok( 'Cepis', qw(lookup lookup_many health normalize_cep default_client) ); +can_ok( 'Cepis::Client', qw(new lookup lookup_many health) ); + +done_testing(); diff --git a/t/01-normalize.t b/t/01-normalize.t new file mode 100644 index 0000000..bf8a85f --- /dev/null +++ b/t/01-normalize.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; + +use Cepis; + +for my $value ( '01001000', '01001-000', ' 01001-000 ', '01001.000' ) { + is( Cepis::normalize_cep($value), '01001000', "'$value' normalises" ); +} + +for my $value ( '', '123', '0100100a', '010010000', 'abcdefgh', '0100 1000x' ) { + my $ok = eval { Cepis::normalize_cep($value); 1 }; + ok( !$ok, "'$value' is rejected" ); + isa_ok( $@, 'Cepis::Error::InvalidCEP' ); +} + +for my $value ( undef, [], {}, \'x' ) { + my $ok = eval { Cepis::normalize_cep($value); 1 }; + ok( !$ok, 'a non-string is rejected' ); + isa_ok( $@, 'Cepis::Error::InvalidCEP' ); +} + +my $ok = eval { Cepis::normalize_cep('123'); 1 }; +ok( !$ok, 'malformed CEP throws' ); +ok( ref $@ && $@->isa('Cepis::Error'), 'one isa test catches everything' ); +like( "$@", qr/8 digits/, 'the error stringifies to its message' ); + +is( Cepis::Client::normalize_cep('01001-000'), + '01001000', 'the function is also reachable on Cepis::Client' ); + +done_testing(); diff --git a/t/02-csv.t b/t/02-csv.t new file mode 100644 index 0000000..8850620 --- /dev/null +++ b/t/02-csv.t @@ -0,0 +1,105 @@ +use strict; +use warnings; +use utf8; + +use Test::More; + +use Cepis::CSV; + +binmode Test::More->builder->output, ':encoding(UTF-8)'; +binmode Test::More->builder->failure_output, ':encoding(UTF-8)'; + +is_deeply( Cepis::CSV::parse_rows(''), [], 'empty input yields no rows' ); + +is_deeply( + Cepis::CSV::parse_rows("a,b,c\n1,2,3\n"), + [ [qw(a b c)], [qw(1 2 3)] ], + 'plain rows' +); + +is_deeply( + Cepis::CSV::parse_rows("a,b\r\n1,2\r\n"), + [ [qw(a b)], [qw(1 2)] ], + 'CRLF line endings' +); + +is_deeply( + Cepis::CSV::parse_rows("a,b\n1,2"), + [ [qw(a b)], [qw(1 2)] ], + 'a missing final newline still closes the row' +); + +is_deeply( + Cepis::CSV::parse_rows(qq{a,b\n"um, dois",3\n}), + [ [qw(a b)], [ 'um, dois', '3' ] ], + 'a quoted field may hold a comma' +); + +is_deeply( + Cepis::CSV::parse_rows(qq{a\n"he said ""hi"""\n}), + [ ['a'], ['he said "hi"'] ], + 'a doubled quote is an escaped quote' +); + +is_deeply( + Cepis::CSV::parse_rows(qq{a,b\n"line\none",2\n}), + [ [qw(a b)], [ "line\none", '2' ] ], + 'a quoted field may hold a newline' +); + +is_deeply( + Cepis::CSV::parse_rows(qq{a,b,c\n,,\n}), + [ [qw(a b c)], [ '', '', '' ] ], + 'empty fields survive' +); + +is_deeply( + Cepis::CSV::parse_rows(qq{a,b\n"",""\n}), + [ [qw(a b)], [ '', '' ] ], + 'explicitly quoted empty fields survive' +); + +is_deeply( + Cepis::CSV::parse_rows("\x{FEFF}a,b\n1,2\n"), + [ [qw(a b)], [qw(1 2)] ], + 'a byte order mark is stripped' +); + +is_deeply( + Cepis::CSV::parse_rows("a,b\n1,2\n\n\n"), + [ [qw(a b)], [qw(1 2)] ], + 'blank lines are skipped' +); + +is_deeply( + Cepis::CSV::parse_rows("cep,localidade\n01001000,São Paulo\n"), + [ [qw(cep localidade)], [ '01001000', 'São Paulo' ] ], + 'non-ASCII characters survive' +); + +my ( $header, $records ) + = Cepis::CSV::parse_hashes("cep,localidade,uf\n01001000,São Paulo,SP\n99999999,,\n"); + +is_deeply( $header, [qw(cep localidade uf)], 'the header row comes back' ); +is_deeply( + $records, + [ { cep => '01001000', localidade => 'São Paulo', uf => 'SP' }, + { cep => '99999999', localidade => '', uf => '' }, + ], + 'records are keyed by column name' +); + +( $header, $records ) = Cepis::CSV::parse_hashes("a,b,c\n1\n"); +is_deeply( + $records, + [ { a => '1', b => '', c => '' } ], + 'a short row is filled with empty strings' +); + +( $header, $records ) = Cepis::CSV::parse_hashes("a\n1,2,3\n"); +is_deeply( $records, [ { a => '1' } ], 'fields beyond the header are dropped' ); + +( $header, $records ) = Cepis::CSV::parse_hashes(''); +is_deeply( [ $header, $records ], [ [], [] ], 'empty input yields nothing' ); + +done_testing(); diff --git a/t/03-lookup.t b/t/03-lookup.t new file mode 100644 index 0000000..5fb3937 --- /dev/null +++ b/t/03-lookup.t @@ -0,0 +1,187 @@ +use strict; +use warnings; +use utf8; + +use FindBin (); +use lib "$FindBin::Bin/lib"; + +use Test::More; +use TestServer qw(se_address json new_client); + +use Cepis; + +{ + my $server = TestServer->new( + routes => { '/01001000' => [ 200, json( se_address() ), {} ] } ); + my $client = new_client($server); + + my $address = $client->lookup('01001-000'); + is( $address->localidade, 'São Paulo', 'localidade' ); + is( $address->uf, 'SP', 'uf' ); + is( $address->logradouro, 'Praça da Sé', 'logradouro' ); + is( $address->cep, '01001000', 'cep comes back unmasked' ); + is( $address->formatted_cep, '01001-000', 'formatted_cep applies the mask' ); + is( $address->unidade, '', 'an absent field is an empty string' ); + is( $address->geo, undef, 'no geo block means no geo' ); + is( $server->count('/01001000'), 1, 'exactly one request was made' ); + $server->stop; +} + +{ + my $body = { %{ se_address() }, + geo => { lat => -23.567202, lon => -46.649659, raio_m => 1084, precisao => 'logradouro' } + }; + my $server = TestServer->new( routes => { '/01310100' => [ 200, json($body), {} ] } ); + my $client = new_client($server); + + my $geo = $client->lookup('01310100')->geo; + isa_ok( $geo, 'Cepis::Geo' ); + cmp_ok( abs( $geo->lat + 23.567202 ), '<', 1e-9, 'lat' ); + cmp_ok( abs( $geo->lon + 46.649659 ), '<', 1e-9, 'lon' ); + is( $geo->raio_m, 1084, 'raio_m' ); + is( $geo->precisao, 'logradouro', 'precisao' ); + ok( $geo->is_precise, 'a street coordinate is precise' ); + $server->stop; +} + +{ + my $body = { %{ se_address() }, + geo => { lat => -23.5, lon => -46.6, raio_m => 22000, precisao => 'localidade' } }; + my $server = TestServer->new( routes => { '/01001000' => [ 200, json($body), {} ] } ); + my $client = new_client($server); + + my $geo = $client->lookup('01001000')->geo; + ok( !$geo->is_precise, 'a municipality centroid is not precise' ); + is( $geo->raio_m, 22000, 'the radius gives the error away' ); + $server->stop; +} + +{ + my $body = { %{ se_address() }, geo => { lat => 'not a number' } }; + my $server = TestServer->new( routes => { '/01001000' => [ 200, json($body), {} ] } ); + my $client = new_client($server); + + my $address = $client->lookup('01001000'); + is( $address->geo, undef, 'a malformed geo block is dropped' ); + is( $address->localidade, 'São Paulo', 'and the address survives it' ); + $server->stop; +} + +{ + my $body = { %{ se_address() }, campo_do_futuro => 'value' }; + my $server = TestServer->new( routes => { '/01001000' => [ 200, json($body), {} ] } ); + my $client = new_client($server); + + my $address = $client->lookup('01001000'); + is( $address->field('campo_do_futuro'), 'value', 'an unknown field is preserved' ); + is( $address->raw->{campo_do_futuro}, 'value', 'and is reachable through raw' ); + is( $address->localidade, 'São Paulo', 'and does not break construction' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { + '/99999999' => [ + 404, + json( { erro => 'cep_nao_encontrado', mensagem => 'CEP não existe na base do DNE' } ), + {} + ] + } + ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('99999999'); 1 }; + ok( !$ok, 'a missing CEP throws' ); + isa_ok( $@, 'Cepis::Error::CEPNotFound' ); + like( "$@", qr/99999999/, 'the message names the CEP' ); + is( $server->count('/99999999'), 1, 'a 404 is not retried' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { '/01001000' => [ 200, json( se_address() ), {} ] } ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('123'); 1 }; + ok( !$ok, 'a malformed CEP throws' ); + isa_ok( $@, 'Cepis::Error::InvalidCEP' ); + is( scalar( $server->calls ), 0, 'and never leaves the machine' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { + '/00000000' => [ + 400, + json( { erro => 'cep_invalido', mensagem => 'rejected by the API' } ), {} + ] + } + ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('00000000'); 1 }; + ok( !$ok, 'a 400 throws' ); + isa_ok( $@, 'Cepis::Error::InvalidCEP' ); + like( "$@", qr/rejected by the API/, "the API's own message comes through" ); + is( $server->count('/00000000'), 1, 'a 400 is not retried' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { + '/01001000' => [ 200, 'captive portal', {} ], + '/01001001' => [ 200, '[1,2,3]', {} ], + } + ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'a body that is not JSON throws' ); + isa_ok( $@, 'Cepis::Error::InvalidResponse' ); + like( "$@", qr/captive portal/, 'the message quotes what came back' ); + + $ok = eval { $client->lookup('01001001'); 1 }; + ok( !$ok, 'a JSON array is not an address' ); + isa_ok( $@, 'Cepis::Error::InvalidResponse' ); + $server->stop; +} + +{ + my $server = TestServer->new( + handler => sub { + my ( $path, $seen, $headers ) = @_; + return [ 200, json( { %{ se_address() }, unidade => $headers->{'user-agent'} } ), {} ]; + } + ); + my $client = new_client($server); + + like( + $client->lookup('01001000')->unidade, + qr{\Acepis-perl/0\.1\.0 \(\+https://cep\.is\)\z}, + 'the request identifies the library' + ); + $server->stop; +} + +{ + my $server = TestServer->new( + handler => sub { + my ( $path, $seen, $headers ) = @_; + return [ 200, json( { %{ se_address() }, unidade => $headers->{accept} } ), {} ]; + } + ); + my $client = new_client($server); + + like( + $client->lookup('01001000')->unidade, + qr{application/json}, + 'and sends an Accept header' + ); + $server->stop; +} + +done_testing(); diff --git a/t/04-retry.t b/t/04-retry.t new file mode 100644 index 0000000..d304b5a --- /dev/null +++ b/t/04-retry.t @@ -0,0 +1,147 @@ +use strict; +use warnings; +use utf8; + +use FindBin (); +use lib "$FindBin::Bin/lib"; + +use Test::More; +use TestServer qw(se_address json new_client); + +use Cepis; +use Time::HiRes (); + +{ + my $server = TestServer->new( + routes => { + '/01001000' => [ + [ 500, json( { erro => 'interno' } ), {} ], + [ 200, json( se_address() ), {} ], + ] + } + ); + my $client = new_client($server); + + is( $client->lookup('01001000')->localidade, 'São Paulo', 'a retry recovers' ); + is( $server->count('/01001000'), 2, 'it took two attempts' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { '/01001000' => [ 503, json( { erro => 'interno' } ), {} ] } ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'exhausting the attempts throws' ); + isa_ok( $@, 'Cepis::Error::ServerError' ); + is( $@->status, 503, 'the status of the last attempt is exposed' ); + is( $server->count('/01001000'), 3, 'three attempts by default' ); + $server->stop; +} + +{ + my $server = TestServer->new( routes => { '/01001000' => [ 500, '{}', {} ] } ); + my $client = new_client( $server, max_attempts => 1 ); + + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'max_attempts of 1 still throws' ); + is( $server->count('/01001000'), 1, 'and disables retrying' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { '/01001000' => [ 429, '{}', { 'Retry-After' => '7' } ] } ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'a 429 throws' ); + isa_ok( $@, 'Cepis::Error::RateLimited' ); + cmp_ok( abs( $@->retry_after - 7 ), '<', 1e-9, 'Retry-After in seconds is read' ); + $server->stop; +} + +{ + my @day = qw(Sun Mon Tue Wed Thu Fri Sat); + my @month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); + my @t = gmtime( time + 4 ); + my $date = sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT', $day[ $t[6] ], $t[3], + $month[ $t[4] ], $t[5] + 1900, $t[2], $t[1], $t[0]; + + my $server = TestServer->new( + routes => { '/01001000' => [ 429, '{}', { 'Retry-After' => $date } ] } ); + my $client = new_client($server); + + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'a 429 with an HTTP date throws' ); + isa_ok( $@, 'Cepis::Error::RateLimited' ); + cmp_ok( $@->retry_after, '>', 0, 'the date form is parsed too' ); + cmp_ok( $@->retry_after, '<=', 5, 'and lands where it should' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { '/01001000' => [ 429, '{}', { 'Retry-After' => '3600' } ] } ); + my $client = new_client($server); + + my $started = Time::HiRes::time(); + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'an absurd Retry-After still throws' ); + cmp_ok( Time::HiRes::time() - $started, '<', 5, 'and is capped by backoff_max' ); + $server->stop; +} + +{ + my $client = Cepis::Client->new( + base_url => 'http://127.0.0.1:1', + max_attempts => 2, + backoff_base => 0.001, + backoff_max => 0.01, + timeout => 1.0, + ); + + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'nothing listening throws' ); + isa_ok( $@, 'Cepis::Error::Network' ); + like( "$@", qr/127\.0\.0\.1:1/, 'the message names the URL' ); +} + +{ + my $server = TestServer->new( routes => { '/01001000' => [ 500, '{}', {} ] } ); + my $client = new_client( + $server, + max_attempts => 50, + backoff_base => 0.05, + backoff_max => 0.05, + total_timeout => 0.3, + ); + + my $started = Time::HiRes::time(); + my $ok = eval { $client->lookup('01001000'); 1 }; + ok( !$ok, 'the call still throws' ); + isa_ok( $@, 'Cepis::Error::ServerError' ); + cmp_ok( Time::HiRes::time() - $started, '<', 3, 'total_timeout bounds the whole call' ); + cmp_ok( $server->count('/01001000'), '<', 50, 'and cuts the attempts short' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { + '/01001000' => [ + [ 502, '{}', {} ], + [ 504, '{}', {} ], + [ 200, json( se_address() ), {} ], + ] + } + ); + my $client = new_client($server); + + is( $client->lookup('01001000')->uf, 'SP', '502 and 504 are retried too' ); + is( $server->count('/01001000'), 3, 'across three attempts' ); + $server->stop; +} + +done_testing(); diff --git a/t/05-batch.t b/t/05-batch.t new file mode 100644 index 0000000..3ae51d0 --- /dev/null +++ b/t/05-batch.t @@ -0,0 +1,146 @@ +use strict; +use warnings; +use utf8; + +use FindBin (); +use lib "$FindBin::Bin/lib"; + +use Test::More; +use TestServer qw(csv_body new_client); + +use Cepis; + +{ + my $body = csv_body( + '01001000,Praça da Sé,lado ímpar,,Sé,São Paulo,SP,São Paulo,Sudeste,3550308,1004,11,7107', + '99999999,,,,,,,,,,,,', + '20040020,Avenida Rio Branco,,,Centro,Rio de Janeiro,RJ,Rio de Janeiro,' + . 'Sudeste,3304557,,21,6001', + ); + my $server = TestServer->new( + routes => { '/csv?ceps=01001000%2C99999999%2C20040020' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + my $result = $client->lookup_many( [qw(01001000 99999999 20040020)] ); + is( scalar @$result, 3, 'the result is as long as the input' ); + is( $result->[0]->localidade, 'São Paulo', 'the first CEP resolved' ); + is( $result->[1], undef, 'a missing CEP is undef at its position' ); + is( $result->[2]->uf, 'RJ', 'and the third is not shifted up' ); + $server->stop; +} + +{ + my $body = csv_body( + '01001000,Praça da Sé,,,Sé,São Paulo,SP,São Paulo,Sudeste,3550308,1004,11,7107'); + my $server + = TestServer->new( routes => { '/csv?ceps=01001000' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + my $address = $client->lookup_many( ['01001000'] )->[0]; + is( $address->localidade, 'São Paulo', 'the batch resolved it' ); + is( $address->geo, undef, 'but a batch never carries a coordinate' ); + $server->stop; +} + +{ + my $body = csv_body( + '01001000,"Rua Um, Dois",,,Centro,São Paulo,SP,São Paulo,Sudeste,1,,11,1'); + my $server + = TestServer->new( routes => { '/csv?ceps=01001000' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + is( $client->lookup_many( ['01001000'] )->[0]->logradouro, + 'Rua Um, Dois', 'a quoted field holding a comma is parsed' ); + $server->stop; +} + +{ + my $server = TestServer->new; + my $client = new_client($server); + + is_deeply( $client->lookup_many( [] ), [], 'an empty list yields an empty list' ); + is( scalar( $server->calls ), 0, 'and makes no request' ); + $server->stop; +} + +{ + my @ceps = map { sprintf '%08d', $_ } 1 .. 501; + my @rows = map {"$_,,,,,X,SP,São Paulo,Sudeste,1,,11,1"} @ceps; + + my $server = TestServer->new( + handler => sub { + my ( $path, $seen ) = @_; + my @slice = $seen == 1 ? @rows[ 0 .. 499 ] : @rows[ 500 .. 500 ]; + return [ 200, csv_body(@slice), {} ]; + } + ); + my $client = new_client($server); + + my $result = $client->lookup_many( \@ceps ); + is( scalar( $server->calls ), 2, '501 CEPs are split into two requests' ); + is( scalar @$result, 501, 'and the result is still 501 long' ); + is( $result->[500]->localidade, 'X', 'the last one is present' ); + $server->stop; +} + +{ + my $body = csv_body('01001000,,,,,São Paulo,SP,São Paulo,Sudeste,1,,11,1'); + my $server = TestServer->new( + routes => { '/csv?ceps=01001000%2C20040020' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + my $result = $client->lookup_many( [qw(01001000 20040020)] ); + is( scalar @$result, 2, 'a truncated response is padded, not returned short' ); + is( $result->[1], undef, 'the missing tail is undef' ); + $server->stop; +} + +{ + my $body = csv_body( + '01001000,,,,,X,SP,São Paulo,Sudeste,1,,11,1', + '01001001,,,,,Y,SP,São Paulo,Sudeste,1,,11,1', + '01001002,,,,,Z,SP,São Paulo,Sudeste,1,,11,1', + '01001003,,,,,W,SP,São Paulo,Sudeste,1,,11,1', + ); + my $server = TestServer->new( + routes => { '/csv?ceps=01001000%2C01001001' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + my $result = $client->lookup_many( [qw(01001000 01001001)] ); + is( scalar @$result, 2, 'an over-long response is truncated to the input length' ); + $server->stop; +} + +{ + my $body = csv_body( '123,,,,,,,,,,,,', '01001000,,,,,X,SP,São Paulo,Sudeste,1,,11,1' ); + my $server = TestServer->new( + routes => { '/csv?ceps=123%2C01001000' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + my $result = $client->lookup_many( [qw(123 01001000)] ); + is( $result->[0], undef, 'a malformed CEP is undef rather than an exception' ); + is( $result->[1]->localidade, 'X', 'and does not cost the rest of the batch' ); + $server->stop; +} + +{ + my $server = TestServer->new( + routes => { '/csv?ceps=01001000' => [ 200, 'captive portal', {} ] } ); + my $client = new_client($server); + + my $ok = eval { $client->lookup_many( ['01001000'] ); 1 }; + ok( !$ok, 'a body that is not the expected CSV throws' ); + isa_ok( $@, 'Cepis::Error::InvalidResponse' ); + $server->stop; +} + +{ + my $server = TestServer->new; + my $client = new_client($server); + + my $ok = eval { $client->lookup_many('01001000'); 1 }; + ok( !$ok, 'lookup_many wants an array reference' ); + $server->stop; +} + +done_testing(); diff --git a/t/06-health.t b/t/06-health.t new file mode 100644 index 0000000..fca2820 --- /dev/null +++ b/t/06-health.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use FindBin (); +use lib "$FindBin::Bin/lib"; + +use Test::More; +use TestServer qw(json new_client); + +use Cepis; + +{ + my $body = json( + { status => 'ok', + dne => '26071', + ceps => 1596168, + geo => 894489, + base_gerada_em => '2026-07-24T03:48:28Z', + } + ); + my $server = TestServer->new( routes => { '/health' => [ 200, $body, {} ] } ); + my $client = new_client($server); + + my $health = $client->health; + isa_ok( $health, 'Cepis::Health' ); + ok( $health->ok, 'the API reports itself healthy' ); + is( $health->dne, '26071', 'dne identifies the database' ); + is( $health->ceps, 1596168, 'ceps' ); + is( $health->geo, 894489, 'geo is a count here, not an object' ); + is( $health->base_gerada_em, '2026-07-24T03:48:28Z', 'base_gerada_em' ); + $server->stop; +} + +{ + my $body = json( + { status => 'degradado', dne => '', ceps => 0, geo => 0, base_gerada_em => '' } ); + my $server = TestServer->new( routes => { '/health' => [ 503, $body, {} ] } ); + my $client = new_client($server); + + my $health = $client->health; + ok( !$health->ok, 'a degraded API does not throw' ); + is( $health->status, 'degradado', 'the diagnosis arrives in status' ); + is( $server->count('/health'), 1, 'and a 503 on /health is not retried' ); + $server->stop; +} + +{ + my $server = TestServer->new( routes => { '/health' => [ 500, '{}', {} ] } ); + my $client = new_client($server); + + my $ok = eval { $client->health; 1 }; + ok( !$ok, 'a 500 on /health still throws' ); + isa_ok( $@, 'Cepis::Error::ServerError' ); + is( $server->count('/health'), 3, 'after retrying' ); + $server->stop; +} + +done_testing(); diff --git a/t/07-config.t b/t/07-config.t new file mode 100644 index 0000000..5c6f19b --- /dev/null +++ b/t/07-config.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use FindBin (); +use lib "$FindBin::Bin/lib"; + +use Test::More; +use TestServer qw(se_address json new_client); + +use Cepis; + +is( Cepis::Client->new( base_url => 'http://x/' )->base_url, + 'http://x', 'a trailing slash is stripped' ); +is( Cepis::Client->new( base_url => 'http://x///' )->base_url, + 'http://x', 'and so are several' ); +is( Cepis::Client->new->base_url, 'https://cep.is', 'the default base_url' ); +is( Cepis::Client::DEFAULT_URL(), 'https://cep.is', 'DEFAULT_URL agrees' ); +is( Cepis::Client::MAX_BATCH(), 500, 'MAX_BATCH is the API limit' ); + +for my $bad ( + { max_attempts => 0 }, + { max_attempts => -1 }, + { timeout => 0 }, + { timeout => -1 }, + { backoff_max => -1 }, + ) +{ + my ($name) = keys %$bad; + my $ok = eval { Cepis::Client->new(%$bad); 1 }; + ok( !$ok, "$name = $bad->{$name} is rejected" ); +} + +my $client = Cepis::Client->new; +like( $client->user_agent, qr{\Acepis-perl/0\.1\.0 }, 'the User-Agent names the library' ); +like( $client->user_agent, qr{https://cep\.is}, 'and where to find it' ); + +is( Cepis::Client->new( user_agent => 'myapp/1.0' )->user_agent, + 'myapp/1.0', 'the User-Agent is overridable' ); + +is( $client->timeout, 10, 'default timeout' ); +is( $client->max_attempts, 3, 'default max_attempts' ); +is( $client->backoff_base, 0.5, 'default backoff_base' ); +is( $client->backoff_max, 8, 'default backoff_max' ); +is( $client->total_timeout, undef, 'no total_timeout by default' ); + +isa_ok( Cepis::default_client(), 'Cepis::Client' ); +is( Cepis::default_client(), Cepis::default_client(), 'the default client is built once' ); + +{ + my $server = TestServer->new( + routes => { + '/01001000' => [ 200, json( se_address() ), {} ], + '/health' => [ 200, json( { status => 'ok' } ), {} ], + } + ); + my $custom = new_client($server); + + is( $custom->lookup('01001000')->uf, 'SP', 'base_url really redirects the client' ); + ok( $custom->health->ok, 'for every endpoint' ); + $server->stop; +} + +done_testing(); diff --git a/t/08-tls.t b/t/08-tls.t new file mode 100644 index 0000000..950fef3 --- /dev/null +++ b/t/08-tls.t @@ -0,0 +1,58 @@ +use strict; +use warnings; + +use FindBin (); +use lib "$FindBin::Bin/lib"; + +use HTTP::Tiny; +use Test::More; +use TestServer qw(se_address json new_client); +use Time::HiRes (); + +use Cepis; + +my ($expected) = HTTP::Tiny->can('can_ssl') ? HTTP::Tiny->can_ssl : (1); +my ( $ok, $why ) = Cepis::Client::tls_available(); + +is( !!$ok, !!$expected, 'tls_available agrees with HTTP::Tiny->can_ssl' ); + +SKIP: { + skip 'this Perl has HTTPS support', 6 if $ok; + + ok( defined $why && length $why, 'the reason is reported' ); + + my $client = Cepis::Client->new( + base_url => 'https://cep.is', + max_attempts => 3, + backoff_base => 30, + backoff_max => 30, + ); + + my $started = Time::HiRes::time(); + my $done = eval { $client->lookup('01001000'); 1 }; + my $err = $@; + + ok( !$done, 'an https call without TLS support throws' ); + isa_ok( $err, 'Cepis::Error::Network' ); + like( "$err", qr/IO::Socket::SSL/, 'the message names IO::Socket::SSL' ); + like( "$err", qr/Net::SSLeay/, 'and Net::SSLeay' ); + cmp_ok( Time::HiRes::time() - $started, '<', 5, + 'and it fails at once rather than retrying a missing module' ); +} + +SKIP: { + skip 'this Perl has no HTTPS support', 1 unless $ok; + is( $why, undef, 'no reason is reported when HTTPS works' ); +} + +{ + my $server = TestServer->new( + routes => { '/01001000' => [ 200, json( se_address() ), {} ] } ); + my $client = new_client($server); + + is( $client->lookup('01001000')->uf, 'SP', + 'an http base_url is never blocked by the TLS guard' ); + $server->stop; +} + +done_testing(); diff --git a/t/lib/TestServer.pm b/t/lib/TestServer.pm new file mode 100644 index 0000000..5a1acda --- /dev/null +++ b/t/lib/TestServer.pm @@ -0,0 +1,298 @@ +package TestServer; + +use strict; +use warnings; + +use Encode (); +use Exporter qw(import); +use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); +use IO::Socket::INET; +use JSON::PP (); +use POSIX (); +use Test::More (); + +our @EXPORT_OK = qw(se_address csv_header csv_body json new_client); + +my %REASON = ( + 200 => 'OK', + 400 => 'Bad Request', + 404 => 'Not Found', + 429 => 'Too Many Requests', + 500 => 'Internal Server Error', + 502 => 'Bad Gateway', + 503 => 'Service Unavailable', +); + +my $ENCODER = JSON::PP->new->canonical; + +BEGIN { + my $builder = Test::More->builder; + binmode $builder->output, ':encoding(UTF-8)'; + binmode $builder->failure_output, ':encoding(UTF-8)'; + binmode $builder->todo_output, ':encoding(UTF-8)'; +} + +sub se_address { + return { + cep => '01001000', + logradouro => "Pra\x{e7}a da S\x{e9}", + complemento => "lado \x{ed}mpar", + unidade => '', + bairro => "S\x{e9}", + localidade => "S\x{e3}o Paulo", + uf => 'SP', + estado => "S\x{e3}o Paulo", + regiao => 'Sudeste', + ibge => '3550308', + gia => '1004', + ddd => '11', + siafi => '7107', + }; +} + +sub csv_header { + return 'cep,logradouro,complemento,unidade,bairro,localidade,uf,estado,' + . 'regiao,ibge,gia,ddd,siafi'; +} + +sub csv_body { + my (@rows) = @_; + return join( "\n", csv_header(), @rows ) . "\n"; +} + +sub json { + my ($data) = @_; + return $ENCODER->encode($data); +} + +sub new_client { + my ( $server, %args ) = @_; + require Cepis::Client; + return Cepis::Client->new( + base_url => $server->url, + timeout => 5.0, + backoff_base => 0.001, + backoff_max => 0.01, + %args, + ); +} + +sub new { + my ( $class, %args ) = @_; + + my $listener = IO::Socket::INET->new( + LocalAddr => '127.0.0.1', + LocalPort => 0, + Proto => 'tcp', + Listen => 128, + ReuseAddr => 1, + ) or die "TestServer: cannot listen: $!"; + + my $port = $listener->sockport; + + pipe( my $reader, my $writer ) or die "TestServer: pipe: $!"; + + my $pid = fork(); + die "TestServer: fork: $!" unless defined $pid; + + if ( $pid == 0 ) { + close $reader; + _child( $listener, $writer, $args{routes} || {}, $args{handler} ); + POSIX::_exit(0); + } + + close $writer; + close $listener; + + my $flags = fcntl( $reader, F_GETFL, 0 ); + fcntl( $reader, F_SETFL, $flags | O_NONBLOCK ); + + return bless { + pid => $pid, + port => $port, + reader => $reader, + buffer => '', + calls => [], + }, $class; +} + +sub url { return 'http://127.0.0.1:' . $_[0]->{port} } + +sub calls { + my ($self) = @_; + $self->_drain; + return @{ $self->{calls} }; +} + +sub count { + my ( $self, $prefix ) = @_; + $self->_drain; + return scalar grep { index( $_, $prefix ) == 0 } @{ $self->{calls} }; +} + +sub stop { + my ($self) = @_; + return unless $self->{pid}; + $self->_drain; + kill 'TERM', $self->{pid}; + waitpid $self->{pid}, 0; + close $self->{reader}; + delete $self->{pid}; + return; +} + +sub DESTROY { + my ($self) = @_; + local $@; + eval { $self->stop; 1 }; + return; +} + +sub _drain { + my ($self) = @_; + return unless $self->{reader}; + + while (1) { + my $chunk = ''; + my $read = sysread( $self->{reader}, $chunk, 65536 ); + last if !defined $read || $read == 0; + $self->{buffer} .= $chunk; + } + while ( $self->{buffer} =~ s/\A([^\n]*)\n// ) { + push @{ $self->{calls} }, $1; + } + return; +} + +sub _child { + my ( $listener, $writer, $routes, $handler ) = @_; + + local $SIG{PIPE} = 'IGNORE'; + $writer->autoflush(1); + + my %state = %$routes; + my $seen = 0; + + while (1) { + my $socket = $listener->accept or next; + binmode $socket; + $socket->autoflush(1); + + my $line = <$socket>; + if ( !defined $line ) { + close $socket; + next; + } + my $path = ( split /\s+/, $line )[1]; + $path = '' unless defined $path; + + my %request_headers; + while ( my $header = <$socket> ) { + last if $header eq "\r\n" || $header eq "\n"; + $request_headers{ lc $1 } = $2 if $header =~ /\A([^:]+):\s*(.*?)\s*\z/s; + } + + $seen++; + print {$writer} "$path\n"; + + my ( $status, $body, $headers ) + = @{ _response_for( \%state, $handler, $path, $seen, \%request_headers ) }; + $body = '' unless defined $body; + $headers = {} unless defined $headers; + + my $bytes = Encode::encode( 'UTF-8', $body ); + my $head = sprintf "HTTP/1.1 %d %s\r\n", $status, + ( $REASON{$status} || 'Unknown' ); + $head .= "$_: $headers->{$_}\r\n" for sort keys %$headers; + $head .= "Content-Type: text/plain; charset=utf-8\r\n"; + $head .= 'Content-Length: ' . length($bytes) . "\r\n"; + $head .= "Connection: close\r\n\r\n"; + + print {$socket} $head; + print {$socket} $bytes; + close $socket; + } + return; +} + +sub _response_for { + my ( $state, $handler, $path, $seen, $request_headers ) = @_; + + return $handler->( $path, $seen, $request_headers ) if $handler; + + my $response = $state->{$path}; + return [ 404, json( { erro => 'cep_nao_encontrado' } ), {} ] + unless defined $response; + + return $response unless ref $response->[0] eq 'ARRAY'; + return @$response > 1 ? shift @$response : $response->[0]; +} + +1; + +__END__ + +=encoding UTF-8 + +=head1 NAME + +TestServer - a throwaway HTTP/1.1 server for the Cepis suite + +=head1 DESCRIPTION + +Brings up a real HTTP server on a random loopback port and points the client at +it through C. Nothing in the suite touches the network and nothing +mocks L: the code path exercised is the one that runs in production, +request construction and error body reading included. + +Deliberately built on L rather than on a web server from CPAN, +because the suite must run against a stock Perl with nothing installed. + +The server runs in a forked child. Routes are set before the fork, so the child +inherits them; each request the child serves is written down a pipe, which is +what C and C read back in the parent. + +=head1 METHODS + +=head2 new + + my $server = TestServer->new( + routes => { '/01001000' => [ 200, $body, {} ] }, + handler => sub { my ( $path, $n ) = @_; return [ 200, $body, {} ] }, + ); + +A route value is either a C<[ $status, $body, \%headers ]> triple or an arrayref +of them, in which case each request consumes the next one and the last repeats +once the list runs out — that is how retrying is tested. An unrouted path +answers 404. + +C takes precedence over C and receives the path, the number of +requests served so far, and a hashref of the request headers with lowercased +names. The handler runs in the child, so the way to assert on a request header is +to return it in the body and check it in the parent. + +Bodies are character strings; the child encodes them as UTF-8 and sets +C from the encoded bytes. + +=head2 url + +The base URL to hand to C<< Cepis::Client->new >>. + +=head2 calls + +Every path requested so far, in order. + +=head2 count + +How many requests so far began with the given prefix. + +=head2 stop + +Stops the child and reaps it. Called automatically on destruction. + +=head1 EXPORTABLE FUNCTIONS + +C (the CEP fixture used across the suite), C, +C, C and C. + +=cut -- cgit v1.3