Business::TNTPost::NL - Calculate Dutch (TNT Post) shipping costs

  use Business::TNTPost::NL;

  my $tnt = Business::TNTPost::NL->new();
     $tnt->country('DE');
     $tnt->weight('534');
     $tnt->large(1);
     $tnt->priority(1);
     $tnt->tracktrace(1);
     $tnt->register(1);

  my $costs = $tnt->calculate or die $Business::TNTPost::NL::ERROR;

  use Business::TNTPost::NL;

  my $tnt = Business::TNTPost::NL->new();
  my $costs = $tnt->calculate(
                  country    =>'DE',
                  weight     => 534,
                  large      => 1,
                  tracktrace => 1,
                  register   => 1,
              ) or die $Business::TNTPost::NL::ERROR;

package Business::TNTPost::NL;

use strict;
use Business::TNTPost::NL::Data qw/:ALL/;
use Carp;
use List::Util qw/reduce/;

our $VERSION = 0.11;
our $ERROR   = undef;

use base qw/Class::Accessor::Fast/;

BEGIN {
    __PACKAGE__->mk_accessors(
        qw/cost large machine priority receipt register tracktrace weight zone/
    );
}

sub new {
    my ( $class, %parameters ) = @_;
    my $self = bless( {}, ref($class) || $class );
    return $self;
}

sub country {
    my ( $self, $cc ) = @_;

    if ($cc) {
        my $zones = Business::TNTPost::NL::Data::zones();
        $self->zone( defined $zones->{$cc} ? $zones->{$cc} : '4' );
    }

    return $self->zone;
}

sub calculate {
    my ( $self, %opt ) = @_;

    # Set the options
    for (
        qw/country weight large priority tracktrace
        register receipt machine/
      )
    {
        $self->$_( $opt{$_} ) if ( defined $opt{$_} );
    }

    croak "Not enough information!"
      unless ( defined $self->zone && defined $self->weight );

    # > 2000 grams automatically means 'tracktrace'
    $self->tracktrace(1) if ( $self->weight > 2000 );

    # Zone 1..4 (with tracktrace) automagically means 'priority'
    $self->priority(1) if ( $self->tracktrace );

    # Zone 3,4 + small automagically means 'priority'
    $self->priority(1) if( $self->zone > 3 && !$self->large );

    # All zones (above NL) are now priority by default
    $self->priority(1) if $self->zone;

    # Fetch the interesting table
    my $ref = _pointer_to_element( table(), $self->_generate_path );
    my $table = $$ref;

    my $highest = 0;
    foreach my $key ( keys %{$table} ) {
        my ( $lo, $hi ) = split ',', $key;
        $highest = $hi if ( $hi > $highest );
        if ( $self->weight >= $lo && $self->weight <= $hi ) {
            $self->cost( $table->{$key} );
            last;
        }
    }
    $ERROR = $self->weight - $highest . " grams too heavy (max: $highest gr.)"
      if ( $highest < $self->weight );

    return ( $self->cost ) ? sprintf( "%0.2f", $self->cost ) : undef;
}

sub _generate_path {
    my $self = shift;

    my @p;

    if ( $self->zone ) {
        push @p, 'world';    # world
        if ( $self->register ) {
            push @p, 'register',    # w/register
              ( $self->zone < 4 )   # w/register/(europe|world)
                ? 'europe'
                : 'world',
              ( $self->machine )   # w/register/(e|w)/(stamp|machine)
                ? 'machine'
                : 'stamp';
        }
        elsif ( $self->tracktrace ) {
            push @p, 'plus', 'zone', $self->zone;    # w/plus/zone/[1..4]
        }
        else {
            push @p, 'basic',           # w/basic
              ( $self->zone < 4 )       # w/basic/(europe|world)
                ? 'europe'
                : 'world',
              ( $self->large )          # w/basic/(e|w)/(large|small)
                ? 'large'
                : 'small';

        if( !$self->large ) {
        # w/basic/(e|w)/small/(machine|stamp)
                push @p, ( $self->machine ) ? 'machine' : 'stamp';
            }

            ### priority is now always the default
            push @p, 'priority';
            #push @p,
            #  ( $self->priority )       # w/basic/(e|w)/(l|s)/(m|s)?/(p|s)
            #    ? 'priority'
            #    : 'standard';
        }
    }
    else {
        push @p, 'netherlands';         # netherlands
        if ( $self->register ) {
            push @p, 'register';        # n/register
        }
        else {
            push @p, ( $self->large )   # n/(large|small)
              ? 'large'
              : 'small';
        }
        ( push @p, ( $self->machine ) ? 'machine' : 'stamp' )
            unless $self->large;;
    }
    # debug
    # print (join " :: ", @p), "\n";
    return @p;
}

sub _pointer_to_element {                       # Thanks 'merlyn'!
    require List::Util;
    return List::Util::reduce( sub { \( $$a->{$b} ) }, \shift, @_ );
}

1;