File Coverage

blib/lib/Plack/Builder/Conditionals.pm

Criterion	Covered	Total	%
statement	96	101	95.0
branch	30	30	100.0
condition	16	21	76.1
subroutine	22	24	91.6
pod	8	8	100.0
total	172	184	93.4

package Plack::Builder::Conditionals;

use strict;
use warnings;
use Net::CIDR::Lite;
use List::MoreUtils qw//;
use Plack::Util;
use Plack::Middleware::Conditional;

our $VERSION = '0.05';

sub import {
    my $class = shift;
    my $caller = caller;
    my %args = @_;

    my @EXPORT = qw/match_if addr path method header browser any all/;

    no strict 'refs';
    my $i=0;
    for my $sub (@EXPORT) {
        my $sub_name = $args{'-prefix'} ? $args{'-prefix'} . '_' . $sub : $sub;
        *{"$caller\::$sub_name"} = \&$sub;
    }
}

sub match_if {
    my $condition = shift;
    my ( $mw, @args ) = @_;

    if (ref $mw ne 'CODE') {
        my $mw_class = Plack::Util::load_class($mw, 'Plack::Middleware');
        $mw = sub { $mw_class->wrap($_[0], @args) };
    }

    return sub {
        Plack::Middleware::Conditional->wrap(
            $_[0],
            condition => $condition,
            builder => $mw
        );
    }
}

sub addr {
    my $not;
    my $ip;
    if ( @_ == 1 ) {
        $ip = $_[0];
    }
    else {
        $not = $_[0];
        $ip = $_[1];
    }

    my @ip = ref $ip ? @$ip : ($ip);
    my $cidr4 = Net::CIDR::Lite->new();
    my $cidr6 = Net::CIDR::Lite->new();
    for my $ip ( @ip ) {
        if ( $ip =~ m!:! ) {
            $cidr6->add_any($ip);
        }
        else {
            $cidr4->add_any($ip);
        }
    }

    return sub {
        my $env = shift;
        my $find_ip;
        if ( $env->{REMOTE_ADDR} =~ m!:! ) {
            $find_ip = $cidr6->find($env->{REMOTE_ADDR});
        }
        else {
            $find_ip = $cidr4->find($env->{REMOTE_ADDR});
        }
        return (defined $not && $not eq '!')  ? !$find_ip : $find_ip;
    };
}

sub _match {
    my $key = shift;
    my $not;
    my $val;
    if ( @_ == 1 ) {
        $val = $_[0];
    }
    else {
        $not = $_[0];
        $val = $_[1];
    }

    return sub {
        my $env = shift;
        my $ret;
        if ( ref $val && ref $val eq 'Regexp' ) {
            $ret = exists $env->{$key} && $env->{$key} =~ m!$val!;
        }
        elsif ( defined $val ) {
            $ret = exists $env->{$key} && $env->{$key} eq $val;
        }
        else {
            $ret = exists $env->{$key};
        }
        return ( defined $not && $not eq '!' ) ? !$ret : $ret;
    };
}

sub path {
    _match( 'PATH_INFO', @_ );
}

sub method {
    my $not;
    my $method;
    if ( defined $_[0] && $_[0] eq '!' ) {
        $not = shift;
    }
    return sub { 1 } unless @_;
    if ( @_ == 1 ) {
        $method = $_[0];
    }
    else {
        my $alternatives = join '|', map { quotemeta($_) } @_;
        $method = qr/^(?:$alternatives)$/i;
    }
    if ( defined $method && ! ref $method )  {
        $method = uc $method;
    }
    _match( 'REQUEST_METHOD', grep { defined } $not, $method );
}

sub header {
    my $header = shift;
    $header =~ s/-/_/g;
    $header = 'HTTP_' . uc($header);
    _match( $header, @_ );
}

sub browser {
    _match( "HTTP_USER_AGENT", @_ );
}

sub any {
    my @match = @_;
    return sub {
        my $env = shift;
        List::MoreUtils::any { $_->($env) } @match;
    };
}

sub all {
    my @match = @_;
    return sub {
        my $env = shift;
        List::MoreUtils::all { $_->($env) } @match;
    };
}


1;
__END__