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.16';
   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     } else {
 102         $request_mods{path} = $path;
 103     }
 104     $request_mods{_body} = delete $request_mods{body};
 105
 106     my $fake_engine = bless(
 107         {
 108             orig_request => $c->req,
 109             request_mods => \%request_mods,
 110         },
 111         'Catalyst::Plugin::SubRequest::Internal::FakeEngine'
 112     );
 113
 114     my $class = ref($c);
 115
 116     no strict 'refs';
 117     no warnings 'redefine';
 118
 119     local *{"${class}::engine"} = sub { $fake_engine };
 120
 121     my $inner_ctx = $class->prepare;
 122
 123     $inner_ctx->stash($stash || {});
 124
 125
 126     $c->stats->profile(
 127         begin   => 'subrequest: /' . $path,
 128         comment => '',
 129     ) if ($c->debug);
 130
 131     $inner_ctx->dispatch;
 132
 133     $c->stats->profile( end => 'subrequest: /' . $path ) if ($c->debug);
 134
 135     return $inner_ctx->response;
 136 }
 137
 138 =head1 SEE ALSO
 139
 140 L<Catalyst>.
 141
 142 =head1 AUTHORS
 143
 144 Marcus Ramberg, C<mramberg@cpan.org>
 145
 146 Tomas Doran (t0m) C<< bobtfish@bobtfish.net >>
 147
 148 =head1 THANK YOU
 149
 150 SRI, for writing the awesome Catalyst framework
 151
 152 =head1 COPYRIGHT
 153
 154 Copyright (c) 2005 - 2008
 155 the Catalyst::Plugin::SubRequest L</AUTHORS>
 156 as listed above.
 157
 158 =head1 LICENSE
 159
 160 This program is free software, you can redistribute it and/or modify it under
 161 the same terms as Perl itself.
 162
 163 =cut
 164
 165 package # hide from PAUSE
 166   Catalyst::Plugin::SubRequest::Internal::FakeEngine;
 167
 168 sub AUTOLOAD { return 1; } # yeah yeah yeah
 169
 170 sub prepare {
 171     my ($self, $c) = @_;
 172     my $req = $c->request;
 173
 174     @{$req}{keys %{$self->{orig_request}}} = values %{$self->{orig_request}};
 175     while (my ($key,$value) = each %{$self->{request_mods}}) {
 176         if (my $mut = $req->can($key)) {
 177             $req->$mut($value);
 178         } else {
 179             $req->{$key} = $value;
 180         }
 181     }
 182 }
 183
 184 1;