view release on metacpan or  search on metacpan

kSession.pm  view on Meta::CPAN

package CGI::kSession;
$CGI::kSession::VERSION = '0.5.3';
use strict;

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

sub start {
    my $cl = shift;
    if (!exists($cl->{lifetime})) { $cl->{lifetime} = 600; }
    if (!exists($cl->{path})) { $cl->{path} = "/var/tmp/"; }
    # ustawia nowy ID jesli nie jest zaden podany juz
    if ((!exists($cl->{SID})) || ((length($cl->{SID}) == 0))) { $cl->id($cl->newID()); }
    
    if (-e $cl->getfile()) { return 0; }
    # nowy plik sesji jesli takowy juz nie istnieje
    open(SF,">".$cl->getfile()); close(SF);
    $cl->check_sessions();
    return 1;
}

sub check_sessions {
    my $cl = shift;
    opendir(SD,$cl->{path});
    my @files = readdir(SD);
    shift @files;
    shift @files;
    foreach my $f (@files) {
	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;
}

#czy sesja o podanym id istnieje
sub exists {
    my ($cl,$id) = @_;
    if (!defined($id)) { return 0; }
    my $file = $cl->{path}.$cl->{$id};
    if (-e $file) { return 1; }
    return 0;
}

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

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

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

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

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