package XML::Node; ###### Generic DOM node
###	$Id: Node.pm,v 1.4 2002/05/24 19:02:03 steve Exp $
###
###	This object implements a node in an extremely simple document
###	object model for XML.  Note that it bears almost no
###	relationship whatever to the W3C's DOM standard.  In
###	particular there are no parent links (traversal must be done
###	by recursion or using a separately-maintained stack), and
###	children are contained in an array rather than a linked list.
###

use Exporter;
push(@ISA, Exporter);

use vars qw($VERSION);
$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);

#############################################################################
###
### Constructors:
###

### XML::Node->readFrom(path)
#	Read an XML file and return its top node.
#
sub readFrom {
    my ($class, $path) = @_;

    return '' unless -f $path;

    my $parser = XML::TrivialParser->new;
    $parser->filter(1);
    $parser->parseFile($path);

    my $self = $parser->top;
    if (ref $self) { $self = bless $self, $class; }
    $self;
}

### XML::Node->new($attr => $val, ..., [$content...])
sub new {
    my ($class, @attrs) = @_;

    ##	 Instance Variables:
    ##	    _list	list of attributes in the order defined.
    ##	    _tag	string tag (optional)
    ##	    _content	list of indexed items
    ##	    _empty	has "empty" flag, i.e. ends in "/>"

    my $self = bless {}, $class;
    my $list = [];
    $self->{'_list'} = $list;

    my($attr, $val);
    while (($attr, $val) = splice(@attrs, 0, 2)) {
	if (! defined $val) {
	    $self->push($attr);
	    return $self;
	}
	push(@$list, $attr) unless (exists $self->{$attr} || $attr =~ /^\_/);
	$self->{$attr} = $val;
    }
    $self;
}

sub init_content {
    my $self = shift;
    $self->{'_content'} = [];
}

### element($tag, [attr=>value...])
sub element {
    my ($class, $tag, $attrs) = @_;
    return $class->new('_tag'=>$tag, @$attrs);
}

### declaration($text)
sub declaration {
    my ($class, $text) = (@_);
    return $class->new('_tag'=>'!', $text);
}

### comment($text)
sub comment {
    my ($class, $text) = (@_);
    return $class->new('_tag'=>'!--', $text);
}

### pi($text)
sub pi {
    my ($class, $text) = (@_);
    return $class->new('_tag'=>'?', $text);
}

### cdata($text)
sub cdata {
    my ($class, $text) = (@_);
    return $class->new('_tag'=>'![CDATA[', $text);
}


#############################################################################
###
### Access to Components:
###

sub tag {
    my $self = shift;

    ## Return (optionally set) the tag.

    if (@_) {
	$self->{'_tag'} = $_[0];
    } else {
	$self->{'_tag'};
    }
}

sub name {
    my $self = shift;

    ## Return (optionally set) the node's name.
    ## If the node is an element, the nodename is the tagname.
    ## If it's not an element, the name is the value of {'name'}.

    my $att = ($self->tag() =~ /^[a-zA-Z_-]/)? '_tag' : 'name';
    if (@_) {
	$self->{$att} = $_[0];
    } else {
	$self->{$att};
    }
}

sub attr {
    my ($self, $attr, $val) = @_;

    ## Return (optionally set) an attribute
    ##	WARNING:  attribute names are NOT automatically lowercased!

    my $old = $self->{$attr};
    if (defined $val) {
	if (! defined $old && $attr !~ /^\_/) {
	    my $list = $self->{_list};
	    push(@$list, $attr);
	}
	$old = $self->{$attr} = $val;
    }
    $old;
}

sub attr_default {
    my ($self, $attr, $val) = @_;

    ## Return an attribute, optionally set to a default.

    my $v = $self->{$attr};
    if (! defined $v) {
	$self->{$attr} = $v = $val;
	if ($attr !~ /^\_/) {
	    my $list = $self->{_list};
	    push(@$list, $attr);
	}
    }
    $v;
}

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

    ## return all the attributes in a hash

    my $attrs = {};
    for (sort keys %$self) {
	next if /^_/;
	$attrs{$_} = $self->{$_};
    }
    return $attrs;
}

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

    ## return all the attribute names in a list

    my $attrs = $self->{'_list'};
    if (!defined($attrs)) {
	@list = sort keys %$self;
	$attrs = [];
	for (@$list) {
	    next if /^\_/;
	    push(@$attrs, $_);
	}
    }
    return $attrs;
}

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

    ## return all the attributes in a list of pairs

    my $attrs = [];
    my $list = $self->attr_names;
    for (@$list) {
	push(@$attrs, $_);
	push(@$attrs, $self->{$_});
    }
    return $attrs;
}

### subElement($name)
#	Returns an immediate sub-element with the given $name (the first, 
#	if there are more than one).
sub subElement {
    my ($self, $name) = (@_);
    my $content = $self->content;
    if (ref $content) {
	my $e;
	for $e (@$content) {
	    if (ref($e) && $e->tag eq $name) { return $e; }
	}
    }
    return '';
}

### getSubElementsByTag($name)
#	Returns a reference to an array containing all immediate sub-elements 
#	with the given tagname.  The return value is always an array
#	reference to an array, but it might be empty.
sub getSubElementsByTag {
    my ($self, $name) = (@_);
    my $content = $self->content;
    my @list = ();
    if (ref $content) {
	my $e;
	for $e (@$content) {
	    if (ref($e) && $e->tag eq $name) { push(@list, $e); }
	}
    }
    return \@list;
}

### getElementsByTag($name)
#	Returns a reference to an array containing all descendent elements 
#	with the given tagname.  The return value is always an array
#	reference to an array, but it might be empty.  
#	Unlike getSubElementsByTag, getElementsByTag is recursive (just like
#	the corresponding DOM operation); it does not recurse into elements
#	with the requested tag, however.
sub getElementsByTag {
    my ($self, $name) = (@_);
    my $content = $self->content;
    my @list = ();
    if (ref $content) {
	my $e;
	for $e (@$content) {
	    if (ref($e) && $e->tag eq $name) { push(@list, $e); }
	    elsif (ref($e) && $e->is_element) {
		my $elts = $e->getElementsByTag($name);
		push(@list, (@$elts));
	    }
	}
    }
    return \@list;
}

### getElements($name)
#	Returns a reference to an array containing all sub-elements 
#	in the Node's content.  The return value is always an array
#	reference to an array, but it might be empty.
sub getElements {
    my ($self, $name) = (@_);
    my $content = $self->content;
    my @list;
    if (ref $content) {
	my $e;
	for $e (@$content) {
	    if (ref($e) && $e->is_element) { push(@list, $e); }
	}
    }
    return \@list;
}


#############################################################################
###
### Content:
###	We use the simplified syntax of push, pop, unshift, and shift
###	rather than the clumsier push_content, and provide a complete
###	set of operations.

sub is_element {
    my $self = shift;

    my $tag = $self->tag;
    if ($tag =~ /^[-a-zA-Z0-9:_.]/) { return $tag; }

    return '';
}

sub content {
    my $self = shift;

    ## Return (optionally set) the content list.

    if (@_) {
	@array = @_;
	$self->{'_content'} = \@array;
    } else {
	$self->{'_content'};
    }
}

sub content_is_blank {
    my $self = shift;
    my $content = $self->content;
    if (! ref $content) { return 1; }
    for my $i (@$content) {
	return 0 if (ref $i);
	return 0 if ($i =~ /[^\s]/s);
    } 
    return 1;	
}

sub mark_empty {
    my ($self, $mark) = (@_);
    $mark = 1 unless $mark;
    $self->marked_empty($mark);
}

sub marked_empty {
    my ($self) = shift;

    ## Returns true if the element ended in '/>'

    if (@_) {
	$self->{'_empty'} = shift;
    }
    return $self->{'_empty'};
}


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

    ## Returns true if there is no content
    my $c = $self->{'_content'};
    if (ref($content) && ref($content) ne 'ARRAY') {
	print STDERR "***non-array content $content\n";
	return 0;
    }

    return !defined $c || !ref $c && $c eq '' || !@$c;
}


sub push {
    ## Push something into the content.  

    my $self = shift;

    my $content = $self->{'_content'};
    if (!defined $content) {
	$content = [];
	$self->{'_content'} = $content;
    }
    for (@_) {
	if (ref($_) eq 'ARRAY') {
	    $self->push(@$_);
	} else {
	    push(@$content, $_);
	}
    }
    $self;
}


