package Apache2::Layout;
use 5.008;

use Apache2::Filter      ();  # $f
use Apache2::RequestRec  ();  # $r
use Apache2::RequestUtil ();  # $r->dir_config()
use Apache2::RequestIO   ();
use Apache2::Connection  ();
use Apache2::SubRequest  ();  # $r->lookup_uri()
use Apache2::Log         ();  # $log->info()
use APR::Table           ();  # dir_config->get() and headers_out->get()
use APR::Bucket          ();
use APR::Brigade         ();
use APR::Const -compile => qw(SUCCESS);

use Apache2::Const -compile => qw(OK DECLINED);

use strict;
use warnings;

our $VERSION = '0.6';

use XSLoader;
XSLoader::load __PACKAGE__, $VERSION;

sub handler {
    my ($f, $bb) = @_;

    my $r = $f->r;

    my $log = $r->server->log;

    # we only process HTML documents
    unless ($r->content_type =~ m!text/html!i) {
        $log->debug('skipping request to ',
                    $r->uri, ' (not an HTML document)');
        return Apache2::Const::DECLINED;
    }

    unless ($r->is_initial_req) {
        $log->debug('skipping subrequest ', $r->uri);
        return Apache2::Const::DECLINED;
    }

    my $context = $f->ctx;

    unless ($context) {

        # these are things we only want to do once no matter how
        # many times our filter is invoked per request

        # prep the configuration
        #$context = {};
        if (my $debug = $r->dir_config->get('LayoutDebug')) {
            $context->{debug} = $debug if $debug;
        }

        if (my $comments = $r->dir_config->get('LayoutComments')) {
            $context->{comments} = $comments if $comments;
        }

        # Ordering is important here, we only match in the order
        # we are building up here. Insert in the right order is
        # paramount!
        my @tags;
        if (my $css = $r->dir_config->get('LayoutCSS')) {
            push @tags,
              {
                name    => 'end_head',
                url     => $css,
                pattern => '</\s*head[^>]*>',
                insert  => 'before',
              };
        }
        if (my $header = $r->dir_config->get('LayoutHeader')) {
            push @tags,
              {
                name    => 'start_body',
                url     => $header,
                pattern => '<\s*body[^>]*>',
                insert  => 'after',
              };
        }
        if (my $footer = $r->dir_config->get('LayoutFooter')) {
            push @tags,
              {
                name    => 'end_body',
                url     => $footer,
                pattern => '</\s*body[^>]*>',
                insert  => 'before',
              };
        }

        unless (@tags) {
            $log->debug('skipping request to ',
                        $r->uri, ' (HTML but no Layout configuration)');
            return Apache2::Const::DECLINED;
        }

        $context->{current_tag} = shift @tags;
        $context->{tags}        = \@tags;

        # output filters that alter content are responsible for removing
        # the Content-Length header, but we only need to do this once.
        $r->headers_out->unset('Content-Length');

        #XXX: At this point, we are seriously altering content, so we
        #XXX: might want to fiddle with outbound headers a bit more.
        #XXX: I am thinking about ETag, Last-Modified, Expires, Cache-Control
        #XXX: Similar problem than mod_includes, might be able to steal from
        #XXX: there.
    }

    my $tags = $context->{tags};

    my $bb_ctx = APR::Brigade->new($f->c->pool, $f->c->bucket_alloc);

    $context->{pass}++;
    while (!$bb->is_empty) {
        my $bucket = $bb->first;

        if ($bucket->is_eos) {
            if ($context->{debug} && $context->{matched}) {
		my $ver = __PACKAGE__ . " v$VERSION";
                my $msg =
                  "$ver matched $context->{matched} times out of $context->{tests} over $context->{reads} reads and $context->{pass} passes";
                if ($context->{comments}) {
                    $bb_ctx->insert_tail(
                                APR::Bucket->new(
                                    $bb_ctx->bucket_alloc, "<!-- $msg -->\n"
                                )
                    );
                }
                else {
                    my $uri = $r->uri;
                    $log->debug("[$uri] $msg");
                }
            }
            $bucket->remove;
            $bb_ctx->insert_tail($bucket);
            last;
        }

        if ($bucket->read(my $data)) {
            $context->{reads}++ if $context->{debug};

            # The extra juggling here is because we don't want to match again a tag we've seen already, so we pop
            # them out as we find them.
            while (my $tag = $context->{current_tag}) {
                my $name = $tag->{name};
                my $pat  = $tag->{pattern};

                $context->{tests}++ if $context->{debug};
                if ($data =~ m{(.*)($pat)(.*)}si) {

                    #We match each tag only once, and in order, so roll over to the next match
                    $context->{current_tag} = shift @{$context->{tags}};

                    $context->{matched}++ if $context->{debug};
                    my ($before, $html_tag, $after) = ($1, $2, $3);

                    my $where = $tag->{insert};
                    my $url   = $tag->{url};

                    $bb_ctx->insert_tail(
                          APR::Bucket->new($bb_ctx->bucket_alloc, $before));
                    if ($where eq 'before') {
                        my $rv = _inject($r, $f, $bb, $bb_ctx, $url,
                                         $context->{comments});
                        return $rv unless $rv == APR::Const::SUCCESS;
                    }

                    $bb_ctx->insert_tail(
                        APR::Bucket->new($bb_ctx->bucket_alloc, $html_tag));

                    if ($where eq 'after') {
                        my $rv = _inject($r, $f, $bb, $bb_ctx, $url,
                                         $context->{comments});
                        return $rv unless $rv == APR::Const::SUCCESS;
                    }

                    $data = $after;
                }

                # Optimization here, if the first pattern didn't match,
                # don't bother looking at the others, this assumes the
                # tags are ordered, which the main loop already does
                else {
                    last;
                }
            }

            # Pass thru unmatched data unmodified
            $bb_ctx->insert_tail(
                            APR::Bucket->new($bb_ctx->bucket_alloc, $data));
        }
    $bucket->remove;
    }

    my $rv = $f->next->pass_brigade($bb_ctx);
    return $rv unless $rv == APR::Const::SUCCESS;

    $bb_ctx->destroy();

    # Stash our context for next time around
    $f->ctx($context);

    return Apache2::Const::OK;
}

