#!/usr/bin/perl

# A CGI wrapper for the Text::Wigwam template module.
# Can be invoked via SSI, mod_rewrite, or from the command line

# Via SSI:
# <!--#exec cgi="/cgi-bin/wigwam.launcher.pl"-->
# <!--#if expr=""-->
# <HTML>
# ... Insert html/template content here
# </HTML>
# <!--#endif-->

# Via mod_rewrite:
# Invoking via mod_rewrite offers more control over the http headers as well
# as allowing html forms to be POSTed directly to html templates for
# processing. Apache must be configured to execute this script via
# mod_rewrite by adding the following lines to httpd.conf (or wherever):
#
# <IfModule mod_rewrite.c>
#  RewriteEngine on
#  RewriteCond %{DOCUMENT_ROOT}%{SCRIPT_FILENAME} -f
#  RewriteRule ^.*\.html.*$ /cgi-bin/wigwam.launcher.pl [PT]
# </IfModule>
#
# Alternatively, you may add the above lines to the .htaccess file of every
# directory (tree?) in which you wish to have HTML files parsed by Wigwam.

# Via command line:
# ./wigwam.launcher.pl some_template_file.html

    use strict;
    no warnings;

    BEGIN{ eval { require Compress::Zlib } }

    use Text::Wigwam;
    use File::Spec::Functions( qw/catfile splitpath/ );

    $| = 1;
    my $headers = Text::Wigwam::Directives::http::headers->new();

    my ( $document, $debugger, $beautify );
    my $config;

# Redirect all explicit http requests for this script to the root domain.
# e.g. http://www.domain.com/cgi-bin/wigwam.launcher.pl
    if( $ENV{SCRIPT_URL} =~ m{^/(perl|cgi-bin)/} ){
        print "Location: http://".$ENV{SERVER_NAME}."\n\n";
        exit;
    }
     # ssi or mod_perl(via Apache::Registry) included?
    elsif( $ENV{SERVER_PROTOCOL} eq "INCLUDED" ){
        #  if $ENV{ MOD_PERL }  # mod_perl (Apache::Registry) detect may go here
#        warn "ssi/mod_perl default dir: ".default_dir( $ENV{SCRIPT_FILENAME} );
        $config = load_config(
            default_dir( $ENV{SCRIPT_FILENAME} ),
            ".wigwam.conf",
            "wigwam.conf",
        );
        $document = document($ENV{DOCUMENT_URI});
        $headers->set( 'Content-type' => "text/html")
          if( $ENV{GATEWAY_INTERFACE} !~ /^CGI\-Perl/ );
         # Disable compression for SSI
        $config->{options}{restrict}{compress} = 0;
        $debugger = init_debugger( @{$config->{debug_template}} );
        $beautify = 'Text::Wigwam::Beautify::Html';
#        $debugger->size;
#        $debugger->set_path( template => @{$config->{template_path}} ) if $debugger;
    }
     # mod_rewrite or mod_perl handler?
    elsif( $ENV{SERVER_PROTOCOL} =~ /^HTTP/ ) {
#        warn "mod_rewrite default dir: ".default_dir( $ENV{SCRIPT_FILENAME} );
        $config = load_config(
            default_dir( $ENV{SCRIPT_FILENAME} ),
            ".wigwam.conf",
            "wigwam.conf",
        );
#        my $alias = "/post/to";
#        $document = $ENV{SCRIPT_URL} || $ENV{REDIRECT_URL};
#        $document =~ s/^\Q$alias\E// if length $alias;
#        $document = document($document);
        $document = document($ENV{SCRIPT_URL} || $ENV{REDIRECT_URL});
        $document .= "index.html" if $document =~ m{/$};
        $headers->set( 'Content-type' => "text/html");
        $headers->set( Expires => "0" );
        if ($ENV{REDIRECT_STATUS} =~ /^4..$/){ print $ENV{REDIRECT_STATUS}; exit; }
        $debugger = init_debugger( @{$config->{debug_template}} );
#        $debugger->size;
        $beautify = 'Text::Wigwam::Beautify::Html';
#        $debugger->set_path( template => @{$config->{template_path}} ) if $debugger;

#        print $headers->out;
#        foreach my $key (keys %ENV) {
#            print "$key = ".$ENV{$key}."<BR>\n";
#        }
#        print "\n<BR>$document";
#        print "\n<BR>SU:".$ENV{SCRIPT_URL};
#        print "\n<BR>RU:".$ENV{REDIRECT_URL};
    }
    else{
#        warn "command-line default dir: ".default_dir($0);
        $config = load_config(
            default_dir($0),
            ".wigwam.conf",
            "wigwam.conf",
        );
#        $headers->set( 'Content-type' => "text/html");
#        $headers->set( Expires => "0");
        $document = $ARGV[0];
        $beautify = 'Text::Wigwam::Beautify::Text';
    }

    my $wwobj;

    unless(
        $wwobj = Text::Wigwam->new(
          file => $document,
          %{$config->{options}},
          global => {
              http => {
                  Headers => $headers,
#                  headers => $headers,
              },
#              self => {
#                PRIMARY => Text::Wigwam::Globals::Snapshot->freeze( $wwobj, 15 ),
#                ZCONFIG => $config->{options},
#                DEBUG   => Text::Wigwam::Globals::Snapshot->freeze( $debugger, 15 ),
#              },
          },
        )
    ){
        print $headers->out.$Text::Wigwam::ERROR;
        die $Text::Wigwam::ERROR;
    }

