File Coverage

blib/lib/ZM/Session.pm

Criterion	Covered	Total	%
statement	3	182	1.6
branch	0	78	0.0
condition	0	9	0.0
subroutine	1	19	5.2
pod	10	18	55.5
total	14	306	4.5

package ZM::Session;
$ZM::Session::VERSION = '0.2.1';
use strict;

sub new
{
    my ($c, %args) = @_;
    my $class = ref($c) || $c;
    $args{SID} = $args{id};
    bless \%args, $class;
}

sub start
{
	my ($cl,$print_content,$no_cookie, $double_enter) = @_;
    if (!defined($cl->{lifetime}))
	{
		$cl->{lifetime} = 600;
	}
    if (!defined($cl->{path}))
	{
		$cl->{path} = "/tmp/";
	}
    # Set ID if not defined
    if ((!defined($cl->{SID})) || ((length($cl->{SID}) == 0)))
	{
		$cl->id($cl->newID());
	}
	if($no_cookie eq "")
	{
		#SET COOKIE
		my @week=("Sunday","Monday","Tuesday","Wednesday","Thursday","Friday","Saturday");
		my @months=("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec");
		my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday)=gmtime(time()+$cl->{lifetime});
		my $t=sprintf("%s, %02d-%s-%02d %02d:%02d:%02d GMT",$week[$wday],$mday,$months[$mon],$year % 100,$hour,$min,$sec);
		print "Content-type: text/html\n" if($print_content ne "nocontent");
		print $cl->{head};
		print "Set-Cookie: SID=".$cl->id."; expires=".$t."; path=/\n";
		print "\n" if $double_enter eq "";
	}
    if (-e $cl->getfile())
	{
		return 0;
	}
    open(SF,">".$cl->getfile());
	close(SF);
    $cl->check_sessions();
	#SET IP
	if (defined($cl->{check_ip}))
	{
		$cl->set("SID_IP",$ENV{REMOTE_ADDR});
	}
    return 1;
}

sub check_sessions
{
    my $cl = shift;
    opendir(SD,$cl->{path});
    my @files = readdir(SD);
#    shift @files;
#    shift @files;
    foreach my $f (@files)
	{
	    next if $f!~/^zm_sess_/;
		if (((stat($cl->{path}.$f))[9] + $cl->{lifetime}) < time())
		{
			unlink($cl->{path}.$f);
		}
	}
    closedir(SD);
}

sub destroy
{
    my $cl = shift;
    if (!$cl->have_id())
	{
		return -1;
	}
    if (-e $cl->getfile())
	{
		unlink($cl->getfile());
	}
    undef $cl->{SID};
    if (defined($cl->{id}))
	{
		undef $cl->{id};
	}
    return 1;
}

sub exists
{
    my ($cl,$id) = @_;
    if (!defined($id))
	{
		return 0;
	}
    my $file = $cl->{path}."zm_sess_".$cl->{$id};
    if (-e $file)
	{
		return 1;
	}
    return 0;
}

sub have_id
{
    my $cl = shift;
    if (!defined($cl->{SID}))
	{
		return 0;
	}
    return 1;
}

sub set_path
{
    my ($cl, $path) = @_;
    if (defined($path)) { $cl->{path} = $path }
    return $cl->{path};
}

sub id
{
    my ($cl, $newid) = @_;
    if (defined($newid))
	{
		$cl->{SID} = $newid;
	}
	if (!$cl->have_id())
	{
		return -1;
	}
    return $cl->{SID};
}

sub getfile
{
    my $cl = shift;
    return $cl->{path}."zm_sess_".$cl->{SID};
}

sub is_set
{
    my ($cl,$name) = @_;
    if (!$cl->have_id())
	{
		return -1;
	}
    if (-e $cl->getfile())
	{
		open(SF,$cl->getfile);
		while (my $l = )
		{
	    	my @line = split (/=/,$l);
		    if ($line[0] eq $name) {
			close(SF);
			return 1;
			}
	    }
		close(SF);
    }
    return 0;
}

