#!/usr/local/bin/perl -w
#
#   Copyright (c) 2002 World Wide Web Consortium, (Massachusetts
#   Institute of Technology, Institut National de Recherche en
#   Informatique et en Automatique, Keio University). All Rights
#   Reserved.  http://www.w3.org/Consortium/Legal/
#
#   Initially written by Sandro Hawke (sandro@w3.org)
#
#   $Id: List.pm,v 1.1 2002/05/30 17:43:03 sandro Exp $
#

#      ONLY THE DOCUMENTATION IS RIGHT HERE.  THE OTHER CODE
#      IS SOME OTHER CODE, LEFT AROUND AS AN EXAMPLE FOR NOW!!!


=head1 NAME

SemWeb::FirstRest -- encoding/decoding between Perl lists and first/rest lists

=head2 SYNOPSIS

    use SemWeb::FirstRest;

    SemWeb::FirstRest->encode($ident, @listOfIdentsOrStrings);
    my @List = SemWeb::FirstRest->decode($ident);

    ... but what about changing, and if it's already defined, and
        something more convenient like
            my $l = SemWeb::List->new($ident);
            $l->getElements()
              ->set
              ->isTerminated
              ->append ... ?

    ... and how to set the namespace to use?
    
=cut

package SemWeb::FirstRestList;

use strict;
use Carp;
use Data::Dumper;    # just for diagnostics

BEGIN {

    use Exporter   ();
    use vars       qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

    # set the version for version checking
    $VERSION     = 0.01;
    
    @ISA         = qw(Exporter);
    @EXPORT      = qw();
    %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
    
    # your exported package globals go here,
    # as well as any optionally exported functions
    @EXPORT_OK   = qw();
}
use vars      @EXPORT_OK;

# non-exported package globals go here
use vars      qw( );

# initialize package globals, first exported ones

# then the others (which are still accessible as $Some::Module::stuff)

# all file-scoped lexicals must be created before
# the functions below that use them.

# file-private lexicals go here

sub new {
    my $this = shift;
    my @args = (@_);
    my $class = ref($this) || $this;
    my $self = {};
    bless $self, $class;
    $self->initialize(@args);
    return $self;
}

1;
__END__

sub initialize {
    my $this = shift;
    my $arg = shift;

    @@@@
}

sub init_from_hash {
    my $this = shift;
    my $h = shift;

    while (my ($key, $value) =  each %$h) {
    }
}

sub init_from_string {
    my $this = shift;
    my $s = shift;

    $s = "#" unless defined $s;

    # this should be last in the table for other perl prefixes to work
    $this->add_prefix("", $s, "");
}

sub add_prefix {
    my $this = shift;
    my $perl_prefix = shift;
    my $rdf_prefix = shift;
    my $xml_prefix = shift;

    unshift @{$this->{prefix_table}}, { 
	perl_prefix=>$perl_prefix,
	xml_prefix=>$xml_prefix,
	rdf_prefix=>$rdf_prefix,
    }
}

sub add {
    my $this = shift;
    my $added = shift;

    $this->{top_level_objects}->{$added} = $added;
}

sub top_level_objects {
    my $this = shift;
    return values %{$this->{top_level_objects}};
}

sub ntriples_unescape {
    my $c = shift;

    # from http://www.w3.org/2001/sw/RDFCore/ntriples/#sec-string1
    return "\\", if $c eq "\\";
    return "\"", if $c eq "\"";
    return "\n", if $c eq "n";
    return "\r", if $c eq "r";
    return "\t", if $c eq "t";

    croak("bad backslash-escaped character '$c'");
}

sub get_object {
    my $this = shift;

    my $name = shift;
    my $bnodes = shift;

    # "literal"
    if ($name =~ m/^"(.*)"$/) {
	my $result = $1;
	$result=~ s/\\(.)/ntriples_unescape($1)/ge;
	return $result;
    }

    # _:bNode?
    if (defined $bnodes && $name =~ m/^_/) {
	if (exists $bnodes->{$name}) { return $bnodes->{$name}; }
	my $result = { };
	$result->{_raw}->{_cooked} = $result;
	bless $result->{_raw}, "RDF::Object";
	$bnodes->{$name} = $result;
	return $result;
    }

    # <rdfid>
    if ($name =~ m/^<(.*)>$/) {
	$name = $1;
    }

    if (exists $this->{rdfid}->{$name}) {
	return $this->{rdfid}->{$name}
    } else {
	my $result = { _rdf_identifier=>$name };
	$result->{_raw}->{_cooked} = $result;
	$result->{_raw}->{"<$uname>"}->{"<$name>"} = 1;   # BUG    1?
	bless $result->{_raw}, "RDF::Object";
	$this->{rdfid}->{$name} = $result;
	return $result;  
    }
}

