lib/Catalyst/Plugin/SubRequest.pm

   1 package Catalyst::Plugin::SubRequest;
   2
   3 use strict;
   4 use warnings;
   5 use Time::HiRes qw/tv_interval/;
   6
   7 our $VERSION = '0.17';
   8
   9 =head1 NAME
  10
  11 Catalyst::Plugin::SubRequest - Make subrequests to actions in Catalyst
  12
  13 =head1 SYNOPSIS
  14
  15     use Catalyst 'SubRequest';
  16
  17     my $res_body = $c->subreq('/test/foo/bar', { template => 'magic.tt' });
  18
  19     my $res_body = $c->subreq( {
  20        path            => '/test/foo/bar',
  21        body            => $body
  22     }, {
  23        template        => 'magic.tt'
  24     });
  25
  26     # Get the full response object
  27     my $res = $c->subreq_res('/test/foo/bar', {
  28         template => 'mailz.tt'
  29     }, {
  30         param1   => 23
  31     });
  32     $c->log->warn( $res->content_type );
  33
  34 =head1 DESCRIPTION
  35
  36 Make subrequests to actions in Catalyst. Uses the  catalyst
  37 dispatcher, so it will work like an external url call.
  38 Methods are provided both to get the body of the response and the full
  39 response (L<Catalyst::Response>) object.
  40
  41 =head1 METHODS
  42
  43 =over 4
  44
  45 =item subreq [path as string or hash ref], [stash as hash ref], [parameters as hash ref]
  46
  47 =item subrequest
  48
  49 =item sub_request
  50
  51 Takes a full path to a path you'd like to dispatch to.
  52
  53 If the path is passed as a hash ref then it can include body, action,
  54 match and path.
  55
  56 An optional second argument as hashref can contain data to put into the
  57 stash of the subrequest.
  58
  59 An optional third argument as hashref can contain data to pass as
  60 parameters to the subrequest.
  61
  62 Returns the body of the response.
  63
  64 =item subreq_res [path as string or hash ref], [stash as hash ref], [parameters as hash ref]
  65
  66 =item subrequest_response
  67
  68 =item sub_request_response
  69
  70 Like C<sub_request()>, but returns a full L<Catalyst::Response> object.
  71
  72 =back
  73
  74 =cut
  75
  76 *subreq = \&sub_request;
  77 *subrequest = \&sub_request;
  78 *subreq_res = \&sub_request_response;
  79 *subrequest_response = \&sub_request_response;
  80
  81 sub sub_request {
  82     return shift->sub_request_response( @_ )->body ;
  83 }
  84
  85 sub sub_request_response {
  86     my ( $c, $path, $stash, $params ) = @_;
  87
  88     $path =~ s#^/##;
  89
  90     $params ||= {};
  91
  92     my %request_mods = (
  93         body => undef,
  94         action => undef,
  95         match => undef,
  96         parameters => $params,
  97     );
  98
  99     if (ref $path eq 'HASH') {
 100         @request_mods{keys %$path} = values %$path;
 101         $path = $path->{path};
 102     } else {
 103         $request_mods{path} = $path;
 104     }
 105     $request_mods{_body} = delete $request_mods{body};
 106
 107     my $fake_engine = bless(
 108         {
 109             orig_request => $c->req,
 110             request_mods => \%request_mods,
 111         },
 112         'Catalyst::Plugin::SubRequest::Internal::FakeEngine'
 113     );
 114
 115     my $class = ref($c);
 116
 117     no strict 'refs';
 118     no warnings 'redefine';
 119
 120     local *{"${class}::engine"} = sub { $fake_engine };
 121
 122     my $inner_ctx = $class->prepare;
 123
 124     $inner_ctx->stash($stash || {});
 125
 126
 127     $c->stats->profile(
 128         begin   => 'subrequest: /' . $path,
 129         comment => '',
 130     ) if ($c->debug);
 131
 132     $inner_ctx->dispatch;
 133
 134     $c->stats->profile( end => 'subrequest: /' . $path ) if ($c->debug);
 135
 136     return $inner_ctx->response;
 137 }
 138
 139 =head1 SEE ALSO
 140
 141 L<Catalyst>.
 142
 143 =head1 AUTHORS
 144
 145 Marcus Ramberg, C<mramberg@cpan.org>
 146
 147 Tomas Doran (t0m) C<< bobtfish@bobtfish.net >>
 148
 149 =head1 THANK YOU
 150
 151 SRI, for writing the awesome Catalyst framework
 152
 153 =head1 COPYRIGHT
 154
 155 Copyright (c) 2005 - 2011
 156 the Catalyst::Plugin::SubRequest L</AUTHORS>
 157 as listed above.
 158
 159 =head1 LICENSE
 160
 161 This program is free software, you can redistribute it and/or modify it under
 162 the same terms as Perl itself.
 163
 164 =cut
 165
 166 package # hide from PAUSE
 167   Catalyst::Plugin::SubRequest::Internal::FakeEngine;
 168
 169 sub AUTOLOAD { return 1; } # yeah yeah yeah
 170
 171 sub prepare {
 172     my ($self, $c) = @_;
 173     my $req = $c->request;
 174
 175     @{$req}{keys %{$self->{orig_request}}} = values %{$self->{orig_request}};
 176     while (my ($key,$value) = each %{$self->{request_mods}}) {
 177         if (my $mut = $req->can($key)) {
 178             $req->$mut($value);
 179         } else {
 180             $req->{$key} = $value;
 181         }
 182     }
 183 }
 184
 185 1;