package AtomicData;

# Copyright (c) 2000, FundsXpress Financial Network, Inc.
# This library is free software released under the GNU Lesser General
# Public License, Version 2.1.  Please read the important licensing and
# disclaimer information included below.

# $Id: AtomicData.pm,v 1.1.1.2 2003/12/06 19:47:26 hartmans Exp $

use strict;

=head1 NAME

AtomicData - abstract base class of a data encapsulator

=head1 SYNOPSIS

 #more later.

=head1 DESCRIPTION

more later.

=cut

$AtomicData::deliminators = '[\.\- \/]';#valid deliminators

=head1 METHODS

C<test_equality> should take two values (which are guaranteed to be in
canonical form for the datatype) and return true if the value are
equal and false otherwise.

C<_canonicalize> should take a single argument, the value to be
canonicalized, and return the canonicalized form or undef if the
canonicalization failed. If it failed, it should set the value of
C<_can_failed> to a list reference of human readable strings giving
one or more reasons why it failed.

C<_verify> should take a single arguement, the value to be verified
(which must be in canonical form), and return first a boolean
indicatating successful verification or not (true means there were no
errors) and secondly a reference to a list ru human readable strings
giving one or more reasons whey the verification failed.

C<_format> should take a single argument, the value to be formatted,
and return the formatted value. The original value should be in
canonical form, so this function is expected to be completely error
free.

=head2 new

 instance
 (AtomicData $obj) new (variable $value)

DESCRIPTION:

Accepts the value which the object is meant to encapsulate and returns
the object. It is permisable to pass in values that will fail on
verification with no error here.

=cut

sub new {
  my ($proto, @arguments) = @_;

  my $this = {};
  bless $this, ref($proto) || $proto;

  $this->{_parameters}   = { blank_ok => 1 };
  $this->{_format}       = {};
  $this->{_possible}     = {};
  $this->{_ordering}     = [];
  $this->{_poss_changed} = 0;

  $this->init(@arguments);

  return $this;
}

=head2 init

 instance
 () init (Values)

=cut

sub init {
  my ($this, $value, @extra_args) = @_;

  # assign the data class.
  my $class = ref($this);
  $this->{_data_class}   = $class;

  # if there are extra args, die.
  @extra_args and die @extra_args." extra args given to scalar: ".ref($this);

  # initialize data to clear.
  $this->clear();

  # assign the default value.
  defined $value and $this->set_value($value);
}

=head2 clear

 instance
 () clear ()

=cut

sub clear {
  my ($this) = @_;

  $this->{_orig_raw_value} = undef;
  $this->{_orig_can_value}    = undef;
  $this->{_raw_value}      = undef;
  $this->{_can_value}         = undef;
  $this->{_can_failed}        = undef;
  $this->{_format_value}      = undef;

  return;
}

=head2 set_data_class and data_class

 instance
 (string $data_class) set_data_class (string $data_class)

 instance
 (string $data_class) data_class ()

DESCRIPTION:

blah blah This will return what this data member should be refered to as for
human recognition. Will accept C<$new_name> to change what it should
be called. Set this to a blank string to effectively clear (undef will
not be recognized).

Example:

 $field->data_class('AtomicData::Text');
 print "type = ".$datum->data_class()."\n";

 $field->set_values("cat","dog");

=cut

sub set_data_class {
  my ($this, $dataclass) = @_;
  $this->{_data_class} = $dataclass;
}

=head2

=cut

sub data_class {
  my ($this) = @_;
  return $this->{_data_class};
}

=head2 set_value

 instance
 () set_value (variable $value)

DESCRIPTION:

This will reset the value being encapsulated.

=cut

