#Copyright Massachusetts Institute of technology, 1998.
#Written by Eric Prud'hommeaux for the World Wide Web Consortium

# $Id: InputSource.pm,v 1.50 2007-08-16 16:07:04 eric Exp $

use strict;
require Exporter;
require AutoLoader;

$W3C::XML::InputSource::REVISION = '$Id: InputSource.pm,v 1.50 2007-08-16 16:07:04 eric Exp $ ';

package W3C::XML::InputSource;
use W3C::Util::Exception;
use vars qw($VERSION $DSLI @ISA @EXPORT @EXPORT_OK @TODO);
@ISA = qw(Exporter AutoLoader);
@EXPORT = qw();
@EXPORT_OK = qw();
$VERSION = 0.97;
$DSLI = 'adpO';
@TODO = ('this is radically different than the java equivilent. Not only is it not done, 
there are design conflicts between the Java and the Perl versions.');

#####
# per-class data

my $Debugging = 0;	# whether to show debugging stuff
my $Outstanding = 0;	# count of outstanding connections

#####
# per-object data
# ATTIBUTES	- array of all the collected attributes
# DEBUG		- per-object control of debugging info

#####
# new - prepare a W3C::XML::InputSource with a new connection
#
# initializer - where to get data for byte stream
#	string - filename where XML is stored
#	SCALAR - ref to actual text of XML
#	ARRAY - array of strings of XML
#	HASH - dies - what could be done here?

sub new {
    my ($proto, $initializer) = @_;
    my $class = ref($proto) || $proto;
    my $self  = {};
    $self->{DEBUG} = 0;
    # "private" data
    $self->{"_OUTSTANDING"} = \$Outstanding;
    if (ref $initializer eq 'SCALAR') {
	$self->{BYTESTREAM} = $$initializer;
    } elsif(ref $initializer eq 'ARRAY') {
	$self->{BYTESTREAM} = join('', @$initializer);
    } elsif(ref $initializer eq 'HASH') {
	&throw(new W3C::Util::NotImplementedException(-message => "Can't initialize an W3C::XML::InputSource from a hash.", 
						      -class => 'W3C::XML::InputSource', -method => 'new'));
    } else {
	local *HANDLE;
	my $openedHandle = 0;
	if($main::{$initializer}) {
	    *HANDLE = $main::{$initializer};
	} else {
	    open(HANDLE, $initializer) || &throw(new W3C::Util::FileNotFoundException(-filename => $initializer));
	    $openedHandle = 1;
	}
	my $oldRS = $/;
	undef $/;
	$/ = $oldRS;
	my $toy = <HANDLE>;
	# @@@ there's probably a better way, but I'm sleepy
	my @tmp = <HANDLE>;
	$self->{BYTESTREAM} = join('', @tmp);
	close (HANDLE) if ($openedHandle);
    }
    ($self->{ContentType}, $self->{Charset}) = (undef, undef);
    bless ($self, $class);
    ++ ${ $self->{"_OUTSTANDING"} };
    return $self;
}

sub guessContentType {
    my ($self) = @_;
    my %fileExtensions = ('ttl' => 'application/turtle', 
			  'n3' => 'application/n3', 
			  'srx' => 'application/sparql-results+xml', 
			  'rdf' => 'application/rdf+xml');
    my $extensionsPattern = join ('|', keys %fileExtensions);
    if ($self->{PUBLICID} =~ m/^file:.*?\.($extensionsPattern)$/) {
	return $fileExtensions{$1};
    } elsif ($self->{BYTESTREAM} =~ m/^\s*</s) {
	my $ext = $self->{BYTESTREAM} =~ m{http://www.w3.org/2005/sparql-results#} ? 'srx' : 'rdf';
	return $fileExtensions{$ext};
    } elsif ($self->{BYTESTREAM} =~ m/^\s*@/m) {
	return $fileExtensions{'ttl'};
    } else {
	return $fileExtensions{'n3'};
    }
}

sub getContentType {
    my ($self) = @_;
    return $self->{ContentType};
}

#####
# setSytemId - 

sub setPublicId {
    my $self = shift;
    $self->{PUBLICID} = shift;
}

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

#####
# setSytemId - 

sub setSystemId {
    my $self = shift;
    $self->{SYSTEMID} = shift;
}

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

#####
# setSytemId - 

sub setByteStream {
    my $self = shift;
    $self->{BYTESTREAM} = shift;
}

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

#####
# setSytemId - 

sub setEncoding {
    my $self = shift;
    $self->{ENCODING} = shift;
}

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

#####
# setSytemId - 

sub setCharacterStream {
    my $self = shift;
    $self->{CHARACTERSTREAM} = shift;
}

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

#####
# debug - cannonical debugging stuff from
# http://www.perl.com/CPAN-local/doc/manual/html/pod/perltoot/Debuging_Methods.html

sub debug {
    my $self = shift;
    warn "usage: thing->debug(level)"    unless @_ == 1;
    my $level = shift;
    if (ref($self))  {
	$self->{"_DEBUG"} = $level;         # just myself
    } else {
	$Debugging        = $level;         # whole class
    }
}

#####
# DESTROY - hook to display debugging info

sub DESTROY {
    my $self = shift;
    if ($Debugging || $self->{"_DEBUG"}) {
	warn "W3C::XML::InputSource destroying $self " . $self->name;
    }
    -- ${ $self->{"_OUTSTANDING"} };
}

package W3C::XML::FileInputSource;
@W3C::XML::FileInputSource::ISA = ('W3C::XML::InputSource');
use W3C::Util::Exception;
use URI;

sub new {
    my ($proto, $source, $parms) = @_;
    my @lines;
    my $publicId;
    if ($source eq '-') {
	@lines = <STDIN>;
	$publicId = join ('', @lines);
	$publicId=~s/([^a-zA-Z0-9_.-])/uc sprintf("%%%02x",ord($1))/eg;
	$publicId = 'data:'.$publicId;
    } else {
	open(SOURCE, '+<', $source) || &throw(new W3C::Util::FileNotFoundException(-filename => $source));
	@lines = <SOURCE>;
	close(SOURCE);
	$publicId = &localFileUrl($source, $parms->{'host'});
    }

    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(\@lines, $parms);
    $self->{SOURCE} = $source;
    $self->setPublicId($publicId);
    $self->{Charset} = undef;
    return $self;
}

sub setByteStream {
    my ($self, $bytes) = @_;
    $self->SUPER::setByteStream($bytes);
    my $source = $self->{SOURCE};
    if ($source eq '-') {
	print $bytes;
    } else {
	open(SOURCE, '>', $source) || &throw(new W3C::Util::FileNotFoundException(-filename => $source));
	print SOURCE $bytes;
	close(SOURCE);
    }
}

sub localFileUrl { # static
    my ($source, $hostname) = @_;
    eval {
	require Sys::Hostname;
	$hostname ||= &Sys::Hostname::hostname;
    }; if ($@) {
	$hostname = 'localhost';
    }
    if ($source =~ m/^\//) {
	$source =~ s/\\/\//g;
	$source = '//'.$hostname.$source;
    } elsif ($^O eq 'MSWin32' && $source =~ m/^([A-Z])\:(.*)$/) {
	my ($drive, $path) = ($1, $2);
	$path =~ s/\\/\//g;
	$source = '//'.$hostname.'/'.$drive.'%3A'.$path;
    } else {
	my $cwd = '/';
	eval {
	    use Cwd;
	    $cwd = &getcwd;
	    chomp $cwd;
	    if ($^O eq 'MSWin32' && $cwd =~ m/^([A-Z])\:(.*)$/) {
		$cwd = '/'.$1.'%3A'.$2;
	    }
	};
	$source =~ s/\\/\//g;
	$source = '//'.$hostname.$cwd.'/'.$source;
    }
    while ($source =~ s/\/[^\/]+\/\.\.//) {}
    while ($source =~ s/\/\.\//\//) {}
    return 'file:'.$source;
}

package W3C::XML::URIInputSource;
@W3C::XML::URIInputSource::ISA = ('W3C::XML::InputSource', 'Exporter');
use vars qw(@EXPORT $PROMPT_CREDENTIAL $ACCEPT);
@EXPORT = qw($PROMPT_CREDENTIAL);
$PROMPT_CREDENTIAL = \ "prompt credential scalar ref";
$ACCEPT = 'application/rdf+xml, application/turtle, text/xml;q=0.2, application/xml;q=0.2, text/plain;q=0.1, */*;q=0.1';

use W3C::Util::Exception;

sub new {
    my ($proto, $source, $parms) = @_;
    my ($content, $contentType);
    my $host = new URI($source)->host();
    if ($host =~ m/(\.(test|example|invalid|localhost)|example\.(com|net|org))$/) {
	$content = '';
	$contentType = 'http://www.rfc-editor.org/rfc/rfc2606.txt';
    } else {
	eval {
	    require LWP::UserAgent;
	    require HTTP::Headers;
	    require HTTP::Request;
	}; if ($@) {
	    &throw(new W3C::Util::LibraryNotFoundException(-filename => 'LWP::UserAgent'));
	}
	my $useragent = new LWP::UserAgent;
	my $headers = new HTTP::Headers(Accept => $ACCEPT); # Guessing just gets you 406s.
	my $request = new HTTP::Request(GET => $source, $headers);
	if ($parms && $parms->{'user'}) {
	    &promptUserPassword($request, $parms->{'user'}, $parms->{'password'}, 'Basic', undef);
	}
	my $result = $useragent->request($request);
	while ($result->code == 401) {
	    my $type = undef;
	    my $parms = {};
	    if (my $tmp = $result->header('www-authenticate')) {
		my @parms;
		($type, @parms) = split(/ /, $tmp);
		$parms = {map {split(/=/)} @parms};
	    }
	    &promptUserPassword($request, $PROMPT_CREDENTIAL, $PROMPT_CREDENTIAL, $type, $parms);
	    $result = $useragent->request($request);
	}
	if (!$result->is_success) {
	    if ($result->code == 404) {
		&throw(new W3C::Util::NoSuchResourceException(-uri => $result->base));
	    } else {
		&throw(new W3C::Util::Exception(-message => $result->base.' got '.$result->code.' '.$result->message));
	    }
	}
	$content = $result->content;
	$contentType = $result->content_type;
    }
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(\ $content);
    $self->{SOURCE} = $source;
    $self->setPublicId($source);
    ($self->{ContentType}, $self->{Charset}) = $contentType;
    return $self;
}

sub setByteStream {
    my ($self, $bytes, $parms) = @_;
    # Cheesy hack for implementation defficiency in the HTTP libraries.
    # error message: "Library does not allow method PUT for 'file:' URLs"
    my $outUrl = URI::new('URI', $self->{SOURCE});
    if ($outUrl->scheme eq 'file') {
	# illegal polymorphic downcast and an early return to boot
	my $source = $self->{SOURCE};
	$self->{SOURCE} = $outUrl->file;
	my $ret = &W3C::XML::FileInputSource::setByteStream($self, $bytes);
	$self->{SOURCE} = $source;
	return $ret;
    }
    # Non-file: URIs continue down here:
    $self->SUPER::setByteStream($bytes);
    my $source = $self->{SOURCE};
    my $useragent = new LWP::UserAgent;
    my $headers = new HTTP::Headers(Accept => 'text/xml');
    my $request = new HTTP::Request(PUT => $source, $headers, $bytes);
    if ($parms && $parms->{'user'}) {
	&promptUserPassword($request, $parms->{'user'}, $parms->{'password'}, 'Basic', undef);
    }
    my $result = $useragent->request($request);
    while ($result->code == 401) {
	my $type = undef;
	my $parms = {};
	if (my $tmp = $result->header('www-authenticate')) {
	    my @parms;
	    ($type, @parms) = split(/ /, $tmp);
	    $parms = {map {split(/=/)} @parms};
	}
	&promptUserPassword($request, $PROMPT_CREDENTIAL, $PROMPT_CREDENTIAL, $type, $parms);
	$result = $useragent->request($request);
    }
    if (!$result->is_success) {
	if ($result->code == 404) {
	    &throw(new W3C::Util::NoSuchResourceException(-uri => $result->base));
	} else {
	    &throw(new W3C::Util::Exception(-message => $result->base.' got '.$result->code.' '.$result->message));
	}
    }
    $self->{LAST_REPLY} = $result->content;
}

sub getLastReply {$_[0]->{LAST_REPLY}}

sub promptUserPassword {
    my ($request, $user, $password, $type, $parms) = @_;
    my $term = undef;
    my $extraPrompt;
    if ($type =~ m/^basic$/i) {
	if ($parms->{'realm'}) {
	    $extraPrompt = " for realm $parms->{realm}";
	}
    } else {
	&throw(new W3C::Util::Exception(-message => "don't know how to handle auth type \"$type\""));
    }
    if ($user == $PROMPT_CREDENTIAL) {
	eval {
	    require Term::ReadLine;
	    $term = new Term::ReadLine('password prompt');
	}; if ($@) {
	    &throw(new W3C::Util::Exception(-message => 'Term::ReadLine and Term::ReadKey are needed for auth prompts'));
	}
	$user = $term->readline("HTTP username$extraPrompt: ");
    }
    if ($password == $PROMPT_CREDENTIAL) {
	eval {
	    if (!$term) {
		require Term::ReadLine;
		$term = new Term::ReadLine('password prompt');
	    }
	    require Term::ReadKey;
	}; if ($@) {
	    &throw(new W3C::Util::Exception(-message => 'Term::ReadLine and Term::ReadKey are needed for auth prompts'));
	}
      Term::ReadKey::ReadMode(2);
	$password = $term->readline("HTTP password$extraPrompt: ");
      Term::ReadKey::ReadMode(1);
	print "\n";
    }
    $request->authorization_basic($user, $password);
}

#####
# END - hook to display debugging info

sub END {
    if ($Debugging) {
	print "All InputSources are going away now.\n";
    }
}

1;

package W3C::XML::InputSource; # so make doesn't complain about the package

__END__

=head1 NAME

W3C::XML::InputSource.pm - input stream for SAX XML parsers

=head1 SYNOPSIS

  use W3C::XML::InputSource;
  my $inputSource = new W3C::XML::FileInputSource($source);
  eval {$xmlParser->parse($inputSource);};

=head1 DESCRIPTION

  This is a partial implementation of the Java SAX InputSource. It stores the
  data stream in a scalar, emulating either a ByteStream or a CharacterStream,
  I'm not sure which.

=head2 SAX use:

  use W3C::XML::XmlParser;
  use W3C::XML::VerboseXmlHandler;
  use W3C::XML::InputSource;
  use W3C::XML::XmlElementTree;
  my $xmlParser = new W3C::XML::PerlXmlParser;
  my $verboseHandler = new W3C::XML::VerboseXmlHandler;
  my $treeHandler = new W3C::XML::XmlElementTree;

  my $handlerList = new W3C::XML::HandlerList([$treeHandler, $verboseHandler], [$verboseHandler]);

  # set the W3C::XML::HandlerList be the document handler and the error handler
  $xmlParser->setDocumentHandler($handler);
  $xmlParser->setErrorHandler($handler);

  # assign a URI to the XML in InputSorce and parse it
  my $inputSource = new W3C::XML::FileInputSource($source);
  eval {$xmlParser->parse($inputSource);};

This module is part of the W3C::XML CPAN module.

=head1 AUTHOR

Eric Prud\'hommeaux <eric@w3.org>

=head1 SEE ALSO

perl(1).

=cut
