root/lang/perl/Yacafi/trunk/lib/Yacafi.pm @ 23465

### NO PACK
package Yacafi;
use strict;
use warnings;
our $VERSION = '0.01';

our $MAX_POST_BODY_SIZE = 1000000;
our $DEBUG              = 0;
our $NOT_FOUND_CODE     = \&_not_found;
our $CURRENT_CLASS      = '';
### NO PACK END

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

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

    # functions export
    for my $name (qw/ dispatch query controller model view redirect filter /) {
        no strict 'refs';
        *{"$caller\::$name"} = \&{$name};
    }
    strict->import;
    warnings->import;
}

sub _pack {
    my $yacafi = _read_file($INC{'Yacafi.pm'}); 
    $yacafi =~ s/### NO PACK\n.+?### NO PACK END\n//sg;
    $yacafi =~ s/\n__END__\n.+$//s;
    $yacafi =~ s/\$CURRENT_CLASS/$CURRENT_CLASS/g;

    my $cgi = _read_file((caller(1))[1]);
    $cgi =~ s/use (?:Yacafi|strict|warnings);//g;
    $cgi =~ s/\$Yacafi::/\$/g;
    my $shebang;
    if ($cgi =~ s/(\#\![^\n]+)//s) {
        $shebang = $1;
    }
    
    my $pl = qq{$shebang
use strict;
use warnings;
package $CURRENT_CLASS;
my \$MAX_POST_BODY_SIZE = 1000000;
my \$DEBUG              = 0;
my \$NOT_FOUND_CODE     = \&_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;
    eval {
        my $action = query('action') || 'index';
        my $func = 'do_' . $action;
        if (my $code = $CURRENT_CLASS->can($func)) {
            $response = $code->();
        } else {
            $response = $NOT_FOUND_CODE->();
        }
    };

    if ($@) {
        die $@ unless $DEBUG;
        $response = +{
            headers => +{},
            body    => 'Error: ' . $@,
        };
    }

    $response ||= +{ headers => +{}, body => '' };
    $response->{body} ||= '';
    $response->{headers}->{'Content-Length'} ||= length($response->{body});
    $response->{headers}->{'Content-Type'} ||= 'text/html';

    # build headers
    while (my($name, $values) = each %{ $response->{headers} }) {
        next unless defined $values;
        for my $value (ref($values) eq 'ARRAY' ? @{ $values } : ( $values )) {
            printf STDOUT "%s: %s\r\n", $name, $value;
        }
    }
    print STDOUT "\r\n" . $response->{body};
}

### NO PACK
sub _parse_query {
    my $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/+/ /;
        $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2", $1)/eg;
        $query->{$key} = $val;
    }
    $query;
}
### NO PACK END

sub query {
    my $name = shift;
#    $QUERY ||= _parse_query;
    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/+/ /;
            $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2", $1)/eg;
            $QUERY->{$key} = $val;
        }
    }
    $QUERY->{$name};
}

sub redirect {
    my($uri, $status) = @_;
    $status ||= 302;
    +{
        headers => +{ Status => $status, Location => $uri },
        body    => 'redirect to ' . $uri,
    }
}

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

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

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


sub _not_found {
    +{
        headers => +{ Status => 404 },
        body    => 'Not Found',
    };
}

my $FILTERS = +{
    html => sub {
        my $text = shift;
        $text =~ s/&/&amp;/g;
        $text =~ s/</&lt;/g;
        $text =~ s/>/&gt;/g;
        $text =~ s/\"/&quot;/g;
        $text =~ s/'/&#39;/g;
        $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;
}

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