### NO PACK
package Yacafi;
use strict;
use warnings;

require Encode;

our $VERSION = '0.01';

our $MAX_POST_BODY_SIZE = 1000000;
our $DEBUG              = 0;
our $NOT_FOUND_CODE     = +{
    headers => +{ Status => 404 },
    body    => 'Not Found',
};
our $CURRENT_CLASS = '';

our $TEMPLATE_MIMETYPES = +{
    html    => 'text/html; charset=utf-8',
    css     => 'text/css',
    js      => 'text/javascript',
    xml     => 'text/xml',
    default => 'text/plain',
};
our $TEMPLATE_PARAMS = +{
    code                => '',
    comment_mark        => '#',
    expression_mark     => '=',
    raw_expression_mark => '=r',
    line_start          => '%',
    template            => '',
    tag_start           => '<%',
    tag_end             => '%>',
    prefix              => '',
    ext                 => 'mt',
};
### NO PACK END

my $CRLF  = "\r\n";
my $QUERY = undef;
### NO PACK
sub import {
    my ( $class, %args ) = @_;
    $QUERY = undef;
    my $caller = caller;
    $CURRENT_CLASS = $args{current_class} || $caller;

    # pre config
    if (   exists $args{extends}
        && exists $args{extends}->{template}
        && ref( $args{extends}->{template}->{params} ) eq 'HASH' )
    {
        while ( my ( $key, $val )
            = each %{ $args{extends}->{template}->{params} } )
        {
            $TEMPLATE_PARAMS->{$key} = $val;
        }
    }

    # create a pack file
    _pack(%args) if @ARGV && $ARGV[0] eq '--pack';

    # functions export
    no strict 'refs';
    for my $name (qw/ dispatch query controller model view redirect filter /)
    {
        *{ $caller . '::' . $name } = \&{$name};
    }
    if ( exists $args{extends} && exists $args{extends}->{template} ) {
        *{ $caller . '::view_template' } = \&view_template_nocompile;
    }

    strict->import;
    warnings->import;
}

