xref: /dports/misc/p5-Geo-Postcodes/Geo-Postcodes-0.32/lib/Geo/Postcodes.pm

package Geo::Postcodes;

#################################################################################
#                                                                               #
#           This file is written by Arne Sommer - perl@bbop.org                 #
#                                                                               #
#################################################################################

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__

=head1 NAME

Geo::Postcodes - Base class for the Geo::Postcodes::* modules

=head1 SYNOPSIS

This module should not be used directly from application programs, but from a
country subclass; e.g.:

 package Geo::Postcodes::U2;

 use Geo::Postcodes 0.30;
 use base qw(Geo::Postcodes);

 use strict;
 use warnings;

 our $VERSION = '0.30';

And so on. See the documentation for making country subclasses for the gory
details; I<perldoc Geo::Postcodes::Subclass> or I<man Geo::Postcodes::Subclass>.

=head1 ABSTRACT

Geo::Postcodes - Base class for the Geo::Postcodes::* modules. It is
useless on its own.

=head1 PROCEDURES AND METHODS

These procedures and methods should, with a few exceptions, not be used directly,
but from a country module. See the documentation for the indiviual country modules
for usage details.

=head2 address, borough, county, location, owner, postcode, type, type_verbose

Methods for accessing the fields of a postcode object. The individual country
modules can support as many of them as needed, and add new ones.

=head2 address_of, borough_of, county_of, location_of, owner_of, postcode_of,
       type_of, type_verbose_of

Procedures that returns the value of the corresponding field for the given postcode.
They will return I<undef> if the postcode does not exist, or the field is without
value for the given postcode.

=head2 get_fields, is_field

I<get_fields()> will return a list of all the fields supported by the module, and
I<is_field($field)> will return true (1) if the specified field is supported by
the module.

=head2 legal, valid

Procedures that return I<true> if the postcode is legal (syntactically), or valid
(in actual use).

=head2 new

This will create a new postcode object.

=head2 selection, selection_loop

Procedures/methods for selecting several postcodes at once.

See the selection manual (I<perldoc Geo::Postcodes::Selection> or
I<man Geo::Postcodes::Selection>) for usage details, and the tutorial
(I<perldoc Geo::Postcodes::Tutorial> or I<man Geo::Postcodes::Tutorial>)
for sample code.

=head2 verify_selectionlist, is_legal_selectionmode, is_legal_initial_selectionmode
       get_selectionmodes, get_initial_selectionmodes

Supporting procedures when using I<selection> or I<selection_loop>.

See the selection manual; I<perldoc Geo::Postcodes::Selection> or
I<man Geo::Postcodes::Selection> for usage details.

=head2 get_postcodes

This will return an unsorted list of all the postcodes.

=head2 get_types

This will return a list of types.  See the next section.

=head2 type2verbose

  my $type_as_english_text  = $Geo::Postcodes::type2verbose($type);
  my $type_as_national_text = $Geo::Postcodes::U2:type2verbose($type);

This procedure gives an english description of the type. Use the child class
directly for a description in the native language.

=head1 TYPE

This class defines the following types for the postal locations:

=over

=item BX

Post Office box

=item ST

Street address

=item SX

Service box (as a Post Office box, but the mail is delivered to
the customer).

=item IO

Individual owner (a company with its own postcode).

=item STBX

Either a Street address (ST) or a Post Office box (BX)

=item MU

Multiple usage (a mix of the other types)

=item PP

Porto Paye receiver (mail where the reicever will pay the postage).

=item PN

Place name

=back

The child classes can use them all, or only a subset, but must not define
their own additions. The child classes are responsible for adding descriptions
in the native language, if appropriate.

=head1 DESCRIPTION

This is the base class for the Geo::Postcodes::* modules.

=head1 CAVEAT

This module uses I<inside out objects>, see for instance
L<http://www.stonehenge.com/merlyn/UnixReview/col63.html> for a discussion of
the concept.

=head1 SEE ALSO

See also the selection manual (I<perldoc Geo::Postcodes::Selection> or
I<man Geo::Postcodes::Selection>) for usage details, the tutorial
(I<perldoc Geo::Postcodes::Tutorial> or I<man Geo::Postcodes::Tutorial>)
for sample code, and the ajax tutorial (I<perldoc Geo::Postcodes::Ajax> or
I<man Geo::Postcodes::Ajax>) for information on using the modules in
combination with ajax code in a html form to get the location updated
automatically.

The latest version of this library should always be available on CPAN, but see
also the library home page; F<http://bbop.org/perl/GeoPostcodes> for additional
information and sample usage. The child classes that can be found there have
some sample programs.

=head1 COPYRIGHT AND LICENCE

Copyright (C) 2006 by Arne Sommer - perl@bbop.org

This library is free software; you can redistribute them and/or modify
it under the same terms as Perl itself.

=cut