# 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.
#
# $Id: DomainParser.pm,v 1.2 1997/12/18 18:06:50 rib Exp $
#
# $Log: DomainParser.pm,v $
# Revision 1.2  1997/12/18 18:06:50  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  1997/05/06 19:02:19  jhorner
# Initial revision
#
package RIB::DomainParser;

require HTML::Parser;
@ISA = qw(HTML::Parser);

use HTML::Entities ();
use Data::Dumper ();

use strict;
use vars qw( $VERSION $DEBUG $DONE );
#$DEBUG = 1;
$DONE = 0;
$VERSION = 0.9;

sub new {
    my $class = shift;
    my $self = bless HTML::Parser->new,$class;
    $self->{hash} = {};
    $self->{curref} = []; # stack of references to the hash
    $self->{curkey} = ''; # current key of the current reference
    $self->{tag} = ''; # current active tag
    $self->{LIST} = [];
    $self->{delim} = "!";
    $self->{'_errormsg'} = [];

    return $self;
}

sub parse {
    my $self = shift;
    eval { $self->SUPER::parse(@_) };
    if ($@) {
        print $@ if $DEBUG;
	$self->{'_buf'} = '';  # flush rest of buffer
	push @{$self->{'_errormsg'}}, "HTML::Parser::Parse Failed!";
	return '';
    }
    return 1;
}

sub ErrorMsg {
    shift @{shift->{'_errormsg'}};
}

sub parse_file {
    my ($self, $file) = @_;
    unless (open(F, $file)){
	push @{$self->{'_errormsg'}}, "Can't open $file: $!";
	return 0;
    }
    my $chunk = '';
    while(read(F, $chunk, 2048)) {
        unless ($self->parse($chunk)){
	    $self->parse(undef); #EOF
	    return 0;
	}
    }
    close(F);
    $self->parse(undef); #EOF
    return 1;
}

sub start {
    my($self,$tag) = @_;
    unless ($DONE) {
	if ($tag eq "ul"){
	    if ($#{$self->{curref}} == -1){
		push @{$$self{'curref'}},$$self{hash};
	    } else {
		print "START <$tag>\n" if $DEBUG;
		# Start of new subdomain
		my $list = peek(@$self{curref});
		print "$$list{$$self{'curkey'}}\n" if $DEBUG;

		# Assign a new anonymous hash to the current key of 
		# the current reference.
		#$$list{$$self{curkey}} = {};
		push @{$$self{'curref'}}, $list->{$$self{curkey}}->{SUB};
	    }
	    $self->{tag} = $tag;
	} elsif ($tag eq "li"){
	    print "START <$tag>\n" if $DEBUG;
	    $self->{tag} = $tag;
	}
    }
}

sub end {
    my ($self,$tag) = @_;
    unless ($DONE) {
	if ($tag eq "ul"){
	    print "END <$tag>\n" if $DEBUG;
	    $self->{tag} = $tag;
	    pop @{$$self{curref}};
	    if ($#{$self->{curref}} == -1){
		$DONE = 1;
		buildlist($self->{LIST},"",$self->{delim},$self->{hash});
	    }
	}
    }
}

sub buildlist {
    my ($array,$delim,$sep,$hash) = @_;
    my($key,$val,$buf);
    while ( ($key,$val) = each %$hash ) {
        if ($delim ne ""){;
            $buf = $delim.$sep.$key;
        } else {
            $buf = $key;
        }
        push(@$array,$buf);
        if ($val ne ""){
            &buildlist($array,$buf,$sep,$val->{SUB});
        }
    }
}

sub text {
    my ($self,$text) = @_;
    unless ($DONE) {

	if ($self->{tag} eq "ul"){
	    #do nothing
	} elsif ($self->{tag} eq "li") {
	    my $list = peek(@$self{curref});

	    print "TEXT <$text>\n" if $DEBUG;
	    # text becomes a list entry
	    my $buf = pretty($text);

	    # Assign a new anonymous hash to the current key of 
	    # the current reference.
	    $$list{$buf}  = { SUB => {}, ASSET => {}};
	    $$self{curkey} = $buf;
	}
    }
}

sub list {
    my $self = shift;
    return @{ $self->{LIST} };
}

sub domains {
    my $self = shift;
    return @{$self->{LIST}};
}