sub split_rdf_name {
    my $in = shift;

    # make the second part as long as possible while still a Qname
    if ($in =~ m/(.*?)([a-zA-Z_][-a-zA-Z_0-9.]*)$/) {
	if ($1 eq "") { die("null namespace guessed from '$in'"); }
	return ($1, $2);
    }
    croak("Can't rdf/xml encode \"$in\" as a predicate\n.");
}

sub perl_name_from_rdf_name {
    my $this = shift;
    my $rdf_name = shift;

    foreach my $e (@{$this->{prefix_table}}) {
	my $rdf_prefix = $e->{rdf_prefix};
	my $len = length($rdf_prefix);
	#print STDERR "Is substr(\"$rdf_name\",0,$len) eq \"$rdf_prefix\"?\n";
	if (substr($rdf_name, 0, $len) eq $rdf_prefix) {
	    return $e->{perl_prefix} . substr($rdf_name, $len);
	}
    }
    
    # we could return undef, if we didn't want this stuff at all

    return "<" . $rdf_name . ">";
}

sub rdf_name_from_perl_name {
    my $this = shift;
    my $perl_name = shift;
    
    if ($perl_name =~ m/^<(.*)>$/) {
	return wantarray ? split_rdf_name($1) : $1;
    }

    foreach my $e (@{$this->{prefix_table}}) {
	my $perl_prefix = $e->{perl_prefix};
	my $len = length($perl_prefix);
	if (substr($perl_name, 0, $len) eq $perl_prefix) {
	    return wantarray ?
		   ($e->{rdf_prefix} , substr($perl_name, $len), $e->{xml_prefix})
            	 : ($e->{rdf_prefix} . substr($perl_name, $len))
	}
    }
    die();
}

sub load_file {
    my $this = shift;
    my $filename = shift;
    my $baseURI = shift || "file://$pwd/$filename";

    $this->{lastLoadBaseURI} = $baseURI;

    if ( ($baseURI || $filename) =~ m/.nt$/ ) {
	return load_ntriples($this, $filename, "file:".$filename, $baseURI);
    }

    if ( ($baseURI || $filename) =~ m/.n3$/ ) {
	return load_n3_file($this, $filename, $baseURI);
    }

    return load_rdfxml_file($this, $filename, $baseURI);
}

sub load_rdfxml_file {
    my $this = shift;
    my $filename = shift;
    my $baseURI = shift;

    my $pseudoBase = "file:$filename";

    #print "pseudoBase $pseudoBase realBase $baseURI\n";
    return $this->load_ntriples("rdfdump --scan --output=ntriples --quiet $pseudoBase |", $pseudoBase, $baseURI, "^rdfdump: ");
}

sub load_n3_file {
    my $this = shift;
    my $filename = shift;
    my $baseURI = shift;

    my $pseudoBase = "file:$filename";

    return $this->load_ntriples("cwm $pseudoBase --ntriples | tee /tmp/cwm.out |", $pseudoBase, $baseURI, "^\\S*\$");
}

sub cleanPrefix {
    my $in = shift;
    my $replaceThisUriPrefix = shift; 
    my $withThisUriPrefix = shift;
    my $out = $in;

    # print "Cleaning '$in' with '$replaceThisUriPrefix' -> '$withThisUriPrefix'\n";

    # this is just a raptor bug workaround
    if ($out =~ m/^\<genid(\d+)\>$/) {
	$out = "_:genid$1";
    }
    # this is just a raptor bug workaround
    if ($out =~ m/^<([^:]+)>$/) {
	$out="<$withThisUriPrefix#$1>";
    } else {
	$out =~ s/^<$replaceThisUriPrefix/<$withThisUriPrefix/;
    }
    # print "==> '$out'\n";
    return $out;
}

