File Coverage

blib/lib/Catalyst/Plugin/Flavour.pm

Criterion	Covered	Total	%
statement	15	48	31.2
branch	0	20	0.0
condition	0	22	0.0
subroutine	5	7	71.4
pod	1	1	100.0
total	21	98	21.4

package Catalyst::Plugin::Flavour;
use strict;
use base qw/Class::Accessor::Fast/;
use NEXT;

use Catalyst::Plugin::Flavour::Data;

our $VERSION = '0.03';

__PACKAGE__->mk_accessors(qw/flavour/);

# add accessors to Catalyst::Request
{
    package Catalyst::Request;
    use base qw/Class::Accessor::Fast/;

    __PACKAGE__->mk_accessors(qw/real_uri/);
    *rpath = \&real_path;
    *ruri  = \&real_uri;

    sub real_path { shift->real_uri->path };
}

=head1 NAME

Catalyst::Plugin::Flavour - Catalyst plugin for request flavours.

=head1 SYNOPSIS

    use Catalyst qw/Flavour/;

=head1 DESCRIPTION

This plugin allows you to handle request flavours like Blosxom.

=head1 EXTENDED METHODS

=head2 prepare_path

=cut

sub prepare_path {
    my $c = shift;
    $c->NEXT::prepare_path(@_);

    # copied from Static::Simple
    foreach my $dir ( @{ $c->config->{static}->{dirs} } ) {
        my $re = ( $dir =~ /^qr\//xms ) ? eval $dir : qr/^${dir}/;
        if ($@) {
            $c->error( "Error compiling static dir regex '$dir': $@" );
        }
        if ( $c->req->path =~ $re ) {
            return $c;
        }
    }

    $c->flavour( Catalyst::Plugin::Flavour::Data->new );
    $c->req->real_uri( $c->req->uri->clone );

    my @path = split m!/+!, $c->req->path || '';
    shift @path unless @path and $path[0];
    push @path, '' if ( $c->req->path || '' ) =~ m!/$!;

    my $config = $c->config->{flavour};

    if ( my ( $fn, $flavour ) = ( $path[-1] || '' ) =~ /(.*)\.(.*?)$/ ) {
        $c->flavour->fn($fn);
        $c->flavour->flavour($flavour);
        $path[-1] =~ s/\.$flavour$//;
        pop @path if $fn eq 'index';
    }
    else {
        $c->flavour->fn( $path[-1] || 'index' );
        $c->flavour->flavour( $config->{default_flavour} || 'html' );
    }

    unless ( defined $config->{date_flavour} and !$config->{date_flavour} ) {
        for my $param (qw/year month day/) {
            last unless $path[0];

            if (   $param eq 'year' && $path[0] =~ /^\d{4}$/
                or $path[0] =~ /^\d?\d$/ )
            {
                $c->flavour->$param( shift @path );
            }
            else {
                last;
            }
        }
    }

    my $path = '/' . join '/', @path;
    $c->req->uri->path( $path );
    $c->req->path( $path );

    $c;
}

=head1 SEE ALSO

L<Catalyst>

http://www.blosxom.com/

=head1 AUTHOR

Daisuke Murase E<lt>[e-mail]<gt>

=head1 COPYRIGHT

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

The full text of the license can be found in the
LICENSE file included with this module.

=cut

1;