#    $wwobj->new_global( GLOBAL => q/Headers/, $headers );
    $wwobj->new_global( GLOBAL => q/Debug/ ); # Triggers the debugger (if enabled)

#    $wwobj->set_global( Headers => $headers );

    $wwobj->set_path( template => @{$config->{template_path}} );
    $wwobj->add_path( module   => @{$config->{module_path}} );
    $wwobj->add_path( engine   => @{$config->{engine_path}} );
    $wwobj->add_path( plugin   => @{$config->{plugin_path}} );

#    my ($error, $body) = $wwobj->execute( $config->{options}{varspace} );
    my ($error, $body) = $wwobj->execute();
    $body = trim_newlines( trim_ssi( $body ) );

    my $debug_mode = $wwobj->get_global( q/Debug/ ) ;
    $wwobj->set_global( Debug => undef );
    if( $error || $debug_mode ){
        print $headers->out;
        warn $error if $error;    # Log the error msg
        unless( $config->{nodebug} ){
#            $debugger = init_debugger( $config->{debug_template} );
            $body = ($body =~ /^\s*$/) ? "" : $body;
            my ( $err, $text ) = $wwobj->debug(
                $beautify,
                $debugger,
            );
#            my ( $text, $err ) = $debugger->beautify(
#                $beautify,
#            );
#            my ( $text, $err ) = $wwobj->beautify(
#                $beautify,
#            );
            warn "Debugger error: $err\n" if $err;
            $error
              = length($err)
                ?  length($error) ? $error : "Debugger error: $err\n"
                :  trim_newlines( trim_ssi($text) )
            ;
        }
#        my $options = $debugger->{config}->cache(q/options/);
#        print $_ . " = " . $options->{$_}. "<BR>\n"
#          for keys %$options;
#        print $debugger->debug( Text::Wigwam::Beautify::Html->new() );
#        exit;
#        print $debugger->engine."/".$debugger->size."/".($debugger->doc || 'root');
#        print "START".$debugger->{text}."END";
        print "$error"; # Echo msg to browser
        exit;
    }

    if(
        $wwobj->get_options(q/compress/)
         && Compress::Zlib->can(q/compress/)
         && $headers->num
    ){
        if( $ENV{HTTP_ACCEPT_ENCODING} =~ /gzip/ ){
            $headers->set( 'Content-encoding' => 'gzip' );
            binmode(STDOUT);
            $body = Compress::Zlib::memGzip($body);
        }
        elsif( $ENV{HTTP_ACCEPT_ENCODING} =~ /deflate/ ){
            $headers->set( 'Content-encoding', 'deflate' );
            binmode(STDOUT);
            $body = compress($body);
        }
    }

    if( $headers->num ){
        $headers->set( 'Content-Length', length $body );
        print $headers->out;
    }
    print $body;

