# vim:sw=4 sta showmatch

use strict;
use vars qw($VERSION);
$VERSION = '0.8.6';




package XML::Handler::SGMLSpl::Node;

sub new {
    my ($class, $type, $saxhash, $parent) = @_;
    $saxhash->{type} = $type;
    $saxhash->{parent} = $parent;
    $saxhash->{ext} = {};
    return bless($saxhash, $class);
}

# Element name
sub name {
    my ($self) = @_;
    if($self->{type} eq 'element') {
	return $self->{LocalName};
    } else {
	return undef;
    }
}

sub attr {
    my ($self, $name) = @_;
    if($name !~ /^\{/) { $name = '{}' . $name; }
    return $self->{Attributes}->{$name}->{Value};
}

sub within {
    my ($self,$name) = @_;
    for ($self = $self->{parent}; $self; $self = $self->{parent}) {
	return $self if ($self->name eq $name);
    }

    return undef;
}

sub in {
    my ($self,$name) = @_;
    if ($self->{parent} and $self->{parent}->name eq $name) {
	return $self->{parent};
    } else {
	return undef;
    }
}

sub ext { return shift->{ext} }
sub parent { return shift->{parent} }

# one of document, element, text, processing-instruction, comment, whitespace
sub type { return shift->{type} }




package XML::Handler::SGMLSpl;

sub new {
    my ($class, $user_data) = @_;
    my $self = {
	rules => {},
	mode => [ '' ],
        namespaces => {},       # public
	user_data => $user_data
    };
    return bless($self, $class);
}

#
# Rule parsing
#

sub add_rule {
    my $sub = pop;
    my ($self, $pattern, $mode) = @_;
    $mode = '' if !defined($mode);

    # Init hashes if not there already
    if(!defined $self->{rules}->{$mode}) {
	$self->{rules}->{$mode} = {
	    t_elem_open	 => {},
	    t_elem_close => {},
	    t_sdata => {},
	};
    }

    if($pattern eq 'text()') {
        $self->{rules}->{$mode}->{t_text} = $sub;
    } elsif($pattern eq 'processing-instruction()') {
        $self->{rules}->{$mode}->{t_pi} = $sub;
    } elsif($pattern eq 'comment()') {
        $self->{rules}->{$mode}->{t_comment} = $sub;
    } elsif($pattern eq 'sdata()') {
        $self->{rules}->{$mode}->{t_sdata}->{''} = $sub;
    } elsif($pattern eq '/<') {
        $self->{rules}->{$mode}->{t_doc_start} = $sub;
    } elsif($pattern eq '/>') {
        $self->{rules}->{$mode}->{t_doc_end} = $sub;
    } elsif($pattern =~ /^(\{([^}]+)\}(.+))<$/) {
        $self->{rules}->{$mode}->{t_elem_open}->{$1} = $sub;
    } elsif($pattern =~ /^(\{([^}]+)\}(.+))>$/) {
        $self->{rules}->{$mode}->{t_elem_close}->{$1} = $sub;
    } elsif($pattern =~ /^(([^:]+):)?([^:]+)<$/) {
        my $x = '{' . $self->{namespaces}->{$2} . '}' . $3;
        $self->{rules}->{$mode}->{t_elem_open}->{$x} = $sub;
    } elsif($pattern =~ /^(([^:]+):)?([^:]+)>$/) {
        my $x = '{' . $self->{namespaces}->{$2} . '}' . $3;
        $self->{rules}->{$mode}->{t_elem_close}->{$x} = $sub;
    } elsif($pattern =~ /^\|(.+)\|$/) {
        $self->{rules}->{$mode}->{t_sdata}->{$1} = $sub;
    } else {
        die "Unknown pattern type!";
    }
}

#
# Modes
#

sub push_mode {
    my ($self, $mode) = @_;
    push(@{$self->{mode}}, $mode);
    return $self->{mode}->[-2];
}

sub mode {
    my ($self) = @_;
    return $self->{mode}->[-1];
}

sub pop_mode {
    my ($self) = @_;
    return pop(@{$self->{mode}});
}

#
# Locators
#

sub set_document_locator {
    my ($self, $arg) = @_;
    $self->{locator} = $arg->{Locator};
}

sub get_locator {
    my ($self) = @_;
    return $self->{locator};
}

#
# Helpful utility method: displays location,
# with optional node address
#

