File Coverage

blib/lib/Geo/Postcodes.pm

Criterion	Covered	Total	%
statement	108	299	36.1
branch	50	234	21.3
condition	19	39	48.7
subroutine	21	39	53.8
pod	31	31	100.0
total	229	642	35.6

package Geo::Postcodes;

#################################################################################
#                                                                               #
#           This file is written by Arne Sommer - [e-mail]                 #
#                                                                               #
#################################################################################

use strict;
use warnings;

our $VERSION = '0.32';

## Which methods are available ##################################################

my @valid_fields = qw(postcode location borough county type type_verbose owner
                       address);  # Used by the 'get_fields' procedure.

my %valid_fields;

foreach (@valid_fields)
{
  $valid_fields{$_} = 1; # Used by 'is_field' for easy lookup.
}

## Type Description #############################################################

my %typedesc;

$typedesc{BX}   = "Post Office box";
$typedesc{ST}   = "Street address";
$typedesc{SX}   = "Service box";
$typedesc{IO}   = "Individual owner";
$typedesc{STBX} = "Street Address and Post Office box";
$typedesc{MU}   = "Multiple usage";
$typedesc{PP}   = "Porto Paye receiver";

$typedesc{PN}   = "Place name";

## OO Methods ###################################################################

our %postcode_of;
our %location_of;
our %borough_of;
our %county_of;
our %type_of;
our %owner_of;
our %address_of;

sub new
{
  my $class      = shift;
  my $postcode   = shift;
  my $self       = shift; # Allow for subclassing.

  return unless valid($postcode);

  unless ($self)
  {
    $self = bless \(my $dummy), $class;
  }

  $postcode_of {$self} =              $postcode;
  $location_of {$self} = location_of ($postcode);
  $borough_of  {$self} = borough_of  ($postcode);
  $county_of   {$self} = county_of   ($postcode);
  $type_of     {$self} = type_of     ($postcode);
  $owner_of    {$self} = owner_of    ($postcode);
  $address_of  {$self} = address_of  ($postcode);
  return $self;
}

sub DESTROY
{
  my $object_id = $_[0];

  delete $postcode_of {$object_id};
  delete $location_of {$object_id};
  delete $borough_of  {$object_id};
  delete $county_of   {$object_id};
  delete $type_of     {$object_id};
  delete $owner_of    {$object_id};
  delete $address_of  {$object_id};
}

sub postcode
{
  my $self = shift;
  return unless defined $self;
  return $postcode_of{$self} if exists $postcode_of{$self};
  return;
}

sub location
{
  my $self = shift;
  return unless defined $self;
  return $location_of{$self} if exists $location_of{$self};
  return;
}

sub borough
{
  my $self = shift;
  return unless defined $self;
  return $borough_of{$self} if exists $borough_of{$self};
  return;
}

sub county
{
  my $self = shift;
  return unless defined $self;
  return $county_of{$self} if exists $county_of{$self};
  return;
}

sub type
{
  my $self = shift;
  return unless defined $self;
  return $type_of{$self} if exists $type_of{$self};
  return;
}

sub type_verbose
{
  my $self = shift;
  return unless defined $self;
  return unless exists $type_of{$self};
  return unless exists $typedesc{$type_of{$self}};
  return $typedesc{$type_of{$self}};
}

sub owner
{
  my $self = shift;
  return unless defined $self;
  return $owner_of{$self} if exists $owner_of{$self};
  return;
}

sub address
{
  my $self = shift;
  return unless defined $self;
  return $address_of{$self} if exists $address_of{$self};
  return;
}

#################################################################################

sub get_postcodes      ## Return all the postcodes, unsorted.
{
  return;
}

sub get_fields         ## Get a list of legal fields for the class/object.
{
  return @valid_fields;
}

sub is_field           ## Is the specified field legal? Can be called as
{                      ## a procedure, or as a method.
  my $field = shift;
  $field    = shift if $field =~ /Geo::Postcodes/; # Called on an object.

  return 1 if $valid_fields{$field};
  return 0;
}

## Global Procedures  - Stub Version, Override in your subclass #################

sub legal # Is it a legal code, i.e. something that follows the syntax rule.
{
  return 0;
}

sub valid # Is the code in actual use.
{
  return 0;
}

sub postcode_of
{
  return;
}

sub location_of
{
  return;
}

sub borough_of
{
  return;
}

sub county_of
{
  return;
}

sub type_of
{
  return;
}

sub type_verbose_of
{
  return;
}

sub owner_of
{
  return;
}

sub address_of
{
  return;
}

sub get_types
{
  return keys %typedesc;
}

sub type2verbose
{
  my $type = shift;
  return unless $type;
  return unless exists $typedesc{$type};
  return $typedesc{$type};
}

my %legal_mode;
   $legal_mode{'and'}  = $legal_mode{'and not'}  = 1;
   $legal_mode{'nand'} = $legal_mode{'nand not'} = 1;
   $legal_mode{'nor'}  = $legal_mode{'nor not'}  = 1;
   $legal_mode{'or'}   = $legal_mode{'or not'}   = 1;
   $legal_mode{'xnor'} = $legal_mode{'xnor not'} = 1;
   $legal_mode{'xor'}  = $legal_mode{'xor not'}  = 1;

my %legal_initial_mode;
   $legal_initial_mode{'all'} = $legal_initial_mode{'none'} = 1;
   $legal_initial_mode{'not'} = $legal_initial_mode{'one'}  = 1;

sub is_legal_selectionmode
{
  my $mode = shift;
  return 1 if $legal_mode{$mode};
  return 0;
}

sub is_legal_initial_selectionmode
{
  my $mode = shift;
  return 1 if $legal_initial_mode{$mode} or $legal_mode{$mode};
  return 0;
}

sub get_selectionmodes
{
  return sort keys %legal_mode;
}

sub get_initial_selectionmodes
{
  return sort (keys %legal_mode, keys %legal_initial_mode);
}

sub verify_selectionlist
{
  return Geo::Postcodes::_verify_selectionlist('Geo::Postcodes', @_);
    # Black magic.
}

sub _verify_selectionlist
{
  my $caller_class = shift;
  my @args         = @_;    # A list of selection arguments to verify

  my $status       = 1;     # Return value
  my @out          = ();
  my @verbose      = ();

  return (0, "No arguments") unless @args;

  if (is_legal_initial_selectionmode($args[0]))
  {
    my $mode = shift @args;

    if (@args and $args[0] eq "not" and is_legal_initial_selectionmode("$mode $args[0]"))
    {
      $mode = "$mode $args[0]";
      shift @args;
    }

    push @out, $mode;
    push @verbose, "Mode: '$mode' - ok";

    return (1, @out) if $mode eq "all" or $mode eq "none";
    return (1, @out) if $mode eq "one" and @args == 0;
      # This one can both be used alone, or followed by more.

    return (0, @verbose, "Missing method/value pair - not ok") unless @args >= 2;
        # Missing method/value pair.
  }

  ## Done with the first one

  while (@args)
  {
    my $argument = shift(@args);

    if ($caller_class->is_field($argument))
    {
      push @out, $argument;
      push @verbose, "Field: '$argument' - ok";

      if (@args)
      {
        $argument = shift(@args);
        push @out, $argument;
        push @verbose, "String: '$argument' - ok";
      }
      else
      {
        push @verbose, "Missing string - not ok"; # The last element was a method.
        $status = 0;
        @args = (); # Terminate the loop
      }
    }
    elsif (is_legal_selectionmode($argument))
    {
      if (@args and $args[0] eq "not" and is_legal_selectionmode("$argument $args[0]"))
      {
        $argument = "$argument $args[0]";
        shift @args;
      }
      push @out, $argument;
      push @verbose, "Mode: '$argument' - ok";

      unless (@args >= 2) # Missing method/value pair
      {
        push @verbose, "Missing method/value pair - not ok";
        $status = 0;
        @args = (); # Terminate the loop
      }
    }
    elsif ($argument eq 'procedure')
    {
      push @out, $argument;
      push @verbose, "Field: 'procedure' - ok";

      my $procedure = shift(@args);
      if (ref $procedure eq "CODE")
      {
        if (_valid_procedure_pointer($procedure))
        {
          push @out, $procedure;
          push @verbose, "Procedure pointer: '$procedure' - ok";
        }
        else
        {
          push @verbose, "No such procedure: '$procedure' - not ok";
          $status = 0;
          @args   = (); # Terminate the loop
        }
      }
      else
      {
        push @verbose, "Not a procedure pointer: '$procedure' - not ok";
        $status = 0;
        @args   = (); # Terminate the loop
      }
    }
    else
    {
      push @verbose, "Illegal argument: '$argument' - not ok";
      $status = 0;
      @args   = (); # Terminate the loop
    }
  }

  return (1, @out) if $status; # Return a modified argument list on success.

  return (0, @verbose);        # Return a list of diagnostic meddages on failure.
}

sub selection_loop
{
  return Geo::Postcodes::_selection_loop('Geo::Postcodes', @_);
    # Black magic.
}

sub _selection_loop
{
  my $caller_class      = shift;

  my $objects_requested = 0; # Not object oriented.

  if ($_[0] eq $caller_class)
  {
    $objects_requested  = 1;
    shift;
  }

  my $procedure_pointer = shift;

  return 0 unless $procedure_pointer;

  my @selection_clauses = @_;
  my @postcodes         = _selection($caller_class, @selection_clauses);

  return 0 unless @postcodes;

  foreach (@postcodes)
  {
    &$procedure_pointer($objects_requested ? $caller_class->new($_) : $_);
  }
  return 1;
}


#################################################################################
#                                                                               #
#  Returns a list of postcodes if called as a procedure;                        #
#    Geo::Postcodes::XX::selection(...)                                         #
#  Returns a list of objects if called as a method;                             #
#    Geo::Postcodes::XX->selection(...)                                         #
#                                                                               #
# Note that 'or' and 'not' are not written efficient, as they recompile the     #
# regular expression(s) for every postcode.                                     #
#                                                                               #
#################################################################################

sub selection
{
  return Geo::Postcodes::_selection('Geo::Postcodes', @_);
    # Black magic.
}

sub _selection
{
  my $caller_class      = shift;

  my $objects_requested = 0; # Not object oriented.

  if ($_[0] eq $caller_class)
  {
    $objects_requested  = 1;
    shift;
  }

  if ($_[0] eq 'all')
  {
    my @all = sort &{&_proc_pointer($caller_class . '::get_postcodes')}();
      # Get all the postcodes.

    return @all unless $objects_requested;

    my @out_objects;

    foreach my $postcode (@all)
    {
      push(@out_objects, $caller_class->new($postcode));
    }

    return @out_objects;
  }

  elsif ($_[0] eq 'none')
  {
    return; # Absolutely nothing.
  }

  my $limit = 0; # Set to one if we have requested only one postcode.
  if ($_[0] eq "one")
  {
    $limit = 1;
    shift; # Get rid of the mode.
  }

  my $mode = "and";
    # The mode defaults to 'and' unless specified.

  my %out = ();

  ## The first set of method/value ##############################################

  my @all = &{&_proc_pointer($caller_class . '::get_postcodes')}();
    # Get all the postcodes.

  my($field, $current_field, $value, $current_value);

  if (@_) # As 'one' can be without additional arguments.
  {
    if (is_legal_initial_selectionmode($_[0]))
    {
      if ($_[1] eq "not" and is_legal_initial_selectionmode("$_[0] $_[1]"))
      {
        $mode = shift; $mode .= " "; $mode .= shift;
      }
      else
      {
        $mode = shift if is_legal_initial_selectionmode($_[0]);
      }
    }

    $field = shift;

    if ($field eq 'procedure')
    {
      my $procedure = shift;
      return unless _valid_procedure_pointer($procedure);

      my $match;

      foreach my $postcode (@all)
      {
        eval { $match = $procedure->($_); };
        return if $@; # Return if the procedure was uncallable.

        if ($mode =~ /not/) { $out{$postcode}++ unless $match; }
        else                { $out{$postcode}++ if     $match; }
      }
    }
    else
    {
      return unless &{&_proc_pointer($caller_class . '::is_field')}($field);
        # Return if the specified method is undefined for the class.
        # As and 'and' with a list with one undefined item gives an empty list.

      my $current_field = &_proc_pointer($caller_class . '::' . $field .'_of');

      $value  = shift; $value =~ s/%/\.\*/g;
      return unless $value;
        # A validity check is impossible, so this is the next best thing.

      foreach my $postcode (@all)
      {
        $current_value = $current_field->($postcode);
          # Call the procedure with the current postcode as argument

        next unless $current_value;
          # Skip postcodes without this field.

        my $match = $current_value =~ m{^$value$}i; ## Case insensitive

        if ($mode =~ /not/) { $out{$postcode}++ unless $match; }
        else                { $out{$postcode}++ if     $match; }
      }
    }

    $mode = 'and' if $mode eq 'not';
  }

  elsif ($limit) # just one argument; 'one'.
  {
    map { $out{$_} = 1 } @all
  }

  while (@_)
  {
    if (is_legal_selectionmode($_[0]))
    {
      if ($_[1] eq "not" and is_legal_selectionmode("$_[0] $_[1]"))
      {
        $mode = shift; $mode .= " "; $mode .= shift;
      }
      else
      {
        $mode = shift if is_legal_selectionmode($_[0]);
      }
    }

    # Use the one already on hand, if none is given.

    my $is_procedure = 0;
    my $procedure;

    $field = shift;

    if ($field eq 'procedure')
    {
      $is_procedure = 1;
      $procedure = shift;
      return unless _valid_procedure_pointer($procedure);
    }
    else
    {
      return unless &{&_proc_pointer($caller_class . '::is_field')}($field);
        # Return if the specified method is undefined for the class.
        # As an 'and' with a list with one undefined item gives an empty list.

      $current_field = &_proc_pointer($caller_class . '::' . $field .'_of');

      $value = shift;
      $value =~ s/%/\.\*/g;
      return unless $value;
        # A validity check is impossible, so this is the next best thing.
    }

    foreach my $postcode ($mode =~ /and/ ? (keys %out) : @all)
    {
      # We start with the result from the previous iteration if the mode
      # is one of the 'and'-family. Otherwise it is one of the 'or'-family,
      # and we have to start from scratch (@all).

      my $match;

      if ($procedure)
      {
        eval { $match = $procedure->($postcode); };
        return if $@; # Return if the procedure was uncallable.
      }
      else
      {
        $current_value = $current_field->($postcode);
          # Call the procedure with the current postcode as argument

        next unless $current_value;
          # Skip postcodes without this field.

        $match = $current_value =~ m{^$value$}i; ## Case insensitive
      }

      if    ($mode eq "and")
      {
        delete $out{$postcode} unless $match;
      }
      elsif ($mode eq "and not")
      {
        delete $out{$postcode} if     $match;
      }

      elsif ($mode eq "nand")
      {
        if ($match and $out{$postcode})   { delete $out{$postcode} if $out{$postcode}; }
        else                              { $out{$postcode}++;                         }
      }
      elsif ($mode eq "nand not")
      {
        if (!$match and $out{$postcode})  { delete $out{$postcode} if $out{$postcode}; }
        else                              { $out{$postcode}++;                         }
      }

      elsif ($mode eq "or")
      {
        $out{$postcode}++      if     $match;
      }
      elsif ($mode eq "or not")
      {
        $out{$postcode}++      unless $match;
      }
      elsif ($mode eq "nor")
      {
        if (!$match and !$out{$postcode}) { $out{$postcode}++;                         }
        else                              { delete $out{$postcode} if $out{$postcode}; }
      }
      elsif ($mode eq "nor not")
      {
        if ($match and !$out{$postcode})  { $out{$postcode}++;                         }
        else                              { delete $out{$postcode} if $out{$postcode}; }
      }
      elsif ($mode eq "xor")
      {
        if ($match)
        {
          if ($out{$postcode}) { delete $out{$postcode}; }
          else                 { $out{$postcode}++;      }
        }
      }
      elsif ($mode eq "xor not")
      {
        unless ($match)
        {
           if ($out{$postcode}) { delete $out{$postcode}; }
           else                 { $out{$postcode}++;      }
        }
      }

      elsif ($mode eq "xnor")
      {
        my $boolean = $out{$postcode} ? 1 : 0;
        if ($match == $boolean)
        {
          $out{$postcode}++;
        }
        else
        {
          delete $out{$postcode} if $out{$postcode};
        }
      }
      elsif ($mode eq "xnor not")
      {
        my $boolean = $out{$postcode} ? 1 : 0;
        if ($match != $boolean)
        {
          $out{$postcode}++;
        }
        else
        {
          delete $out{$postcode} if $out{$postcode};
        }
      }
    }
  }

  ###############################################################################

  return unless %out;
    # Return nothing if we have an empty list (or rather, hash).

  my @out;

  if ($limit)                   # The caller has requested just one postcode,   #
  {                             #  and will get exactly that if any matches     #
    my @list = keys %out;       #  were found. The returned postcode is chosen  #
    @out = $list[rand(@list)];  #  by random.                                   #
  }
  else
  {
    @out = sort keys %out;
      # This will give an ordered list, as opposed to a semi random order. This #
      # is essential when comparing lists of postcodes, as the test scripts do. #
  }

  ###############################################################################

  return @out unless $objects_requested;

  my @out_objects;

  foreach my $postcode (@out)
  {
    push(@out_objects, $caller_class->new($postcode));
  }

  return @out_objects;
}


sub _proc_pointer
{
  my $procedure_name = shift;
  return \&{$procedure_name};
}

sub _valid_procedure_pointer
{
  my $ptr = shift;
  return 0 if ref $ptr ne "CODE";
  return 1 if defined(&$ptr);
  return 0;
}

1;
__END__