view release on metacpan or  search on metacpan

lib/Beagle/Web.pm  view on Meta::CPAN

sub redirect {
    shift @_ if @_ && $_[0] eq 'Beagle::Web';
    my $location = shift;
    my $code     = shift;
    $location =~ s!^/?!$prefix! if $location;
    $req->new_response( $code || 302, [ Location => $location || $prefix ] );
}

my $res;
sub response { $res }

sub handle_request {
    shift @_ if @_ && $_[0] eq 'Beagle::Web';
    my $env = shift;
    init() unless $bh;

    $req = Beagle::Web::Request->new($env);

    my $n = $req->env->{'BEAGLE_NAME'} || $req->header('X-Beagle-Name');
    $n = decode_utf8($n) unless Encode::is_utf8($n);

    if ( $names && $n && grep { $n eq $_ } @$names ) {
        $bh   = $bh{$n};
        $name = $n;
    }

    if (   web_admin()
        || !$updated{$name}
        || time - $updated{$name} >= 60 )
    {
        $bh->update;
        update_archives($bh);
        update_tags($bh);
        update_feed($bh);
        $updated{$name} = time;
    }

    require Plack::Response;
    $res = Plack::Response->new;

    if ( my $match = $router->match($env) ) {
        if ( my $method = delete $match->{code} ) {
            my $ret = $method->(%$match);
            if ( ref $ret && $ret->isa('Plack::Response') ) {
                $res = $ret;
                $res->status( 200 ) unless $res->status;
            }
            else {
                if ( $ret ) {
                    $res->body(
                        Encode::is_utf8($ret)
                        ? encode_utf8 $ret
                        : $ret
                    );
                    $res->status( 200 ) unless $res->status;
                }
            }
        }
    }

    $res->status( 404 ) unless $res->status;
    $res->content_type( 'text/html' ) unless $res->content_type;

    $res->finalize;
}

sub prefix { $prefix }

1;

__END__

=head1 NAME

Beagle::Web - web interface of Beagle

=head1 DESCRIPTION

Beagle::Web - web interface of Beagle

=head1 AUTHOR

sunnavy <sunnavy@gmail.com>


=head1 LICENCE AND COPYRIGHT

Copyright 2011 sunnavy@gmail.com

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