sub list
{
    my ($cl) = @_;
    my %h;
    if (!$cl->have_id())
	{
		return -1;
	}
    if (-e $cl->getfile())
    {
	open(SF,$cl->getfile);
	while (my $l = )
	{
	    my @line = split (/=/,$l);
	    $h{$line[0]}=$line[1];
	}
	close(SF);
	return %h;
    }
    return 0;
}

sub unset
{
    my ($cl,$name) = @_;
    my $content = "";
    if (!$cl->have_id())
	{
		return -1;
	}
    if (!$cl->is_set($name))
	{
		return 0;
	}
    open(SF,$cl->getfile());
    while (my $l = )
	{
    	$l =~ s/^$name=(.*?)\n//i;
    	$content .= $l;
	}
	close(SF);
    open(SF,">".$cl->getfile());
    print SF $content;
    close(SF);
}

sub unsetall
{
    my ($cl,$name) = @_;
    my $content = "";
	if (!$cl->have_id())
	{
		return -1;
	}
	if (-e $cl->getfile())
	{
		return 0;
	}
    open(SF,">".$cl->getfile());
	close(SF);
    $cl->check_sessions();

    return 1;
}

sub get
{
    my ($cl,$name) = @_;
    $name=~s/(\(|\))/\\$1/;
    if (!$cl->have_id())
	{
		return -1;
	}
	if (-e $cl->getfile())
	{
		open(SF,$cl->getfile());
		while (my $l = )
		{
	    	if ($l =~ /^$name=(.*?)\n/i)
			{
				close(SF);
				return $1;
			}
	    }
		close(SF);
    }
	else
	{
    	return -1;
    }
	return "";
}

sub set
{
    my ($cl,$name,$value) = @_;
    if (!$cl->have_id()) { return -1; }
	if (-e $cl->getfile())
	{
		my $content = "";
		my $flag=0;
		open(SF,$cl->getfile());
		while (my $l = )
		{
			$flag=1 if($l =~ s/^$name=(.*?)\n/$name=$value\n/gis);
	    	$content .= $l;
	    }
		close(SF);
		if(!$flag)
		{
			$content.="$name=$value\n";
		}
		open(SF,">".$cl->getfile());
		print SF $content;
		close(SF);
		return 1;
    }
    return 0;
}


sub newID
{
    my $cl = shift;
	#GET COOKIE
	my %COOKIES=$cl->parse_COOKIE();
	if($COOKIES{SID} ne "")
	{
		$cl->{SID}=$COOKIES{SID};
	}
#	print "Content-type: text/html\n\n";
#	print "COOKIE: ".$COOKIES{SID}."";
	if(($COOKIES{SID} eq "") || !($cl->check_ip_addr))
	{
		do
		{
	    	my $ary = "0123456789abcdefghijABCDEFGH";	# replace with the set of characters
	    	$cl->{SID} = "";
		    my $arylen = length($ary);
    		for my $i (0 .. 23)
			{
				my $idx = int(rand(time) % $arylen);
				my $dig = substr($ary, $idx, 1);
				$cl->{SID} .= $dig;
		    }
		}
		while($cl->exists($cl->{SID}));
	}
	return $cl->{SID};
}

sub check_ip_addr
{
	my $cl = shift;
	return 1 if(!defined($cl->{check_ip}));
#	print "Content-type: text/html\n\n";
#	print "SID_IP: ".$cl->get("SID_IP")." IP: ".$ENV{REMOTE_ADDR};
#	print " GETFILE: ".$cl->getfile();
	return 0 if($cl->get("SID_IP") ne $ENV{REMOTE_ADDR});
	return 1
}

sub parse_COOKIE
{
	my @keypairs = split(/;/,$ENV{HTTP_COOKIE});
	my %COOKIE;
    foreach my $keyvalue (@keypairs)
    {
        $keyvalue=~s/^\s+//;
        my ($key,$value) = split(/=/,$keyvalue);
        $key =~ tr/+/ /;
        $key =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
        $value =~ tr/+/ /;
        $value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C",hex($1))/eg;
        $value=~s/\r//g;
        $COOKIE{$key} = $value;
    }
	return(%COOKIE);
}

#############################

1;

__END__