package PLP;

# Not to be used without the CGI script;

our $VERSION = '3.01';

use PLP::Functions ();
use PLP::Fields;
use PLP::Tie::Headers;
use PLP::Tie::Delay;
use PLP::Tie::Print;

sub SendHeaders () {
    our $sentheaders = 1;
    print STDOUT "Content-Type: text/plain\n\n" if $DEBUG & 2;
    print STDOUT map("$_: $PLP::Script::header{$_}\n", keys %PLP::Script::header), "\n";
};

sub source {
    my ($path, $level, $linespec) = @_;
    $level = 0 if not defined $level;
    $linespec = '1' if not defined $linespec;
    our ($inA, $inB);
    (my $file = $path) =~ s[.*/][];
    my $source = $level
	? qq/\cQ;\n#line 1 "$file"\nprint q\cQ/
	: qq/\n#line 1 "$file"\nprint q\cQ/;
    my $linenr = 0;
    local *SOURCE;
    open SOURCE, $path or return $level
	? qq{\cQ; die qq[Can't open "\Q$path\E" (\Q$!\E)]; print q\cQ}
	: qq{\n#line $linespec\ndie qq[Can't open "\Q$path\E" (\Q$!\E)];};
    LINE: while (defined (my $line = <SOURCE>)) {
	$linenr++;
	for (;;) {
	    $line =~ /
		\G                  # Begin where left off
		( \z                # End
		| <:=? | :>         # PLP tags     <:=? ... :>
		| <\(.*?\)>         # Include tags <(...)>
		| <[^:(][^<:]*      # Normal text
		| :[^>][^<:]*       # Normal text
		| [^<:]*            # Normal text
		)
	    /gxs;
	    next LINE unless length $1;
	    my $part = $1;
	    if ($part eq '<:=' and not $inA || $inB) {
		$inA = 1;
		$source .= "\cQ, ";
	    } elsif ($part eq '<:' and not $inA || $inB) {
		$inB = 1;
		$source .= "\cQ; ";
	    } elsif ($part eq ':>' and $inA) {
		$inA = 0;
		$source .= ", q\cQ";
	    } elsif ($part eq ':>' and $inB) {
		$inB = 0;
		$source .= "; print q\cQ";
	    } elsif ($part =~ /^<\((.*?)\)>\z/ and not $inA || $inB) {
		$source .= source($1, $level + 1) .
			   qq/\cQ, \n#line $linenr "$file"\nq\cQ/;
	    } else {
		$part =~ s/\\/\\\\/ if not $inA || $inB;
		$source .= $part;
	    }
	}
    }
    $source .= "\cQ" unless $level;
    return $source;
}

sub error {
    my ($error, $type) = @_;
    if (not defined $type or $type < 100) {
	PLP::sendheaders unless $PLP::sentheaders;
	$error =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
	print qq{<table border=1 class="PLPerror"><tr><td>},
	      qq{<span><b>Debug information:</b><BR>$error</td></tr></table>};
    } else {
	select STDOUT;
	my ($short, $long) = @{ +{
	    404 => [ 'Not Found', "The requested URL $ENV{REQUEST_URI} was not found on this server." ],
	    403 => [ 'Forbidden', "You don't have permission to access $ENV{REQUEST_URI} on this server." ],
	}->{$type} };
	print "Status: $type\nContent-Type: text/html\n\n",
	      qq{<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n},
	      "<html><head>\n<title>--$type $short</title>\n</head></body>\n",
	      "<h1>$short</h1>\n$long<p>\n<hr>\n$ENV{SERVER_SIGNATURE}</body></html>";
    }
}

1;

