--- /dev/null
+package VJournal::Session;
+
+use strict;
+use Carp;
+use CGI;
+use Cwd;
+use File::Spec;
+
+use vars qw($AUTOLOAD);
+use constant COOKIE_NAME=>'VJ_SESSION';
+use constant CONFIG_NAME=>'.vjournalrc';
+
+
+our %config;
+
+=head1 NAME
+
+VJournal::Session - handle authorized use session
+
+=head1 SYNOPSIS
+
+ use VJournal::Session
+ my $s = VJournal::Session->new;
+
+=head1 DESCRIPTION
+
+B<VJournal::Session> manages session. Sesssion objects incoroprates
+B<CGI.pm> context, and any methods of CGI.pm can be called as session
+object methods.
+
+=head1 METHODS
+
+=head2 new
+
+ $session = new VJournal::Session();
+ $session = new VJournal::Session($cgi);
+
+Creates new B<session> object based on the CGI request. If no CGI
+object is expilcitely provided, creates one using default constructor.
+
+If there is no session cookie in the CGI context, or cookie is expired,
+or cookie is bound to IP address, other than current B<remote_addr()>,
+returns B<undef>.
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my %attrs;
+ if (!@_) {
+ %attrs=(-cgi=>new CGI);
+ } elsif (scalar(@_)%2==0) {
+ %attrs=@_;
+ } elsif (scalar(@_) == 1) {
+ %attrs=(-cgi=>$_[0]);
+ } else {
+ croak "Invalid call to VJournal::Session::new"
+ }
+ if (exists $attrs{-cgi} && $attrs{-cgi}->can("cookie")) {
+ my $cgi=$attrs{-cgi};
+ my $sess_id = $cgi->cookie(COOKIE_NAME);
+ return undef unless $sess_id;
+ load_config();
+ if (!exists($config{-sessionbase})) {
+ croak "No VJournal config read";
+ }
+ my %userbase;
+ dbmopen %userbase,$config{-sessionbase},0644;
+
+ return undef if (!exists($userbase{$sess_id}));
+ my ($name,$avatar,$email,$avwidth,$avheight,$ip,$expire) =
+ split(/:/,$userbase{$sess_id});
+ if ($ip && $ip ne $attrs{-cgi}->remote_addr()) {
+ return undef;
+ }
+ my $me={-id=>$sess_id,-name=>$name,-cgi=>$cgi};
+ if ($avatar) {
+ $me->{-avatar}=$avatar;
+ $me->{-avwidth}=$avwidth;
+ $me->{-avheight}=$avheight;
+ }
+ if ($email) {
+ $me->{-email}=$email;
+ }
+
+ my $now = time();
+ if ($expire < $now) {
+ delete $userbase{$sess_id};
+ return undef;
+ } elsif ($expire < $now - $config{-gracetime}) {
+ $expire+=$config{-sessiontime};
+ $userbase{$sess_id}=join(":",$name,$avatar,$email,$avwidth,$avheight,$ip,$expire);
+ $me->{-cookie}=
+ [$cgi->cookie(-name=>COOKIE_NAME,-value=>$sess_id,-expires=>
+ $expire)];
+ }
+ return bless $pkg,$me;
+ }
+}
+
+=head2 create
+
+Creates new session for given user. It is assumet that user have been
+properly authenticated by caller. (i.e. using OpenID).
+
+ $session=VJournal::Session->create(-user=>'user',-cgi=>$cgi,-email=>$mailaddress,
+ -avatar=>$uri,
+ -bind_to_ip=>1
+ );
+
+If B<-bind_to_ip> is specified, session would be bound to IP address.
+Avatar uri and email address might be provided by the authentication
+mechanism.
+
+If they are not obtained for free, caller shouldn't attempt to provide
+them to create. Better to check if avatar and email are defined after
+session creation. May be they are already cached.
+
+=cut
+
+sub create {
+ my $pkg=shift;
+ if (scalar(@_)%2!=0) {
+ croak("Invalid call to ".$pkg."->create");
+ }
+ my %params = @_;
+ croack("User name is required by ".$pkg."->creae");
+ $params{-cgi}=CGI->new() if(!$params{-cgi});
+ load_config($params{-cgi});
+
+}
+
+=head2 avatar
+
+ print $s->avatar()
+ %props=$s->avatar
+ $s->avatar("http://www.some.site/userpic/user.gif");
+
+In the scalar context returns img tag for user avatar.
+In the vector context returns list which looks like
+
+ -src=>http://some.site/some.pic, -width=>nnn,-height=>nnn,-alt=>username
+
+If URL is supplied, attempts to cache image in the local userpic area
+so subsequent calls to the avatar would return local copy.
+
+=cut
+
+sub avatar {
+ my $self = shift;
+ if (@_) {
+ #setup new avatar
+ require VJournal::Avatar;
+ my %a = VJournal::Avatar::cache($_[0]);
+ while (my($key,$val)=each %a) {
+ $self->{$key}=$val;
+ }
+ $self->_update_user();
+ } elsif (exists($self->{-avatar})) {
+ my @a=(-src=>$self->{-avatar},-width=>$self->{-avwidth},-height=>$self->{-avheight},-alt=>$self->{-name});
+ if (wantarray) {
+ return @a;
+ } else {
+ return $self->{-cgi}->img(@a);
+ }
+ }
+}
+
+=head2 email
+
+ my $addr=$s->email();
+ $s->email($address);
+
+=cut
+
+
+sub email {
+ my $self = shift;
+ if (@_) {
+ $self->{-email} = shift;
+ if (!exists $self->{-avatar}) {
+ require VJournal::Avatar;
+ VJournal::Avatar::by_email($self->{-email});
+ }
+ $self->_update_user();
+ }
+ return $self->{-email};
+}
+
+=head2 isowner
+
+ if ($s->isowner()) {
+ ....
+
+returns true, if current user is owner of the blog
+
+=cut
+
+sub isowner {
+ my $self=shift;
+ return $self->{-name} eq $config{-owner};
+}
+
+=head2 _update_user
+
+ $s->_update_user
+
+Updates intformation about user in the user and session database.
+Internal function, called from B<create>, B<avatar> and B<email>.
+
+=cut
+
+=head2 header
+
+Overrideds CGI.pm header routine and adds to the header Set-Cookie
+headers for cookies created by B<new>, B<create> or added by B<set_cookie>
+
+=cut
+
+sub header {
+ my $self = shift;
+ push @_,-cookie=>$self->{-cookie} if exists($self->{-cookie}) ;
+ return $self->{-cgi}->header(@_);
+}
+
+=head2 load_config
+
+ load_config($cgi)
+
+walks up the path_translated() and searches for the B<.vjournalrc> config.
+dies if config not found.
+
+=cut
+
+sub load_config {
+ my $path=$_[0]->path_translated();
+ my @dirs = (File::Spec->splitdir($path));
+ my $found =0;
+ while (@dirs) {
+ my $d=File::Spec->catdir(@dirs,CONFIG_NAME);
+ if (-r $d) {
+ open F,"<",$d;
+ local $/=undef;
+ my $config = <F>;
+ close F;
+ eval "%config = {$d}";
+ die $@ if ($@);
+ $found = 1;
+ }
+ pop @dirs;
+ }
+ die ("Cannot find config file inside $path") unless $found;
+ my @reqkeys=qw(-owner -statedir -templatedir);
+ foreach my $key (@reqkeys) {
+ die "Required key $key missing from config"
+ unless exists $config{$key};
+ }
+ # sensible defaults
+ $config{-sessionbase}||=$config{-statedir}."/sessions.db";
+ $config{-userbase}||=$config{-statedir}."/user.db";
+ $config{-sessiontime}||=86400*30;
+ $config{-gracetime}||=86400;
+}
+
+=head2 AUTOLOAD
+
+Delegates all called methods which are not implemented to the CGI.pm
+object
+
+=cut
+
+
+sub AUTOLOAD {
+ my $self=shift;
+ my $func = $AUTOLOAD;;
+ croak("Invalid method $AUTOLOAD") unless CGI->can($func);
+ return $self->{-cgi}->$func(@_);
+}
+
+1;
projects / oss / vjournal.git / commitdiff