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.15';
   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     $c->subreq('/test/foo/bar', { template => 'magic.tt' });
  18
  19     $c->subreq(        {       path            => '/test/foo/bar',
  20                        body            => $body        },
  21                {       template        => 'magic.tt'           });
  22
  23 =head1 DESCRIPTION
  24
  25 Make subrequests to actions in Catalyst. Uses the  catalyst
  26 dispatcher, so it will work like an external url call.
  27
  28 =head1 METHODS
  29
  30 =over 4
  31
  32 =item subreq [path as string or hash ref], [stash as hash ref], [parameters as hash ref]
  33
  34 =item sub_request
  35
  36 Takes a full path to a path you'd like to dispatch to.
  37 If the path is passed as a hash ref then it can include body, action, match and path.
  38 Any additional parameters are put into the stash.
  39
  40 =back
  41
  42 =cut
  43
  44 *subreq = \&sub_request;
  45
  46 sub sub_request {
  47     my ( $c, $path, $stash, $params ) = @_;
  48
  49     $path =~ s#^/##;
  50
  51     $params ||= {};
  52
  53     my %request_mods = (
  54         body => undef,
  55         action => undef,
  56         match => undef,
  57         parameters => $params,
  58     );
  59
  60     if (ref $path eq 'HASH') {
  61         @request_mods{keys %$path} = values %$path;
  62     } else {
  63         $request_mods{path} = $path;
  64     }
  65     $request_mods{_body} = delete $request_mods{body};
  66
  67     my $fake_engine = bless(
  68         {
  69             orig_request => $c->req,
  70             request_mods => \%request_mods,
  71         },
  72         'Catalyst::Plugin::SubRequest::Internal::FakeEngine'
  73     );
  74
  75     my $class = ref($c);
  76
  77     no strict 'refs';
  78     no warnings 'redefine';
  79
  80     local *{"${class}::engine"} = sub { $fake_engine };
  81
  82     my $inner_ctx = $class->prepare;
  83
  84     $inner_ctx->stash($stash || {});
  85
  86
  87     $c->stats->profile(
  88         begin   => 'subrequest: /' . $path,
  89         comment => '',
  90     ) if ($c->debug);
  91
  92     $inner_ctx->dispatch;
  93
  94     $c->stats->profile( end => 'subrequest: /' . $path ) if ($c->debug);
  95
  96     return $inner_ctx->response->body;
  97 }
  98
  99 =head1 SEE ALSO
 100
 101 L<Catalyst>.
 102
 103 =head1 AUTHORS
 104
 105 Marcus Ramberg, C<mramberg@cpan.org>
 106
 107 Tomas Doran (t0m) C<< bobtfish@bobtfish.net >>
 108
 109 =head1 THANK YOU
 110
 111 SRI, for writing the awesome Catalyst framework
 112
 113 =head1 COPYRIGHT
 114
 115 Copyright (c) 2005 - 2008
 116 the Catalyst::Plugin::SubRequest L</AUTHORS>
 117 as listed above.
 118
 119 =head1 LICENSE
 120
 121 This program is free software, you can redistribute it and/or modify it under
 122 the same terms as Perl itself.
 123
 124 =cut
 125
 126 package # hide from PAUSE
 127   Catalyst::Plugin::SubRequest::Internal::FakeEngine;
 128
 129 sub AUTOLOAD { return 1; } # yeah yeah yeah
 130
 131 sub prepare {
 132     my ($self, $c) = @_;
 133     my $req = $c->request;
 134
 135     @{$req}{keys %{$self->{orig_request}}} = values %{$self->{orig_request}};
 136     while (my ($key,$value) = each %{$self->{request_mods}}) {
 137         if (my $mut = $req->can($key)) {
 138             $req->$mut($value);
 139         } else {
 140             $req->{$key} = $value;
 141         }
 142     }
 143 }
 144
 145 1;