# NHSE Repository in a Box (RIB)
#
# The authors of this software are Paul McMahan and Jeff Horner.
# Copyright (c) 1997 by the University of Tennessee.
# Permission to use, copy, modify, and distribute this software for any
# purpose without fee is hereby granted, provided that this entire notice
# is included in all copies of any software which is or includes a copy
# or modification of this software and in all copies of the supporting
# documentation for such software.
# THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTY.  IN PARTICULAR, NEITHER THE AUTHORS NOR UNIVERSITY OF TENNESSEE
# MAKE ANY REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE
# MERCHANTABILITY OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
#
#
#>Copyright 1996 Gisle Aas. All rights reserved.
#>
#>This library is free software; you can redistribute it and/or
#>modify it under the same terms as Perl itself.
#>
#>Gisle Aas <aas@sn.no>
#>
#
# I feel oblidged to cite the above since this package
# borrows heavily from his/her file Parser.pm.
#
# Jeff Horner <jhorner@cs.utk.edu>
#
# $Id: ConfigParser.pm,v 1.6 1998/05/13 20:21:35 rib Exp $
#
# $Log: ConfigParser.pm,v $
# Revision 1.6  1998/05/13 20:21:35  rib
# fixed bug in objectashtml causing relationships to be incorrectly
# pointed to relative urls even when show_object.pl was in effect.
#
# Revision 1.5  1998/05/13 01:26:36  rib
# changed version number to 1.3
#
# Revision 1.3  1998/04/24 19:18:41  rib
# changed objectashtml routine so that it doesn't try to substitute
# "../" for local objects unless the *entire* repository name is in the
# url of a relationship. i.e if $entry =~ /^$riburl\/repositories\/$repo\//
# instead of $entry =~ /^$riburl\/repositories\/$repo/
#
# Revision 1.2  1997/12/18 18:06:47  rib
#         - fixed bug in ConfigParser.pm.  When an Asset was linked to from a
#           repository under the same rib installation as the source repository,
#           urls for relationships weren't pointing to the correct location.  They
#           were pointing towards a (nonexistant) object in the local repository
#           rather than the object in the foreign repository.
#
#         - Commented out the part of ConfigParser which makes a HEAD request
#           before assuming that the html for the destination object is already
#           there.  This created too much traffic and logging garbage.
#
#         - changed ConfigParser.pm so that objectashtml() prints relationships
#           separated with <br>'s.  When a realtionship had more than one value
#           they were all on the same line.
#
#         -  updated DomainParser.pm to sort entries in the catalog by the name of
#            the Asset rather than the filename (md5s of nonlocals alerted
#            us to this problem because the filename didn't look like the name).
#
# Revision 1.1.1.1  1997/12/10 15:59:34  jhorner
# RIB pre 1.0
#
# Revision 1.1  1997/05/06 19:01:51  jhorner
# Initial revision
#
package RIB::ConfigParser;

use strict;
use HTML::Entities ();
use RIB::BIDMParser ();
use RIB::Util ();
use Data::Dumper ();
use LWP::UserAgent ();
use HTTP::Request ();

use vars qw ($DEBUG $VERSION);
$DEBUG = 1;
$VERSION = 0.9;
sub new
{
    my $class = shift;
    my $self = {
	_buf      => '',
	_curtag   => [],
	_curclass => '',
	_curaorr  => '', # CURrent Attribute OR Relationship name
	_hash     => {},
	_classlist => [], # for faulty hierarchy checking
	_index    => 0,   # also for the above
	_matrix   => [],  # also for the above
	_errormsg => [],  # gets updated anytime a method failes
    };
    bless $self, $class;
    $self;
}

# NOTE: this is an OBJECT method, not a class method.
#
# It returns a new ConfigParser object, so we use 
# the ref() function on $kind to get the name of the package.
sub InstanceOf {
    my ($kind,$foreign,$arg1,$arg2) = @_;
    my $ob = {};
    my $self = bless $ob, ref($kind);

    if (defined $arg2){
    # $arg2 is a BIDMParser
	if (defined $kind->{'_hash'}{$arg1}){
	    # $kind is a ConfigParser with info
	    # on many classes, but $arg1 is the class
	    # we're interested in.
	    $self->{'_hash'} = $kind->{'_hash'}{$arg1};
	} elsif ($kind->IsConfiguredFor($arg1)){
	    # $kind is a ConfigParser with info on
	    # only one class: $kind->IsConfiguredFor()
	    $self->{'_hash'} = $kind->{'_hash'};
	} else {
	    # Caller doesn't know how to use this method
	    return '';
	}
	# Add new empty values to fields
	#print ref($self->{'_hash'}{FIELDS}{"Domain"}{VALUES}),"\n";
	my $field;
	foreach $field (@{$self->{'_hash'}{FIELDSEQ}}){
	    $self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString} = [];
	}
	$self->{'_classlist'} = ();
	push @{$self->{'_classlist'}} , $arg1;
	$self->AddEntries($arg2->link);
	$self->AddEntries($arg2->meta);
    } elsif (defined $arg1){
	if (ref($arg1) eq "RIB::BIDMParser"){
	    # Need to check if $kind has configinfo
	    # for only one class
	    unless (scalar($kind->IsConfiguredFor()) == 1){
		# Caller doesn't know how to use this method
		return '';
	    }
	    $self->{'_hash'} = $kind->{'_hash'};
	    $self->{'_classlist'} = ();
	    push @{$self->{'_classlist'}} , $arg1;
	    # Add new empty values to fields
	    my $field;
	    foreach $field (@{$self->{'_hash'}{FIELDSEQ}}){
		$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString} = [];
	    }
            $self->AddEntries($arg1->link);
            $self->AddEntries($arg1->meta);
	} elsif ($kind->IsConfiguredFor($arg1)) {
	    # how many classes does $kind have info on?
	    if (scalar($kind->IsConfiguredFor()) == 1){
		$self->{'_hash'} = $kind->{'_hash'};
	    } else {
		$self->{'_hash'} = $kind->{'_hash'}{$arg1};
	    }
	    $self->{'_classlist'} = ();
	    push @{$self->{'_classlist'}} , $arg1;
	    # Add new empty values to fields
	    my $field;
	    foreach $field (@{$self->{'_hash'}{FIELDSEQ}}){
		$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString} = [];
	    }
	}
    } else {
	# Regardless of how many classes $kind has
	# info on, just reference it anyway.
	$self->{'_hash'} = $kind->{'_hash'};
	# Add new empty values to fields
	my $field;
	foreach $field (@{$self->{'_hash'}{FIELDSEQ}}){
	    $self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString} = [];
	}
    }
    $self->{'_hash'}{FIELDS}{FOREIGN}{VALUES}{$self->AsString} = 
	($foreign) ? $foreign : '';
    return $self;
}


