File Coverage

blib/lib/WebDAO/Response.pm

Criterion	Covered	Total	%
statement	130	171	76.0
branch	18	38	47.3
condition	5	13	38.4
subroutine	27	37	72.9
pod	20	26	76.9
total	200	285	70.1

package WebDAO::Response;

=head1 NAME

WebDAO::Response - Response class

=head1 SYNOPSYS

        new WebDAO::Response:: cv => $cv

=head1 DESCRIPTION

Class for make HTTP response

=cut

our $VERSION = '0.01';
use Data::Dumper;
use WebDAO::Base;
use IO::File;
use DateTime;
use DateTime::Format::HTTP;
use base qw( WebDAO::Base );

__PACKAGE__->mk_attr(
    _headers => undef,
    _is_headers_printed =>0,
    _cv_obj => undef,
    _is_file_send => 0,
    _is_need_close_fh => 0,
    __fh => undef,
    _is_flushed => 0,
    _call_backs => undef,
    _is_modal => 0,
    _forced_want_format => undef,
    _is_empty=>0,
    status => 200 #default HTTP status
    );

use strict;
use warnings;

=head1 METHODS

=cut

sub new {
    my $class = shift;
    my $self  = {};
    my $stat;
    bless( $self, $class );
    $self->_init(@_);
    return $self;
}

sub _init {
    my $self = shift;
    return $self->init(@_);
}

sub init {
    my $self = shift;
    my %par  = @_;
    $self->_headers( {} );
    $self->_call_backs( [] );
    $self->_cv_obj( $par{cv} );
    return 1;
}

=head2 get_request

Return ref to request object (WebDAO::CV)

=cut

sub get_request {
    my $self = shift;
    return $self->_cv_obj;
}

=head2 set_status INT

set response HTTP status

    $r->set_status(200)

return C<$self>

=cut

sub set_status {
    my $self = shift;
    $self->status(@_);
    $self
}


=head2 set_header NAME, VALUE

Set out header:

        $response->set_header('Location', $redirect_url);
        $response->set_header( 'Content-Type' => 'text/html; charset=utf-8' );

return $self reference

=cut

sub set_header {
    my ( $self, $name, $par ) = @_;
    #translate CGI headers
    if ( $name =~ /^-/) {
            my $UKey = uc $name;

            if ( $UKey eq '-STATUS' ) {
                my ($status) = $par =~ m/(\d+)/;
                $self->status($status);
                return $self;
            }
            warn "Deprecated header name $name !";
    } elsif ( $name eq 'Set-Cookie') {
        push @{ $self->_headers->{ $name } }, $par;
        return $self
    }

    $self->_headers->{ $name } = $par;
    $self;
}



=head2 get_header NAME

return value for  header NAME:

=cut

sub get_header {
    my ( $self, $name ) = @_;
    return $self->_headers->{ $name };
}

=head2 aliases for headers

=head3 content_type

  $r->content_type('text/html; charset=utf-8');

=cut

sub content_type {
    my $self = shift;
    unless ($#_ > 0 ) {
        $self->set_header('Content-Type', @_)
    }
    $self->get_header('Content-Type');
}

=head3 content_length

A decimal number indicating the size in bytes of the message content.

=cut

sub content_length {
    my $self = shift;
    unless ($#_ > 0 ) {
      $self->set_header('Content-Length' , @_)
    }
    $self->get_header('Content-Length');
}

=head3

=head2 get_mime_for_filename

Determine mime type for filename (Simple by ext);
return str

=cut

sub get_mime_for_filename {
    my $self          = shift;
    my $filename      = shift;
    my $no_default_flag = shift;
    my %types_for_ext = (
        avi  => 'video/x-msvideo',
        bmp  => 'image/bmp',
        css  => 'text/css',
        gif  => 'image/gif',
        gz   => 'application/gzip',
        html => 'text/html',
        htm  => 'text/html',
        jpg  => 'image/jpeg',
        jpeg => 'image/jpeg',
        js   => 'application/javascript',
        midi => 'audio/midi',
        mp3  => 'audio/mpeg',
        mpeg => 'video/mpeg',
        mpg  => 'video/mpeg',
        mov  => 'video/quicktime',
        pdf  => 'application/pdf',
        png  => 'image/png',
        ppt  => 'application/vnd.ms-powerpoint',
        rtf  => 'text/rtf',
        tif  => 'image/tif',
        tiff => 'image/tif',
        txt  => 'text/plain',
        xls  => 'application/vnd.ms-excel',
        xml  => 'appliction/xml',
        wav  => 'audio/x-wav',
        zip  => 'application/zip',
    );
    my ($ext) = $filename =~ /\.(\w+)$/;
    if ( my $type = $types_for_ext{ lc $ext } ) {
        return $type;
    }
    return $no_default_flag ? undef : 'application/octet-stream';
}

=head2 print_header

print header.return $self reference

=cut

sub print_header {
    my $self  = shift;
    my $pnted = $self->_is_headers_printed;
    return $self if $pnted;
    my $cv      = $self->get_request;
    $cv->status($self->status);
    $cv->print_headers(%{ $self->_headers });
    $self->_is_headers_printed(1);
    $self;
}

=head2  redirect2url  [, $code]

Set headers for redirect to url.return $self reference

