richter 00/09/05 23:24:37
Modified: . Embperl.pm Faq.pod epmain.c test.pl
Log:
- Session Management
Revision Changes Path
1.115 +147 -64 embperl/Embperl.pm
Index: Embperl.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl.pm,v
retrieving revision 1.114
retrieving revision 1.115
diff -u -r1.114 -r1.115
--- Embperl.pm 2000/08/24 05:43:39 1.114
+++ Embperl.pm 2000/09/06 06:24:36 1.115
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: Embperl.pm,v 1.114 2000/08/24 05:43:39 richter Exp $
+# $Id: Embperl.pm,v 1.115 2000/09/06 06:24:36 richter Exp $
#
###################################################################################
@@ -680,6 +680,7 @@
*ScanEnvironement = \&ScanEnvironment ; # for backward compatibility (was typo)
+
#######################################################################################
sub CleanCallExecuteReq
@@ -902,40 +903,9 @@
*{"$package\:\:param"} = $$req{'param'};
}
- my $udat ;
- my $mdat ;
-
- if ($SessionMgnt && !$r -> SubReq)
- {
- $udat = tied(%udat) ;
- $mdat = tied(%mdat) ;
- my $sessid ;
- my $cookie_name = $r -> CookieName ;
- my $cookie_val = $ENV{HTTP_COOKIE} ||
($req_rec?$req_rec->header_in('Cookie'):undef) ;
-
- if (defined ($cookie_val) && ($cookie_val =~
/$cookie_name=(.*?)(\;|\s|$)/))
- {
- $sessid = $1 ;
- print LOG "[$$]SES: Received session cookie $1\n" if ($dbgSession) ;
- $r -> SessionMgnt (0) ; # do not resend cookie
- }
- if ($SessionMgnt == 1)
- {
- $udat -> {ID} = $sessid ;
- $udat -> {DIRTY} = 0 ;
+ $r -> SetupSession ($req_rec, $Inputfile) ;
- $mdat -> {ID} = substr(MD5 -> hexhash ($Inputfile), 0,
&Apache::Session::ID_LENGTH );
- $mdat -> {DIRTY} = 0 ;
- }
- else
- {
- $udat -> setid ($sessid) ;
- $mdat -> setid (substr(MD5 -> hexhash ($Inputfile), 0, $mdat -> {args}
-> {IDLength} || $DefaultIDLength));
- }
- }
-
-
{
local $SIG{__WARN__} = \&Warn ;
local *0 = \$Inputfile;
@@ -978,40 +948,9 @@
*{"$package\:\:param"} = $saved_param;
}
-
- if ($SessionMgnt && !$r -> SubReq)
- {
- if ($SessionMgnt == 1)
- {
- if ($udat->{'DIRTY'})
- {
- print LOG "[$$]SES: Store session data of \%udat
id=$udat->{ID}\n" if ($dbgSession) ;
- $udat->{'DATA'}->store ;
- }
- else
- {
- print LOG "[$$]SES: session data not dirty, do not store
\%udat\n" if ($dbgSession) ;
- }
- $udat->{'DATA'} = undef ;
- $udat -> {ID} = undef ;
- if ($mdat->{'DIRTY'})
- {
- print LOG "[$$]SES: Store session data of \%mdat
id=$mdat->{ID}\n" if ($dbgSession) ;
- $mdat->{'DATA'}->store ;
- }
-
- $mdat->{'DATA'} = undef ;
- $mdat -> {ID} = undef ;
- }
- else
- {
- $udat -> cleanup ;
- $mdat -> cleanup ;
- }
- }
+ $r -> CleanupSession ;
-
$r -> Export ($exports, caller ($$req{import} - 1)) if ($$req{import} &&
($exports = $r -> ExportHash)) ;
my $cleanup = $$req{'cleanup'} || ($optDisableVarCleanup?-1:0) ;
@@ -1621,6 +1560,150 @@
eval 'use Apache::Constants qw(&OPT_EXECCGI &DECLINED &OK &FORBIDDEN)' ;
die "use Apache::Constants failed: $@" if ($@);
}
+
+
+#######################################################################################
+
+sub SetupSession
+
+ {
+ my $r ;
+ $r = shift if (!(ref ($_[0]) =~ /^Apache/)) ;
+ my ($req_rec, $Inputfile) = @_ ;
+
+ if ($HTML::Embperl::SessionMgnt && (!defined ($r) || !$r -> SubReq))
+ {
+ my $udat = tied(%HTML::Embperl::udat) ;
+ my $mdat = tied(%HTML::Embperl::mdat) ;
+ my $sessid ;
+ my $cookie_name = $r?$r -> CookieName:$ENV{EMBPERL_COOKIE_NAME} ||
'EMBPERL_UID' ;
+ my $cookie_val = $ENV{HTTP_COOKIE} ||
($req_rec?$req_rec->header_in('Cookie'):undef) ;
+
+ if (defined ($cookie_val) && ($cookie_val =~ /$cookie_name=(.*?)(\;|\s|$)/))
+ {
+ $sessid = $1 ;
+ print HTML::Embperl::LOG "[$$]SES: Received session cookie $1\n" if
($HTML::Embperl::dbgSession) ;
+
+ $r -> SessionMgnt (0) if ($r) ; # do not resend cookie
+ }
+
+ if ($HTML::Embperl::SessionMgnt == 1)
+ {
+ if (!$udat -> {ID})
+ {
+ $udat -> {ID} = $sessid ;
+ $udat -> {DIRTY} = 0 ;
+ }
+
+ if ($Inputfile && !$mdat -> {ID})
+ {
+ $mdat -> {ID} = substr(MD5 -> hexhash ($Inputfile), 0,
&Apache::Session::ID_LENGTH );
+ $mdat -> {DIRTY} = 0 ;
+ }
+ }
+ else
+ {
+ $udat -> setid ($sessid) if (!$udat -> getid) ;
+ $mdat -> setid (substr(MD5 -> hexhash ($Inputfile), 0, $mdat -> {args} ->
{IDLength} || $HTML::Embperl::DefaultIDLength)) if ($Inputfile && !$mdat -> getid)
+ }
+ }
+ else
+ {
+ return undef ; # No session Management
+ }
+
+ return wantarray?(\%HTML::Embperl::udat,
\%HTML::Embperl::mdat):\%HTML::Embperl::udat ;
+ }
+
+#######################################################################################
+
+sub GetSession
+
+ {
+ if ($HTML::Embperl::SessionMgnt)
+ {
+ my $udat = tied(%HTML::Embperl::udat) ;
+
+ if ($HTML::Embperl::SessionMgnt == 1)
+ {
+ return wantarray?(\%HTML::Embperl::udat,
\%HTML::Embperl::mdat):\%HTML::Embperl::udat if ($udat -> {ID}) ;
+ }
+ else
+ {
+ return wantarray?(\%HTML::Embperl::udat,
\%HTML::Embperl::mdat):\%HTML::Embperl::udat if ($udat -> getid) ;
+ }
+ }
+ else
+ {
+ return undef ; # No session Management
+ }
+ }
+
+#######################################################################################
+
+sub DeleteSession
+
+ {
+ my $r = shift || HTML::Embperl::CurrReq () ;
+
+ tied(%HTML::Embperl::udat) -> delete ; # Delete session data
+ $r -> SessionMgnt (-1) ; # resend cookie without value
+ }
+
+
+#######################################################################################
+
+sub RefreshSession
+
+ {
+ my $r = shift || HTML::Embperl::CurrReq () ;
+
+ $r -> SessionMgnt ($HTML::Embperl::SessionMgnt) ; # resend cookie
+ }
+
+#######################################################################################
+
+sub CleanupSession
+
+ {
+ my $r = shift || HTML::Embperl::CurrReq () ;
+
+ if ($HTML::Embperl::SessionMgnt && (!defined ($r) || !$r -> SubReq))
+ {
+ my $udat = tied(%HTML::Embperl::udat) ;
+ my $mdat = tied(%HTML::Embperl::mdat) ;
+
+ if ($HTML::Embperl::SessionMgnt == 1)
+ {
+ if ($udat->{'DIRTY'})
+ {
+ print HTML::Embperl::LOG "[$$]SES: Store session data of
\%HTML::Embperl::udat id=$udat->{ID}\n" if ($HTML::Embperl::dbgSession) ;
+ $udat->{'DATA'}->store ;
+ }
+ else
+ {
+ print HTML::Embperl::LOG "[$$]SES: session data not dirty, do not
store \%HTML::Embperl::udat\n" if ($HTML::Embperl::dbgSession) ;
+ }
+
+ $udat->{'DATA'} = undef ;
+ $udat -> {ID} = undef ;
+ if ($mdat->{'DIRTY'})
+ {
+ print HTML::Embperl::LOG "[$$]SES: Store session data of
\%HTML::Embperl::mdat id=$mdat->{ID}\n" if ($HTML::Embperl::dbgSession) ;
+ $mdat->{'DATA'}->store ;
+ }
+
+ $mdat->{'DATA'} = undef ;
+ $mdat -> {ID} = undef ;
+ }
+ else
+ {
+ $udat -> cleanup ;
+ $mdat -> cleanup ;
+ }
+ }
+ }
+
1.16 +3 -3 embperl/Faq.pod
Index: Faq.pod
===================================================================
RCS file: /home/cvs/embperl/Faq.pod,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- Faq.pod 2000/08/10 19:32:46 1.15
+++ Faq.pod 2000/09/06 06:24:36 1.16
@@ -238,7 +238,7 @@
=head2 How do I build Embperl with debugging informations
-=over4
+=over 4
=item edit the Makefile
@@ -477,7 +477,7 @@
Nothing weird here. Everything is well defined. Just let us try to
understand how I<Perl>, I<mod_perl> and I<Embperl> works together:
-"perldoc -f use" tells us:
+ "perldoc -f use" tells us:
Imports some semantics into the current package from the named module,
generally by aliasing certain subroutine or variable names into your
@@ -490,7 +490,7 @@
So what's important here for us is, that C<use> executes a C<require> and
this is always done before any other code is executed.
-"perldoc -f require" says (among other things):
+ "perldoc -f require" says (among other things):
..., demands that a library file be included if it hasn't already
been included.
1.72 +10 -2 embperl/epmain.c
Index: epmain.c
===================================================================
RCS file: /home/cvs/embperl/epmain.c,v
retrieving revision 1.71
retrieving revision 1.72
diff -u -r1.71 -r1.72
--- epmain.c 2000/08/17 07:31:57 1.71
+++ epmain.c 2000/09/06 06:24:36 1.72
@@ -2346,10 +2346,18 @@
MAGIC * pMG ;
char * pUID = NULL ;
STRLEN ulen = 0 ;
-
+ // $http_headers_out{'Set-Cookie'} = "EMBPERL_UID=; expires=Thu,
1-Jan-1970 00:00:01 GMT";
+
if (r -> nSessionMgnt)
{
- if (r -> nSessionMgnt == 2)
+ if (r -> nSessionMgnt == -1)
+ { /* delete cookie */
+ pCookie = newSVpvf ("%s=; expires=Thu, 1-Jan-1970 00:00:01
GMT%s%s%s%s", r -> pConf -> sCookieName,
+ r -> pConf -> sCookieDomain[0]?"; domain=":"" , r ->
pConf -> sCookieDomain,
+ r -> pConf -> sCookiePath[0]?"; path=":"" , r ->
pConf -> sCookiePath) ;
+
+ }
+ else if (r -> nSessionMgnt == 2)
{
if ((pMG = mg_find((SV *)r -> pUserHash,'P')))
{
1.68 +2 -0 embperl/test.pl
Index: test.pl
===================================================================
RCS file: /home/cvs/embperl/test.pl,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -r1.67 -r1.68
--- test.pl 2000/08/24 05:43:40 1.67
+++ test.pl 2000/09/06 06:24:36 1.68
@@ -94,6 +94,8 @@
'getsess.htm',
'mdatsess.htm?cnt=3',
'execgetsess.htm',
+ 'delsess.htm',
+ 'getsess.htm',
'clearsess.htm',
'EmbperlObject/epopage1.htm',
'EmbperlObject/epodiv.htm',
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
