lib/BS/HTTPD/Request.pm

   1 package BS::HTTPD::Request;
   2 use feature ':5.10';
   3 use strict;
   4 no warnings;
   5
   6 =head1 NAME
   7
   8 BS::HTTPD::Request - A web application request handle for L<BS::HTTPD>
   9
  10 =cut
  11
  12 sub new {
  13    my $this  = shift;
  14    my $class = ref($this) || $this;
  15    my $self  = { @_ };
  16    bless $self, $class
  17 }
  18
  19 =item B<url>
  20
  21 This method returns the URL of the current request.
  22
  23 =cut
  24
  25 sub url {
  26    my ($self) = @_;
  27    my $url = $self->{cur_url};
  28    my $u = URI->new ($url);
  29    $u->query (undef);
  30    $u
  31 }
  32
  33 sub is_form_submit {
  34    my ($self) = @_;
  35    defined $self->form_id
  36 }
  37
  38 sub form_id {
  39    my ($self) = @_;
  40    my $id = $self->parm ("_APP_SRV_FORM_ID");
  41    $id = $self->parm ("a") if defined $self->parm ("a");
  42    $id
  43 }
  44
  45 =item B<form ($content, $callback)>
  46
  47 This method will create a form for you and bind it to the C<$handler>
  48 you gave. The content of the form tag can be given by C<$content>, which
  49 can either be a string or a code reference, which will be called and should
  50 return the form content.
  51
  52 When the form is submitted the C<$callback> will be called before the submit
  53 request executes any of your content callbacks. The form ID is transmitted via
  54 a hidden input element with the name C<_APP_SRV_FORM_ID>, and you should take
  55 care not to use that form element name yourself.
  56
  57 The C<$callback> will receive as first argument the L<BS::HTTPD> object.
  58
  59 You can access the transmitted form parameters via the C<parm> method.
  60
  61 =cut
  62
  63 sub form {
  64    my ($self, $cont, $cb) = @_;
  65    my $id = $self->{httpd}->alloc_id ($cb);
  66    my $url = $self->url;
  67    '<form action="'.$url.'" method="POST" enctype="multipart/form-data">'
  68    .'<input type="hidden" name="_APP_SRV_FORM_ID" value="'.$id.'" />'
  69    .(ref $cont ? $cont->() : $cont)
  70    .'</form>'
  71 }
  72
  73 =item B<respond ([$res])>
  74
  75 This method will send a response to the request.
  76 If no C<$res> argument was given eventually accumulated output will be
  77 send as C<text/html>.
  78
  79 Otherweis C<$res> can be:
  80
  81 =over 4
  82
  83 =item * an array reference
  84
  85 Then the array reference has these elements:
  86
  87    my ($code, $message, $header_hash, $content) =
  88          [200, 'ok', { 'Content-Type' => 'text/html' }, '<h1>Test</h1>' }]
  89
  90 =item * a hash reference
  91
  92 If it was a hash reference the hash is first searched for the C<redirect>
  93 key and if that key does not exist for the C<content> key.
  94
  95 The value for the C<redirect> key should contain the URL that you want to redirect
  96 the request to.
  97
  98 The value for the C<content> key should contain an array reference with the first
  99 value being the content type and the second the content.
 100
 101 =back
 102
 103 Here is an example:
 104
 105    $httpd->reg_cb (
 106       _image_elmex => sub {
 107          my ($httpd, $req) = @_;
 108
 109          open IMG, "$ENV{HOME}/media/images/elmex.png"
 110             or $req->respond (
 111                   [404, 'not found', { 'Content-Type' => 'text/plain' }, 'not found']
 112                );
 113
 114          $req->respond ({ content => ['image/png', do { local $/; <IMG> }] });
 115       }
 116    );
 117
 118 =cut
 119
 120 sub respond {
 121    my ($self, $res) = @_;
 122
 123    my $rescb = $self->{resp};
 124
 125    if (ref $res eq 'HASH') {
 126       my $h = $res;
 127       if ($h->{redirect}) {
 128          $res = [
 129             301, 'redirected', { Location => $h->{redirect} },
 130             "Redirected to <a href=\"$h->{redirect}\">here</a>"
 131          ];
 132       } elsif ($h->{content}) {
 133          $res = [
 134             200, 'ok', { 'Content-Type' => $h->{content}->[0] },
 135             $h->{content}->[1]
 136          ];
 137       }
 138    }
 139
 140    if (not defined $res) {
 141       if ($self->{output} eq '') {
 142          $rescb->(404, "ok", { 'Content-Type' => 'text/html' }, "<h1>No content</h1>");
 143       } else {
 144          $rescb->(200, "ok", { 'Content-Type' => 'text/html' }, $self->{output});
 145       }
 146    } else {
 147       $rescb->(@$res);
 148    }
 149 }
 150
 151 sub link {
 152    my ($self, $lbl, $cb, $newurl) = @_;
 153    my $id = $self->{httpd}->alloc_id ($cb);
 154    $newurl //= $self->url;
 155    '<a href="'.$newurl.'?a='.$id.'">'.$lbl.'</a>';
 156 }
 157
 158 sub parm {
 159    my ($self, $key) = @_;
 160    if (exists $self->{parm}->{$key}) {
 161       return $self->{parm}->{$key}->[0]->[0]
 162    }
 163    return undef;
 164 }
 165
 166 sub content {
 167    my ($self) = @_;
 168    return $self->{content};
 169 }
 170
 171 sub o { shift->{output} .= join '', @_ }
 172
 173
 174 1;