sub load_ntriples {
    my $this = shift;
    my $filename = shift;
    my $replaceThisUriPrefix = shift; 
    my $withThisUriPrefix = shift;
    my $ignoreable_line_pattern = shift;

    my $bnodes = {};
    my @result;
    my %in_result;

    open(F, $filename) or 
	die("can't read \"$filename\": $!");
    while (<F>) {
	next if $ignoreable_line_pattern && $_ =~ $ignoreable_line_pattern;
	s/^\s*//;
	next if m/^$/;
	next if m/^\s*\#/;
	my ($subj, $pred, $obj) = split(/\s+/, $_, 3);
	unless (defined $obj) {
	    print "Bad NTriples Line: $_\n";
	    next;
	}
	# accept bad n-triples, with """... newline ... """;
        if ($obj =~ s/\s*\"\"\"/\"/) {
	    #print "Incomplete OBJ <<<$obj>>>\n";
	    while ($obj !~ s/\"\"\"/\"/) {
		my $newline = <F>;
		#print "Adding ** $newline ** \n";
		$obj .= $newline;		
	    }
	}

	$obj =~ s/\s*\.\s*$//;

	# print "'$subj', '$pred', '$obj' ==> ";

	if (defined $withThisUriPrefix) {
	    $subj = cleanPrefix($subj, $replaceThisUriPrefix, $withThisUriPrefix);
	    $pred = cleanPrefix($pred, $replaceThisUriPrefix, $withThisUriPrefix);
	    $obj  = cleanPrefix($obj, $replaceThisUriPrefix, $withThisUriPrefix);
	}
	print "TRIPLE: '$subj', '$pred', '$obj'\n";
	if ($this->{triple_hook}) { 
	    if ($this->{triple_hook}->($subj, $pred, $obj)) {
		goto after_add;
	    }
	} 

	my $s = $this->get_object($subj, $bnodes);
	my $p = $this->get_object($pred, $bnodes);
	my $o = $this->get_object($obj,  $bnodes);

	# make a do-raw variable?   different library?
	if (1) {
	    if (ref($o)) {
		$s->{_raw}->{$pred}->{$obj} = $o->{_raw};
	    } else {
		$s->{_raw}->{$pred}->{$obj} = $o;
	    }
	}
	$this->{subjects}->{$s}=$s;
	
	# cooked
	my $pname = $p->{_rdf_identifier};
	if ($pname eq "<http://www.w3.org/1999/02/22-rdf-syntax-ns#type>") {
	    # BUG: assume there's only one rdf:type for the object
	    bless $s, $this->perl_name_from_rdf_name($o->{_rdf_identifier});
	} else {
	    $pname = $this->perl_name_from_rdf_name($pname);
	    if (exists $s->{$pname}) {
		if ( ! exists $s->{"@".$pname}) {
		    push @{$s->{"@".$pname}}, $s->{$pname};
		} 
		push @{$s->{"@".$pname}}, $o;
	    } else {
		$s->{$pname} = $o;
		# print STDERR "spo: $s $pname $o\n";
	    }
	}
	
	if (! $in_result{$s}) {
	    push @result, $s;
	    $in_result{$s} = 1;
	    $this->add($s);
	}

      after_add:
    }
    close(F);
    return @result;
}

sub load {
    my $this = shift;
    my $source = shift;

    $source =~ s/\#.*//;

    if ( ! ($source =~ /:/) ) { return $this->load_file($source); }

    # pretty kludgy

    my $tmp = "/tmp/rdf_pool_" . $$ . "_" . ($load_count++);
    my $auth = "";

    # hack since we can't do content negotiation properly!
    foreach my $suffix (".rdf", ".xml", "") {
	my $got_it;
	open(P, "wget $auth -O $tmp '$source$suffix' 2>&1 |") or die("running wget");
	while(<P>) {
	    if (/^HTTP request sent, awaiting response... 200/) { $got_it = 1; }
	    if (/^HTTP request sent, awaiting response... /) { 
		print STDERR "wget $source$suffix\n==> $_\n";
	    }
	}
	close(P);
	if ($got_it) { goto GOT_IT; }
    }
    croak("Can't obtain content from $source");

  GOT_IT:
    print STDERR "got data, $tmp\n";
    $this->load_file($tmp, $source);
    # unlink $tmp;
}

sub xquote {
   my $in = shift @_;
   $in =~ s/&/&amp;/g;
   $in =~ s/</&lt;/g;
   $in =~ s/>/&gt;/g;
   return $in;
}