sub unshift {
    ## unshift something into the content, i.e. attach it to the front.

    my $self = shift;
    $self->init_content unless exists $self->{'_content'};
    my $content = $self->{'_content'};
    for (@_) {
	if (ref($_) eq 'ARRAY') {
	    unshift(@$content, $_);
	} else {
	    unshift(@$content, $_);
	}
    }
    $self;
}

sub item {
    my ($self, $index, $value) = @_;

    ## Return (optionally set) an indexed item of content.

    $self->{'_content'} = [] unless exists $self->{'_content'};
    my $content = $self->{'_content'};
    return unless defined $content;

    if (defined $value) {
	$content->[$index] = $value;
    } else {
	$content->[$index];
    }
}


#############################################################################
###
### Conversion to String:
###

sub toString {
    my ($self, $contentOnly) = @_;

    ## Convert a token, or its content if $contentOnly is true,
    ##	  to a string.


    my $string = $self->content_string;
    return $string if $contentOnly;

    $string = $self->starttag . $string;
    $string .=  $self->endtag 
	if ($self->needs_end_tag || $self->internal_content);
    return $string;
}


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

    ## Convert content to a string.

    my $string = '';

    my $content = $self->content;
    if (ref $content) {
	for (@$content) { 
	    if (ref($_)) { $string .= $_->toString; }
	    else         { $string .= 1? $_ : $self->encode_entities($_); } # === ents?
	}
    }
    return $string;
}

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

    ## Returns the string representing the element's start tag.
    ##	  Note that some tags have nonstandard representations,
    ##	  and that attributes might be references to objects.

    my $name = $self->{'_tag'};

    return '' unless defined $name;

    if ($self->internal_content) {
	return "<$name";
    }
    my $tag = "<$name";
    my $list = $self->{'_list'};
    $list = sort keys %$self unless defined $list;
    my $atr;
    for $atr (@$list) {
	next if $atr =~ /^_/;
	my $val = $self->{$atr};
	if ($atr eq $val &&
	    exists($boolean_attr{$name}) && $boolean_attr{$name} eq $atr) {
	    $tag .= " $atr";
	} else {
	    $val = 1? $val : $self->encode_entities($val); # === entities? ===
	    $val = ($val =~ /\"/)? "'" . $val . "'" : qq{"$val"};
	    $tag .= qq{ $atr=$val};
	}
    }
    my $mark = ($self->marked_empty eq "/") ? " /" : "";
    "$tag$mark>";
}

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

    my $name = $self->{'_tag'};
    return '' if $name eq '' || $name eq ':' || $self->marked_empty;
    my $ending = $internal_content_tags{$name};
    if (defined $ending) {
	return "$ending>";
    }
    "</$name>";
}



#############################################################################
###
### Expansion:
###

### $self->expand($process)
#
sub expand {
    my ($self, $p) = @_;
    my $name = $self->{'_tag'};
    my $content = $self->{'_content'};

    if (!defined $name || $name eq '') {
	# nodelist
	if (ref $content) {
	    for $node (@$content) { $p->expandNode($node) }
	}
    } elsif ($name eq '!--') {
	$p->comment($content);
    } elsif ($name eq '!') {
	$p->declaration($content);
    } elsif ($name eq '?') {
	$p->pi($content);
    } elsif ($name eq '![CDATA[') {
	$p->cdata($content);
    } else {
	$p->element($name, $self, $content);
    }
}


#############################################################################
###
### Syntax:
###

sub needs_end_tag {
    return 1;
}

%internal_content_tags = ('!' => '',
			  '!--' => '--',
			  '?' => '?',
			  '&' => ';',
			  '![CDATA[' => ']]',
			  );


sub internal_content {
    my ($self, $interp) = @_;

    return 0 unless $self->tag;
    return exists $internal_content_tags{$self->tag};
}

sub encode_entities {
    my ($self, $str) = (@_);
    $str =~ s/\&/\&amp;/gs;
    $str =~ s/\</\&lt;/gs;
    $str =~ s/\>/\&gt;/gs;
    $str;
}


#############################################################################
1;

