package XML::Filter::DetectWS;

use strict;

use XML::Filter::SAXT;

#----------------------------------------------------------------------

#	CONSTANT DEFINITIONS

#----------------------------------------------------------------------

# Locations of whitespace

sub WS_START	(%) { 1 }	# just after <a>

sub WS_END	(%) { 2 }	# just before </a>

sub WS_INTER	(%) { 0 }	# not at the start or end (i.e. intermediate)

sub WS_ONLY	(%) { 3 }	# both START and END, i.e. between <a> and </a>

# The states of the WhiteSpace detection code

# for regular elements, i.e. elements that:

# 1) don't have xml:space="preserve"

# 2) have an ELEMENT model that allows text children (i.e. ANY or Mixed content)

sub START          (%) { 0 }	# just saw <elem>

sub ONLY_WS        (%) { 1 }	# saw <elem> followed by whitespace (only)

sub ENDS_IN_WS	   (%) { 2 }	# ends in whitespace (sofar)

sub ENDS_IN_NON_WS (%) { 3 }	# ends in non-ws text or non-text node (sofar)

# NO_TEXT States: when <!ELEMENT> model does not allow text

# (we assume that all text children are whitespace)

sub NO_TEXT_START	   (%) { 4 }	# just saw <elem>

sub NO_TEXT_ONLY_WS        (%) { 5 }	# saw <elem> followed by whitespace (only)

sub NO_TEXT_ENDS_IN_WS	   (%) { 6 }	# ends in whitespace (sofar)

sub NO_TEXT_ENDS_IN_NON_WS (%) { 7 }	# ends in non-text node (sofar)

# State for elements with xml:space="preserve" (all text is non-WS)

sub PRESERVE_WS    (%) { 8 }

#----------------------------------------------------------------------

#	METHOD DEFINITIONS

#----------------------------------------------------------------------

# Constructor options:

#

# SkipIgnorableWS	1 means: don't forward ignorable_whitespace events

# Handler		SAX Handler that will receive the resulting events

#

sub new

{

    my ($class, %options) = @_;

    my $self = bless \%options, $class;

    $self->init_handlers;

    $self;

}

# Does nothing

sub noop {}

sub init_handlers

{

    my ($self) = @_;

    my %handlers;

    my $handler = $self->{Handler};

    for my $cb (map { @{$_} } values %XML::Filter::SAXT::SAX_HANDLERS)

    {

	if (UNIVERSAL::can ($handler, $cb))

	{

	    $handlers{$cb} = eval "sub { \$handler->$cb (\@_) }";

	}

	else

	{

	    $handlers{$cb} = \&noop;

	}

    }

    if ($self->{SkipIgnorableWS})

    {

	delete $handlers{ignorable_whitespace};	# if it exists

    }

    elsif (UNIVERSAL::can ($handler, 'ignorable_whitespace'))

    {

	# Support ignorable_whitespace callback if it exists

	# (if not, just use characters callback)

	$handlers{ignorable_whitespace} = 

	    sub { $handler->ignorable_whitespace (@_) };

    }

    else

    {

	$handlers{ignorable_whitespace} = $handlers{characters};

    }

    $handlers{ws} = $handlers{characters};    

#?? were should whitespace go?

    # NOTE: 'cdata' is not a valid PerlSAX callback

    if (UNIVERSAL::can ($handler, 'start_cdata') &&

	UNIVERSAL::can ($handler, 'end_cdata'))

    {

	$handlers{cdata} = sub {

	    $handler->start_cdata;

	    $handler->characters (@_);

	    $handler->end_cdata;

	}

    }

    else	# pass CDATA as regular characters

    {

	$handlers{cdata} = $handlers{characters};

    }

    $self->{Callback} = \%handlers;

}

sub start_cdata

{

    my ($self, $event) = @_;

    $self->{InCDATA} = 1;

}

sub end_cdata

{

    my ($self, $event) = @_;

    $self->{InCDATA} = 0;

}

sub entity_reference

{

    my ($self, $event) = @_;

    $self->push_event ('entity_reference', $event);

    my $parent = $self->{ParentStack}->[-1];

    $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;

}

sub comment

{

    my ($self, $event) = @_;

    $self->push_event ('comment', $event);

    my $parent = $self->{ParentStack}->[-1];

    $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;

}

sub processing_instruction

{

    my ($self, $event) = @_;

    $self->push_event ('processing_instruction', $event);

    my $parent = $self->{ParentStack}->[-1];

    $parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;

}

sub start_document

{

    my ($self, $event) = @_;

    # Initialize initial state

    $self->{ParentStack} = [];

    $self->{EventQ} = [];

    $self->{InCDATA} = 0;

    $self->init_handlers;

    $event = {} unless defined $event;

    # Don't preserve WS by default (unless specified by the user)

    $event->{PreserveWS} = defined ($self->{PreserveWS}) ? 

					$self->{PreserveWS} : 0;

    # We don't need whitespace detection at the document level

    $event->{State} = PRESERVE_WS;

    $self->push_event ('start_document', $event);

    push @{ $self->{ParentStack} }, $event;

}