sub set_value {
  my ($this, $value) = @_;

  # if there was no value before, this must be our value.
  if (!defined $this->{_raw_value}) {
    $this->{_raw_value} = $value;
    return;
  }

  # if this value is the same as the current value, don't reset.
  return if $this->{_raw_value} eq $value;

  # if there is currently no orig value, transfer current-to-orig
  if (!defined $this->{_orig_raw_value}) {
    $this->canonicalize();
    $this->{_orig_raw_value} = $this->{_raw_value};
    $this->{_orig_can_value} = $this->{_can_value};
  }

  # set value.
  $this->{_raw_value} = $value;
  $this->{_can_value}    = undef;
  $this->{_can_failed}   = undef;
  $this->{_format_value} = undef;
  return;
}

=head2 value

 instance
 (variable $value) value ()

DESCRIPTION:

This will return, in the following order of precedence:

 1) the canonical value if C<canonicalize> has been successfully
    called.
 2) the original value entered if the value was not canonicalizical or
    if C<canonicalize> have been called

Note that the canonical and original value might all have the same form.

=cut

sub value {
  my ($this) = @_;
  return $this->{_can_value} if defined $this->{_can_value};
  return $this->{_raw_value};
}

=head2 raw_value

 instance
 (variable $raw_value) raw_value ()

DESCRIPTION:

See the note in DESCRIPTION above regarding retrieved canonical
values.

=cut

sub raw_value {
  my ($this) = @_;
  return $this->{_raw_value};
}

=head2 canonical_value

 instance
 (variable $canonical_value) canonical_value ()

DESCRIPTION:

See the note in DESCRIPTION above regarding retrieved canonical
values.

=cut

sub canonical_value {
  my ($this) = @_;
  $this->canonicalize();
  return $this->{_can_value};
}

=head2 format

 instance
 (variable $format_value) format ()

 instance/private
 (variable $format_value) _format (variable $orig_value)

DESCRIPTION:

This will attempt to return the formatted value of the encapsulated
data. The formatted value is derived from the canonical value, and
thus this function relies on C<canonicalize()>.  If a child has
no other formatting options, then there is no need to implement
C<_format>.

_format() returns C<$orig_value>. This is so that children do not need to
implement C<_format> unless they have a reason too.

=cut

sub formatted_value {
  my ($this) = @_;
  my ($value,$problems) = $this->format();
  return $value;
}

=head2 set_orig_value

 instance
 () set_orig_value (variable $value)

DESCRIPTION:

This will reset the previous value being encapsulated.

=cut

sub set_orig_value {
  my ($this,$value) = @_;
  if (defined $value) {
    $this->{_orig_raw_value} = $value;
    $this->{_orig_can_value} = $this->canonicalize($value);
  } else {
    $this->canonicalize();
    $this->{_orig_raw_value} = $this->{_raw_value};
    $this->{_orig_can_value} = $this->{_can_value};
  }
  return;
}

=head2

=cut

sub orig_value {
  my ($this) = @_;
  return $this->{_orig_can_value} if defined $this->{_orig_can_value};
  return $this->{_orig_raw_value} if defined $this->{_orig_raw_value};
  return $this->{_can_value} if defined $this->{_can_value};
  return $this->{_raw_value};
}

=head2 changed_p

 instance
 (boolean) changed_p ()

DESCRIPTION:

=cut

sub changed_p {
  my ($this) = @_;
  return 0 unless defined $this->orig_value();
  return !$this->test_equality($this->orig_value());
}

=head2 poss_changed_p

 instance
 (boolean) changed_p ()

DESCRIPTION:

=cut

sub poss_changed_p {
  my ($this,$val) = @_;
  defined $val and $this->{_poss_changed} = $val;
  return $this->{_poss_changed};
}

=head2 canonicalize

 instance/class
 (variable $canonical_value) canonicalize ([value $original_value])

DESCRIPTION:

This will attempt to canonicalize the original value and return the
canonical form. It will raise an exception if there is a problem. This
can be called in a class context as well and passed a value to
canonicalize.  The computed canonical value is cached only when the
input value is from the internal original value.

=cut

