lib/AnyEvent/HTTPD/Request.pm

   1 package AnyEvent::HTTPD::Request;
   2 use strict;
   3 no warnings;
   4
   5 =head1 NAME
   6
   7 AnyEvent::HTTPD::Request - A web application request handle for L<AnyEvent::HTTPD>
   8
   9 =head1 DESCRIPTION
  10
  11 This is the request object as generated by L<AnyEvent::HTTPD> and given
  12 in the request callbacks.
  13
  14 =head1 METHODS
  15
  16 =over 4
  17
  18 =cut
  19
  20 sub new {
  21    my $this  = shift;
  22    my $class = ref($this) || $this;
  23    my $self  = { @_ };
  24    bless $self, $class
  25 }
  26
  27 =item B<url>
  28
  29 This method returns the URL of the current request.
  30
  31 =cut
  32
  33 sub url {
  34    my ($self) = @_;
  35    my $url = $self->{url};
  36    my $u = URI->new ($url);
  37    $u->query (undef);
  38    $u
  39 }
  40
  41 sub is_form_submit {
  42    my ($self) = @_;
  43    defined $self->form_id
  44 }
  45
  46 sub form_id {
  47    my ($self) = @_;
  48    my $id = $self->parm ("_APP_SRV_FORM_ID");
  49    $id = $self->parm ("_afid") if defined $self->parm ("_afid");
  50    $id
  51 }
  52
  53 =item B<form ($content, $callback)>
  54
  55 This method will create a form for you and bind it to the C<$handler>
  56 you gave. The content of the form tag can be given by C<$content>, which
  57 can either be a string or a code reference, which will be called and should
  58 return the form content.
  59
  60 When the form is submitted the C<$callback> will be called before the submit
  61 request executes any of your content callbacks. The form ID is transmitted via
  62 a hidden input element with the name C<_APP_SRV_FORM_ID>, and you should take
  63 care not to use that form element name yourself.
  64
  65 The C<$callback> will receive as first argument the L<AnyEvent::HTTPD> object.
  66
  67 You can access the transmitted form parameters via the C<parm> method.
  68
  69 =cut
  70
  71 sub form {
  72    my ($self, $cont, $cb) = @_;
  73    my $id = $self->{httpd}->alloc_id ($cb);
  74    my $url = $self->url;
  75    '<form action="'.$url.'" method="POST" enctype="multipart/form-data">'
  76    .'<input type="hidden" name="_APP_SRV_FORM_ID" value="'.$id.'" />'
  77    .(ref $cont ? $cont->() : $cont)
  78    .'</form>'
  79 }
  80
  81 =item B<respond ([$res])>
  82
  83 This method will send a response to the request.
  84 If no C<$res> argument was given eventually accumulated output will be
  85 send as C<text/html>.
  86
  87 Otherwise C<$res> can be:
  88
  89 =over 4
  90
  91 =item * an array reference
  92
  93 Then the array reference has these elements:
  94
  95    my ($code, $message, $header_hash, $content) =
  96          [200, 'ok', { 'Content-Type' => 'text/html' }, '<h1>Test</h1>' }]
  97
  98 =item * a hash reference
  99
 100 If it was a hash reference the hash is first searched for the C<redirect>
 101 key and if that key does not exist for the C<content> key.
 102
 103 The value for the C<redirect> key should contain the URL that you want to redirect
 104 the request to.
 105
 106 The value for the C<content> key should contain an array reference with the first
 107 value being the content type and the second the content.
 108
 109 =back
 110
 111 Here is an example:
 112
 113    $httpd->reg_cb (
 114       '/image/elmex' => sub {
 115          my ($httpd, $req) = @_;
 116
 117          open IMG, "$ENV{HOME}/media/images/elmex.png"
 118             or $req->respond (
 119                   [404, 'not found', { 'Content-Type' => 'text/plain' }, 'not found']
 120                );
 121
 122          $req->respond ({ content => ['image/png', do { local $/; <IMG> }] });
 123       }
 124    );
 125
 126 =cut
 127
 128 sub respond {
 129    my ($self, $res) = @_;
 130
 131    my $rescb = $self->{resp};
 132
 133    if (ref $res eq 'HASH') {
 134       my $h = $res;
 135       if ($h->{redirect}) {
 136          $res = [
 137             301, 'redirected', { Location => $h->{redirect} },
 138             "Redirected to <a href=\"$h->{redirect}\">here</a>"
 139          ];
 140       } elsif ($h->{content}) {
 141          $res = [
 142             200, 'ok', { 'Content-Type' => $h->{content}->[0] },
 143             $h->{content}->[1]
 144          ];
 145       }
 146    }
 147
 148    if (not defined $res) {
 149       if ($self->{output} eq '') {
 150          $rescb->(404, "ok", { 'Content-Type' => 'text/html' }, "<h1>No content</h1>");
 151       } else {
 152          $rescb->(200, "ok", { 'Content-Type' => 'text/html' }, $self->{output});
 153       }
 154    } else {
 155       $rescb->(@$res);
 156    }
 157 }
 158
 159 =item B<link ($label, $callback, $newurl)>
 160
 161 This method returns a html link which will call C<$callback>
 162 when the user follows the link. It uses the C<_afid> param name,
 163 so take care not to use it for other things.
 164 C<$newurl> should be undef or the new (local) destination url,
 165 see also the C<url> method above.
 166
 167 =cut
 168
 169 sub link {
 170    my ($self, $lbl, $cb, $newurl) = @_;
 171    my $id = $self->{httpd}->alloc_id ($cb);
 172    unless (defined $newurl) { $newurl = $self->url; }
 173    '<a href="'.$newurl.'?_afid='.$id.'">'.$lbl.'</a>';
 174 }
 175
 176 =item B<parm ($key)>
 177
 178 Returns the first value of the form parameter C<$key> or undef.
 179
 180 =cut
 181
 182 sub parm {
 183    my ($self, $key) = @_;
 184    if (exists $self->{parm}->{$key}) {
 185       return $self->{parm}->{$key}->[0]->[0]
 186    }
 187    return undef;
 188 }
 189
 190 =item B<content>
 191
 192 Returns the request content or undef if only parameters for a form
 193 were transmitted.
 194
 195 =cut
 196
 197 sub content {
 198    my ($self) = @_;
 199    return $self->{content};
 200 }
 201
 202 =item B<o ($str)>
 203
 204 This method appends C<$str> to the response output of this request.
 205 The accumulated output can be sent back as 'text/html' by calling the
 206 C<respond> method without an argument.
 207
 208 =cut
 209
 210 sub o { shift->{output} .= join '', @_ }
 211
 212 =back
 213
 214 =head1 COPYRIGHT & LICENSE
 215
 216 Copyright 2008 Robin Redeker, all rights reserved.
 217
 218 This program is free software; you can redistribute it and/or modify it
 219 under the same terms as Perl itself.
 220
 221
 222 =cut
 223
 224 1;