package PLP;

# Not to be used without the CGI script;

our $VERSION = '3.05';

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

=head1 PLP

None of the functions in this module should be called by PLP scripts.

Functions:

=over 10

=item sendheaders

Sends the headers waiting in %PLP::Script::header

=item source

Given a filename and optional level (level should be C<0> if it isn't called
by C<source> itself), and optional linespec (used by C<PLP::Functions::Include>),
parses a PLP file and returns Perl code, ready to be eval'ed.

=item error

Given a description OR number, returns a piece of HTML, OR prints error headers.

=item start

Inits everything, reads the first file, sets environment.

=cut

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) {
	return undef unless $PLP::DEBUG & 1;
	my $plain = $error;
	(my $html = $plain) =~ s/([<&>])/'&#' . ord($1) . ';'/ge;
	PLP::sendheaders unless $PLP::sentheaders;
	$PLP::ERROR->($plain, $html);
    } 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>";
    }
}

sub _default_error {
    my ($plain, $html) = @_; 
    print qq{<table border=1 class="PLPerror"><tr><td>},
	  qq{<span><b>Debug information:</b><BR>$html</td></tr></table>};
}

sub start {
    my $file = $ENV{PATH_TRANSLATED};
    $ENV{PLP_NAME} = $ENV{PATH_INFO};
    my $path_info;
    while (not -f $file) {
        if (not $file =~ s/(\/+[^\/]*)$//) {
	    print STDERR "PLP: Not found: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";

	    if (exists $ENV{MOD_PERL}) {
		Apache->request->uri($ENV{REQUEST_URI});
		print STDOUT "Status: 404 Not Found";
		Apache::exit();
	    } else {
		PLP::error(undef, 404);
		exit;
	    }
	}
	my $pi = $1;
	$ENV{PLP_NAME} =~ s/\Q$pi\E$//;
	$path_info = $pi . $path_info;
    }
    
    if (exists $ENV{MOD_PERL}) {
	Apache->request->uri($ENV{REQUEST_URI});
    }

    if (not -r $file) {
	print STDERR "PLP: Can't read: $ENV{PATH_TRANSLATED} ($ENV{REQUEST_URI})\n";
	if (exists $ENV{MOD_PERL}) {
	    print STDOUT "Status: 403 Forbidden";
	    Apache::exit();
	} else {
	    PLP::error(undef, 403);
	    exit;
	}
    }

    delete @ENV{
	qw(PATH_TRANSLATED SCRIPT_NAME SCRIPT_FILENAME PATH_INFO),
        grep { /^REDIRECT_/ } keys %ENV
    };

    $ENV{PATH_INFO} = $path_info if defined $path_info;
    $ENV{PLP_FILENAME} = $file;
    (my $dir = $file) =~ s{/[^/]+$}[];
    chdir $dir;

    $PLP::code = PLP::source($file, 0);

    tie *PLPOUT, 'PLP::Tie::Print';
    select PLPOUT;
    $PLP::ERROR = \&_default_error;
}

1;