sub canonicalize {
  my ($this, $input_value) = @_;
  my $value;

  # if we're called without a input value.
  if (! defined($input_value)) {

    # if we've already computed the canonicalized value..
    defined($this->{_can_value}) and
      return $this->{_can_value};

    # if we failed to canonicalize before..
    $this->{_can_failed} and return;

    # use the internal original value.
    $value = $this->{_raw_value};
  } else {
    $value = $input_value;
  }

  # canonicalize the value (possibly set _can_failed)
  $value = $this->_canonicalize($value);

  # if the canonicalization failed..
  $this->{_can_failed} and return;

  if (! defined $input_value) {
    # only cache the value when called without a value argument.
    $this->{_can_value} = $value;
  }

  return $value;
}

=head2

=cut

sub _canonicalize {
  my ($this, $input_value) = @_;
  return $input_value;
}

=head2 verify

 instance
 () verify ()

 instance/private
 (bool $verified, string \@errors) _verify (variable $value)

DESCRIPTION:

This function will verify off of the canonical form data of the
encapsulated data. It will then check against the set parameters (see
C<parameters> for valid keys) to make sure that the data falls
within the proper constraints.

Verification will procede from the most base class to the leaf class.

=cut

sub verify {
  my ($this) = @_;

  defined $this->canonicalize() or
    return (0, $this->{_can_failed});

  # if the subclass defines a _verify() method, call it.
  if ($this->can("_verify")) {
    my ($success,$problems) = $this->_verify();
    $success or return (0, $problems);
  } 

  return (1, []);
}

=head2

=cut

sub _verify {
  my ($this) = @_;

  # get the canonical value and parameters
  my $value = $this->canonical_value();
  my $parameters = $this->parameters();

  # value must be defined.
  defined $value or return (0, ['Data is undefined']);

  # check if value is blank.
  if (defined $parameters->{blank_ok} and 
      $parameters->{blank_ok} == 0 and
      $value eq "") {
    return (0, ["Data cannot be blank"]);
  }
  $value eq "" and return (1, []);

  # if we are value-constrained..
  my ($possible,$ordering) = $this->possible_hash();
  if (%$possible and !defined $possible->{$value}) {
    return (0, ["'$value' is not an allowed value"]);
  }

  #check to make sure it falls within max and min characters
  my $length = length($value);
  my $min_length = $parameters->{min_length};
  my $max_length = $parameters->{max_length};

  defined $min_length and $length < $min_length and
    return (0, ['The string length of the data is less than '.
		'the minimum required length of '.$min_length]);
  defined $max_length and $length > $max_length and
    return (0, ["The string length of the data is greater than ".
		"the maximum allowed length of $max_length"]);

  return (1, []);
}

=head2

=cut

sub format {
  my ($this,$input_value) = @_;
  my $value;

  if (! defined $input_value) {
    defined $this->{_format_value} and
      return ($this->{_format_value}, []);

    if ($this->{_format}->{original}) {
      $this->{_format_value} = $this->{_raw_value};
      return ($this->{_raw_value}, []);
    }

    $value = $this->canonicalize();
    if ($this->{_can_failed}) {
      return ($this->{_raw_value}, $this->{_can_failed});
    }
  } else {
    $value = $input_value;
  }

  my $problems;
  ($value,$problems) = $this->_format($value);

  if (! defined $input_value) {
    # only cache the value when called without a value argument.
    $this->{_format_value} = $value;
  }

  return($value,$problems);
}

=head2

=cut

sub _format {
  my ($this, $input_value) = @_;
  return $input_value;
}

=head2 set_parameters and parameters

 instance
 () set_parameters (\%parameters)

 instance
 (\%parameters) parameters ()

DESCRIPTION:

This will call C<parameters> on each member data encapsulotorw
passing C<%parameters> on.

=cut

sub set_parameters {
  my ($this, $params) = @_;
  %{$this->{_parameters}} = %$params;
}

=head2

=cut

sub reset_parameters {
  my ($this, $params) = @_;
  $this->{_parameters} = $params;
}

=head2

=cut

sub set_parameter {
  my ($this, $key, $val) = @_;
  $this->{_parameters}->{$key} = $val;
}