sub _pack {
    my %args   = @_;
    my $yacafi = _read_file( $INC{'Yacafi.pm'} );

    # extends
    $yacafi =~ s!### EXTEND (\w+)\n(.+?)### EXTEND \1 END\n!
        $args{extends}->{$1} ? $2 : ''
    !esg;

    $yacafi =~ s/### NO PACK\n.+?### NO PACK END\n//sg;
    $yacafi =~ s/\n__END__\n.+$//s;
    $yacafi =~ s/'\.\$CURRENT_CLASS\.'/$CURRENT_CLASS/g;
    $yacafi =~ s/\$CURRENT_CLASS/$CURRENT_CLASS/g;

    my $global = '';
    for my $code ( $yacafi =~ /### GLOBAL\n(.+?)### GLOBAL END\n/sg ) {
        $global .= $code;
    }
    $yacafi =~ s/### GLOBAL\n(.+?)### GLOBAL END\n//sg;

    my $cgi = _read_file( ( caller(1) )[1] );
    $cgi =~ s/use (?:Yacafi|strict|warnings).*?;\n//sg;
    $cgi =~ s/\$Yacafi::/\$/g;

    my $shebang;
    if ( $cgi =~ s/(\#\![^\n]+)//s ) {
        $shebang = $1;
    }

    if ( ref( $args{extends}->{template}->{files} ) eq 'ARRAY' ) {

        # template files prcompile
        my $append = 'my $TEMPLATE_COMPILED = +{' . "\n";
        for my $file ( @{ $args{extends}->{template}->{files} } ) {
            my ( $mime_type, $code ) = template_builder($file);
            $code =~ s/;$//;
            $append
                .= '    \'' 
                . $file
                . '\' => [\''
                . $mime_type . '\', '
                . $code . "],\n";
        }
        $global .= "\n" . $append . "\n};\n";
    }

    my $pl = qq{$shebang
### GENERATED BY Yacafi $VERSION
use strict;
use warnings;
$global
package $CURRENT_CLASS;
my \$MAX_POST_BODY_SIZE = 1000000;
my \$DEBUG              = 0;
my \$NOT_FOUND_CODE     = +{
    headers => +{ Status => 404 },
    body    => 'Not Found',
};
{\n$yacafi\n}
{\n$cgi\n}\n
};

    print $pl;
    exit;
}

sub _read_file {
    my $file = shift;
    open my $fh, '<', $file or die $file . ': ' . $!;
    do { local $/; <$fh> };
}
### NO PACK END

sub dispatch {
    my $response;

### NO PACK
    my $caller_filename = ( caller(0) )[1];

    # copied by MENTA
    local $SIG{__DIE__} = sub {
        my $msg = shift;
        $msg =~ s/$caller_filename/CGI file/g;
        my $i = 0;
        my @trace;
        while ( my ( $package, $filename, $line, ) = caller($i) ) {
            my $context = sub {
                my ( $file, $linenum ) = @_;
                my $code;
                if ( -f $file ) {
                    my $start = $linenum - 3;
                    my $end   = $linenum + 3;
                    $start = $start < 1 ? 1 : $start;
                    open my $fh, '<:utf8', $file or die $file . ': ' . $!;
                    my $cur_line = 0;
                    while ( my $line = <$fh> ) {
                        ++$cur_line;
                        last if $cur_line > $end;
                        next if $cur_line < $start;
                        my @tag
                            = $cur_line == $linenum
                            ? ( q{<strong>}, '</strong>' )
                            : ( '', '' );
                        $code .= sprintf( '%s%5d: %s%s',
                            $tag[0], $cur_line, filter( $line => 'html' ),
                            $tag[1], );
                    }
                    close $file;
                }
                return $code;
                }
                ->( $filename, $line );
            $filename = 'CGI file' if $filename eq $caller_filename;
            push @trace,
                +{
                level    => $i,
                package  => $package,
                filename => $filename,
                line     => $line,
                context  => $context
                };
            $i++;
        }
        die { message => $msg, trace => \@trace };
    };
### NO PACK END

    eval {
        my $action = lc( $ENV{PATH_INFO} || '' );
        $action =~ s!^/+!!  if( $action );
        $action =~ s!/!_!g  if( $action );
        $action = '' unless $action =~ /^[a-z0-9_]*$/;
        $action ||= 'index';

        my $func = 'do_' . $action;
        if ( my $code = $CURRENT_CLASS->can($func) ) {
            $response = $code->();
        }
        else {
            $response
                = ref($NOT_FOUND_CODE) eq 'CODE'
                ? $NOT_FOUND_CODE->($func)
                : $NOT_FOUND_CODE;
        }
    };

    if ($@) {
### NO PACK
        my $err = $@;
        die $err unless $DEBUG;
        die $err unless ref($err) eq 'HASH';

        warn $err->{message};

        my $body;
        my $msg = filter( $err->{message} => 'html' );
        $body
            = qq{<!doctype html><head><title>500 Internal Server Error</title><style type="text/css">body { margin: 0; padding: 0; background: rgb(230, 230, 230); color: rgb(44, 44, 44); } h1 { margin: 0 0 .5em; padding: .25em; border: 0 none; border-bottom: medium solid rgb(0, 0, 15); background: rgb(63, 63, 63); color: rgb(239, 239, 239); font-size: x-large; } p { margin: .5em 1em; } li { font-size: small; } pre { background: rgb(255, 239, 239); color: rgb(47, 47, 47); font-size: medium; } pre code strong { color: rgb(0, 0, 0); background: rgb(255, 143, 143); } p.f { text-align: right; font-size: xx-small; } p.f span { font-size: medium; }</style></head><h1>500 Internal Server Error</h1><p>$msg</p><ol>};
        for my $stack ( @{ $err->{trace} } ) {
            $body .= '<li>'
                . filter(
                join( ', ',
                    $stack->{package}, $stack->{filename}, $stack->{line} ) =>
                    'html'
                ) . qq(<pre><code>$stack->{context}</code></pre></li>);
        }
        $body
            .= qq{</ol><p class="f"><span>Powered by <strong>Yacafi</strong></span>, Web application framework</p>};

        eval "use utf8";
        utf8::encode($body);
        $response = +{
            headers => +{ Status => 500 },
            body    => $body,
        };
### NO PACK END
        die $@ unless $response;
    }

    $response ||= +{};
    my %headers = %{ $response->{headers} || +{} };
    my $body = $response->{body} || '';
    #$headers{'Content-Length'} ||= length($body);
    $headers{'Content-Length'} ||= length(Encode::encode_utf8($body));
    $headers{'Content-Type'}   ||= 'text/html; charset=utf-8';

    # build headers
    while ( my ( $name, $values ) = each %headers ) {
        next unless defined $values;
        for my $value ( ref($values) eq 'ARRAY' ? @{$values} : ($values) ) {
            printf STDOUT $name . ': ' . $value . $CRLF;
        }
    }
    print STDOUT $CRLF . $body;
}

sub query {
    my $name = shift;
    unless ($QUERY) {
        my $input = '';
        if ( $ENV{REQUEST_METHOD} eq "POST" ) {
            if ( $ENV{CONTENT_LENGTH} > $MAX_POST_BODY_SIZE ) {
                die "too long Content-Length";
            }
            else {
                read( STDIN, $input, $ENV{CONTENT_LENGTH} );
            }
        }
        else {
            $input = $ENV{QUERY_STRING} || '';
        }

        for ( split /&/, $input ) {
            my ( $key, $val ) = split /=/, $_;
            $val =~ tr/+/ / if( $val );
            $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2", $1)/eg;
            $QUERY->{$key} = $val;
        }
    }
    $QUERY->{$name};
}

sub redirect {
    +{  headers => +{ Status => ( $_[1] || 302 ), Location => $_[0] },
        body => 'redirect to ' . $_[0],
    };
}

sub controller {
    my $name = shift;
    my $func = 'do_' . $name;
    die 'controller: '
        . $CURRENT_CLASS . '::'
        . $func
        . ' function is missing...'
        unless my $code = $CURRENT_CLASS->can($func);
    $code->(@_);
}

sub model {
    my $name = shift;
    my $func = 'model_' . $name;
    die 'model: ' . $CURRENT_CLASS . '::' . $func . ' function is missing...'
        unless my $code = $CURRENT_CLASS->can($func);
    $code->(@_);
}

sub view {
    my $name = shift;
    my $func = 'view_' . $name;
    die 'view: ' . $CURRENT_CLASS . '::' . $func . ' function is missing...'
        unless my $code = $CURRENT_CLASS->can($func);
    my $ret = $code->(@_);
    return $ret if ref($ret);
    return +{
        headers => +{},
        body    => $ret,
    };
}

my %FILTERS = (
    html => sub {
        my $text = shift;
        $text =~ s/&/&amp;/g   if( $text );
        $text =~ s/</&lt;/g    if( $text );
        $text =~ s/>/&gt;/g    if( $text );
        $text =~ s/\"/&quot;/g if( $text );
        $text =~ s/'/&#39;/g   if( $text );
        $text;
    },
);

sub filter {
    return \%FILTERS if @_ == 0;
    my ( $text, @filters ) = @_;
    for my $filter (@filters) {
        next
            unless exists $FILTERS{$filter}
                && ref( $FILTERS{$filter} ) eq 'CODE';
        $text = $FILTERS{$filter}->($text);
    }
    $text;
}

sub docroot { 
    my $s = $ENV{SCRIPT_NAME} || '';
    $s =~ s|/[^/]+$||; 
    $s;
}

sub uri_for {
    my ( $path, $query ) = @_;
    my @q;
    while ( my ( $key, $val ) = each %$query ) {
        $val = join '', map {
            /^[a-zA-Z0-9_.!~*'()-]$/
                ? $_
                : '%'
                . uc( unpack( 'H2', $_ ) )
        } split //, $val;
        push @q, "${key}=${val}";
    }
    docroot . '/' . $path . ( scalar @q ? '?' . join( '&', @q ) : '' );
}

### EXTEND template
### NO PACK

=pod

### NO PACK END
# based on Mojo::Template. Copyright (C) 2010, Sebastian Riedel.
# AND some modified by tokuhirom
# Yacafi imported by yappo
sub view_template {
    my $file = shift;
    die 'template file not found ('.$file.')' unless my $cache = $TEMPLATE_COMPILED->{$file};
    +{
        headers => +{ 'Content-Type' => $cache->[0] },
        body    => $cache->[1]->(@_),
    }
}

### GLOBAL
my $TEMPLATE_PARAMS;
### GLOBAL END
### NO PACK

=cut

sub view_template_nocompile {
    my $file = shift;
    my ( $mime_type, $code ) = template_builder($file);
    die 'template file not found (' . $file . ')' . $code unless $code;
    +{  headers => +{ 'Content-Type' => $mime_type },
        body    => ( eval $code )->(@_),
    };
}

sub template_builder {
    my $file = shift;
    $file
        = $TEMPLATE_PARAMS->{prefix} . $file . '.' . $TEMPLATE_PARAMS->{ext};
    open my $fh, '<:utf8', $file or die $! . ': ' . $file;

    # sub parse {
    my $tmpl = do { local $/; '% my %stash = @_' . "\n" . <$fh> };
    my ($ext) = $file =~ /\.([^\.]+)$/;
    my $mime_type = $TEMPLATE_MIMETYPES->{$ext}
        || $TEMPLATE_MIMETYPES->{default};

    # Clean start
    my @tree;

    # Tags
    my $line_start    = quotemeta $TEMPLATE_PARAMS->{line_start};
    my $tag_start     = quotemeta $TEMPLATE_PARAMS->{tag_start};
    my $tag_end       = quotemeta $TEMPLATE_PARAMS->{tag_end};
    my $cmnt_mark     = quotemeta $TEMPLATE_PARAMS->{comment_mark};
    my $expr_mark     = quotemeta $TEMPLATE_PARAMS->{expression_mark};
    my $raw_expr_mark = quotemeta $TEMPLATE_PARAMS->{raw_expression_mark};

    # Tokenize
    my $state                = 'text';
    my $multiline_expression = 0;
    for my $line ( split /\n/, $tmpl ) {

        # Perl line without return value
        if ( $line =~ /^$line_start\s+(.+)$/ ) {
            push @tree, [ 'code', $1 ];
            $multiline_expression = 0;
            next;
        }

        # Perl line with return value
        if ( $line =~ /^$line_start$expr_mark\s+(.+)$/ ) {
            push @tree, [ 'expr', $1 ];
            $multiline_expression = 0;
            next;
        }

        # Perl line with raw return value
        if ( $line =~ /^$line_start$raw_expr_mark\s+(.+)$/ ) {
            push @tree, [ 'raw_expr', $1 ];
            $multiline_expression = 0;
            next;
        }

        # Comment line, dummy token needed for line count
        if ( $line =~ /^$line_start$cmnt_mark\s+(.+)$/ ) {
            push @tree, [];
            $multiline_expression = 0;
            next;
        }

        # Escaped line ending?
        if ( $line =~ /(\\+)$/ ) {
            my $length = length $1;

            # Newline escaped
            if ( $length == 1 ) {
                $line =~ s/\\$//;
            }

            # Backslash escaped
            if ( $length >= 2 ) {
                $line =~ s/\\\\$/\\/;
                $line .= "\n";
            }
        }

        # Normal line ending
        else { $line .= "\n" }

        # Mixed line
        my @token;
        for my $token (
            split /
            (
                $tag_start$raw_expr_mark # Raw Expression
            |
                $tag_start$expr_mark   # Expression
            |
                $tag_start$cmnt_mark   # Comment
            |
                $tag_start             # Code
            |
                $tag_end               # End
            )
        /x, $line
            )
        {

            # Garbage
            next unless $token;

            # End
            if ( $token =~ /^$tag_end$/ ) {
                $state                = 'text';
                $multiline_expression = 0;
            }

            # Code
            elsif ( $token =~ /^$tag_start$/ ) { $state = 'code' }

            # Comment
            elsif ( $token =~ /^$tag_start$cmnt_mark$/ ) { $state = 'cmnt' }

            # Raw Expression
            elsif ( $token =~ /^$tag_start$raw_expr_mark$/ ) {
                $state = 'raw_expr';
            }

            # Expression
            elsif ( $token =~ /^$tag_start$expr_mark$/ ) {
                $state = 'expr';
            }

            # Value
            else {

                # Comments are ignored
                next if $state eq 'cmnt';

                # Multiline expressions are a bit complicated,
                # only the first line can be compiled as 'expr'
                $state = 'code' if $multiline_expression;
                $multiline_expression = 1 if $state eq 'expr';

                # Store value
                push @token, $state, $token;
            }
        }
        push @tree, \@token;
    }

    # }
    # sub build {

    # Compile
    my @lines;
    for my $line (@tree) {

        # New line
        push @lines, '';
        for ( my $j = 0; $j < @{$line}; $j += 2 ) {
            my $type  = $line->[$j];
            my $value = $line->[ $j + 1 ];

            # Need to fix line ending?
            my $newline = chomp $value;

            # Text
            if ( $type eq 'text' ) {

                # Quote and fix line ending
                $value = quotemeta($value);
                $value .= '\n' if $newline;

                $lines[-1] .= "\$_MOJO .= \"" . $value . "\";";
            }

            # Code
            if ( $type eq 'code' ) {
                $lines[-1] .= "$value;";
            }

            # Expression
            if ( $type eq 'expr' ) {
                $lines[-1]
                    .= "\$_MOJO .= filter( scalar($value) => 'html' );";
            }

            # Raw Expression
            if ( $type eq 'raw_expr' ) {
                $lines[-1] .= "\$_MOJO .= $value;";
            }
        }
    }

    # Wrap
    $lines[0] ||= '';
    $lines[0] = q/sub { my $_MOJO = '';/ . $lines[0];
    $lines[-1] .= q/return $_MOJO; };/;

    return $mime_type => join( "\n", @lines );

    # }
}
### NO PACK END
### EXTEND template END

1;
__END__

=head1 NAME

Yacafi - Yet another CGI application framework interface

=head1 SYNOPSIS

  use Yacafi;

=head1 DESCRIPTION

Yacafi is

=head1 AUTHOR

Kazuhiro Osawa E<lt>yappo <at> shibuya <döt> plE<gt>

=head1 SEE ALSO

=head1 REPOSITORY

  svn co http://svn.coderepos.org/share/lang/perl/Yacafi/trunk Yacafi

Yacafi is Subversion repository is hosted at L<http://coderepos.org/share/>.
patches and collaborators are welcome.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut