File Coverage

blib/lib/Business/DK/Postalcode.pm

Criterion	Covered	Total	%
statement	146	146	100.0
branch	26	26	100.0
condition			n/a
subroutine	25	25	100.0
pod	8	8	100.0
total	205	205	100.0

package Business::DK::Postalcode;

use strict;
use warnings;
use Tree::Simple;
use base qw(Exporter);
use Params::Validate qw(validate_pos SCALAR ARRAYREF OBJECT);
use utf8;
use 5.010; #5.10.0

use constant TRUE                        => 1;
use constant FALSE                       => 0;
use constant NUM_OF_DATA_ELEMENTS        => 6;
use constant NUM_OF_DIGITS_IN_POSTALCODE => 4;

## no critic (Variables::ProhibitPackageVars)
our @postal_data = ;

no strict 'refs';

my $regex;

our $VERSION = '0.12';
our @EXPORT_OK
    = qw(get_all_postalcodes get_all_cities get_all_data create_regex validate_postalcode validate get_city_from_postalcode get_postalcode_from_city);

# TODO: we have to disable this policy here for some reason?
## no critic (Subroutines::RequireArgUnpacking)
sub validate_postalcode {
    my ($postalcode) = @_;

   #loose check since we are doing actual validation, so we just need a scalar
    validate_pos( @_, { type => SCALAR }, );

    if ( not $regex ) {
        $regex = ${ create_regex() };
    }

    if (my ($untainted_postalcode)
        = $postalcode =~ m{
        \A #beginning of string
        ($regex) #generated regular expression, capturing
        \z #end of string
        }xsm
        )
    {
        return $untainted_postalcode;
    } else {
        return FALSE;
    }
}

## no critic (Subroutines::RequireArgUnpacking)
sub validate {

    #validation happens in next step (see: validate_postalcode)
    return validate_postalcode( $_[0] );
}

sub get_all_data {
    return \@postal_data;
}

sub get_all_cities {
    my @cities = ();

    _retrieve_cities( \@cities );

    return \@cities;

}

sub get_city_from_postalcode {
    my ($parameter_data) = @_;
    my $city = '';

    validate( @_, {
        zipcode => { type => SCALAR }, });

    my $postaldata = get_all_data();

    foreach my $line (@{$postaldata}) {
        my @entries = split /\t/x, $line, NUM_OF_DATA_ELEMENTS;

        if ($entries[0] eq $parameter_data) {
            $city = $entries[1];
            last;
        }
    }

    return $city;
}

sub get_postalcode_from_city {
    my ($parameter_data) = @_;
    my @postalcodes;

    validate( @_, {
        city => { type => SCALAR }, });

    my $postaldata = get_all_data();

    foreach my $line (@{$postaldata}) {
        my @entries = split /\t/x, $line, NUM_OF_DATA_ELEMENTS;

        if ($entries[1] =~ m/$parameter_data$/i) {
            push @postalcodes, $entries[0];
        }
    }

    return @postalcodes;
}

sub get_all_postalcodes {
    my ($parameter_data) = @_;
    my @postalcodes = ();

    validate_pos( @_, { type => ARRAYREF, optional => TRUE }, );

    if ( not $parameter_data ) {
        @{$parameter_data} = @postal_data;
    }

    foreach my $zipcode ( @{$parameter_data} ) {
        _retrieve_postalcode( \@postalcodes, $zipcode );
    }

    return \@postalcodes;
}

sub _retrieve_cities {
    my ( $cities ) = @_;

    #this is used internally, but we stick it in here just to make sure we
    #get what we want
    validate_pos( @_, { type => ARRAYREF }, );

    foreach my $line (@postal_data) {
        my @entries = split /\t/x, $line, NUM_OF_DATA_ELEMENTS;

        push @{$cities}, $entries[1];
    }

    return;
}

sub _retrieve_postalcode {
    my ( $postalcodes, $string ) = @_;

    #this is used internally, but we stick it in here just to make sure we
    #get what we want
    validate_pos( @_, { type => ARRAYREF }, { type => SCALAR, regex => qr/[\w\t]+/, }, );

    ## no critic qw(RegularExpressions::RequireLineBoundaryMatching RegularExpressions::RequireExtendedFormatting RegularExpressions::RequireDotMatchAnything)
    my @entries = split /\t/x, $string, NUM_OF_DATA_ELEMENTS;

    if ($entries[0] =~ m{
        ^ #beginning of string
        \d{${\NUM_OF_DIGITS_IN_POSTALCODE}} #digits in postalcode
        $ #end of string
        }xsm
        )
    {
        push @{$postalcodes}, $entries[0];
    }

    return 1;
}

sub create_regex {
    my ($postalcodes) = @_;

    validate_pos( @_, { type => ARRAYREF, optional => 1 } );

    if ( not $postalcodes ) {
        $postalcodes = get_all_postalcodes();
    }

    my $tree = Tree::Simple->new( 'ROOT', Tree::Simple->ROOT );

    foreach my $postalcode ( @{$postalcodes} ) {
        _build_tree( $tree, $postalcode );
    }

    my $generated_regex = [];

    my $no_of_children = $tree->getChildCount();

    foreach my $child ( $tree->getAllChildren() ) {
        if ( $child->getIndex() < ( $tree->getChildCount() - 1 ) ) {
            $child->insertSibling( $child->getIndex() + 1,
                Tree::Simple->new(q{|}) );
        }
    }
    $tree->insertChild( 0, Tree::Simple->new('(') );
    $tree->addChild( Tree::Simple->new(')') );

    $tree->traverse(
        sub {
            my ($_tree) = shift;

            #DEBUG section - outputs tree to STDERR
            # warn "\n";
            # $tree->traverse(
            #     sub {
            #         my ($traversal_tree) = @_;
            #         warn( "\t" x $traversal_tree->getDepth() )
            #             . $traversal_tree->getNodeValue() . "\n";
            #     }
            # );

            my $no_of_children = $_tree->getChildCount();

            if ( $no_of_children > 1 ) {

                foreach my $child ( $_tree->getAllChildren() ) {
                    if ($child->getIndex() < ( $_tree->getChildCount() - 1 ) )
                    {
                        $child->insertSibling( $child->getIndex() + 1,
                            Tree::Simple->new(q{|}) );
                    }
                }

                #first element
                $_tree->insertChild( 0, Tree::Simple->new('(') );

                #last element
                $_tree->addChild( Tree::Simple->new(')') );
            }
        }
    );

    #traverses the tree and creates a flat list of the tree
    $tree->traverse(
        sub {
            my ($traversal_tree) = shift;
            push @{$generated_regex}, $traversal_tree->getNodeValue();
        }
    );

    #stringifies the flat list so we have a string representation of the
    #generated regular expression
    my $result = join q{}, @{$generated_regex};

    return \$result;
}

sub _build_tree {
    my ( $tree, $postalcode ) = @_;

    ## no critic qw(RegularExpressions::RequireLineBoundaryMatching RegularExpressions::RequireExtendedFormatting RegularExpressions::RequireDotMatchAnything)
    validate_pos(
        @_,
        { type => OBJECT, isa   => 'Tree::Simple' },
        { type => SCALAR, regex => qr/\d{${\NUM_OF_DIGITS_IN_POSTALCODE}}/, },
    );

    my $oldtree = $tree;

    my @digits = split //xsm, $postalcode, NUM_OF_DIGITS_IN_POSTALCODE;
    for ( my $i = 0; $i < scalar @digits; $i++ ) {

        if ( $i == 0 ) {
            $tree = $oldtree;
        }

        my $subtree = Tree::Simple->new( $digits[$i] );

        my @children = $tree->getAllChildren();
        my $child    = undef;
        foreach my $c (@children) {
            if ( $c->getNodeValue() == $subtree->getNodeValue() ) {
                $child = $c;
                last;
            }
        }

        if ($child) {
            $tree = $child;
        } else {
            $tree->addChild($subtree);
            $tree = $subtree;
        }
    }
    $tree = $oldtree;

    return 1;
}

1;

=encoding UTF-8

=pod

=begin markdown

[![CPAN version](https://badge.fury.io/pl/Business-DK-Postalcode.svg)](http://badge.fury.io/pl/Business-DK-Postalcode)
[![Build Status](https://travis-ci.org/jonasbn/bdkpst.svg?branch=master)](https://travis-ci.org/jonasbn/bdkpst)
[![Coverage Status](https://coveralls.io/repos/jonasbn/bdkpst/badge.png?branch=master)](https://coveralls.io/r/jonasbn/bdkpst?branch=master)

=end markdown

=head1 NAME

Business::DK::Postalcode - Danish postal code validator and container

=head1 VERSION

This documentation describes version 0.08

=head1 SYNOPSIS

    # basic validation of string
    use Business::DK::Postalcode qw(validate);

    if (validate($postalcode)) {
        print "We have a valid Danish postalcode\n";
    } else {
        warn "Not a valid Danish postalcode\n";
    }


    # basic validation of string, using less intrusive subroutine
    use Business::DK::Postalcode qw(validate_postalcode);

    if (validate_postalcode($postalcode)) {
        print "We have a valid Danish postal code\n";
    } else {
        warn "Not a valid Danish postal code\n";
    }


    # using the untainted return value
    use Business::DK::Postalcode qw(validate_postalcode);

    if (my $untainted = validate_postalcode($postalcode)) {
        print "We have a valid Danish postal code: $untainted\n";
    } else {
        warn "Not a valid Danish postal code\n";
    }


    # extracting a regex for validation of Danish postal codes
    use Business::DK::Postalcode qw(create_regex);

    my $regex_ref = ${create_regex()};

    if ($postalcode =~ m/$regex/) {
        print "We have a valid Danish postal code\n";
    } else {
        warn "Not a valid Danish postal code\n";
    }


    # All postal codes for use outside this module
    use Business::DK::Postalcode qw(get_all_postalcodes);

    my @postalcodes = @{get_all_postalcodes()};


    # All postal codes and data for use outside this module
    use Business::DK::Postalcode qw(get_all_data);

    my $postalcodes = get_all_data();

    foreach (@{postalcodes}) {
        printf
            'postal code: %s city: %s street/desc: %s company: %s province: %d country: %d', split /\t/, $_, 6;
    }

=head1 FEATURES

=over

=item * Providing list of Danish postal codes and related area names

=item * Look up methods for Danish postal codes for web applications and the like

=back

=head1 DESCRIPTION

This distribution is not the original resource for the included data, but simply
acts as a simple distribution for Perl use. The central source is monitored so this
distribution can contain the newest data. The monitor script (F) is
included in the distribution.

The data are converted for inclusion in this module. You can use different extraction
subroutines depending on your needs:

=over

=item * L, to retrieve all data, data description below in L.

=item * L, to retrieve all postal codes

=item * L, to retieve all cities

=item * L, to retrieve one or more postal codes from a city name

=item * L, to retieve a city name from a postal code

=back

=head2 Data

Here follows a description of the included data, based on the description from
the original source and the authors interpretation of the data, including
details on the distribution of the data.

=head3 city name

A non-unique, case-sensitive representation of a city name in Danish.

=head3 street/description

This field is either a streetname or a description, is it only provided for
a few special records.

=head3 company name

This field is only provided for a few special records.

=head3 province

This field is a bit special and it's use is expected to be related to distribution
all entries inside Copenhagen are marked as 'False' in this column and 'True' for
all entries outside Copenhagen - and this of course with exceptions. The data are
included since they are a part of the original data.

=head3 country

Since the original source contains data on 3 different countries:

=over

=item * Denmark

=item * Greenland

=item * Faroe Islands

=back

Only the data representing Denmark has been included in this distribtion, so this
field is always containing a one.

For access to the data on Greenland or Faroe Islands please refer to: L
and L respectfully.

=head2 Encoding

The data distributed are in Danish for descriptions and names and these are encoded in UTF-8.

=head1 EXAMPLES

A web application example is included in the examples directory following this distribution
or available at L.

=head1 SUBROUTINES AND METHODS

=head2 validate

A simple validator for Danish postal codes.

Takes a string representing a possible Danish postal code and returns either
B<1> or B<0> indicating either validity or invalidity.

    my $rv = validate(2665);

    if ($rv == 1) {
        print "We have a valid Danish postal code\n";
    } ($rv == 0) {
        print "Not a valid Danish postal code\n";
    }

=head2 validate_postalcode

A less intrusive subroutine for import. Acts as a wrapper of L.

    my $rv = validate_postalcode(2300);

    if ($rv) {
        print "We have a valid Danish postal code\n";
    } else {
        print "Not a valid Danish postal code\n";
    }

=head2 get_all_data

Returns a reference to a a list of strings, separated by tab characters. See
L for a description of the fields.

    use Business::DK::Postalcode qw(get_all_data);

    my $postalcodes = get_all_data();

    foreach (@{postalcodes}) {
        printf
            'postalcode: %s city: %s street/desc: %s company: %s province: %d country: %d', split /\t/, $_, 6;
    }

=head2 get_all_postalcodes

Takes no parameters.

Returns a reference to an array containing all valid Danish postal codes.

    use Business::DK::Postalcode qw(get_all_postalcodes);

    my $postalcodes = get_all_postalcodes;

    foreach my $postalcode (@{$postalcodes}) { ... }

=head2 get_all_cities

Takes no parameters.

Returns a reference to an array containing all Danish city names having a postal code.

    use Business::DK::Postalcode qw(get_all_cities);

    my $cities = get_all_cities;

    foreach my $city (@{$cities}) { ... }

Please note that this data source used in this distribution by no means is authorative
when it comes to cities located in Denmark, it might have all cities listed, but
unfortunately also other post distribution data.

=head2 get_city_from_postalcode

Takes a string representing a Danish postal code.

Returns a single string representing the related city name or an empty string indicating nothing was found.

    use Business::DK::Postalcode qw(get_city_from_postalcode);

    my $zipcode = '2300';

    my $city = get_city_from_postalcode($zipcode);

    if ($city) {
        print "We found a city for $zipcode\n";
    } else {
        warn "No city found for $zipcode";
    }

=head2 get_postalcode_from_city

Takes a string representing a Danish city name.

Returns a reference to an array containing zero or more postal codes related to that city name. Zero indicates nothing was found.

Please note that city names are not unique, hence the possibility of a list of postal codes.

    use Business::DK::Postalcode qw(get_postalcode_from_city);

    my $city = 'København K';

    my $postalcodes = get_postalcode_from_city($city);

    if (scalar @{$postalcodes} == 1) {
        print "$city is unique\n";
    } elsif (scalar @{$postalcodes} > 1) {
        warn "$city is NOT unique\n";
    } else {
        die "$city not found\n";
    }

=head2 create_regex

This method returns a generated regular expression for validation of a string
representing a possible Danish postal code.

    use Business::DK::Postalcode qw(create_regex);

    my $regex_ref = ${create_regex()};

    if ($postalcode =~ m/$regex/) {
        print "We have a valid Danish postalcode\n";
    } else {
        print "Not a valid Danish postalcode\n";
    }

=head1 PRIVATE SUBROUTINES AND METHODS

=head2 _retrieve_cities

Takes a reference to an array based on the DATA section and return a reference
to an array containing only city names.

=head3 _retrieve_postalcode

Takes a reference to an array based on the DATA section and return a reference
to an array containing only postal codes.

=head3 _build_tree

Internal method to assist L in generating the regular expression.

Takes a L object and a reference to an array of data elements.

=head1 DIAGNOSTICS

There are not special diagnostics apart from the ones related to the different
subroutines.

=head1 CONFIGURATION AND ENVIRONMENT

This distribution requires no special configuration or environment.

=head1 DEPENDENCIES

=over

=item * L (core)

=item * L (core)

=item * L

=item * L

=back

=head2 TEST

Please note that the above list does not reflect requirements for:

=over

=item * Additional components in this distribution, see F. Additional
components list own requirements

=item * Test and build system, please see: F for details

=item * Requirements for scripts in the F directory

=item * Requirements for examples in the F directory

=back

=head1 BUGS AND LIMITATIONS

There are no known bugs at this time.

The data source used in this distribution by no means is authorative when it
comes to cities located in Denmark, it might have all cities listed, but
unfortunately also other post distribution data.

=head1 BUG REPORTING

Please report issues via CPAN RT:

=over

=item * Web (RT): L

=item * Web (Github): L

=item * Email (RT): L

=back

=head1 INCOMPATIBILITIES

There are no known incompatibilities at this time.

=head1 TEST AND QUALITY

=head2 Perl::Critic

This version of the code is complying with L a severity: 1

The following policies have been disabled.

=over

=item * L

Disabled locally using 'no critic' pragma.

The module  uses a package variable as a cache, this might not prove usefull in
the long term, so when this is adressed and this might address this policy.

=item * L

Disabled locally using 'no critic' pragma.

This policy is violated when using L at some point this will
be investigated further, this might be an issue due to referral to @_.

=item * L

Disabled locally using 'no critic' pragma.

This is disabled for some two basic regular expressions.

=item * L

Disabled locally using 'no critic' pragma.

This is disabled for some two basic regular expressions.

=item * L

Disabled locally using 'no critic' pragma.

This is disabled for some two basic regular expressions.

=item * L

Constants are good, - see the link below.

=item * L

=item * L

This one interfers with our DATA section, perhaps DATA should go before POD,
well it is not important so I have disabled the policy.

=item * L

This would require a re-write of part of the code. Currently I rely on use of the iterator in the F loop, so it would require significant
changes.

=item * L

Temporarily disabled, marked for follow-up

=back

Please see F for details.

=head2 TEST COVERAGE

Test coverage report is generated using L via L,
for the version described in this documentation (See L).

    ---------------------------- ------ ------ ------ ------ ------ ------ ------
    File                           stmt   bran   cond    sub    pod   time  total
    ---------------------------- ------ ------ ------ ------ ------ ------ ------
    ...Business/DK/Postalcode.pm  100.0  100.0    n/a  100.0  100.0   98.7  100.0
    ...Business/DK/Postalcode.pm  100.0  100.0    n/a  100.0  100.0    1.2  100.0
    Total                         100.0  100.0    n/a  100.0  100.0  100.0  100.0
    ---------------------------- ------ ------ ------ ------ ------ ------ ------

    $ ./Build testcover

=head1 SEE ALSO

=over

=item * Main data source: L

=item * Information resource on data source: L

=item * Alternative implementation: L

=item * Alternative validation: L

=item * Related complementary implementation: L

=item * Related complementary implementation: L

=item * Related implementation, same author: L

=item * Related implementation, same author: L

=item * Related implementation, same author: L

=item * Related implementation, same author: L

=back

=head1 RESOURCES

=over

=item * MetaCPAN: L

=item * Website: L

=item * Bugtracker: L

=item * Git repository: L

=back

=head1 TODO

Please see the project F file, or the bugtracker (RT), website or issues resource at Github.

=head1 AUTHOR

=over

=item * Jonas B. Nielsen, (jonasbn) - C<<  >>

=back

=head1 ACKNOWLEDGEMENTS

=over

=item * Mohammad S Anwar, POD corrections PR #6

=back

=head1 MOTIVATION

Back in 2006 I was working on a project where I needed to do some presentation
and validation of Danish postal codes. I looked at L

The implementation at the time of writing looked as follows:

    Denmark     =>  "(?k:(?k:[1-9])(?k:[0-9])(?k:[0-9]{2}))",
    # Postal codes of the form: 'DDDD', with the first
    # digit representing the distribution region, the
    # second digit the distribution district. Postal
    # codes do not start with a zero. Postal codes
    # starting with '39' are in Greenland.

This pattern holds some issues:

=over

=item * Doing some fast math you can see that you will allow 9000 valid postal
codes where the number should be about 1254

=item * 0 is actually allowed for a set of postal codes used by the postal service
in Denmark, in some situations these should perhaps be allowed as valid data

=item * Greenland specified as starting with '39' is not a part of Denmark, but
should be under Greenland and the ISO code 'GL', see also:

=over

=item * L

=back

=back

So I decided to write a regular expression, which would be better than the one
above, but I did not want to maintain it I wanted to write a piece of software,
which could generate the pattern for me based on a finite data set.

=head1 COPYRIGHT

Business-DK-Postalcode is (C) by Jonas B. Nielsen, (jonasbn) 2006-2019

=head1 LICENSE

Business-DK-Postalcode and related is released under the Artistic License 2.0

=over

=item * L

=back

=cut

__DATA__