package XML::SAX::Context;

# $Id: Context.pm,v 1.11 2003/08/19 18:41:44 mrodrigu Exp $

use 5.006;
use strict;
use warnings;

our $VERSION = '0.03';

package XML::SAX::Context;
use base qw(XML::SAX::Base);
use Carp;
use Hook::LexWrap;
use List::Util qw( first);

our @ISA = ('XML::SAX::Base');

use vars qw( $AUTOLOAD);

my $DEBUG=1;

our $saved_self;
our %saved_wrappers;

our %FIELDS = map { lc $_ => $_ } qw( Name NamespaceURI Prefix LocalName Attributes);
our %SAX1   = map { $_ => 1     } qw( XML::Parser::PerlSAX);

sub new
  { my $class = shift;
    my %options = @_;
    my $self= bless \%options, $class;

	$self->{'_XML::SAX::Context'}->{_context}=[];

	%saved_wrappers=(); # used to give a scope to the wrappers
	                    # so the methods are not wrapped several times

	my %wrappers= ( start_element => { pre =>  sub { if( (defined $_[0]->{my_parser_name}) and $SAX1{$_[0]->{my_parser_name}})
							                           { XML::SAX::Context::sax1_2_sax2( @_); }
													  else        
							                            { push @{$_[0]->{'_XML::SAX::Context'}->{_context}}, $_[1] ; }
					                                 $_[0]->{'_XML::SAX::Context'}->{_in_tag}=1;
                                                   },
									   post	=> sub { $_[0]->{'_XML::SAX::Context'}->{_in_tag}=0; }
                                     },
                    end_element   => { pre  => sub { $saved_self= $_[0];                                      # need to store self for post processing
									                 $_[0]->{'_XML::SAX::Context'}->{_in_tag}=1; 
                                                   },
							           post => sub { pop  @{$saved_self->{'_XML::SAX::Context'}->{_context}}; # use saved_self from pre wrapper
                                                      $_[0]->{'_XML::SAX::Context'}->{_in_tag}=0;
                                                   },
                                     },
					end_document  => { post => sub { %saved_wrappers=();                                      # drop the wrappers
									                 undef $_[0]->{'_XML::SAX::Context'};
							                       },
									 },
                  );
	foreach my $method ( keys %wrappers)
	  { 
		no strict "refs";
		# wrap either the method in the subclass or in this class
        my $wrapped_class= List::Util::first { defined &{"$_\::$method"} } ($class, @{"$class\::ISA"} );
		#warn "wrapping $wrapped_class\::$method\n";
		$saved_wrappers{$method}= wrap "$wrapped_class\::$method", %{$wrappers{$method}};
      }

	return $self;
  }

# here as stubs, trying to wrap directly around XML::SAX::Base handlers is much harder
sub start_element { my $self= shift; $self->SUPER::start_element( @_); }
sub end_element   { my $self= shift; $self->SUPER::end_element( @_);   }
sub end_document  { my $self= shift; $self->SUPER::end_document( @_);  }

# turn SAX1 events into SAX2 ones
sub sax1_2_sax2
  { 
    # first deal with the bits of the tag name
    my( $prefix, $localname);
    if( $_[1]->{Name}=~ /:/)
      { ( $prefix, $localname)= split /:/, $_[1]->{Name}; }
    else
      { $localname= $_[1]->{Name}; $prefix=''; }
    # turn SAX1 attributes into SAX2 attributes
    my %atts= map { "{}".$_ => { Name => $_, Value => $_[1]->{Attributes}->{$_} } } keys %{$_[1]->{Attributes}};
    push @{$_[0]->{'_XML::SAX::Context'}->{_context}}, 
        { Name => $_[1]->{Name}, LocalName => $localname, Prefix => $prefix, NamespaceURI => "", Attributes => \%atts };
  }