=cut

sub redirect2url {
    my ( $self, $redirect_url, $code ) = @_;
    $self->set_modal->set_status( $code || 302 );
    $self->set_header( 'Location', $redirect_url );
}

=head2 set_cookie ( name => , value=> ...)

Set cookie.
return $self reference

=cut

sub set_cookie {
    my $self = shift;
    $self->set_header("Set-Cookie", { @_ });
    $self;
}


=head2 set_callback(sub1{}[, sub2{} ..])

Set callbacks for call after flush

=cut

sub set_callback {
    my $self = shift;
    push @{ $self->_call_backs }, @_;
    return $self;
}

=head2 send_file || [, -type=>]

Prepare headers and save

    $respose->send_file($filename, -type=>'image/jpeg');

=cut

sub send_file {
    my $self = shift;
    my $file = shift;
    my %args = @_;
    my $file_handle;
    my $file_name;
    if ( ref $file
        and ( UNIVERSAL::isa( $file, 'IO::Handle' ) or ( ref $file ) eq 'GLOB' )
        or UNIVERSAL::isa( $file, 'Tie::Handle' ) )
    {
        $file_handle = $file;
    }
    else {
        $file_name   = $file;
        $file_handle = new IO::File::("< $file")
          or die "can't open file: $file" . $!;
        $self->_is_need_close_fh(1);
        $self->__fh($file_handle);
    }

    #set file headers
    my ( $size, $mtime ) = ( stat $file_handle )[ 7, 9 ];
    $self->content_length( $size );
    my $formated =
      DateTime::Format::HTTP->format_datetime(
        DateTime->from_epoch( epoch => $mtime ) );
    $self->set_header( 'Last-Modified', $formated );

    #Determine mime tape of file
    if ( my $predefined = $args{-type} ) {
        $self->content_type( $predefined );
    }
    else {
        ##
        if ($file_name) {
            $self->content_type(
                $self->get_mime_for_filename($file_name) );
        }
    }

    #set modal mode and flag for send file
    $self->set_modal->_is_file_send(1);
    $self;
}

sub print {
    my $self = shift;
    my $cv   = $self->get_request;
    $self->print_header;
    $cv->print(@_);
    return $self;
}

sub _print_dep_on_context {
    my ( $self, $session ) = @_;
    my $res = $self->html;
    $self->print( ref($res) eq 'CODE' ? $res->() : $res );
}

=head2 flush

Flush current state of response.

=cut

sub flush {
    my $self = shift;
    return $self if $self->_is_flushed;
    $self->print_header;

    #do self print file
    if ( $self->_is_file_send ) {
        my $fd = $self->__fh;
        $self->get_request->print(<$fd>);
        close($fd) if $self->_is_need_close_fh;
    }
    $self->_is_flushed(1);

    #do callbacks
    my $ref_calls = $self->_call_backs;
    while ( my $code = pop @$ref_calls ) {
        $code->();
    }

    #clear callbacks
    @{ $self->_call_backs } = ();
    $self;
}

=head2 set_modal

Set modal mode for answer

=cut

sub set_modal {
    my $self = shift;
    $self->_is_modal(1);
    $self;
}

=head2 error404

Set HTTP 404 headers

=cut

sub error404 {
    my $self = shift;
    $self->set_modal->set_status(404);
    $self->print(@_) if @_;
    return $self;
}

sub html : lvalue {
    my $self = shift;
    $self->{__html};
}

sub set_html {
    my $self = shift;
    my $data = shift;
    $self->html = $data;
    return $self;
}

sub json : lvalue {
    my $self = shift;
    $self->{__json};

}

sub set_json {
    my $self = shift;
    my $data = shift;
    $self->json = $data;
    return $self;
}

sub _destroy {
    my $self = shift;
    $self->{__html} = undef;
    #destroy called from Engine::execute2
    # destroy tests by cleared _cv_obj
#    $self->_cv_obj( undef );
    $self->_headers( {} );
    $self->_call_backs( [] );
}

=head2 wantformat ['format',['forse_set_format']]

Return expected output format: defauilt html

       # return string for format
       $r->wantformat()

Check if desired format is expected

  #$r->wantformat('html') return boolean
  if ($r->wantformat('html')) {
      #
  }

Force set desired format:

  $r->wantformat('html'=>1); #return $response object ref

=cut

sub wantformat {
    my $self = shift;
    if ( @_ > 1 ) {
        $self->_forced_want_format(shift);
        return $self;
    }
    my $desired = $self->_forced_want_format();
    my $default =
         $desired
      || $self->detect_wantformat( $self->get_request ) #call with CV object
      || 'html';
    if ( scalar(@_) == 1 ) {
        return $default eq shift;
    }
    return $default;
}

=head2 detect_wantformat ($cv)

Method for detect output format when C called

Must return :

        string  - output format, i.e. 'html', 'xml'
        undef - unknown ( use defaults )

=cut

sub detect_wantformat {
    return undef    #unknown by default
}


=head2 set_empty

Set flag for empty response. Headers are not printed.
return $self
=cut

sub set_empty { $_[0]->_is_empty(1); $_[0]}

=head2 is_empty

Check is response cleared.
Return 1|0

=cut

sub is_empty { return $_[0]->_is_empty() }

1;
__DATA__