sub end_document

{

    my ($self, $event) = @_;

    $event = {} unless defined $event;

    $self->push_event ('end_document', $event);

    $self->flush;

}

sub start_element

{

    my ($self, $event) = @_;

    my $pres = $event->{Attributes}->{'xml:space'};

    if (defined $pres)

    {

	$event->{PreserveWS} = $pres eq "preserve";

    }

    else

    {

	$event->{PreserveWS} = $self->{ParentStack}->[-1]->{PreserveWS};

    }

    if ($self->{NoText}->{ $event->{Name} })

    {

	$event->{NoText} = 1;

    }

    $event->{State} = $self->get_init_state ($event);

    $self->push_event ('start_element', $event);

    push @{ $self->{ParentStack} }, $event;

}

sub end_element

{

    my ($self, $event) = @_;

    # Mark previous whitespace event as the last event (WS_END)

    # (if it's there)

    my $prev = $self->{EventQ}->[-1];

    $prev->{Loc} |= WS_END if exists $prev->{Loc};

    $self->push_event ('end_element', $event);

    my $elem = pop @{ $self->{ParentStack} };

    delete $elem->{State};

}

sub characters

{

    my ($self, $event) = @_;

    if ($self->{InCDATA})

    {

	# NOTE: 'cdata' is not a valid PerlSAX callback

	$self->push_event ('cdata', $event);

	my $parent = $self->{ParentStack}->[-1];

	$parent->{State} |= ENDS_IN_NON_WS unless $parent->{State} == PRESERVE_WS;

	return;

    }

    my $text = $event->{Data};

    return unless length ($text);

    my $state = $self->{ParentStack}->[-1]->{State};

    if ($state == PRESERVE_WS)

    {

	$self->push_event ('characters', $event);

    }

    elsif ($state == NO_TEXT_START)

    {

	# ELEMENT model does not allow regular text.

	# All characters are whitespace.

	$self->push_event ('ignorable_whitespace', { Data => $text, Loc => WS_START });

	$state = NO_TEXT_ONLY_WS;

    }

    elsif ($state == NO_TEXT_ONLY_WS)

    {

	$self->merge_text ($text, 'ignorable_whitespace', WS_START );

    }

    elsif ($state == NO_TEXT_ENDS_IN_NON_WS)

    {

	$self->push_event ('ignorable_whitespace', { Data => $text, Loc => WS_INTER });

	$state = NO_TEXT_ENDS_IN_WS;

    }

    elsif ($state == NO_TEXT_ENDS_IN_WS)

    {

	$self->merge_text ($text, 'ignorable_whitespace', WS_INTER );

    }

    elsif ($state == START)

    {

#?? add support for full Unicode

	$text =~ /^(\s*)(\S(?:.*\S)?)?(\s*)$/;

	if (length $1)

	{

	    $self->push_event ('ws', { Data => $1, Loc => WS_START });

	    $state = ONLY_WS;

	}

	if (length $2)

	{

	    $self->push_event ('characters', { Data => $2 });

	    $state = ENDS_IN_NON_WS;

	}

	if (length $3)

	{

	    $self->push_event ('ws', { Data => $3, Loc => WS_INTER });

	    $state = ENDS_IN_WS;

	}

    }

    elsif ($state == ONLY_WS)

    {

	$text =~ /^(\s*)(\S(?:.*\S)?)?(\s*)$/;

	if (length $1)

	{

	    $self->merge_text ($1, 'ws', WS_START);

	}

	if (length $2)

	{

	    $self->push_event ('characters', { Data => $2 });

	    $state = ENDS_IN_NON_WS;	    

	}

	if (length $3)

	{

	    $self->push_event ('ws', { Data => $3, Loc => WS_INTER });

	    $state = ENDS_IN_WS;	    

	}

    }

    else # state == ENDS_IN_WS or ENDS_IN_NON_WS

    {

	$text =~ /^(.*\S)?(\s*)$/;

	if (length $1)

	{

	    if ($state == ENDS_IN_NON_WS)

	    {

		$self->merge_text ($1, 'characters');

	    }

	    else

	    {

		$self->push_event ('characters', { Data => $1 });

		$state = ENDS_IN_NON_WS;	    

	    }

	}

	if (length $2)

	{

	    if ($state == ENDS_IN_WS)

	    {

		$self->merge_text ($2, 'ws', WS_INTER);

	    }

	    else

	    {

		$self->push_event ('ws', { Data => $2, Loc => WS_INTER });

		$state = ENDS_IN_WS;

	    }

	}

    }

    $self->{ParentStack}->[-1]->{State} = $state;

}