sub warn_location
{
    my $self = shift;
    my $msg = pop;
    my $node = shift;

    my $location = $self->get_locator && $self->get_locator->location();

    my ($sysid, $linenum) = ('-', '');
    if($location) {
	$sysid = $location->{SystemId};
	$linenum = $location->{LineNumber};
    }

    my $nodeinfo;
    if(defined $node) {
	if($node->type() eq 'element') {
	    $nodeinfo = $node->name;
	} elsif($node->type eq 'text') {
	    $nodeinfo = $node->parent->name;
	}
    }

    if(defined $nodeinfo) {
	warn "$0:${sysid}:${linenum}:${nodeinfo}: ${msg}\n";
    } else {
	warn "$0:${sysid}:${linenum}: ${msg}\n";
    }
}
    


 

#
# Standard handlers: not intended for user
#

sub start_document {
    my ($self) = @_;

    my $doc = XML::Handler::SGMLSpl::Node->new(
		'document', {}, undef);
    $self->{current_node} = $doc;
    
    &{($self->{rules}->{$self->mode}->{t_doc_start} || sub{})}
	($self->{user_data}, $doc, $self);
}

sub end_document {
    my ($self) = @_;

    my $doc = $self->{current_node};
    $self->{current_node} = undef;
    
    return &{($self->{rules}->{$self->mode}->{t_doc_end} || sub{})}
	($self->{user_data}, $doc, $self);
}

sub start_element {
    my ($self, $arg) = @_;

    my $elem = XML::Handler::SGMLSpl::Node->new(
		    'element', $arg, $self->{current_node});
		    
    $self->{current_node} = $elem;

    $elem->{_last_mode} = $self->mode;

    my $key = '{' . $arg->{NamespaceURI} . '}' . $arg->{LocalName};
    my $default_key = '{' . $arg->{NamespaceURI} . '}*';
    
    my $elemrules = $self->{rules}->{$self->mode}->{t_elem_open};
    &{($elemrules->{$key} || $elemrules->{$default_key} || sub{})}
       ($self->{user_data}, $elem, $self);
}
    
sub end_element {
    my ($self, $arg) = @_;

    my $elem = $self->{current_node};

    my $key = '{' . $arg->{NamespaceURI} . '}' . $arg->{LocalName};
    my $default_key = '{' . $arg->{NamespaceURI} . '}*';

    # We always enter the end element handler with the same mode
    # as we had entered the start element handler.
    # In most cases this is the more sane behavior, even though
    # it's inconsistent.

    my $elemrules = $self->{rules}->{$elem->{_last_mode}}->{t_elem_close};
    &{($elemrules->{$key} || $elemrules->{$default_key} || sub{})}
       ($self->{user_data}, $elem, $self);
       
    $self->{current_node} = $elem->parent;
}

sub characters {
    my ($self, $arg) = @_;

    my $textnode = XML::Handler::SGMLSpl::Node->new(
		    'text', $arg, $self->{current_node});
    
    &{($self->{rules}->{$self->mode}->{t_text} || sub{})}
	($self->{user_data}, $textnode, $self);
}

sub processing_instruction {
    my ($self, $arg) = @_;

    my $pi = XML::Handler::SGMLSpl::Node->new(
		    'processing-instruction', $arg, $self->{current_node});
    
    &{($self->{rules}->{$self->mode}->{t_pi} || sub{})}
	($self->{user_data}, $pi, $self);
}

sub ignorable_whitespace {
    my ($self, $arg) = @_;

    my $textnode = XML::Handler::SGMLSpl::Node->new(
		    'whitespace', $arg, $self->{current_node});
    
    &{($self->{rules}->{$self->mode}->{t_text} || sub{})}
	($self->{user_data}, $textnode, $self);
}

sub comment {
    my ($self, $arg) = @_;

    my $comment = XML::Handler::SGMLSpl::Node->new(
		    'comment', $arg, $self->{current_node});
    
    &{($self->{rules}->{$self->mode}->{t_comment} || sub{})}
	($self->{user_data}, $comment, $self);
}

#
# SDATA entities (SGML)
#

sub internal_entity_ref {
    my ($self, $arg) = @_;

    my $sdata = XML::Handler::SGMLSpl::Node->new(
		    'sdata', $arg, $self->{current_node});

    my $sdatarules = $self->{rules}->{$self->mode}->{t_sdata};
    &{($sdatarules->{$arg->{LocalName}} || $sdatarules->{''} || sub{})}
       ($self->{user_data}, $sdata, $self);
}

# FIXME: Write a man page.

# Autoload methods go after =cut, and are processed by the autosplit program.

1;