sub _inject {
    my ($r, $f, $bb, $bb_ctx, $url, $comments) = @_;
    $bb_ctx->insert_tail(
           APR::Bucket->new($bb_ctx->bucket_alloc, "<!-- $url START -->\n"))
      if $comments;

    my $rv = $f->next->pass_brigade($bb_ctx);
    return $rv unless $rv == APR::Const::SUCCESS;
    $rv = _call($url, $r, $f);    #XXX: move back to perl land
    return $rv unless $rv == APR::Const::SUCCESS;
    $bb_ctx->insert_tail(
             APR::Bucket->new($bb_ctx->bucket_alloc, "<!-- $url END -->\n"))
      if $comments;
    return $rv;
}

use Apache2::SubRequest ();

my $call = \&_call_xs;
sub _call {
   return $call->(@_); 
}

sub _call_pp {
    my ($url, $r, $f) = @_;
    # This Pure-perl code would work, if not for a bug in mod_perl
    # mod_perl 2.0.4 will be fixed (r607687)
    my $subr = $r->lookup_uri($url, $f->next);
    my $rc = $subr->run;

    return $rc;
}

42;

__END__

=head1 NAME 

Apache2::Layout - mod_perl 2.0 html layout engine

=head1 SYNOPSIS

httpd.conf:

  PerlModule Apache2::Layout

  Alias /layout /usr/local/apache2/htdocs
  <Location /layout>
    PerlOutputFilterHandler Apache2::Layout

    PerlSetVar LayoutFooter /footer.html
    PerlSetVar LayoutHeader /header.html
    PerlSetVar LayoutCSS /head.html
  </Location>

=head1 DESCRIPTION

Apache2::Layout is a filter module that can be used to inject HTML
layout into HTML documents. Very handy when trying to apply customizations
to existing HTML content without needing to change them.

Only documents with a content type of "text/html" are affected - all
others are passed through unaltered.

=head1 OPTIONS

=over 4

=item LayoutComments

Inserts HTML comments in the output, marking where inserted content begins
and ends

  PerlSetVar LayoutComments On

LayoutComments has no default.

=item LayoutDebug

Logs debugging information about the processing. Combined with L<LayoutComments>,
will insert a debug summary as an HTML comment at the end of the filtered document.

  PerlSetVar LayoutDebug On

LayoutDebug has no default.

=item LayoutCSS

Specifies a url to insert right before the end of the HTML E<lt>headE<gt> element,
typically used to inject stylesheets into the document.

  PerlSetVar LayoutCSS /css/style.css

LayoutCSS has no default.

=item LayoutHeader

Specifies a url to insert right after the beginning of the HTML E<lt>bodyE<gt> element,
typically used to inject the begging of a content wrapper into the document.

  PerlSetVar LayoutHeader /templates/header.html

LayoutHeader has no default.

=item LayoutFooter

Specifies a url to insert right before the end of the HTML E<lt>bodyE<gt> element,
typically used to inject the end of a content wrapper into the document.

  PerlSetVar LayoutHeader /templates/footer.html

LayoutFooter has no default.

=back

=head1 API

=head2 handler

This is the one and only user-visible function, it's the main filter
handler.

  PerlOutputFilterHandler Apache2::Layout

=head1 NOTES

This is alpha software, and as such has not been tested on multiple
platforms or environments.

=head1 SEE ALSO

perl(1), mod_perl(3), Apache(3), mod_layout

=head1 AUTHOR

Philippe M. Chiasson E<lt>gozer@ectoplasm.orgE<gt>

=head1 REPOSITORY

http://svn.ectoplasm.org/projects/perl/Apache2-Layout/trunk/

=head1 COPYRIGHT

Copyright (c) 2007, Philippe M. Chiasson
All rights reserved.

This module is free software.  It may be used, redistributed
and/or modified under the same terms as Perl itself.

=cut