sub xml_name_from_perl_name {
    my $this = shift;
    my $perl_name = shift;
    my $nameSpaces = shift;     # updated if a new namespace is used
    my $revNameSpaces = shift;  # updated if a new namespace is used

    my ($namespace, $localpart, $xml_prefix) = 
	$this->rdf_name_from_perl_name($perl_name);

    # print STDERR "PerlName='$perl_name' ==> rdfpre='$namespace'  localpart='$localpart' xmlpre='$xml_prefix'\n";

    if (exists $nameSpaces->{$namespace}) {
	$xml_prefix = $nameSpaces->{$namespace};
	if ($xml_prefix) {
	    return $xml_prefix . ":" . $localpart;
	} else {
	    return $localpart;
	}
    }

    if (! defined $xml_prefix) {
	# guess some prefix
	if ($namespace =~ m/^(.*?)([a-zA-Z_][-a-zA-Z_0-9.]*).?$/) {
	    $xml_prefix = $2;
	} else {
	    $xml_prefix = "ns";
	}
    }
    
    my $count = "";
    while (exists $revNameSpaces->{$xml_prefix . $count}) {
	$count++;
    }
    $xml_prefix = $xml_prefix . $count;
    $revNameSpaces->{$xml_prefix} = $namespace;
    $nameSpaces->{$namespace} = $xml_prefix;
    if ($xml_prefix) {
	return $xml_prefix . ":" . $localpart;
    } else {
	return $localpart;
    }
}

sub rdfxml_description {
    my $this = shift;
    my $obj = shift;
    my $ns = shift;
    my $rns = shift;
    my $done_map = shift;
    my $indent = shift || 0;
    my $result = "";

    my $class = ref $obj;
    print STDERR "$indent rdfxml_desc entered with $obj\n";

    if (! $class) {
	return $obj;
    }

    if ($done_map->{$obj}) { print STDERR "already been done!  don't call me!"; }

    my $type = $class;
    if ($class eq "HASH") {
	my $explicit_type = $obj->{_rdf_type};
	if ($explicit_type) {
	    if ($type && $explicit_type ne $type) {
		croak("object with contradictory types");
	    }
	    $type = $explicit_type;
	} else {
	    $type = undef;
	}
    } elsif ($class eq "ARRAY") {
	croak("arrays not handled at top level (@$obj)");
    } else {
	if (!$type) {
	    croak("can't serialize $class objects without more information.");
	}
    }

    my $id = $obj->{_rdf_identifier};
    unless ($id) { $id = "#obj" . $done_map->{__COUNT}++; }
    $done_map->{$obj} = $id; 

    my $prefix = " " x $indent;

    my $tag;
    if ($type) {
	$tag = $this->xml_name_from_perl_name($type, $ns, $rns);
    } else {
	$tag = "rdf:Description";
    }
    $result .= "$prefix<$tag rdf:about=\"" . xquote($id) . "\">\n";

    while (my ($key,$val) = each %$obj) {
	next if ($key eq "_rdf_type");
	next if ($key eq "_rdf_identifier");

	#print STDERR "key: $key\n";
	my $multivalued = 1;
	if ($key =~ m/^@(.*)/) {
	    $key = $1;
	    $multivalued = 1;
	}
	my $attr = $this->xml_name_from_perl_name($key, $ns, $rns);

	if ($done_map->{$val}) {
	    $result .= "$prefix  <$attr rdf:resource=\"" . $done_map->{$val} . "\" />\n";
	} else {
	    if (ref $val eq "ARRAY") {
		if ($multivalued) {
		    for my $v (@$val) {
			if (ref $v eq "ARRAY") { croak("can't handle nested arrays"); }
			if (ref $v) {
			    $result .= "$prefix  <$attr>\n";
			    $result .= $this->rdfxml_description($v, $ns, $rns, 
								 $done_map, $indent+4);
			    $result .= "$prefix  </$attr>\n";
			} else {
			    $result .= "$prefix  <$attr>" . xquote($v) . "</$attr>\n";
			}
		    }
		} else {
		    # encode it as an RDF list <li>
		    die("not implemented");
		}
	    } elsif (ref $val) {
		$result .= "$prefix  <$attr>\n";
		$result .= $this->rdfxml_description($val, $ns, $rns, 
						     $done_map, $indent+4);
		$result .= "$prefix  </$attr>\n";
	    } else {
		$result .= "$prefix  <$attr>" . xquote($val) . "</$attr>\n";
	    }
	}
    }
    
    $result .= "$prefix</$tag>\n";

    return $result;
}


