use utf8;
use strict;

use XML::LibXML;

use XML::Pastor::Type;

package XML::Pastor::SimpleType;
use Scalar::Util qw(reftype);

our @ISA = qw(XML::Pastor::Type);

use overload 
	'""'	=> \&stringify,
	'0+'	=> \&numify,
	'bool'	=> \&boolify;
	
XML::Pastor::SimpleType->mk_accessors(qw(value));

#----------------------------------------------
# Accepts a single parameter or a hash.
# If single parameter, then it is taken to be the value.
#----------------------------------------------
sub new {
	my $proto 	= shift;
	my $class	= ref($proto) || $proto;
	my $self 	= (@_ == 1) ? {value=>$_[0]} : {@_};
	
	return bless $self, $class;
}

#----------------------------------------------
# String value.
#----------------------------------------------
sub stringify {
	my $self = shift;
	return "" . $self->value();	# force stringification on value
}

#----------------------------------------------
# Numeric value.
#----------------------------------------------
sub numify {
	my $self = shift;
	return +$self->value();	# force numerification on value
}

#----------------------------------------------
# Boolean value.
#----------------------------------------------
sub boolify {
	my $self = shift;
	my $val = $self->value();	
		
	return $val;	
}


#----------------------------------------------
# from_dom (CONSTRUCTOR)
#----------------------------------------------
sub from_xml_dom {
	my $self 	= shift->new();
	my $node	= shift;
	
	if (UNIVERSAL::isa($node, "XML::LibXML::Text")) {
		$self->value($node->nodeValue());
		return $self;
	}elsif (UNIVERSAL::isa($node, "XML::LibXML::Attr")) {
		$self->value($node->value());
		return $self;
	}elsif (UNIVERSAL::isa($node, "XML::LibXML::Element")) {
		$self->value($node->textContent());		
		return $self;
	}	
	return undef;
}