##########  PARSING METHODS  ##################

sub eof
{
    shift->parse(undef);
}

sub load_url {
    my ($self,$url) = @_;
    my $ua = LWP::UserAgent->new("RIBcatalog/0.1");
    my $req = HTTP::Request->new('GET',$url);
    my $res = $ua->request($req);
    if ($res->is_success){
        $self->parse($res->content);
	return 1;
    } else {
	my $err = $res->code . " - " . $res->message;
        push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
        return 0;
    }
}


sub parse
{
    my $self = shift;
    my $buf = \ $self->{'_buf'};
    unless (defined $_[0]) {
	# signals EOF (assume rest is plain text)
	if (length $$buf){
	    $self->text($$buf) unless ($$buf =~ /^[\n\r\t\f\b\0\ ]+$/);
	}
	$$buf = '';
	return $self;
    }
    $$buf .= $_[0];

    # Parse html text in $$buf.  The strategy is to remove complete
    # tokens from the beginning of $$buf until we can't decide whether
    # it is a token or not, or the $$buf is empty.
    while (1) {  # the loop will end by returning when text is parsed
	# First we try to pull off any plain text (anything before a "<" char)
	if ($$buf =~ s|^([^<]+)||) {
	    unless (length $$buf) {
		my $text = $1;
		# At the end of the buffer, we should not parse white space
		# but leave it for parsing on the next round.
		if ($text =~ s|(\s+)$||) {
		    $$buf = $1;
                # Same treatment for chopped up entites.
		} elsif ($text =~ s/(&(?:(?:\#\d*)?|\w*))$//) {
		    $$buf = $1;
		};
		$self->text($text) unless ($text =~ /^[\n\r\t\f\b\0 ]+$/);
		return $self;
	    } else {
		$self->text($1) unless ($1 =~ /^[\n\r\t\f\b\0 ]+$/);
	    }
	# Then, look for an end tag
	} elsif ($$buf =~ s|^</||) {
	    # end tag
	    if ($$buf =~ s|^\s*([a-z][a-z0-9\.\-]*)\s*>||i) {
		$self->end(lc($1));
	    } elsif ($$buf =~ m|^\s*[a-z]*[a-z0-9\.\-]*\s*$|i) {
		$$buf = "</" . $$buf;  # need more data to be sure
		return $self;
	    } else {
		# it is plain text after all
		$self->text($$buf) unless ($$buf =~ /^[\n\r\t\f\b\0 ]+$/);
		$$buf = "";
	    }
	# Then, finally we look for a start tag
	} elsif ($$buf =~ s|^<||) {
	    # start tag
	    my $eaten = '<';

	    # This first thing we must find is a tag name.  RFC1866 says:
	    #   A name consists of a letter followed by letters,
	    #   digits, periods, or hyphens. The length of a name is
	    #   limited to 72 characters by the `NAMELEN' parameter in
	    #   the SGML declaration for HTML, 9.5, "SGML Declaration
	    #   for HTML".  In a start-tag, the element name must
	    #   immediately follow the tag open delimiter `<'.
	    if ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\.\-]*)\s*)||) {
		$eaten .= $1;
		my $tag = lc $2;
		my %attr;
		my @attrseq;

		# Then we would like to find some attributes
                #
                # Arrgh!! Since stupid Netscape violates RCF1866 by
                # using "_" in attribute names (like "ADD_DATE") of
                # their bookmarks.html, we allow this too.
		while ($$buf =~ s|^(([a-zA-Z][a-zA-Z0-9\.\-_]*)\s*)||) {
		    $eaten .= $1;
		    my $attr = lc $2;
		    my $val;
		    # The attribute might take an optional value (first we
		    # check for an unquoted value)
		    if ($$buf =~ s|(^=\s*([^\"\'>\s][^>\s]*)\s*)||) {
			$eaten .= $1;
			$val = $2;
			HTML::Entities::decode($val);
		    # or quoted by " or '
		    } elsif ($$buf =~ s|(^=\s*([\"\'])(.*?)\2\s*)||s) {
			$eaten .= $1;
			$val = $3;
			if ($val ne ""){
			    HTML::Entities::decode($val);
			} else { 
			    undef $val
			}
                    # truncated just after the '=' or inside the attribute
		    } elsif ($$buf =~ m|^(=\s*)$| or
			     $$buf =~ m|^(=\s*[\"\'].*)|s) {
			$$buf = "$eaten$1";
			return $self;
		    } else {
			# assume attribute with implicit value
		    }
		    if (defined $val ){
			$attr{$attr} = $val;
		    } else {
			$attr{$attr} = undef; # so we can have the key exist
		    }
		    push(@attrseq, $attr);
		}

		# At the end there should be a closing ">"
		if ($$buf =~ s|^>||) {
		    $self->start($tag, \%attr, \@attrseq, "$eaten>");
		} elsif (length $$buf) {
		    # Not a conforming start tag, regard it as normal text
		    $self->text($eaten) 
			unless ($eaten =~ /^[\n\r\t\f\b\0 ]+$/);
		} else {
		    $$buf = $eaten;  # need more data to know
		    return $self;
		}

	    } elsif (length $$buf) {
		$self->text($eaten) unless ($eaten =~ /^[\n\r\t\f\b\0 ]+$/);
	    } else {
		$$buf = $eaten . $$buf;  # need more data to parse
		return $self;
	    }

	} elsif (length $$buf) {
	    die; # This should never happen
	} else {
	    # The buffer is empty now
	    return $self;
	}
    }
    $self;
}

sub parse_config
{
    my($self, $file) = @_;
    my $lock = $file . "\.lock";
    if (-e $lock){
	sleep 5;
	if (-e $lock){
	    my $err = "Someone is editing $file".
	    " at the moment. Please wait a few seconds and".
	    " then perform this action again. If you believe".
	    " that someone is NOT editing this file, then".
	    " ask your RIB administrator to remove $lock.";
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return 0;
	}
    }
    # Assume $file is a filename
    unless (open(F, $file)){
	my $err = "Can't open $file. Reason: $!.";
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    my  $chunk = '';
    while(read(F, $chunk, 2048)) {
        $self->parse($chunk);
    }

    close(F);
    $self->eof;
    unless ($self->lookfor_hierarchy_faults) {
	print "Lookfor_hierarchy_faults failed!" if $DEBUG;
	return 0;
    }
    $self->flatten_hierarchy;
    return 1;
}

sub parse_cached_config
{
    my($self, $file) = @_;
    my $lock = $file . "\.lock";
    if (-e $lock){
	sleep 5;
	if (-e $lock){
	    my $err = "Someone is editing $file".
	    " at the moment. Please wait a few seconds and".
	    " then perform this action again. If you believe".
	    " that someone is NOT editing this file, then".
	    " ask your RIB administrator to remove $lock.";
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return '';
	}
    }
    # Assume $file is a filename
    unless (open(F, $file)){
	push @{$self->{'_errormsg'}}, "Can't open $file. Reason: $!.";
	return 0;
    }
    my $chunk = ''; my $buf = '';
    while(read(F, $chunk, 2048)) {
        $buf .= $chunk;
    }
    close(F);
    my $tmp;
    no strict 'vars';
    $tmp = eval "my $buf";
    use strict 'vars';
    if ($@){
	my $err = "An error occured while trying to eval $file: $@.".
	    " Please contact your RIB administrator!";
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    $self->{'_hash'} = $tmp->{'_hash'};
    $self->{'_classlist'} = $tmp->{'_classlist'};
    return 1;
}

sub load_class {
    my ($self,$class,$file,$override) = @_;
    unless ($self->load_config($file,$override)) {
	print "Load_config failed!" if $DEBUG;
	return '';
    }
    $self->{'_hash'} = $self->{'_hash'}->{$class};
    $self->{'_classlist'} = ();
    push @{$self->{'_classlist'}} , $class;
    my $field;
    foreach $field ( @{$self->{'_hash'}{FIELDSEQ}} ){
	$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString} = [];
    }
    return 1;
}

sub load_config
{
    my($self, $file,$override) = @_;
    # Assume $file is a filename

    my $chunk = '';
    if (defined $override){
	# Override cached config file and parse 
	unless ($self->parse_config($file)) {
	   print "Parse_config failed!" if $DEBUG;
	   return '';
	}
	return 1;
    }

    # Now see if we can read the cached config file or not
    my $cache = $file . "\.cache";
    my (@v,@f);
    if (-e $cache){
	my $lock = $cache . "\.lock";
	if (-e $lock){
	    sleep 5;
	    if (-e $lock){
		my $err = "Someone is editing $cache".
		" at the moment. Please wait a few seconds and".
		" then perform this action again. If you believe".
		" that someone is NOT editing this file, then".
		" ask your RIB administrator to remove $lock.";
		push @{$self->{'_errormsg'}}, $err;
		print $err if $DEBUG;
		return '';
	    }
	}

	@v = stat($cache);
	@f = stat($file);
	unless (defined $v[9] && defined $f[9]){
	    my $err = "There seems to be a".
		" problem with the status of either $file or".
		" $cache. Please contact your RIB administrator.";
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return '';
	}
	# Parse cached config if newer or same age as $file
	if ($f[9] <= $v[9]){
	    unless ($self->parse_cached_config($cache)) {
		print "Parse_cached_config failed!" if $DEBUG;
		return '';
	    }
	    return 1;
	}
    }

    # Parse config and create new cache
    unless ($self->parse_config($file)) {
	print "Parse_config failed!" if $DEBUG;
	return '';
    }
    unless ($self->create_cached_config($file)) {
	print "Create_cached_config failed!" if $DEBUG;
	return '';
    }
    return 1;
}

sub create_cached_config {
    my ($self,$file) = @_;
    my $cache = $file . "\.cache";
    unless (open(F,">$cache")){
	my $err = "Can't open $cache. Reason: $!.";
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    $Data::Dumper::Indent = 0;
    print F Data::Dumper::Dumper($self);
    close(F);
    return 1;
}

sub text
{
    my($self, $text) = @_;
    #print $text if $DEBUG;
    my $hash = $self->{'_hash'}->{$self->{'_curclass'}};
    if ($self->{'_curaorr'} eq ''){
	unless (exists $hash->{DESC}){
	    $hash->{DESC} = _pretty($text);
	} else {
	    $hash->{DESC} .= " ". _pretty($text);
	}
    } else {
	$hash->{FIELDS}->{$self->{'_curaorr'}}->{DESC} = _pretty($text);
    }
    return 1;
}

sub start
{
    my($self, $tag, $attr, $attrseq, $origtext) = @_;

    #print "START: $origtext\n" if $DEBUG;
    if ($tag eq "class"){
	# the _curtag stack better be empty
	if ( _isempty($self->{'_curtag'}) ){
	    # the class Must have a name
	    if ( !(exists $attr->{name}) || !(defined $attr->{name}) ) {
		my $err = "You must define a NAME for each class in your".
		    " configuration file. This error occurs right after".
		    " the class definition of ". 
		    _topofstack(@{$self->{'_classlist'}}) . '.';
		push @{$self->{'_errormsg'}}, $err;
		print $err if $DEBUG;
		return 0;
	    }

	    # Initialize a new class data structure
	    my $newhash = {};
	    $newhash->{INDEX} = $self->{'_index'};

	    # Save some state
	    push @{$self->{'_curtag'}}, $tag;
	    $self->{'_curclass'} = $attr->{name};
	    push @{$self->{'_classlist'}}, $attr->{name};
	    $self->{'_index'} += 1;
	    

	    if ( exists $attr->{extends} ){
		unless (defined $attr->{extends}){
		    my $class = $attr->{name};
		    my $err = "You must give a value to the tag EXTENDS ".
			"when defining class $class.";
		    push @{$self->{'_errormsg'}}, $err;
		    print $err if $DEBUG;
		    return 0;
		}
		if ( $attr->{name} eq $attr->{extends} ){
		    my $class = $attr->{name};
		    my $err = "You CANNOT allow class $class to extend itself.";
		    push @{$self->{'_errormsg'}}, $err;
		    print $err if $DEBUG;
		    return 0;
		}

		$newhash->{EXTENDS} = $attr->{extends};
	    }

	    $newhash->{FIELDSEQ} = [];
	    $newhash->{FIELDS} = {};
	    $self->{'_hash'}->{$attr->{name}} = $newhash; 

	    
	} elsif (_topofstack($self->{'_curtag'}) eq "class"){
	    my $class = $self->{'_curclass'};
	    my $err = "You cannot embed definition of a CLASS within ".
		"another class, or possibly missing end tag </CLASS> at".
		" definition of $class.";
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return 0;
	} else {
	    my $err = "You cannot embed a CLASS tag within ".
		"any other start tag, ";
	    if (defined $self->{'_curclass'}){
		my $class = $self->{'_curclass'};
		$err .= "at definition of class $class";
	    } 
	    if (defined $self->{'_curaorr'}){
		my $field = $self->{'_curaorr'};
		$err .= " near definiton of $field";
	    }
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return 0;
	}
    } elsif ($tag eq "attribute" || $tag eq "relationship"){
	if (_isempty($self->{'_curtag'})){
	    my $err = "You must define ${tag}s within class definitions.".
		"Error caught near definition of ". 
		_topofstack(@{$self->{'_classlist'}}). '.';
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return 0;
	}
	if (_topofstack($self->{'_curtag'}) ne "class"){
	    my $buf = _topofstack($self->{'_curtag'});
	    my $class = $self->{'_curclass'};
	    my $err = "You must not embedd $tag definitons within ".
		"$buf definitons near definition of class $class.";
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return 0;
	}
	push @{$self->{'_curtag'}}, $tag;
	my $hash = $self->{'_hash'}->{$self->{'_curclass'}};
	if ( !(exists $attr->{name}) || !(defined $attr->{name}) ) {
	    my $class = $self->{'_curclass'};
	    my $err = "You must define a NAME for $tag in definition of $class.";
	    push @{$self->{'_errormsg'}}, $err;
	    print $err if $DEBUG;
	    return 0;
        }
	$self->{'_curaorr'} = $attr->{name};
	my $symbol;
	foreach $symbol ( @{$hash->{FIELDSEQ}} ){
	    if ( $symbol eq $attr->{name} ){
		my $class =  $self->{'_curclass'};
		my $err = "You cannot define $symbol twice ".
		    "in definition of $class: ";
		push @{$self->{'_errormsg'}}, $err;
		print $err if $DEBUG;
		return 0;
	    }
	}
	push @{$hash->{FIELDSEQ}}, $attr->{name};
	$hash->{FIELDS}->{$attr->{name}} = {};
	$hash->{FIELDS}->{$attr->{name}}->{VALUES} = {};

	if ( $tag eq "attribute" ){
	    if ( exists $attr->{dtype} ){
		unless ( defined $attr->{dtype} ){
		    my $class = $self->{'_curclass'};
		    my $err = "You must define a value for DTYPE".
		        "in ATTRIBUTE tag $attr->{name} ".
		        "in definition of class $class";	
		    push @{$self->{'_errormsg'}}, $err;
		    print $err if $DEBUG;
		    return 0;
		}
		$hash->{FIELDS}->{$attr->{name}}->{DATA_TYPE} = $attr->{dtype};
	    } else {
		    my $class = $self->{'_curclass'};
		    my $err = "You must define a value for DTYPE".
		        "in ATTRIBUTE tag $attr->{name} ".
		        "in definition of class $class";	
		    push @{$self->{'_errormsg'}}, $err;
		    print $err if $DEBUG;
		    return 0;
	    }
	    # To specify for attribute
	    $hash->{FIELDS}->{$attr->{name}}->{IS_ATTRIBUTE} = 1;     
	}

	if ( $tag eq "relationship" ){
	    if ( exists $attr->{dest} ){
		unless ( defined $attr->{dest} ){
		    my $class = $self->{'_curclass'};
		    my $err = "You must define a value for DEST".
		        "in ATTRIBUTE tag $attr->{name} ".
		        "in definition of class $class";	
		    push @{$self->{'_errormsg'}}, $err;
		    print $err if $DEBUG;
		    return 0;
		}
		$hash->{FIELDS}->{$attr->{name}}->{DEST} = $attr->{dest};
	    } else {
		    my $class = $self->{'_curclass'};
		    my $err = "You must define a value for DEST".
		        "in ATTRIBUTE tag $attr->{name} ".
		        "in definition of class $class";	
		    push @{$self->{'_errormsg'}}, $err;
		    print $err if $DEBUG;
		    return 0;
            }
	    # To specify for relationship
	    $hash->{FIELDS}->{$attr->{name}}->{IS_ATTRIBUTE} = 0;
	}

	if (exists $attr->{req}){
	    $hash->{FIELDS}->{$attr->{name}}->{IS_REQUIRED} = 1;
	} else {
	    $hash->{FIELDS}->{$attr->{name}}->{IS_REQUIRED} = 0;
	}
	if (exists $attr->{mult}){
	    $hash->{FIELDS}->{$attr->{name}}->{IS_MULTIPLE} = 1;
	} else {
	    $hash->{FIELDS}->{$attr->{name}}->{IS_MULTIPLE} = 0;
	}
	if (exists $attr->{noshow}){
	    $hash->{FIELDS}->{$attr->{name}}->{IS_SHOW} = 0;
	} else {
	    $hash->{FIELDS}->{$attr->{name}}->{IS_SHOW} = 1;
	}
	if (exists $attr->{alt}){
	    unless (defined $attr->{alt}){
		my $class = $self->{'_curclass'};
		my $err = "You must define a value for ALT".
		    "in ATTRIBUTE tag $attr->{name} ".
		    "in definition of class $class";	
		push @{$self->{'_errormsg'}}, $err;
		print $err if $DEBUG;
		return 0;
	    }
	    $hash->{FIELDS}->{$attr->{name}}->{ALT} = $attr->{alt};
	}
    } else { 
	my $err = "Undefined start tag, $tag";
	if (defined $self->{'_curclass'}){
	    my $class = $self->{'_curclass'};
	    $err .= ", at definition of $class";
	} 
	if (defined $self->{'_curaorr'} && $self->{'_curaorr'}){
	    my $field = $self->{'_curaorr'};
	    $err .= " near $field";
	}
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    return 1;
}

sub end
{
    my($self, $tag) = @_;

    #print $tag if $DEBUG;
    if ( $tag ne "class" && $tag ne "attribute" && $tag ne "relationship"){
	my $err = "Undefined end tag, $tag";
	if (defined $self->{'_curclass'}){
	    my $class = $self->{'_curclass'};
	    $err .= " at definition of $class";
	} 
	if (defined $self->{'_curaorr'}){
	    my $field = $self->{'_curaorr'};
	    $err .= " near <b>$field</b>";
	}
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    if (_topofstack($self->{'_curtag'}) ne $tag){
	my $top = _topofstack($self->{'_curtag'});
	my $err = "Missing end tag, $tag";
	if (defined $self->{'_curclass'}){
	    my $class = $self->{'_curclass'};
	    $err .= ", at definition of class $class";
	} 
	if (defined $self->{'_curaorr'}){
	    my $field = $self->{'_curaorr'};
	    $err .= " near $field";
	}
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    pop @{$self->{'_curtag'}} ;
    $self->{'_curclass'} = '' if ($tag eq "class");
    $self->{'_curaorr'} = '' if ($tag eq "attribute" || 
			         $tag eq "relationship");
}

######################  ACCESS METHODS #######################

sub ErrorMsg {
    shift @{shift->{'_errormsg'}};
}
sub AsString {
    my $self = shift;
    "$self";
}

sub Classes {
    my $self = shift;
    return @{$self->{'_classlist'}} if (exists $self->{'_classlist'});
}
sub Fields {
    my ($self,$class) = @_;
    if (defined $class){
	if (exists $self->{'_hash'}{$class}){
	    return @{$self->{'_hash'}{$class}{FIELDSEQ}};
	}
	return ();
    }
    unless (defined $self->{'_hash'}{FIELDSEQ}){
	#die "Fields: $self";
	return ();
    }
    return @{$self->{'_hash'}{FIELDSEQ}};
}

sub Attributes {
    my ($self,$class) = @_;
    if (defined $class){
	if (exists $self->{'_hash'}{$class}){
	    return grep( 
		$self->{'_hash'}{$class}{FIELDS}{$_}{IS_ATTRIBUTE},
			@{$self->{'_hash'}{$class}{FIELDSEQ}} );
	}
	return '';
    }
    return grep( $self->{'_hash'}{FIELDS}{$_}{IS_ATTRIBUTE},
	@{$self->{'_hash'}{FIELDSEQ}} );
}

sub Relationships {
    my ($self,$class) = @_;
    if (defined $class){
	if (exists $self->{'_hash'}{$class}){
	    return grep( 
		!($self->{'_hash'}{$class}{FIELDS}{$_}{IS_ATTRIBUTE}),
			@{$self->{'_hash'}{$class}{FIELDSEQ}} );
	}
	return '';
    }
    return grep( !($self->{'_hash'}{FIELDS}{$_}{IS_ATTRIBUTE}),
	@{$self->{'_hash'}{FIELDSEQ}} );
}

sub IsFlag {
    my ($self,$flag,$field,$class) = @_;
    if (defined $class){
	if (exists $self->{'_hash'}{$class}){
	    if (exists $self->{'_hash'}{$class}{FIELDS}{$field}){
		return 
		    $self->{'_hash'}{$class}{FIELDS}{$field}{$flag};
	    }
	    return '';
	}
	return '';
    }
    return $self->{'_hash'}{FIELDS}{$field}{$flag};
}

sub IsRequired {
    my $self = shift;
    return $self->IsFlag("IS_REQUIRED",@_);
}

sub IsMultiple {
    my $self = shift;
    return $self->IsFlag("IS_MULTIPLE",@_);
}
sub IsShowable {
    my $self = shift;
    return $self->IsFlag("IS_SHOW",@_);
}
sub IsAttribute {
    my $self = shift;
    return $self->IsFlag("IS_ATTRIBUTE",@_);
}
sub IsRelationship {
    my $self = shift;
    # this prints the opposite
    return (1 + $self->IsFlag("IS_ATTRIBUTE",@_)) % 2;
}
sub DataType {
    my $self = shift;
    return $self->IsFlag("DATA_TYPE",@_);
}

sub Desc {
    my ($self,$arg1,$arg2) = @_;

    if ( !(defined $arg1) ){
	# we are an object with only one class description
	# so return description of the class
	return $self->{'_hash'}{DESC};
    } elsif ( !(defined $arg2) ){
	# we are an object with one or many class descriptions
	# and we don't know if arg1 is a field or a class
	if (exists $self->{'_hash'}{$arg1}){
	    # arg1 is a class, return its description
	    return $self->{'_hash'}{$arg1}{DESC};
	} else {
	    # arg1 is a field
	    return $self->{'_hash'}{FIELDS}{$arg1}{DESC};
	}
    } else {
	# we are an object with many classes
	# $arg1 is a class, $arg2 is a field
	return $self->{'_hash'}{$arg2}{FIELDS}{$arg1}{DESC};
    }
}

sub Alt {
    my ($self,$field,$class) = @_;
    if (defined $class
        && exists $self->{'_hash'}{$class}
        && exists $self->{'_hash'}{$class}{FIELDS}{$field}
        && exists $self->{'_hash'}{$class}{FIELDS}{$field}{ALT}
        && defined $self->{'_hash'}{$class}{FIELDS}{$field}{ALT}
        && ($self->{'_hash'}{$class}{FIELDS}{$field}{ALT} ne '') ){

        return $self->{'_hash'}{$class}{FIELDS}{$field}{ALT};

    } elsif (exists $self->{'_hash'}{FIELDS}{$field}
        && exists $self->{'_hash'}{FIELDS}{$field}{ALT}
        && defined $self->{'_hash'}{FIELDS}{$field}{ALT}
        && ($self->{'_hash'}{FIELDS}{$field}{ALT} ne '') ){

        return $self->{'_hash'}{FIELDS}{$field}{ALT};

    }
    return $field;
}

sub Destination {
    my $self = shift;
    return $self->IsFlag("DEST",@_);
}

sub AddEntries {
    my $self = shift;
    my %hash = @_;

    my $val;
    foreach $val ( $self->Fields() ){
	if (exists $hash{$val} ){
	    $self->ForceAddEntry($val,@{$hash{$val}});
	}
    }
}

sub AddEntry {
    my ($self, $field, @vals) = @_;

    # How many entries does $field have right now?
    my $num = $self->NumEntries($field);
    if ( $self->IsMultiple($field)  || ($num == 0 && scalar(@vals) == 1) ){
	push @{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}}, @vals;
	return 1;
    } else {
	return 0;
    }
}

sub ForceAddEntry {
    my ($self, $field, @vals) = @_;

    # How many entries does $field have right now?
    my $num = $self->NumEntries($field);
    if ( $self->IsMultiple($field)  || ($num == 0 && scalar(@vals) == 1) ){
        push @{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}}, @vals;
        return 2;
    } elsif ($num == 0) {
	push @{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}},
	     $vals[0];
	return 1;
    } else {
        return 0;
    }
}

sub ListEntries {
    my ($self, $field) = @_;

    return @{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}}
	if (exists $self->{'_hash'}{FIELDS}{$field});
    return ();
}

sub ListEntriesAsHtml {
    my ($self, $field) = @_;
    my ($buf,$val);

    if (exists $self->{'_hash'}{FIELDS}{$field}){
	$buf .= "<ul>\n";
	foreach $val 
	    (@{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}}){
	    $buf .= "<li>$val\n";
	}
	$buf .= "</ul>\n";	
	return $buf;
    }

    return '';
}

sub FirstEntry {
    my ($self, $field) = @_;

    return $self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}[0]
	if (defined $self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}[0]);
    return '';
}

sub FirstEntryAsHtml {
    my ($self, $field) = @_;

    if ($self->DataType($field) eq "url"){
	return "<a href=\"" . $self->FirstEntry($field) . "\">".
	    $self->FirstEntry($field) . "</a>";
    } elsif ($self->DataType($field) =~ /email/i) {
	return "<a href=\"mailto:" .  $self->FirstEntry($field) ."\">" .
	    $self->FirstEntry($field) . "</a>";
    } else {
	return $self->FirstEntry($field);
    }
}

sub ReplaceEntry {
    my ($self,$field,$old,$new) = @_;

    my $values = $self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString};
    my $i;
    foreach $i (0 .. $#$values ) {
	if ($values->[$i] eq $old){
	    $values->[$i] = $new;
	    return;
	}
    }
}

sub NumEntries {
    my ($self,$field) = @_;
    return scalar(@{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}});
}

sub NumRealEntries {
    my ($self,$field) = @_;
    return scalar(grep( !(/^\s+$/ || /^$/), 
	@{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}} ));
}

sub RemoveLastEntry {
    my ($self,$field) = @_;

    pop @{$self->{'_hash'}{FIELDS}{$field}{VALUES}{$self->AsString}};
}

sub IsConfiguredFor {
    my ($self,$class) = @_;
    
    if (defined $class){
	my $val;
	foreach $val (@{$self->{'_classlist'}}){
	    return 1 if ($val eq $class);
	}
	return 0;
    } else {
	return @{$self->{'_classlist'}};
    }
}

# Only call this method on objects returned from InstanceOf()
sub AsHtml {
    my ($self,$buf,$repo,$file,$cp,$nest) = @_;
    unless (defined $nest) {$nest = 0;}
    $$buf .= "\n<!--BEGIN_RIB_OBJECT-->\n";
    unless ($self->objectashtml($buf,$repo,$file,$cp,$nest)){
	return 0;
    }
    $$buf .= "\n<!--END_RIB_OBJECT-->\n";
    return 1;
}

sub objectashtml {
    my ($self,$buf,$repo,$file,$cp,$nest) = @_;

    my $riburl = RIB::Util->GetRibUrl;
    my $ribdir = RIB::Util->GetRibDir;
    #my $repo_name = RIB::Util->GetRepoName;

    if ($nest >= 50){
	my $err = 'RIB::ConfigParser->objectashtml: TOO MUCH RECURSION';
	push @{$self->{'_errormsg'}}, $err;
	return 0;
    }

    if ($self->IsConfiguredFor('Asset')){
	my $tmp = $self->FirstEntry('Name');
	$$buf .= '<h2>'. $self->FirstEntry('Name') . "</h2>\n";
    }
    
    $$buf .= "<dl>\n";
    my $field;
    foreach $field ( $self->Fields ){
	if ($self->IsShowable($field)){
	    if ($self->IsAttribute($field)){
		my $val;
		if ($self->NumRealEntries($field) > 1){
		    $val = $self->ListEntriesAsHtml($field);
		} elsif ($self->NumRealEntries($field) == 1){
		    $val = $self->FirstEntryAsHtml($field);
		} else {
		    next;
		}
		$$buf .= '<dt><strong>'. $self->Alt($field) ."</strong>\n";
		$$buf .= "<dd>$val\n";
	    } else {
	    # $field is a relationship
		my $val;
		if ($self->NumRealEntries($field) >= 1){
		    my ($bp, $entry, $oname,$dest);
		    foreach $entry ($self->ListEntries($field)){
			$dest = $self->Destination($field);
			$bp = RIB::BIDMParser->new();
			if ($entry =~ /^$riburl\/repositories\/$repo\//){
			    $entry =~ s|$riburl|file:$ribdir|;
			    $entry =~ /\/([^\/]+).html$/;
			    #$oname = "../$dest/$1.html"; # no longer a good idea since show_object.pl
                                                          # might be used to generated the html
                            $oname = "$riburl/repositories/$repo/catalog/$dest/$1.html";
			} else {
                            # this url will create the html for the foreign object dynamically
                            $oname = $riburl . "/cgi-bin/pub/show_object.pl?r=$repo&u=$entry";
			}
			if($bp->parse_url($entry)) {
			    my $ob = $cp->InstanceOf($entry,$dest,$bp);
			    if ($nest > 0){
				$ob->objectashtml(\$val,$repo,$file,$cp,$nest - 1);
			    } else {
				$val .= "<a href=\"$oname\">"
				. $ob->FirstEntry('Name') . "</a><br>\n";
			    }
			} else {
			    my $buf = 'HTTP Error: ' . $bp->error_msg;
			    print "\t$field contains a broken value!".
				" Reason:\n\t $buf\n\tThe value in the catalog".
				" will be empty.\n";
			}
			$bp = '';
		    }
		} else {
		    next;
		}
		$$buf .= '<dt><strong>' . $self->Alt($field) . "</strong>\n";
		$$buf .= "<dd>$val\n";
	    }
        }
    }
    $$buf .= "</dl>\n";
    if ($self->IsConfiguredFor('Asset')){
	$$buf .= "<br>Meta Data URL from which this entry was created:<br>\n";
	$$buf .= '<b>';
       	$$buf .= ($self->IsForeign) ? $self->IsForeign : 
		RIB::Util->GetRibUrl() . '/repositories/' .
		$repo . '/objects/Asset/' . $file . "</b>\n";
    }
    return 1;
}

sub IsForeign {
    my $self = shift;
    $self->{'_hash'}{FIELDS}{FOREIGN}{VALUES}{$self->AsString};
}
#######################  MISC METHODS #########################
sub print_config {
    my ($self,$buf) = @_;
    my $hash = $self->{'_hash'};

    my $val;
    foreach $val (keys %$hash){

	if (defined $buf){ $$buf .= qq(<class name="$val" ); } 
	else { print qq(<class name="$val" ); }
	    
	if (exists $hash->{$val}->{EXTENDS}){
	    my $buf = $hash->{$val}->{EXTENDS};
	    print qq(extends="$buf");
	}
	if (defined $buf){ $$buf .= ">\n"; }
	else { print ">\n"; }
	my $class = $hash->{$val};
	my $symbol;
	foreach $symbol ( @{$class->{FIELDSEQ}}){
	    my $field = $class->{FIELDS}->{$symbol};
	    my $end;
	    if ($field->{IS_ATTRIBUTE}){
		$end = "attribute";
		my $dtype = $field->{DATA_TYPE};
		if (defined $buf){ 
		    $$buf .= qq(  <attribute name="$symbol");
		    $$buf .= qq( dtype="$dtype");
		} else {
		    print qq(  <attribute name="$symbol");
		    print qq( dtype="$dtype");
		}
	    } else {
		$end = "relationship";
		my $dest = $field->{DEST};
		if (defined $buf){
		    $$buf .= qq(  <relationship name="$symbol");
		    $$buf .= qq( dest="$dest");
		} else {
		    print qq(  <relationship name="$symbol");
		    print qq( dest="$dest");
		}
	    }
	    if ($field->{IS_MULTIPLE}){
		if (defined $buf){ $$buf .= qq( mult); }
		else {print qq( mult);}
	    }
	    if ($field->{IS_REQUIRED}){
		if (defined $buf){ $$buf .= qq( req); }
		else {print qq( req);}
	    }
	    unless ($field->{IS_SHOW}){
		if (defined $buf){ $$buf .= qq( noshow); }
		else {print qq( noshow);}
	    }
	    if (defined $buf){ $$buf .= ">\n  </$end>\n"; }
	    else {print ">\n  </$end>\n";}
	}
	if (defined $buf){ $$buf .= "</class>\n"; }
	else {print "</class>\n";}
    }
}    

#################  PRIVATE METHODS  #####################

sub lookfor_hierarchy_faults {
    my $self = shift;
    my $classes = $self->{'_classlist'};
    my $hash = $self->{'_hash'};
    my $mat = $self->{'_matrix'};

    my $class;
    foreach $class (@$classes){
	if (exists $hash->{$class}->{EXTENDS}){
	    my $parentindex = $hash->{$hash->{$class}->{EXTENDS}}->{INDEX};
	    $mat->[$hash->{$class}->{INDEX}][$parentindex] = 1;
	}
    }
    _tc($mat);
    my @badclasses;
    my $i;
    foreach $i (0 .. $#$mat){
	if (defined $mat->[$i][$i]){
	    push @badclasses, $classes->[$i] ;
	}
    }
    if (defined @badclasses){
	my $buf = join(' ',@badclasses);
	my $err = "FAULTY CLASS HIERARCHY! ".
	    "The following classes are involved:".
	    "$buf. Please correct!";
	push @{$self->{'_errormsg'}}, $err;
	print $err if $DEBUG;
	return 0;
    }
    return 1;
}

sub flatten_hierarchy {
    my $self = shift;
    my $hash = $self->{'_hash'};
    my $class;

    foreach $class ( @{$self->{'_classlist'}} ){
	my $child = $hash->{$class};
	my $parent = $child;
	while (exists $parent->{EXTENDS}){
	    $parent = $hash->{$parent->{EXTENDS}};
	    my $symbol;
	    foreach $symbol ( @{$parent->{FIELDSEQ}} ){
		if ( !(exists $child->{FIELDS}->{$symbol}) ){
		    push @{$child->{FIELDSEQ}}, $symbol;
		    $child->{FIELDS}->{$symbol} = {};
		    _copy_field($child,$symbol,$parent);
		} elsif ( !(exists $child->{FIELDS}->{$symbol}->{DESC}) ){
		    $child->{FIELDS}->{$symbol}->{DESC} =
			$parent->{FIELDS}->{$symbol}->{DESC};
		}
	    }
	}
    }
}


sub _copy_field {
    my ($child,$field,$parent) = @_;
    $child->{FIELDS}{$field}{IS_REQUIRED} = $parent->{FIELDS}{$field}{IS_REQUIRED};
    $child->{FIELDS}{$field}{IS_MULTIPLE} = $parent->{FIELDS}{$field}{IS_MULTIPLE};
    $child->{FIELDS}{$field}{IS_ATTRIBUTE} = $parent->{FIELDS}{$field}{IS_ATTRIBUTE};
    $child->{FIELDS}{$field}{IS_SHOW} = $parent->{FIELDS}{$field}{IS_SHOW};
    $child->{FIELDS}{$field}{ALT} = $parent->{FIELDS}{$field}{ALT};
    $child->{FIELDS}{$field}{DESC} = $parent->{FIELDS}{$field}{DESC};
    if ($child->{FIELDS}{$field}{IS_ATTRIBUTE}){
	$child->{FIELDS}{$field}{DATA_TYPE} = 
	    $parent->{FIELDS}{$field}{DATA_TYPE};
    } else {
	$child->{FIELDS}{$field}{DEST} = $parent->{FIELDS}{$field}{DEST};
    }
}

sub _tc {
    my $am = shift;
    my $v = $#$am;
    my ($y,$x,$j);
    for $y (0 .. $v){
        for $x (0 .. $v){
            if (defined $am->[$x][$y]){
                for $j (0 .. $v){
                    $am->[$x][$j]  = 1 if (defined $am->[$y][$j]);
                }
            }
        }
    }
}

sub _isempty {
    my $array = shift;
    return 1 if ($#$array == -1);
    return 0;
}

sub _topofstack {
    my $array = shift;
    return $array->[$#$array];
}

sub _pretty {
    my $buf = shift;
    HTML::Entities::decode($buf);
    $buf =~ s/^[\n\t\r\f\b\0 ]+//o;
    $buf =~ s/[\n\r\t\f\b\0 ]+$//o;
    $buf =~ s/[\n\r\t\f\b\0 ]+/ /og;

    return $buf;
}

1;