File Coverage

blib/lib/Catalyst/ActionRole/MatchHost.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Catalyst::ActionRole::MatchHost;
2              
3 1     1   22204 use warnings;
  1         2  
  1         26  
4 1     1   5 use strict;
  1         1  
  1         28  
5 1     1   367 use Moose::Role;
  0            
  0            
6             use namespace::autoclean;
7              
8             =head1 NAME
9              
10             Catalyst::ActionRole::MatchHost - Match action against domain host name
11              
12             =cut
13              
14             our $VERSION = '0.03';
15              
16             =head1 SYNOPSIS
17              
18             Match host name
19              
20             package MyApp::Controller::Root
21              
22             use Moose;
23             BEGIN { extends 'Catalyst::Controller::ActionRole' };
24              
25             sub index :Path('/') :Does('MatchHost') :Host(^mainhost$)
26             {
27             my ( $self, $c ) = @_;
28             ...
29             }
30              
31             ...
32              
33             package MyApp::Controller::NonRoot
34              
35             use Moose;
36             BEGIN { extends 'Catalyst::Controller::ActionRole' };
37              
38             sub index :Path('/') :Does('MatchHost') :HostNot(^mainhost$)
39             {
40             my ( $self, $c ) = @_;
41             ...
42             }
43              
44              
45             =cut
46              
47             around match => sub
48             {
49             my $orig = shift;
50             my $self = shift;
51             my ( $c ) = @_;
52              
53             my $host = $c->req->uri->host;
54             return 0 unless $self->check_domain_constraints( $host );
55              
56             $self->$orig( @_ );
57             };
58              
59             sub check_domain_constraints
60             {
61             my ( $self, $host ) = @_;
62              
63             if ( exists $self->attributes->{'Host'} )
64             {
65             foreach my $dom ( @{ $self->attributes->{'Host'} } )
66             {
67             if ( !$self->_test($host, $dom) )
68             {
69             return undef;
70             }
71             }
72             }
73             if ( exists $self->attributes->{'HostNot'} )
74             {
75             foreach my $dom ( @{ $self->attributes->{'HostNot'} } )
76             {
77             if ( $self->_test($host, $dom) )
78             {
79             return undef;
80             }
81             }
82             }
83              
84             return 1;
85             }
86              
87             sub _test
88             {
89             my $self = shift;
90             my ( $string, $test ) = @_;
91              
92             return $string =~ /$test/i;
93             }
94              
95              
96             =head1 AUTHOR
97              
98             Anatoliy Lapitskiy, C<< <nuclon at cpan.org> >>
99              
100             =head1 BUGS
101              
102             Please report any bugs or feature requests to C<bug-catalyst-action-domain at rt.cpan.org>, or through
103             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-ActionRole-MatchHost>. I will be notified, and then you'll
104             automatically be notified of progress on your bug as I make changes.
105              
106              
107              
108              
109             =head1 SUPPORT
110              
111             You can find documentation for this module with the perldoc command.
112              
113             perldoc Catalyst::ActionRole::MatchHost
114              
115              
116             You can also look for information at:
117              
118             =over 4
119              
120             =item * RT: CPAN's request tracker
121              
122             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-ActionRole-MatchHost>
123              
124             =item * AnnoCPAN: Annotated CPAN documentation
125              
126             L<http://annocpan.org/dist/Catalyst-ActionRole-MatchHost>
127              
128             =item * CPAN Ratings
129              
130             L<http://cpanratings.perl.org/d/Catalyst-ActionRole-MatchHost>
131              
132             =item * Search CPAN
133              
134             L<http://search.cpan.org/dist/Catalyst-ActionRole-MatchHost/>
135              
136             =back
137              
138              
139             =head1 ACKNOWLEDGEMENTS
140              
141              
142             =head1 COPYRIGHT & LICENSE
143              
144             Copyright 2009 Anatoliy Lapitskiy.
145              
146             This program is free software; you can redistribute it and/or modify it
147             under the terms of either: the GNU General Public License as published
148             by the Free Software Foundation; or the Artistic License.
149              
150             See http://dev.perl.org/licenses/ for more information.
151              
152              
153             =cut
154              
155              
156             1; # End of Catalyst::ActionRole::MatchHost