sub domain {
    my ($self,$fqrdn) = @_;
    my $hash = $self->{'hash'};
    while ($fqrdn ne ""){
	if ($fqrdn =~ /!/){
	    $fqrdn =~ s/^([^!]*)!//;
	    $hash = $hash->{$1}{SUB};
	} else {
	    $fqrdn =~ s/^(.*)$//;
	    $hash = $hash->{$1};
	}
    }
    return $hash;
}

sub AddDomain {
    my ($self,$fqrdn) = @_;
    my $hash = $self->{'hash'};

    while ($fqrdn ne ""){
        if ($fqrdn =~ /!/){
            $fqrdn =~ s/^(.*)!//;
	    if (exists $hash->{$1}){
		$hash = $hash->{$1}->{SUB};
	    } else {
		$hash->{$1} = { 'SUB' => {} , 'ASSET' => {} };
		$hash = $hash->{$1}->{SUB};
	    }
        } else {
            $fqrdn =~ s/^(.*)$//;
	    if (exists $hash->{$1}){
		$hash = $hash->{$1};
	    } else {
		$hash->{$1} = { 'SUB' => {} , 'ASSET' => {} };
		$hash = $hash->{$1}->{SUB};
	    }
        }
    }
}

sub AddDomains {
    my ($self,@fqrdn) = @_;
    my $domain;
    foreach $domain (@fqrdn){
	$self->AddDomain($domain);
    }
}

sub AssetsOfDomain {
    my ($self,$fqrdn) = @_;
    return $self->domain($fqrdn)->{ASSET};
}

sub SubsOfDomain {
    my ($self,$fqrdn) = @_;
    return $self->domain($fqrdn)->{SUB};
}

sub hash {
    my $self = shift;
    return $self->{hash};
}

sub DomainsAsHtml {
    my $self = shift;
    my $buf = '';
    $self->print_top(\$buf,$self->hash,1);
    $buf;
}

sub print_top {
    my ($self,$buf,$hash) = @_;

    $$buf .= "<ul>\n";
    my ($key,$val,$ubuf);
    foreach $key ( sort keys %$hash) {
	$$buf .= "<li> <a href=\"#";
	$val = HTML::Entities::encode($key);
	$ubuf = $val;
	$ubuf =~ s/\s+/_/g;
	$$buf .= "$ubuf\">$val</a>\n";

	if (scalar(keys %{$hash->{$key}->{SUB}}) > 0){
	    $self->print_top($buf,$hash->{$key}->{SUB});
	}
    }
    $$buf .= "</ul>";
}

sub DomainsWithAssetsAsHtml {
    my ($self,$cp) = @_;
    my $buf = '';
    $self->print_bottom(\$buf,$self->hash,$cp);
}

sub print_bottom {
    my ($self,$buf,$hash,$cp) = @_;

    $$buf .= "<dl>\n";
    my ($key,$val,$ubuf);
    foreach $key (sort keys %$hash){
	$$buf .= "\t<dt> <a name=\"";
	$val = HTML::Entities::encode($key);
	$ubuf = $val;
	$ubuf =~ s/\s+/_/g;
	$$buf .= "$ubuf\"><strong>$val</strong></a>\n";

	if (scalar(keys %{$hash->{$key}->{ASSET}}) > 0){
	    my $assets = $hash->{$key}->{ASSET};
	    foreach $key (sort {lc($$assets{$a}->FirstEntry("Name")) cmp lc($$assets{$b}->FirstEntry("Name"))} keys %$assets){
		my $bp = $$assets{$key};
		$$buf .= "\t<dd>";
		if ($bp->FirstEntry("Icon")){
		    $$buf .= "<img src=\"" . $bp->FirstEntry("Icon").
			"\">";
		}
		$$buf .= qq(<a href="Asset/$key">);
		$$buf .= $bp->FirstEntry("Name");
		$$buf .= "</a> ";
		$$buf .= $bp->FirstEntry("TitleLine");
		$$buf .= "\n";
	    }
	}
	if (scalar(keys %{$hash->{$key}->{SUB}}) > 0){
	    $$buf .= "\t<dd>";
	    $self->print_bottom($buf,$hash->{$key}->{SUB},$cp);
	}
	    
    }
    $$buf .= "</dl>\n";
}

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

sub pretty {
    my $buf = shift;
    HTML::Entities::decode($buf);
    $buf =~ s/^\s+//;
    $buf =~ s/\s+$//;
    $buf =~ s/\s+/ /g;
    return $buf;
}

1;