sub as_rdfxml {
    my $this = shift;

    my $ns = { "http://www.w3.org/1999/02/22-rdf-syntax-ns#" => "rdf" };
    my $rns = { "rdf" => "http://www.w3.org/1999/02/22-rdf-syntax-ns#" }; 
    my $done_map = { };

    my $contents = "";
    
    foreach my $obj ($this->top_level_objects()) {
	$contents .= $this->rdfxml_description($obj, $ns, $rns, $done_map, 2)
	    unless $done_map->{$obj};
    }

    # print Dumper($ns);

    my $result = "<rdf:RDF ";
    my $def;
    while (my ($key,$val) = each %$ns) {    
	if ($val eq "") { $def = $key; next; }
	$result .= "xmlns:$val=\"$key\"\n         ";        
    }
    if ($def) {
	$result .= "xmlns=\"" . $def . "\"";
    }
    $result .= ">\n$contents</rdf:RDF>\n";
    return $result;
}

sub rdf_prefix_for_xml_prefix {
    my $this = shift;
    my $prefix = shift;

    foreach my $e (@{$this->{prefix_table}}) {
	return $e->{rdf_prefix}, if $e->{xml_prefix} && $e->{xml_prefix} eq $prefix;
    }
    return undef;
}

sub save_rdfxml_file {
    my $this = shift;
    my $filename = shift;
    my %options = (@_);

    use Fcntl ':flock'; # import LOCK_* constants

    if ($options{append}) {
	open(OUT, ">>", $filename) || croak("open $filename: $!");
    } else {
	open(OUT, ">", $filename) || croak("open $filename: $!");
    }

    if ($options{lock}) {
	flock OUT, LOCK_EX  || croak("flock $filename: $!");
	if ($options{append}) {
	    seek(OUT, 0, 2);  # reseek to the end, now that we have it locked
	}
    }

    print OUT $this->as_rdfxml();

    if ($options{lock}) {
	flock OUT, LOCK_UN;
    }
    close(OUT);
}

sub forEachTriple {
    my $this = shift;
    my $func = shift;

    # total hack implementation for now!

    my $tmp = "/tmp/pool.$$.rdf";
    print "Using tmp file for text: $tmp\n";
    print STDERR __LINE__ . "\n";;
    $this->save_rdfxml_file($tmp);
    print STDERR __LINE__ . "\n";;
    my $that = RDF::Pool->new();
    print STDERR __LINE__ . "\n";;
    $that->{triple_hook} = $func;
    print STDERR __LINE__ . "\n";;
    $that->load($tmp);
    print STDERR __LINE__ . "\n";;
    $that = undef;

    unlink $tmp;
}

sub elements {
    my $obj = shift;

    # should compare to _daml_nil, but rdfdump isn't giving us those!
    # so this is the closing version.....

    unless ($obj->isa('_daml_List')) {
	print Dumper($obj);
	die;
    }

    my @rest = ();
    if ($obj->{_daml_rest}) {
	@rest = elements($obj->{_daml_rest});
    }
    return ( $obj->{_daml_first}, @rest );
}

sub raw_elements {
    my $obj = shift;

    # should compare to _daml_nil, but rdfdump isn't giving us those!
    # so this is the closing version.....

    unless ($obj->hasType("${damlns}List")) {
	print Dumper($obj);
	die;
    }

    my @rest = ();
    if ($obj->{"<${damlns}rest>"}) {
	# print "looking for rest of " . keys(%{$obj->{"<$uname>"}}) . "\n";
	@rest = raw_elements($obj->getOnly("${damlns}rest"));
    }
    return ( $obj->getOnly("${damlns}first"), @rest );
}



package RDF::Object;

sub hasType {
    my $this = shift;
    my $type = shift;

    return ($this->{"<${rdfns}type>"}->{"<$type>"} || 0);
}

sub getOnly {
    my $this = shift;
    my $property = shift;

    my $values = $this->{"<$property>"};

    if ($values) {
	my @allValues = values(%$values);
	if (@allValues == 1) {
	    return $allValues[0];
	} else {
	    # too many
	    die "Property $property has " . scalar(@allValues) . " values, not one.";
	}
    } else {
	# too few
	die "Property $property has no values, not one.";
    }
}

sub getMaybeOne {
    my $this = shift;
    my $property = shift;

    my $values = $this->{"<$property>"};

    if ($values) {
	my @allValues = values(%$values);
	if (@allValues == 1) {
	    # print "RETURNING: $allValues[0]\n";
	    return $allValues[0];
	} else {
	    # too many
	    die "Property $property has " . scalar(@allValues) . " values, not one.";
	}
    } else {
	return undef;
    }
}

    


1;
