File Coverage

blib/lib/HTML/WebDAO/Session.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

#$Id: Session.pm 292 2008-06-15 08:24:28Z zag $

package HTML::WebDAO::Session;
use HTML::WebDAO::Base;
use HTML::WebDAO::CVcgi;
use HTML::WebDAO::Store::Abstract;
use HTML::WebDAO::Response;
use Data::Dumper;
use base qw( HTML::WebDAO::Base );
use Encode qw(encode decode is_utf8);
use strict;
__PACKAGE__->attributes
  qw( Cgi_obj Cgi_env U_id Header Params  _store_obj _response_obj _is_absolute_url);

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

#Need to be forever called from over classes;
sub Init {

    #Parametrs is realm
    my $self = shift;
    my %args = @_;
    Header $self ( {} );
    U_id $self undef;
    Cgi_obj $self $args{cv}
      || new HTML::WebDAO::CVcgi::;    #create default controller
    my $cv = $self->Cgi_obj;           # Store Cgi_obj in local var
                                       #create response object
    $self->_response_obj(
        new HTML::WebDAO::Response::
          session => $self,
        cv => $cv
    );
    _store_obj $self ( $args{store} || new HTML::WebDAO::Store::Abstract:: );

    #workaround for CGI.pm: http://rt.cpan.org/Ticket/Display.html?id=36435
    my %accept = ();
    if ( $cv->http('accept') ) {
        %accept = map { $_ => $cv->Accept($_) } $cv->Accept();
    }
    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
            query_string => $cv->query_string,
            referer      => $cv->referer(),
            accept       => \%accept
        }
    );

    #fix CGI.pm bug http://rt.cpan.org/Ticket/Display.html?id=25908
    $self->Cgi_env->{path_info} =~ s/\?.*//s;
    $self->get_id;
    Params $self ( $self->_get_params() );
    $self->Cgi_env->{path_info_elments} =
      [ grep { defined $_ } split( /\//, $self->Cgi_env->{path_info} ) ];

}

#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 _load_attributes_by_path {
    my $self = shift;
    $self->_store_obj->_load_attributes( $self->get_id(), @_ );
}

sub _store_attributes_by_path {
    my $self = shift;
    $self->_store_obj->_store_attributes( $self->get_id(), @_ );
}

sub flush_session {
    my $self = shift;
    $self->_store_obj->flush( $self->get_id() );
}

sub response_obj {
    my $self = shift;
    return $self->_response_obj;
}

#Session interface to device(HTTP protocol) specific function
#$self->SendEvent("_sess_servise",{
#		funct 	=> geturl,
#		par	=> $ref,
#		result	=> \$res
#});

sub sess_servise {
    my ( $self, $event_name, $par ) = @_;
    my %service = (
        geturl  => sub { $self->sess_servise_geturl(@_) },
        getenv  => sub { $self->sess_servise_getenv(@_) },
        getsess => sub { return $self },
    );
    if ( exists( $service{ $par->{funct} } ) ) {
        ${ $par->{result} } = $service{ $par->{funct} }->( $par->{par} );
    }
    else {
        logmsgs $self "not exist request funct !" . $par->{funct};
    }
}

#
#{variable=>{
#			name=>Par,
#			value=>"10"},
#event	=>{
#			name=>"_info_on",
#			value=>"10"
#			}})
sub sess_servise_geturl {
    my ( $self, $par ) = @_;
    my $str;
    $str = $par->{path} || '';
    if ( exists( $par->{event} ) ) {
        $str .= "ev/evn_"
          . $par->{event}->{name} . "/"
          . $par->{event}->{value} . "/";
    }
    if ( exists( $par->{variable} ) ) {
        $par->{variable}->{name} =~ s/\./\//g;
        $str .= "par/"
          . $par->{variable}->{name} . "/"
          . $par->{variable}->{value} . "/";
    }
    $str .= ( exists( $par->{file} ) ) ? $par->{file} : $self->Cgi_env->{file};
    if ( ref( $par->{pars} ) eq 'HASH' ) {
        my @pars;
        while ( my ( $key, $val ) = each %{ $par->{pars} } ) {
            push @pars, "$key=$val";
        }
        $str .= "?" . join "&" => @pars;
    }

    #set absolute path
    $str = $self->Cgi_env->{base_url} . $str if $self->set_absolute_url;
    return $str;
}

#get current session enviro-ent
sub sess_servise_getenv {
    my ($self) = @_;
    return $self->Cgi_env;
}

sub response {
    my $self = shift;
    my $res  = shift;

    #    unless $res->type
    return if $res->{cleared};
    my $headers = $self->Header();
    $headers->{-TYPE} = $res->{type} if $res->{type};
    while ( my ( $key, $val ) = each %$headers ) {
        my $UKey = uc $key;
        $res->{headers}->{$UKey} = $headers->{$UKey}
          unless exists $res->{headers}->{$UKey};
    }

    #    $res->{headers} = $headers;
    $self->Cgi_obj->response($res);
}

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

sub ExecEngine() {
    my ( $self, $eng_ref ) = @_;

    #print $self->print_header();
    $eng_ref->RegEvent( $self, "_sess_servise", \&sess_servise );
    $eng_ref->Work($self);
    $eng_ref->SendEvent("_sess_ended");

    #print @{$eng_ref->Fetch()};
    $eng_ref->_destroy;
    $self->flush_session();

}

#for setup Output headers
sub set_header {
    my $self     = shift;
    my $response = $self->response_obj;
    return $self->response_obj->set_header(@_)

}

#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;
}

sub print_header() {
    my ($self) = @_;
    my $_cgi   = $self->Cgi_obj();
    my $ref    = $self->Header();
    return $self->response( { data => '', } );
    return $_cgi->header( map { $_ => $ref->{$_} } keys %{ $self->Header() } );
}

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