=head2

=cut

sub parameters {
  my ($this, $params) = @_;
  defined $params and $this->{_parameters} = $params;
  return $this->{_parameters};
}

=head2 set_format

 instance
 () set_format (\%format)

DESCRIPTION:

Accepts a reference to a hash that will dictate how to format the
canonical value. Note that the key 'original' is supported on this and
all children. The effect of setting this to true is to return the
value last entered by the C<set_value> command.

For all other key/value pairs and there affects, one must reference
the children.

=cut

sub set_format {
  my ($this, $format) = @_;
  %{$this->{_format}} = %$format;
}

=head2

=cut

sub reset_format {
  my ($this, $format) = @_;
  $this->{_format} = $format;
}

=head2

=cut

sub get_format {
  my ($this) = @_;
  return $this->{_format};
}

=head2

=cut

sub set_possible_hash {
  my ($this, $possible, $ordering) = @_;
  $ordering ||= [ sort keys %$possible ];
  @{$this->{_ordering}} = @$ordering;
  %{$this->{_possible}} = %$possible;
}

=head2

=cut

sub set_possible {
  my ($this, $possible_ary) = @_;
  @{$this->{_ordering}} = @$possible_ary;
  %{$this->{_possible}} = ();
  map { $this->{_possible}->{$_} = $_ } @$possible_ary;
  $this->{_possible};
}

=head2

=cut

sub possible_hash {
  my ($this) = @_;
  return ($this->{_possible},$this->{_ordering}) if wantarray();
  return $this->{_possible};
}

=head2 set_possible_hash, set_possible, and possible_hash

 instance
 () set_possible_hash (\%possible[, @order ])

 instance
 () set_possible (\@words)

 instance
 (\%possible[, @order ]) possible_hash ()

DESCRIPTION: 

This will set the possible values acceptable. When verify is called,
it will check to make sure that all values in the member data list are
possible. If never called or reset (C<$this->set_possible([]);>), then
all values will be considered possible. Note that anything satisfying
C<$val eq ''> will be allowed.

=cut

sub reset_possible {
  my ($this, $possible, $ordering) = @_;
  $this->{_possible} = $possible;
  $this->{_ordering} = $ordering || [ sort keys %$possible ];
}

=head2 test_equality

 instance
 (bool $equal) test_equality (string $val1, string $val2)

DESCRIPTION:

Will return true if C<$val1> and C<$val2> are alphabetically equal.

=cut

sub test_equality {
  my ($this, $in1, $in2) = @_;
  defined $in1 or die "test_equality() requires at least one parameter.\n";
  my $val1 = ref($in1) ? $in1->value() : $in1;
  my $val2 = ref($in2) ? $in2->value() : ($in2 ? $in2 : $this->value());
  return ($val1 eq $val2);
}

=head2

=cut

sub free_internals {
  my ($this) = @_;
  delete $this->{_parameters};
  delete $this->{_format};
  delete $this->{_possible};
  delete $this->{_ordering};
  return;
}

1;
__END__

=head1 BUGS

No known bugs, but this does not mean no bugs exist.

=head1 SEE ALSO

L<AtomicData>, L<HTMLIO>, L<Field>.

=head1 COPYRIGHT

 PSP - Perl Server Pages
 Copyright (c) 2000, FundsXpress Financial Network, Inc.

 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2 of the License, or (at your option) any later version.

 BECAUSE THIS LIBRARY IS LICENSED FREE OF CHARGE, THIS LIBRARY IS
 BEING PROVIDED "AS IS WITH ALL FAULTS," WITHOUT ANY WARRANTIES
 OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING, WITHOUT
 LIMITATION, ANY IMPLIED WARRANTIES OF TITLE, NONINFRINGEMENT,
 MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE, AND THE
 ENTIRE RISK AS TO SATISFACTORY QUALITY, PERFORMANCE, ACCURACY,
 AND EFFORT IS WITH THE YOU.  See the GNU Lesser General Public
 License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307  USA

=cut