BEGIN {
    sub load_config {
        my( $path, @fcandidates ) = @_;
        return { make_config() } unless @fcandidates;
        while( @fcandidates ){
            my $full = catfile( $path, shift @fcandidates );
            if( -f "$full" ){
                delete $INC{$full}; # Persistent environments require this
                my $uconfig = require "$full";
                $uconfig = ref $uconfig eq 'HASH' ? $uconfig : {};
                return { make_config(%$uconfig) };
            }
        }
#        warn "Config file (".join(', ' => @_).") not found in $path";
        return {};
    }
    sub default_dir {
        my ( $fspec ) = @_;
        my ( $volume, $path, $file ) = splitpath($fspec);
        return $path;
    }
    sub trim_newlines {
        my ( $str ) = @_;
        $str =~ s/^\s*//s; # Remove all leading white space
        $str =~ s/(?:\n\s+\n)+/\n/g;
        return $str;
    }

    sub trim_ssi {
        my ( $str ) = @_;
        $str  =~ s/\s*<!--#.*?-->\s*?[\r\n]?//gs;
        return "$str\n";
    }

    sub init_debugger {
        my ( @opts ) = @_;
#        warn "DEBUG: ". join( "=>" => @$dtemp );
        return Text::Wigwam->new(
            @opts,
#            Restrict => { engine => 'Totem' },
            Varspace => {},
        ) or die "Problem initializing debugger - ".$Text::Wigwam::ERROR;
    }

    sub document { docroot().$_[0] }

    sub docroot {
        my ( $docroot ) = $ENV{DOCUMENT_ROOT} =~ m{^([\w:/\\-]+)$}
          or die "Unsafe document root!";
        return $docroot;
    }

    sub make_config {
      my (@args) = @_;
      return (
        nodebug    => 0,
        module_path   => [ qw( ) ],
        engine_path   => [ qw( ) ],
        plugin_path   => [ qw( ) ],
        template_path => [ qw( ) ],
        options => {
            restrict => {
                config_open => '<<',
                config_term => '>>',
                default_engine => 'Fusion',
            },
            defaults => {
                strict_tags    => 1,
                code_term      => q/!!]/,
                code_open      => q/[!!/,
                text_open      => q/!!>/,
                text_term      => q/<!!/,
                code_term_trim => q/~!]/,
                code_open_trim => q/[!~/,
                text_open_trim => q/~!>/,
                text_term_trim => q/<!~/,
                compress => 1,
            },
            settings => {
                plugins => 'DirectiveSet',
                modules => '',
                compress => Compress::Zlib->can qw(compress) ? 1 : 0,
            },
            varspace => {},
        },
        debug_template => [
            text => <<ENDOFTEMPLATE,
<!DOCTYPE html PUBLIC '-//W3C//DTD HTML 4.01//EN' 'http://www.w3.org/TR/html4/strict.dtd'>
<html lang="en">
 <head>
  <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1">
  <title>Wigwam Template Debugger</title>
  <style type="text/css">
    b.identify    { color : red;  }
    b.comment    { color : red; font-style : italic }
    i.unknown    { color : gray;  }
    i.implied    { color : gray;  }
    b.directive  { color : purple;   }
    b.tagentity  { color : black;   }
    tt.tagentity  { color : black;   }
    i.error  { color : red;   }

    b.variable   { color : blue;  }
    i.variable   { color : blue;  }

    q.literal    { color : green; font-family : monospace; }
    tt.literal   { color : green; }
    tt.plaintext   { color : green; }
    pre.template { color : gray;  }

    span.unknown   { color : gray  ; font-style  : italic;    }
    span.directive { color : purple ;   }
    span.tagentity { color : black   ; }
    span.error { color : red   ; font-style : italic       }
    span.variable  { color : blue  ;    }
    span.literal   { color : green ; font-family : monospace; }
    span.template  { color : gray  ; font-family : monospace; }
  </style>
 </head>
 <body>
 [!! /* wigwam.launcher.pl */ #parameters < TEMPLATE DEBUG > &TEMPLATE(DEBUG)  !!]
 </body>
</html>
ENDOFTEMPLATE
			restrict => {
				config_open    => q/<!--/,
				config_term    => q/-->/,
				default_engine => q/Fusion/,
			},
			defaults => {
				strict_tags    => 1,
				text_open      => q/!!>/,
				text_term      => q/<!!/,
				code_open      => q/[!!/,
				code_term      => q/!!]/,
				text_open_trim => q/~!>/,
				text_term_trim => q/<!~/,
				code_open_trim => q/[!~/,
				code_term_trim => q/~!]/,
			},
			settings => {
				plugins => 'DirectiveSet',
				modules => '',
				compress => Compress::Zlib->can qw(compress) ? 1 : 0,
			},
			varspace => {
			},
        ],
        @args,
      );
    }
}

package Text::Wigwam::Directives::http::headers;
 # An embedded Wigwam module that manages http headers.

    use Text::Wigwam::Const( qw/STRING/ );

    sub new { bless {} }
    sub num { scalar keys %{$_[0]} }
    sub zap { delete $_[0]->{lc $_[1]}; return }
    sub add { push @{$_[0]->{lc $_[1]}}, $_[2]; return }
    sub set { $_[0]->{lc $_[1]} = [ $_[2] ]; return }
    sub out {
        my ($headers) = @_;
        return unless $headers->num;
        my @http_headers;
        for my $key ( keys %$headers ){
            push( @http_headers, "$key: $_" ) for (@{$headers->{$key}});
            $headers->zap( $key );
        }
        return join( "\n", @http_headers, "\n" );
    }

# The associated directives happen to share a namespace with the object class.

    sub _proto_num { [ ] }
    sub _proto_zap { [ STRING ] }
    sub _proto_add { [ STRING , STRING ] }
    sub _proto_set { [ STRING , STRING ] }

    sub _num { num( header_hash(@_) ) }
    sub _zap { zap( header_hash(@_), $_[0]->get_arg) }
    sub _add { add( header_hash(@_), $_[0]->get_arg, $_[0]->get_arg) }
    sub _set { set( header_hash(@_), $_[0]->get_arg, $_[0]->get_arg) }

    sub header_hash { return ($_[0]->get_global(q/global/))->{http}{headers} }


package Text::Wigwam::Directives;

# Provide a #debug directive so that the debugger can be invoked from
# within a template.

    sub _proto_debug { [ STRING ] }
    sub _debug {
       my ($Api) = @_;
        $Api->set_global( Debug => 1 );   # Trigger the debugger
        $Api->debug( $Api->get_arg );     # Insert a comment
        return;
    }