#----------------------------------------------
# xml_validate
#----------------------------------------------
sub xml_validate {
	my $self 	= shift;
	my $path	= shift || '';	
	my $type	= $self->XmlSchemaType();
	my $value	= $self->value;
	    $value	= $self->normalize_whitespace($value);

	unless (defined $type) {
		return ($self->xml_validate_further(@_) && $self->xml_validate_ancestors(@_));			
	}
	
	if (defined(my $prop = $type->length)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $len (@$prop) {
			($len == length($value)) or die "Pastor : Validate : $path : Length must be exactly '$len' for value '$value'";
		}				
	}

	if (defined(my $prop = $type->minLength)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $minLen (@$prop) {
			(length($value) >= $minLen) or die "Pastor : Validate : $path : Length must be minimum '$minLen' for value '$value'";
		}				
	}
	
	if (defined(my $prop = $type->maxLength)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $maxLen (@$prop) {
			(length($value) <= $maxLen) or die "Pastor : Validate : $path : Length must be maximum '$maxLen' for value '$value'";
		}				
	}
	
	if (defined(my $prop = $type->regex)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		my $pass=0;
		foreach my $regex (@$prop) {
			if ($value =~ /$regex/) {
				$pass =1;
				last;
			}
		}				
		$pass or die "Pastor : Validate : $path : Value does not match any of the given regexes. Value is '$value'";
	}

	if (defined(my $prop = $type->pattern)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		my $pass=0;
		foreach my $pattern (@$prop) {
			if ($value =~ /$pattern/) {
				$pass =1;
				last;
			}
		}				
		$pass or die "Pastor : Validate : $path : Value does not match any of the given patterns. Value is '$value'";
	}
	

	if (defined(my $enumeration = $type->enumeration)) {
		(exists $enumeration->{$value}) or die "Pastor : Validate : $path : Not in the permitted enumeration : value '$value'";
	}
	
	
	if (defined(my $prop = $type->minInclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $min (@$prop) {
			($value >= $min) or die "Pastor : Validate : $path : Value must be at least (minimum) '$min' : But value is '$value'";
		}				
	}
	
	if (defined(my $prop = $type->maxInclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $max (@$prop) {
			($value <= $max) or die "Pastor : Validate : $path : Value must be at most (maximum) '$max' : But value is '$value'";
		}				
	}

	if (defined(my $prop = $type->minExclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $min (@$prop) {
			($value > $min) or die "Pastor : Validate : $path : Value must be greater than '$min' : But value is '$value'";
		}				
	}
	
	if (defined(my $prop = $type->maxExclusive)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $max (@$prop) {
			($value < $max) or die "Pastor : Validate : $path : Value must be less than '$max' : But value is '$value'";
		}				
	}


	# Digits part is shamelessly copied from XML::Validator::Schema by Sam Tregar
   if (defined($type->totalDigits) || defined($type->fractionDigits)) {
        # strip leading and trailing zeros for numeric constraints
        my $digits = $value;
        $digits  =~ s/^([+-]?)0*(\d*\.?\d*?)0*$/$1$2/g;

        if (defined(my $prop=$type->totalDigits)) {
			$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];        	
            foreach my $tdigits (@$prop) {
                die "Pastor : Validate : $path : Value has more total digits than the allowed '$tdigits'"
                  if $digits =~ tr!0-9!! > $tdigits;
            }
        }

        if (defined(my $prop=$type->fractionDigits)) {
			$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];        	        	
            foreach my $fdigits (@$prop) {
                die "Pastor : Validate : $path : Value has more fraction digits than the allowed '$fdigits'"            	
                  if $digits =~ /\.\d{$fdigits}\d/;
            }
        }        
    }

	
	return ($self->xml_validate_further(@_) && $self->xml_validate_ancestors(@_));	
}



#-----------------------------------------------------------------------------
# By default, this just returns TRUE. But it could be overriden by descendants (like 'date').
#-----------------------------------------------------------------------------
sub xml_validate_further {
	return 1;
}


#-----------------------------------------------------------------------------
# Validate the ancestors. Base classes need to be validated.
#-----------------------------------------------------------------------------
sub xml_validate_ancestors {
	my $self	= shift;
	my $value	= $self->value;
	my @ancestors = $self->get_ancestors();
		
	foreach my $class (@ancestors) {
		next unless (UNIVERSAL::can($class, 'new') && UNIVERSAL::can($class, 'xml_validate'));
		
		my $obj=$class->new(value => $value);
		return 0 unless $obj->xml_validate(@_);
	}
	
	return 1;
}


#-----------------------------------------------------------------------------
# Normalize white space. 
#-----------------------------------------------------------------------------
sub normalize_whitespace {
    my $self 	= shift;
    my $value 	= shift;
	my $type	= $self->XmlSchemaType();

	if (defined(my $prop = $type->whiteSpace)) {
		$prop = (reftype($prop) eq 'ARRAY') ? $prop : [$prop];
		foreach my $ws (@$prop) {
	        if ($ws =~ /^replace$/i) {
    	        $value =~ s![\t\n\r]! !g;            
        	} elsif ($ws =~ /^collapse$/i) {
            	$value =~ s!\s+! !g;
	            $value =~ s!^\s!!g;
    	        $value =~ s!\s$!!g;
        	}
	        return $value;	# only the first one gets treated!
		}				
	}else {
		my @ancestors = $self->get_ancestors();
		foreach my $class(@ancestors) {
			next unless UNIVERSAL::can($class, 'normalize_whitespace') && UNIVERSAL::can($class, 'new');
			my $object = $class->new(value=>$value);
			my $nvalue = $object->normalize_whitespace($value);
			
			return $nvalue if ($nvalue ne $value);			
		}
	}
		    
    return $value;
}

1;

__END__

=head1 NAME

B<XML::Pastor::SimpleType> - Ancestor of all simple classes generated by L<XML::Pastor> and also the builtin simple classes.

=head1 ISA

This class descends from L<XML::Pastor::Type>. 

=head1 DESCRIPTION

B<XML::Pastor::SimpleType> is an B<abstract> ancestor of all simple classes 
(those global and implicit Simple Type definitions in the schema, including builtin ones) generated 
by L<XML::Pastor> which is a Perl code generator from W3C XSD schemas. For an introduction, please refer to the
documentation of L<XML::Pastor>.

B<XML::Pastor::SimpleType> defines some overloads (stringification, numification, boolification) and method overrides 
from L<XML::Pastor::Type>. 

B<XML::Pastor::SimpleType> contains (actually I<inherits from> L<XML::Pastor::Type>) a class data accessor called L</XmlSchemaType()> 
with the help of L<Class::Data::Inheritable>. This accessor is normally used by many other methods to access the W3C schema meta information 
related to the class at hand. But at this stage, L</XmlSchemaType()> does not contain any information and this is 
why B<XML::Pastor::ComplexType> remains abstract. 

The generated subclasses set L</XmlSchemaType()> to information specific to the W3C schema type. It is then used for the XML binding and validation methods. 

=head1 OVERLOADS

Several overloads are performed so that a B<XML::Pastor::SimpleType> object looks like a regular scalar. Basically, they all use the 'value' field as the scalar.

=head4 stringification

This is done with the B<stringify> (overridable) method. The returned value is the stringification of the contents of the 'value' field.
 
=head4 numification

This is done with the B<numify> (overridable) method. The returned value is the numification of the contents of the 'value' field.

=head4 boolification

This is done with the B<boolify> (overridable) method. The returned value is the boolification of the contents of the 'value' field. This method is
indeed overriden by the B<XML::Pastor::Builtin::boolean> class in order to count the string 'false' as a false value.

=head1 METHODS

=head2 CONSTRUCTORS
 
=head4 new() 

  $class->new($value)
  $class->new(%fields)

B<CONSTRUCTOR> overriden from L<XML::Pastor::Type>.

The new() constructor method instantiates a new B<XML::Pastor::SimpleType> object. It is inheritable, and indeed inherited,
by the generated decsendant classes. Normally, you do not call the B<new> method on B<XML::Pastor::SimpleType>. You rather
call it on your generated subclasses.
  
Any -named- fields that are passed as parameters are initialized to those values within
the newly created object. The only field that makes any sense at this time is the 'I<value>' field.
This is why it has been made easier to pass I<value> as the one and only parameter.

The following two calls are equivalent:

  my $object = $class->new($value);
  my $object = $class->new(value => $value);

Stick with the first one, as the second one requires the knowledge of the internal 
organization of the object.

=head4 from_xml_dom() 

	my $object = $class->from_xml_dom($node);
	
B<CONSTRUCTOR> that should be called upon your generated class rather than B<XML::Pastor::ComplexType>.
  
This method instatiates an object of the generated class from a DOM object passed as a parameter. Currently, the DOM
object must be either of type L<XML::LibXML::Attr>, L<XML::LibXML::Text> or of type L<XML::LibXML::Element> (with textContent).

Currently, the method is quite forgiving as to the actual contents of the DOM. No validation is performed during this call.

.

=head2 CLASS DATA ACCESSORS

=head4 XmlSchemaType()

  my $type = $class->XmlSchemaType()

B<CLASS METHOD>, but may also be called directly on an B<OBJECT>. 

B<XML::Pastor::SimpleType> defines (thanks to L<Class::Data::Inheritable>) 
a class data acessor B<XmlSchemaType> which returns B<undef>. 

This data accessor is set by each generated simple class to the meta information coming from your B<W3C Schema>. 
This data is of class L<XML::Pastor::Schema::SimpleType>. 

You don't really need to know much about B<XmlSchemaType>. It's used internally by Pastor's XML binding and validation 
methods as meta information about the generated class. 


=head2 ACCESSORS

=head4 value()

  $currentValue = $object->value();	# GET
  $object->value($newValue);		# SET

Gets and sets the value of the 'value' field, which is the actual SCALAR value of the object.

=head2 OTHER METHODS

=head4 is_xml_valid()

  $bool = $object->is_xml_valid();

B<OBJECT METHOD>, inherited from L<XML::Pastor::Type>. Documented here for completeness.

'B<is_xml_valid>' is similar to L</xml_validate> except that it will not B<die> on failure. 
Instead, it will just return FALSE (0). 

The implementation of this method, inherited from L<XML::Pastor::Type>, is very simple. Currently,
it just calls L</xml_validate> in an B<eval> block and will return FALSE (0) if L</xml_validate> dies.  
Otherwise, it will just return the same value as L</xml_validate>.

In case of failure, the contents of the special variable C<$@> will be left untouched in case you would like to access the 
error message that resulted from the death of L</xml_validate>.

.

=head4 xml_validate()
 
	$object->xml_validate();	# Will die on failure

B<OBJECT METHOD>, overriden from L<XML::Pastor::Type>.
 
'B<xml_validate>' validates a Pastor XML object (of a generated class) with respect to the META information that
had originally be extracted from your original B<W3C XSD Schema>.

On sucess, B<xml_validate> returns TRUE (1). On failure, it will B<die> on you on validation errors. 

The W3C recommendations have been observed as closely as possible for the implementation of this method. 
Neverthless, it remains somewhat more relaxed and easy compared to B<Castor> for example.


The following properties of XML Simple Type declarations in the W3C schema are observed:

=over

=item length

The string length of the value.

=item minLength, maxLength

The minimum and maximum string lengths for the value.

=item pattern

One ore more W3C regex patterns that the value must match. If more than one is present, 
any one match is considered sufficient for validity. 

=item regex  (not present in W3C schema)

Like 'pattern', but guaranteed to be a Perl regular expression even if the W3C 'pattern' diverges from this in the future.
This is used internally for builtin types. Like 'pattern', one or more regexes can be present. 

=item enumeration

A hash of enumeration values. 

=item minInclusive, maxInclusive

Minimum and maximum inclusive values.

=item minExclusive, maxExclusive

Minimum and maximum exclusive values.

=item totalDigits, fractionDigits

The total and fraction digits (in a floating point number) respectively.

=back

These properties are obtained from the schema type object returned from the L</XmlSchemaType> class data accessor call.

The builtin types use these properties extensively to enforce vaildity. The 'regex' property is 
used heavily for builtin types. 

After checking the conformity with these properties, B<xml_validate> calls L</xml_validate_further> to perform 
extra checks. For B<XML::Pastor::SimpleType> this always returns TRUE, but some builtin types 
(like L<XML::Pastor::Builtin::date> and L<XML::Pastor::Builtin::dateTime>) actually perform some extra validation 
during this call. 

Then, the B<xml_validate> method is called on any capable ancestors in the ISA array. A failure in any one of these 
calls will result in the failure of B<xml_validate> which will consequently I<die>.


=head4 xml_validate_further()
 
	$object->xml_validate_further();	# Never called directly.

B<OBJECT METHOD>, overriden from L<XML::Pastor::Type>.
 
'B<xml_validate_further>' should perform extra validation on a Pastor XML object (of a generated class).

It is called by L</xml_validate> after performing rutine validations.  

This method should return TRUE(1) on success, and I<die> on failure with an error message.

For B<XML::Pastor::SimpleType>, this method simple returns TRUE(1).

This method may be overriden by subclasses and it is indeed oevrriden by several builtin classes like
like L<XML::Pastor::Builtin::date> and L<XML::Pastor::Builtin::dateTime>. 

=head1 BUGS & CAVEATS

There no known bugs at this time, but this doesn't mean there are aren't any. 
Note that, although some testing was done prior to releasing the module, this should still be considered alpha code. 
So use it at your own risk.

Note that there may be other bugs or limitations that the author is not aware of.

=head1 AUTHOR

Ayhan Ulusoy <dev@ulusoy.name>


=head1 COPYRIGHT

  Copyright (C) 2006-2007 Ayhan Ulusoy. All Rights Reserved.

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


=head1 SEE ALSO

See also L<XML::Pastor>, L<XML::Pastor::ComplexType>, L<XML::Pastor::Type>

And if you are curious about the implementation, see L<Class::Accessor>, L<Class::Data::Inheritable>


=cut
