package TKL::URLcheck;

## $Id: URLcheck.pm,v 1.6 2004/08/20 10:34:54 sondberg Exp $

use Data::Dumper;
use TKL;
use strict;
use vars qw(@ISA);

@ISA = qw(TKL);


sub find_schemas {
    my $self = shift;
    my $schema_dir = $self->{schema_dir};
    my $root = $self->find_portal_root();
    my $dir = "$root/$schema_dir";
    my $ret = {};

    return undef unless -d $dir;

    while (my $schema_file = <$dir/*$TKL::schema_suffix>) {
	$schema_file =~ /\/([^\/]*)$/;
	$ret->{$1} = $schema_file;
    }
    return $ret;
}


sub find_uri_elem {
    my ($self, $xsd_file) = @_;
    my $xsd_root = $self->document_element($xsd_file);

    $self->xsd_parse($xsd_root, my $elements = [], my $path = []);

    return $elements;
}


sub xsd_parse {
    my ($self, $node, $elements, $path) = @_;

    foreach my $kid ($node->childNodes()) {
	my $node_type = $kid->nodeType();
	if ($node_type == XML::LibXML::XML_ELEMENT_NODE) {
	    my $tag = $kid->nodeName();
	    my $ns_URI = $kid->getNamespaceURI();
	    next unless $ns_URI eq $TKL::schema_NS_URI;
	    my $prefix = $kid->getPrefix();
	    $tag =~ s/^$prefix://;
	    my $name = $kid->getAttribute("name");
	    if (($tag eq "element") || ($tag eq "attribute")) {
		if (defined($name) && length($name)) {
		    if ($tag eq "attribute") {
			$name = "\@$name";
		    }
		    my $ext_path = [@$path, $name];
		    my $type = $kid->getAttribute("type");
		    #print "TAG='$tag', TYPE='$type', NAME='$name'\n";
		    if (defined($type) && length($type)) {
			if ($type eq $TKL::uri_element_type) {
			    push @$elements, $ext_path;
			}
		    } else {
			$self->xsd_parse($kid, $elements, $ext_path);
		    }
		}
	    } elsif ($tag eq "sequence") {
		$self->xsd_parse($kid, $elements, $path);
	    } elsif ($tag eq "complexType") {
		$self->xsd_parse($kid, $elements, $path);
	    } elsif ($tag eq "simpleType") {
		$self->xsd_parse($kid, $elements, $path);
	    } elsif ($tag eq "restriction") {
		if (my $base = $kid->getAttribute("base")) {
		    if ($base eq $TKL::uri_element_type) {
			push @$elements, $path;
		    }
		} else {
		    warn "$0 - xsd_parse: xs:restriction without base attribute";
		}
	    } elsif ($tag eq "annotation") {
	    } elsif ($tag eq "choice") {
		$self->xsd_parse($kid, $elements, $path);
	    } elsif ($tag eq "simpleContent") {
		## This type of XML structure should be supported as well...
	    } else {
		warn "$0 - xsd_parse: Schema element '$tag' currently not supported by parser";
	    }
	}
    }
}


sub find_urls {
    my ($self, $dir, $elements, $xsd, $records) = @_;
    my $browse = $self->browse($dir);
    my $dirs = $browse->{dirs};
    my $files = $browse->{files};

    foreach my $sub_dir (@$dirs) {
	$self->find_urls("$dir/$sub_dir", $elements, $xsd, $records);
    }
    
    foreach my $tkl (@$files) {
	my $root = $tkl->document_element;

        if ( !$root ) {
            next;
        }
        
	next unless $xsd eq $tkl->extract_schema();
	my $latest_modifier = $root->getAttribute('modifier') || $root->getAttribute('creator');
	foreach my $xpath (@$elements) {
	    my @nodes = $root->findnodes("/" . join("/", @$xpath));
	    foreach my $url_node (@nodes) {
		$latest_modifier = "" unless defined($latest_modifier);
		push @$records, { URL      => $url_node->firstChild->nodeValue,
                                  FILENAME => $tkl->filename,
                                  USER     => $latest_modifier };
	    }
	}
    }
}

1;


__END__

=head1 NAME

TKL::URLcheck - Perl package with auxiliary methods for a URL checker.

=head1 SYNOPSIS

  use TKL::URLcheck;

  my $tkl = new TKL::URLcheck();

=head1 DESCRIPTION

=head1 AUTHOR

Anders Sønderberg Mortensen <sondberg@indexdata.dk>
Indexdata
2003/06/12

=head1 SEE-ALSO

perl(1).

=cut