# the whole point of this: methods that give you info on the context
sub context           { return $_[0]->{'_XML::SAX::Context'}->{_context}                       } # a ref to the stack
sub ancestors         { return $_[0]->{'_XML::SAX::Context'}->{_context}                       } # a ref to the whole stack
sub parent            { return  List::Util::first { !$_[1] or name_equals($_, $_[1]) } 
                                         reverse @{$_[0]->{'_XML::SAX::Context'}->{_context}}[0..$#{$_[0]->{'_XML::SAX::Context'}->{_context}}-1] }

sub depth             { return scalar @{$_[0]->{'_XML::SAX::Context'}->{_context}}             } # 
                

# returns whether an element has a name
# first param is an element, second param is a name					  
sub name_equals
  { my( $elt, $name)= @_;
	return undef unless( $elt && $name);
    if( $name=~ /^\{/)                                                  # name is in clarkian notation
	  { return $name eq clarkian( $elt); }   
	else
	  { return $name eq $elt->{Name}; }
  }

# takes an attribute hash and an attribute name and returns the attribute 
# dwims in the sense that it can be passed a clarkian notation for the attribute, a short name or a prefixed name
sub find_dwim_att
  { my( $parser, $attributes, $att)= @_;
	my $key;
	if( $att=~ /^\s*\{/)               # clarkian notation, attribute can be found easily
      { $key= $att; }
	elsif( $att=~ /:/)                    # prefix used, need to go through the Name's to find the proper attribute
      { $key= List::Util::first { $_->{Name} eq $att } keys %$attributes; }
    else                                  # Name used, add the {} to get the clarkian notation
     { $key= "{}$att"; }
	return $attributes->{$key}; 
  }

sub clarkian
  { my $elt= shift;
	my $namespace_uri= $elt->{NamespaceURI} || '';
	return "\{$namespace_uri\}$elt->{LocalName}";
  }

sub AUTOLOAD
  { # normalize method name to that stoopid Java style
	 (my $method= lc $AUTOLOAD)=~ s{_}{}g;
	my $sub;
	# look for field methods
	if( $method=~ m{::curr(?:ent)?(.*)$} and (my $field= $FIELDS{$1}) )
	  { # current_<field>
		$sub = sub { $_[0]->{'_XML::SAX::Context'}->{_context}->[-1]->{$field} };
      }
	elsif( $method=~ m{::parent(.*)$} and ($field= $FIELDS{$1}) )
	  { # parent_<field>
		$sub = sub { my $parent= shift(@_)->parent( @_); return $parent ? $parent->{$field} : '';};
      }
	elsif( $method=~ m{::ancestor(.*)s$} and ($field= $FIELDS{$1}) )
	  { # ancestor_<field>s
		$sub = sub { return map { $_->{$field} } @{$_[0]->{'_XML::SAX::Context'}->{_context}} };
      }
	elsif( $method=~ m{::inel(emen)?t$})
	  { $sub = sub { return $_[0]->{'_XML::SAX::Context'}->{_in_tag} 
		                       ? name_equals( ($_[0]->{'_XML::SAX::Context'}->{_context}->[-2] || return undef), $_[1]) 
		                       : name_equals( ($_[0]->{'_XML::SAX::Context'}->{_context}->[-1] || return undef), $_[1]);
                           };
      }
    elsif( $method=~ m{::withinel(emen)?t$})
      { $sub= sub { return scalar grep { name_equals( $_, $_[1]) } @{$_[0]->{'_XML::SAX::Context'}->{_context} } } }
	elsif( $method=~ m{::cur(?:rent)att(ribute)?$})
	  { $sub = sub { return find_dwim_att( $_[0], $_[0]->{'_XML::SAX::Context'}->{_context}->[-1]->{Attributes}, $_[1]); };
      }
	elsif( $method=~ m{::cur(?:rent)att(ribute)?val(ue)?$})
	  { $sub = sub { return $_[0]->current_attribute( $_[1])->{Value}; };
      }
	elsif( $method=~ m{::inheritedatt(ribute)?$})
	  { $sub = sub { my( $parser, $att_name)= @_;
					 foreach my $elt (reverse @{$parser->{'_XML::SAX::Context'}->{_context}})
					   { if( defined (my $att= find_dwim_att( $parser, $elt->{Attributes}, $att_name))) 
					       { return $att->{Value}; }
                       }
					 return undef;
				   }
      }
	# redispatch if nothing found
	else
	  { croak "unknown method $AUTOLOAD"; }

    no strict 'refs';
	*{$AUTOLOAD} = $sub;
	goto &$AUTOLOAD;
  }

  
sub DESTROY { }
			
1;

__END__

=head1 NAME

XML::SAX::Context

=head1 ABSTRACT

XML::SAX::Context - A sub-class of XML::SAX::Base that stores context 
information during parsing

=head1 SYNOPSIS

  use XML::SAX::Context;
  use XML::Parser::PerlSAX;
  my $handler= MyHandler->new;
  my $parser= my $parser = XML::Parser::PerlSAX->new(Handler => $handler);
  $parser->parse( $doc);

  package TestHandler;

  use base qw(XML::SAX::Context);
  
  sub start_element
    { my( $self, $elt)= @_;
      my $current_name= $self->current_name;
      my @ancestor_names= $self->ancestor_names;
      my $current_depth= $self->depth;
	  print "in foo" if( $self->in_element( "foo"));
    }
  
  sub characters
    { my( $self, $chars)= @_;
      my $current_tag= $self->current_name;
	  my $context= $self->context;
      print "I'm here\n" 
        if( ($self->depth > 3) 
             and ($self->parent( 'ul')->{Attribute}->{'{}foo'} eq 'bar')
          );
    }

=head1 DESCRIPTION

XML::SAX::Context allows handlers that subclass it to use convenience
methods to access the current parsing context (open elements...)

XML::SAX::Context keeps a stack with the open elements and
gives methods to access this stack conveniently

Note: all method names are case insensitive and underscores are discarded, so
C<current_localname> can also be called C<currentLocalName> or 
C<current_local_name> or even C<CuRrEnTlOcAlNaMe> (not recommended!)

=head2 Methods

=over 4

=item context

returns a reference to the stack of open elements

=item current_element

returns a reference to the current element as received in the start_element 
handler

=item current_name

returns the I<Name> of the currently open element

=item current_localname

returns the I<LocalName> of the currently open element

=item current_prefix

returns the I<Prefix> of the currently open element

=item current_namespaceuri

returns the I<NamespaceURI> of the currently open element

=item parent_name

returns the I<Name> of the parent of currently open element

=item parent_localname

returns the I<LocalName> of the parent of currently open element

=item parent_prefix

returns the I<Prefix> of the parent of currently open element

=item parent_namespaceuri

returns the I<NamespaceURI> of the parent of currently open element

=item depth

returns the level in the parse tree. This is purely the level in terms of 
open elements, starting with 1. In short it is the size of the context stack.

=item ancestors

same as L<context>

=item ancestor_names

returns a list of ancestor I<Name>s, with the root first

=item ancestor_localnames

returns a list of ancestor I<LocalName>s, with the root first

=item ancestor_prefixs

returns a list of ancestor I<Prefix>s, with the root first

=item ancestor_namespaceuris

returns a list of ancestor I<NamespaceURI>s, with the root first

=item in_element ( $tagname)

returns true if the parent element tag name is C<$tagname>.
<$tagname> can be either the I<Name>, including the prefix, or
the clarkian notation for the name: C<{NamespaceURI}LocalName>.

=item within_element ( $tagname)

returns the number of elements in the ancestor list which name is C<$tagname>

=item parent ( $optional_tagname)

returns a reference to the parent of the current element. If an 
C<$optional_tagname> is given then it will give a reference to the deepest 
element in the ancestor list which Name is C<$optional_tagname>

=item inherited_attribute ( $attribute_name)

walks the context stack (from the top) and returns the value of the first 
attribute C<$attribute_name> found.


=back 

=head2 Convenient Functions

The module also provides (but does not export at the moment, so you have to
use the full name of the function C<XML::SAX::Context::clarkian> for example)
the following functions:

=over 4

=item clarkian ($element)

returns the clarkian notation for C<$element> (C<$element> is an eleement as
received by the C<start_element> handler, and as stored in the C<context> 
stack): C<< {<NamespaceURI>}<LocalName> >>

=back

=head1 TODO

Allow keeping the siblings of the top of the pile, that's often useful

Check Namespace declarations, they're probably a huge PITA ;--(

=head1 SEE ALSO

XML::SAX::Base

=head1 AUTHOR

Michel Rodriguez, E<lt>mirod@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2003 by Michel Rodriguez

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

=cut