sub element_decl

{

    my ($self, $event) = @_;

    my $tag = $event->{Name};

    my $model = $event->{Model};

    # Check the model to see if the elements may contain regular text

    $self->{NoText}->{$tag} = ($model eq 'EMPTY' || $model !~ /\#PCDATA/);

    $self->push_event ('element_decl', $event);

}

sub attlist_decl

{

    my ($self, $event) = @_;

    my $prev = $self->{EventQ}->[-1];

    if ($prev->{EventType} eq 'attlist_decl' && 

	$prev->{ElementName} eq $event->{ElementName})

    {

	$prev->{MoreFollow} = 1;

	$event->{First} = 0;

    }

    else

    {

	$event->{First} = 1;

    }

    $self->push_event ('attlist_decl', $event);

}

sub notation_decl

{

    my ($self, $event) = @_;

    $self->push_event ('notation_decl', $event);

}

sub unparsed_entity_decl

{

    my ($self, $event) = @_;

    $self->push_event ('unparsed_entity_decl', $event);

}

sub entity_decl

{

    my ($self, $event) = @_;

    $self->push_event ('entity_decl', $event);

}

sub doctype_decl

{

    my ($self, $event) = @_;

    $self->push_event ('doctype_decl', $event);

}

sub xml_decl

{

    my ($self, $event) = @_;

    $self->push_event ('xml_decl', $event);

}

#?? what about set_document_locator, resolve_entity

#

# Determine the initial State for the current Element.

# By default, we look at the PreserveWS property (i.e. value of xml:space.)

# The user can override this to force xml:space="preserve" for a particular

# element with e.g.

#

# sub get_init_state

# {

#    my ($self, $event) = @_;

#    ($event->{Name} eq 'foo' || $event->{PreserveWS}) ? PRESERVE_WS : START;

# }

#

sub get_init_state

{

    my ($self, $event) = @_;

    my $tag = $event->{Name};

    if ($self->{NoText}->{$tag})	# ELEMENT model does not allow text

    {

	return NO_TEXT_START;

    }

    $event->{PreserveWS} ? PRESERVE_WS : START;

}

sub push_event

{

    my ($self, $type, $event) = @_;

    $event->{EventType} = $type;

    $self->flush;

    push @{ $self->{EventQ} }, $event;

}

# Merge text with previous event (if it has the same EventType)

# or push a new text event

sub merge_text

{

    my ($self, $str, $eventType, $wsLocation) = @_;

    my $q = $self->{EventQ};

    my $prev = $q->[-1];

    if (defined $prev && $prev->{EventType} eq $eventType)

    {

	$prev->{Data} .= $str;

    }

    else

    {

	my $event = { Data => $str };

	$event->{Loc} = $wsLocation if defined $wsLocation;

	$self->push_event ($eventType, $event);

    }

}

# Forward all events on the EventQ

sub flush

{

    my ($self) = @_;

    my $q = $self->{EventQ};

    while (@$q)

    {

	my $event = shift @$q;

	my $type = $event->{EventType};

	delete $event->{EventType};

	$self->{Callback}->{$type}->($event);

    }

}

1; # package return code

__END__

=head1 NAME

XML::Filter::DetectWS - A PerlSAX filter that detects ignorable whitespace

=head1 SYNOPSIS

 use XML::Filter::DetectWS;

 my $detect = new XML::Filter::DetectWS (Handler => $handler,

					 SkipIgnorableWS => 1);

=head1 DESCRIPTION

This a PerlSAX filter that detects which character data contains 

ignorable whitespace and optionally filters it.

Note that this is just a first stab at the implementation and it may

change completely in the near future. Please provide feedback whether

you like it or not, so I know whether I should change it.

The XML spec defines ignorable whitespace as the character data found in elements

that were defined in an <!ELEMENT> declaration with a model of 'EMPTY' or

'Children' (Children is the rule that does not contain '#PCDATA'.)

In addition, XML::Filter::DetectWS allows the user to define other whitespace to 

be I<ignorable>. The ignorable whitespace is passed to the PerlSAX Handler with

the B<ignorable_whitespace> handler, provided that the Handler implements this 

method. (Otherwise it is passed to the characters handler.)

If the B<SkipIgnorableWS> is set, the ignorable whitespace is simply

discarded.

XML::Filter::DetectWS also takes xml:space attributes into account. See below

for details.

CDATA sections are passed in the standard PerlSAX way (i.e. with surrounding

start_cdata and end_cdata events), unless the Handler does not implement these

methods. In that case, the CDATA section is simply passed to the characters 

method.

=head1 Constructor Options

=over 4

=item * SkipIgnorableWS (Default: 0)

When set, detected ignorable whitespace is discarded.

=item * Handler