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 sub_request
  48
  49 Takes a full path to a path you'd like to dispatch to.
  50
  51 If the path is passed as a hash ref then it can include body, action,
  52 match and path.
  53
  54 An optional second argument as hashref can contain data to put into the
  55 stash of the subrequest.
  56
  57 An optional third argument as hashref can contain data to pass as
  58 parameters to the subrequest.
  59
  60 Returns the body of the response.
  61
  62 =item subreq_res [path as string or hash ref], [stash as hash ref], [parameters as hash ref]
  63
  64 =item sub_request_response
  65
  66 Like C<sub_request()>, but returns a full L<Catalyst::Response> object.
  67
  68 =back
  69
  70 =cut
  71
  72 *subreq = \&sub_request;
  73 *subreq_res = \&sub_request_response;
  74
  75 sub sub_request {
  76     return shift->sub_request_response( @_ )->body ;
  77 }
  78
  79 sub sub_request_response {
  80     my ( $c, $path, $stash, $params ) = @_;
  81
  82     $path =~ s#^/##;
  83
  84     $params ||= {};
  85
  86     my %request_mods = (
  87         body => undef,
  88         action => undef,
  89         match => undef,
  90         parameters => $params,
  91     );
  92
  93     if (ref $path eq 'HASH') {
  94         @request_mods{keys %$path} = values %$path;
  95     } else {
  96         $request_mods{path} = $path;
  97     }
  98     $request_mods{_body} = delete $request_mods{body};
  99
 100     my $fake_engine = bless(
 101         {
 102             orig_request => $c->req,
 103             request_mods => \%request_mods,
 104         },
 105         'Catalyst::Plugin::SubRequest::Internal::FakeEngine'
 106     );
 107
 108     my $class = ref($c);
 109
 110     no strict 'refs';
 111     no warnings 'redefine';
 112
 113     local *{"${class}::engine"} = sub { $fake_engine };
 114
 115     my $inner_ctx = $class->prepare;
 116
 117     $inner_ctx->stash($stash || {});
 118
 119
 120     $c->stats->profile(
 121         begin   => 'subrequest: /' . $path,
 122         comment => '',
 123     ) if ($c->debug);
 124
 125     $inner_ctx->dispatch;
 126
 127     $c->stats->profile( end => 'subrequest: /' . $path ) if ($c->debug);
 128
 129     return $inner_ctx->response;
 130 }
 131
 132 =head1 SEE ALSO
 133
 134 L<Catalyst>.
 135
 136 =head1 AUTHORS
 137
 138 Marcus Ramberg, C<mramberg@cpan.org>
 139
 140 Tomas Doran (t0m) C<< bobtfish@bobtfish.net >>
 141
 142 =head1 THANK YOU
 143
 144 SRI, for writing the awesome Catalyst framework
 145
 146 =head1 COPYRIGHT
 147
 148 Copyright (c) 2005 - 2008
 149 the Catalyst::Plugin::SubRequest L</AUTHORS>
 150 as listed above.
 151
 152 =head1 LICENSE
 153
 154 This program is free software, you can redistribute it and/or modify it under
 155 the same terms as Perl itself.
 156
 157 =cut
 158
 159 package # hide from PAUSE
 160   Catalyst::Plugin::SubRequest::Internal::FakeEngine;
 161
 162 sub AUTOLOAD { return 1; } # yeah yeah yeah
 163
 164 sub prepare {
 165     my ($self, $c) = @_;
 166     my $req = $c->request;
 167
 168     @{$req}{keys %{$self->{orig_request}}} = values %{$self->{orig_request}};
 169     while (my ($key,$value) = each %{$self->{request_mods}}) {
 170         if (my $mut = $req->can($key)) {
 171             $req->$mut($value);
 172         } else {
 173             $req->{$key} = $value;
 174         }
 175     }
 176 }
 177
 178 1;