File Coverage

blib/lib/WebDAO/Session.pm

Criterion	Covered	Total	%
statement	41	72	56.9
branch	0	10	0.0
condition	2	5	40.0
subroutine	10	17	58.8
pod	2	9	22.2
total	55	113	48.6

package WebDAO::Session;
#$Id$

=head1 NAME

WebDAO::Session - Session interface to protocol specific function

=head1 DESCRIPTION

Session interface to device(HTTP protocol) specific function

=cut


our $VERSION = '0.02';
use WebDAO;
use WebDAO::CV;
use WebDAO::Response;
use Encode qw(encode decode is_utf8);
use strict;
use warnings;

mk_attr(
    Cgi_obj => undef, # request object
    Cgi_env => undef,
    U_id=> undef,
    Params => undef,
    _response_obj=> undef, #deprecated ?
    _is_absolute_url =>undef #deprecated ?
);

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


sub _init {
    #Parametrs is realm
    my $self = shift;
    my %args = @_;
    U_id $self undef;
    Cgi_obj $self $args{cv}
      || new WebDAO::CV::;    #create default controller
    my $cv = $self->Cgi_obj;           # Store Cgi_obj in local var
                                      #create response object
    $self->_response_obj(
        new WebDAO::Response::
        cv => $cv
    );

    Cgi_env $self (
        {
            url => $cv->url( -base => 1 ),    #http://eng.zag
            path_info         => $cv->url( -absolute => 1, -path_info => 1 ),
            path_info_elments => [],
            file              => "",
            base_url     => $cv->url( -base => 1 ),    #http://base.com
            accept       => $cv->accept,
        }
    );

    Params $self ( $self->_get_params() );
    $self->Cgi_env->{path_info_elments} = $self->call_path($self->Cgi_env->{path_info});
    #set default header
    $cv->set_header("Content-Type" => 'text/html; charset=utf-8');
}


#Get cgi params;
sub _get_params {
    my $self = shift;
    my $_cgi = $self->Cgi_obj();
    my %params;
    foreach my $i ( $_cgi->param()  ) {
        my @all = $_cgi->param($i);
        foreach my $value (@all) {
            next if ref $value;
            $value = decode( 'utf8', $value ) unless is_utf8($value);
        }
        $params{$i} = scalar @all > 1 ? \@all : $all[0];
    }
    return \%params;
}


#Can be overlap if you choose another
#alghoritm generate unique session ID (i.e cookie,http_auth)
sub get_id {
    my $self = shift;
    my $coo  = U_id $self;
    return $coo if ($coo);
    return rand(100);
}

=head2 call_path [$url]

Return ref to array of element from $url or from CGI ENV

=cut

sub call_path {
    my $self = shift;
    my $url = shift || return $self->Cgi_env->{path_info_elments};
    $url =~ s%^/%%;
    $url =~ s%/$%%;
    return [ grep { defined $_ } split( /\//, $url ) ];

}

=head2  set_absolute_url 1|0

Set flag for build absolute pathes. Return previus value.

=cut

sub set_absolute_url {
    my $self       = shift;
    my $value      = shift;
    my $prev_value = $self->_is_absolute_url;
    $self->_is_absolute_url($value) if defined $value;
    return $prev_value;
}

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

#deprecated ??? use WebDAO::Engine::response
sub response_obj {
    my $self = shift;
    return $self->_response_obj;
}

sub print {
    my $self = shift;
    $self->Cgi_obj->print(@_);
}

sub ExecEngine {
    my ( $self, $eng_ref,$path ) = @_;
    $eng_ref->_execute($self, $path);
    $eng_ref->__send_event__("_sess_ended"); # TODO: deprecated : delete this line
    $eng_ref->_commit();
    $eng_ref->_destroy;
}

sub destroy {
    my $self = shift;
    $self->_response_obj(undef);
}
1;
__DATA__

=head1 SEE ALSO

http://webdao.sourceforge.net

=head1 AUTHOR

Zahatski Aliaksandr, E<lt>[e-mail]<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2002-2012 by Zahatski Aliaksandr

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut