You are viewing a plain text version of this content. The canonical link for it is here.
Posted to embperl-cvs@perl.apache.org by ri...@locus.apache.org on 2000/11/10 09:52:50 UTC
cvs commit: embperl/test/html delrdsess.htm delwrsess.htm getbsess.htm setbadsess.htm setunknownsess.htm delsess.htm
richter 00/11/10 00:52:49
Modified: . Tag: Embperl2c Embperl.pm EmbperlObject.pm MANIFEST
Makefile.PL epmain.c test.pl
Embperl Tag: Embperl2c Session.pm
test/cmp Tag: Embperl2c delsess.htm
test/html Tag: Embperl2c delsess.htm
Added: test/cmp Tag: Embperl2c delrdsess.htm delwrsess.htm
getbsess.htm setbadsess.htm setunknownsess.htm
test/html Tag: Embperl2c delrdsess.htm delwrsess.htm
getbsess.htm setbadsess.htm setunknownsess.htm
Log:
Embperl 2 - Sessionhandling sync with 1.3b7_dev
Revision Changes Path
No revision
No revision
1.118.4.11 +49 -58 embperl/Embperl.pm
Index: Embperl.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl.pm,v
retrieving revision 1.118.4.10
retrieving revision 1.118.4.11
diff -u -r1.118.4.10 -r1.118.4.11
--- Embperl.pm 2000/11/08 21:40:15 1.118.4.10
+++ Embperl.pm 2000/11/10 08:52:26 1.118.4.11
@@ -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.118.4.10 2000/11/08 21:40:15 richter Exp $
+# $Id: Embperl.pm,v 1.118.4.11 2000/11/10 08:52:26 richter Exp $
#
###################################################################################
@@ -86,7 +86,7 @@
##ep2##
-$VERSION = '2.0a13' ;
+$VERSION = '2.0a14' ;
##/ep2##
##ep1##$VERSION = '1.3b7_dev';
@@ -409,8 +409,8 @@
eval "require $session_handler" ;
die $@ if ($@) ;
- tie %udat, $session_handler, undef, \%sargs ;
tie %mdat, $session_handler, undef, \%sargs ;
+ tie %udat, $session_handler, undef, {%sargs, recreate_id => 1} ;
$SessionMgnt = 2 ;
warn "[$$]SES: Embperl Session management enabled ($ver)\n" if ($ENV{MOD_PERL}) ;
}
@@ -431,30 +431,6 @@
#######################################################################################
-#no strict ;
-
-sub _eval_ ($)
- {
- my $result = eval "package $evalpackage ; $_[0] " ;
- if ($@ ne '')
- { logevalerr ($@) ; }
- return $result ;
- }
-
-#use strict ;
-
-#######################################################################################
-
-sub _evalsub_ ($)
- {
- my $result = eval "package $evalpackage ; sub { $_[0] } " ;
- if ($@ ne '')
- { logevalerr ($@) ; }
- return $result ;
- }
-
-#######################################################################################
-
sub Warn
{
local $^W = 0 ;
@@ -587,9 +563,9 @@
sub CheckFile
{
- my ($filename, $req_rec, $AllowZeroFilesize, $allow, $pathref, $debug) = @_ ;
-
- my $path = $$pathref ;
+ my ($filename, $req_rec, $AllowZeroFilesize, $allow, $pathref, $debug) = @_ ;
+
+ my $path = $$pathref ;
if (-d $filename)
{
@@ -622,7 +598,7 @@
shift @path while ($skip--) ;
my $fn = '' ;
print LOG "[$$]Embperl path search Path: " . join (';',@path) . " Filename: $filename\n" if ($debug);
- $$pathref = join (';', @path) ;
+ $$pathref = join (';', @path) ;
foreach (@path)
{
@@ -871,8 +847,8 @@
bless $r, $$req{'bless'} if (exists ($$req{'bless'})) ;
- $r -> Path ($req->{path}) if ($req->{path}) ;
-
+ $r -> Path ($req->{path}) if ($req->{path}) ;
+
my $package = $r -> CurrPackage ;
$evalpackage = $package ;
my $exports ;
@@ -1653,8 +1629,6 @@
{
$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)
@@ -1717,8 +1691,17 @@
my $r = shift || HTML::Embperl::CurrReq () ;
my $disabledelete = shift ;
- tied(%HTML::Embperl::udat) -> delete if (!$disabledelete) ; # Delete session data
- $r -> SessionMgnt (-1) ; # resend cookie without value
+ my $udat = tied (%HTML::Embperl::udat) ;
+ if (!$disabledelete) # Delete session data
+ {
+ $udat -> delete ;
+ }
+ else
+ {
+ $udat-> {data} = {} ; # for make test only
+ $udat->{initial_session_id} = "!DELETE" ;
+ }
+ $udat->{status} = 0;
}
@@ -1729,7 +1712,7 @@
{
my $r = shift || HTML::Embperl::CurrReq () ;
- $r -> SessionMgnt ($HTML::Embperl::SessionMgnt) ; # resend cookie
+ $r -> SessionMgnt ($HTML::Embperl::SessionMgnt | 4) ; # resend cookie
}
#######################################################################################
@@ -1745,7 +1728,7 @@
my $udat = tied(%HTML::Embperl::udat) ;
my $mdat = tied(%HTML::Embperl::mdat) ;
- if ($HTML::Embperl::SessionMgnt == 1)
+ if ($HTML::Embperl::SessionMgnt & 1)
{
if ($udat->{'DIRTY'})
{
@@ -1776,26 +1759,34 @@
}
}
+
+#######################################################################################
+
+sub SetSessionCookie
+
+ {
+ my $r = shift ;
+ $r = undef if (!(ref ($r) =~ /^HTML::Embperl/));
+
+ if ($HTML::Embperl::SessionMgnt)
+ {
+ my $udat = tied (%HTML::Embperl::udat) ;
+ my $id = $udat -> getid ;
+ my $initialid = $udat -> getinitialid ;
+
+ my $name = $ENV{EMBPERL_COOKIE_NAME} || 'EMBPERL_UID' ;
+ my $domain = "; domain=$ENV{EMBPERL_COOKIE_DOMAIN}" if (exists ($ENV{EMBPERL_COOKIE_DOMAIN})) ;
+ my $path = "; path=$ENV{EMBPERL_COOKIE_PATH}" if (exists ($ENV{EMBPERL_COOKIE_PATH})) ;
+ my $expires = "; expires=$ENV{EMBPERL_COOKIE_EXPIRES}" if (exists ($ENV{EMBPERL_COOKIE_EXPIRES})) ;
+ $expires = "; expires=Thu, 1-Jan-1970 00:00:01 GMT" if ($id && !$initialid) ;
+
+ if ($id || $initialid)
+ {
+ Apache -> request -> header_out ("Set-Cookie" => "$name=$id$domain$path$expires") ;
+ }
+ }
+ }
-#######################################################################################
-
-sub SetSessionCookie
-
- {
- my $r = shift ;
- $r = undef if (!(ref ($r) =~ /^HTML::Embperl/));
-
- if ($HTML::Embperl::SessionMgnt && (!defined ($r) || $r -> SessionMgnt))
- {
- my $name = $ENV{EMBPERL_COOKIE_NAME} || 'EMBPERL_UID' ;
- my $domain = "; domain=$ENV{EMBPERL_COOKIE_DOMAIN}" if (exists ($ENV{EMBPERL_COOKIE_DOMAIN})) ;
- my $path = "; path=$ENV{EMBPERL_COOKIE_PATH}" if (exists ($ENV{EMBPERL_COOKIE_PATH})) ;
- my $expires = "; expires=$ENV{EMBPERL_COOKIE_EXPIRES}" if (exists ($ENV{EMBPERL_COOKIE_EXPIRES})) ;
-
- Apache -> request -> header_out ("Set-Cookie" => "$name=" . (tied (%HTML::Embperl::udat) -> getid). "$domain$path$expires") ;
- }
- }
-
#######################################################################################
sub CreateAliases
1.36.4.3 +0 -0 embperl/EmbperlObject.pm
Index: EmbperlObject.pm
===================================================================
RCS file: /home/cvs/embperl/EmbperlObject.pm,v
retrieving revision 1.36.4.2
retrieving revision 1.36.4.3
diff -u -r1.36.4.2 -r1.36.4.3
--- EmbperlObject.pm 2000/11/08 21:40:21 1.36.4.2
+++ EmbperlObject.pm 2000/11/10 08:52:26 1.36.4.3
@@ -10,7 +10,7 @@
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
-# $Id: EmbperlObject.pm,v 1.36.4.2 2000/11/08 21:40:21 richter Exp $
+# $Id: EmbperlObject.pm,v 1.36.4.3 2000/11/10 08:52:26 richter Exp $
#
###################################################################################
1.50.4.8 +12 -2 embperl/MANIFEST
Index: MANIFEST
===================================================================
RCS file: /home/cvs/embperl/MANIFEST,v
retrieving revision 1.50.4.7
retrieving revision 1.50.4.8
diff -u -r1.50.4.7 -r1.50.4.8
--- MANIFEST 2000/11/08 21:40:22 1.50.4.7
+++ MANIFEST 2000/11/10 08:52:26 1.50.4.8
@@ -172,6 +172,11 @@
test/html/clearsess.htm
test/html/delsess.htm
test/html/getdelsess.htm
+test/html/getbsess.htm
+test/html/delrdsess.htm
+test/html/delwrsess.htm
+test/html/setbadsess.htm
+test/html/setunknownsess.htm
test/html/registry/reggetsess.htm
test/html/EmbperlObject/epobase.htm
test/html/EmbperlObject/epohead.htm
@@ -179,7 +184,7 @@
test/html/EmbperlObject/epopage1.htm
test/html/EmbperlObject/epodiv.htm
test/html/EmbperlObject/sub/subsub/eposubsub.htm
-test/html/EmbperlObject/sub/subsub/subsubsub/eposubsub.htm
+test/html/EmbperlObject/sub/subsub/subsubsub/eposubsub.htm
test/html/EmbperlObject/eposubsub.htm
test/html/EmbperlObject/sub/epohead.htm
test/html/EmbperlObject/sub/epopage2.htm
@@ -275,7 +280,7 @@
test/cmp/epodiv.htm
test/cmp/epopage2.htm
test/cmp/eposubsub.htm
-test/cmp/eposubsub.htm3
+test/cmp/eposubsub.htm3
test/cmp/epoobj1.htm
test/cmp/epoobj2.htm
test/cmp/epoobj3.htm
@@ -283,6 +288,11 @@
test/cmp/eponotfound.htm
test/cmp/epostopdir.htm
test/cmp/epobaselib.htm
+test/cmp/getbsess.htm
+test/cmp/delrdsess.htm
+test/cmp/delwrsess.htm
+test/cmp/setbadsess.htm
+test/cmp/setunknownsess.htm
test/conf/httpd.conf.src
test/conf/startup.pl
test/conf/startup_dso.pl
1.31.4.4 +3 -1 embperl/Makefile.PL
Index: Makefile.PL
===================================================================
RCS file: /home/cvs/embperl/Makefile.PL,v
retrieving revision 1.31.4.3
retrieving revision 1.31.4.4
diff -u -r1.31.4.3 -r1.31.4.4
--- Makefile.PL 2000/11/08 21:40:24 1.31.4.3
+++ Makefile.PL 2000/11/10 08:52:26 1.31.4.4
@@ -909,7 +909,7 @@
'EmbperlD.pod' => 'blib/man3/HTML::EmbperlD.3',
'EmbperlObject.pm' => 'blib/man3/HTML::EmbperlObject.3',
},
- 'clean' => { FILES => 'dirent.h test/conf/httpd.conf test/tmp/*' },
+ 'clean' => { FILES => 'dirent.h test/conf/httpd.conf test/tmp/* Embperl.c' },
'realclean' => { FILES => 'embpexec.pl embpexec.bat embpcgi.pl embpcgi.test.pl embpcgi.bat test/conf/config.pl' },
'dist' => { COMPRESS => 'gzip', SUFFIX => 'gz'},
'dynamic_lib' => $dynlib,
@@ -957,4 +957,6 @@
close OUT ;
chmod 0755, $f or die "Cannot set executable $f" ;
}
+
+unlink ('Embperl.c') ;
1.75.4.12 +33 -31 embperl/epmain.c
Index: epmain.c
===================================================================
RCS file: /home/cvs/embperl/epmain.c,v
retrieving revision 1.75.4.11
retrieving revision 1.75.4.12
diff -u -r1.75.4.11 -r1.75.4.12
--- epmain.c 2000/11/08 21:40:32 1.75.4.11
+++ epmain.c 2000/11/10 08:52:26 1.75.4.12
@@ -2557,11 +2557,40 @@
SV * pSVID = NULL ;
MAGIC * pMG ;
char * pUID = NULL ;
+ char * pInitialUID = NULL ;
STRLEN ulen = 0 ;
+ STRLEN ilen = 0 ;
+ IV bModified ;
if (r -> nSessionMgnt)
{
- if (r -> nSessionMgnt == -1)
+ SV * pUserHashObj = NULL ;
+ if ((pMG = mg_find((SV *)r -> pUserHash,'P')))
+ {
+ dSP; /* initialize stack pointer */
+ int n ;
+ pUserHashObj = pMG -> mg_obj ;
+
+ PUSHMARK(sp); /* remember the stack pointer */
+ XPUSHs(pUserHashObj) ; /* push pointer to obeject */
+ PUTBACK;
+ n = perl_call_method ("getids", G_ARRAY) ; /* call the function */
+ SPAGAIN;
+ if (n > 2)
+ {
+ bModified = POPi ;
+ pSVID = POPs;
+ pUID = SvPV (pSVID, ulen) ;
+ pSVID = POPs;
+ pInitialUID = SvPV (pSVID, ilen) ;
+ }
+ PUTBACK;
+ }
+
+ if (r -> bDebug & dbgSession)
+ lprintf (r, "[%d]SES: Received Cookie ID: %s New Cookie ID: %s Session data is%s modified\n", r -> nPid, pInitialUID, pUID, bModified?"":" NOT") ;
+
+ if (ilen > 0 && (ulen == 0 || (!bModified && strcmp ("!DELETE", pInitialUID) == 0)))
{ /* 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,
@@ -2569,37 +2598,10 @@
if (r -> bDebug & dbgSession)
lprintf (r, "[%d]SES: Delete Cookie -> %s\n", r -> nPid, SvPV(pCookie, ldummy)) ;
- }
- else if (r -> nSessionMgnt == 2)
- {
- if ((pMG = mg_find((SV *)r -> pUserHash,'P')))
- {
- dSP; /* initialize stack pointer */
- SV * pUserHashObj = pMG -> mg_obj ;
- int n ;
-
-
- PUSHMARK(sp); /* remember the stack pointer */
- XPUSHs(pUserHashObj) ; /* push pointer to obeject */
- PUTBACK;
- n = perl_call_method ("getid", 0) ; /* call the function */
- SPAGAIN;
- if (n > 0)
- {
- pSVID = POPs;
- pUID = SvPV (pSVID, ulen) ;
- }
- PUTBACK;
- }
- }
- else
- {
- ppSVID = hv_fetch (r -> pUserHash, sUIDName, sizeof (sUIDName) - 1, 0) ;
- if (ppSVID && *ppSVID)
- pUID = SvPV (*ppSVID, ulen) ;
}
-
- if (ulen > 0)
+ else if (ulen > 0 &&
+ ((bModified && (ilen == 0 || strcmp (pInitialUID, pUID) !=0)) ||
+ (r -> nSessionMgnt & 4)))
{
pCookie = newSVpvf ("%s=%s%s%s%s%s%s%s", r -> pConf -> sCookieName, pUID,
r -> pConf -> sCookieDomain[0]?"; domain=":"" , r -> pConf -> sCookieDomain,
1.70.4.19 +73 -10 embperl/test.pl
Index: test.pl
===================================================================
RCS file: /home/cvs/embperl/test.pl,v
retrieving revision 1.70.4.18
retrieving revision 1.70.4.19
diff -u -r1.70.4.18 -r1.70.4.19
--- test.pl 2000/11/08 21:40:34 1.70.4.18
+++ test.pl 2000/11/10 08:52:29 1.70.4.19
@@ -307,49 +307,93 @@
'mdatsess.htm' => {
'offline' => 0,
'query_info' => 'cnt=0',
+ 'cookie' => 'expectno',
},
'setsess.htm' => {
'offline' => 0,
'query_info' => 'a=1',
+ 'cookie' => 'expectnew',
},
'mdatsess.htm' => {
'offline' => 0,
'query_info' => 'cnt=1',
+ 'cookie' => 'expectno',
},
'getnosess.htm' => {
'offline' => 0,
'query_info' => 'nocookie=2',
+ 'cookie' => 'expectnew,nocookie,nosave',
},
'mdatsess.htm' => {
'offline' => 0,
'query_info' => 'cnt=2',
+ 'cookie' => 'expectno',
},
'getsess.htm' => {
'offline' => 0,
+ 'cookie' => 'expectno',
},
'mdatsess.htm' => {
'offline' => 0,
'query_info' => 'cnt=3',
+ 'cookie' => 'expectno',
},
'execgetsess.htm' => {
'offline' => 0,
+ 'cookie' => 'expectno',
},
'registry/reggetsess.htm' => {
'modperl' => 1,
'cgi' => 0,
+ 'cookie' => 'expectno',
},
'getsess.htm' => {
'offline' => 0,
+ 'cookie' => 'expectno',
},
+ 'delwrsess.htm' => {
+ 'offline' => 0,
+ 'cookie' => 'expectnew',
+ },
+ 'getbsess.htm' => {
+ 'offline' => 0,
+ 'cookie' => 'expectno',
+ },
+ 'delrdsess.htm' => {
+ 'offline' => 0,
+ 'cookie' => 'expectexpire',
+ },
+ 'getdelsess.htm' => {
+ 'offline' => 0,
+ 'cookie' => 'expectno',
+ },
+ 'setsess.htm' => {
+ 'offline' => 0,
+ 'query_info' => 'a=1',
+ 'cookie' => 'expectnew',
+ },
'delsess.htm' => {
'offline' => 0,
+ 'cookie' => 'expectexpire',
},
'getdelsess.htm' => {
'offline' => 0,
+ 'cookie' => 'expectno',
},
'clearsess.htm' => {
'offline' => 0,
+ 'cookie' => 'expectno',
+ },
+ 'setbadsess.htm' => {
+ 'offline' => 0,
+ 'query_info' => 'val=2',
+ 'cookie' => 'expectnew,cookie=/etc/passwd',
},
+ 'setunknownsess.htm' => {
+ 'offline' => 0,
+ 'query_info' => 'val=3',
+ 'cookie' => 'expectnew,cookie=1234567890abcdefABCDEF',
+ },
'EmbperlObject/epopage1.htm' => {
'offline' => 0,
'cgi' => 0,
@@ -421,7 +465,7 @@
$opt_offline $opt_ep1 $opt_cgi $opt_modperl $opt_execute $opt_nokill $opt_loop
$opt_multchild $opt_memcheck $opt_exitonmem $opt_exitonsv $opt_config $opt_nostart $opt_uniquefn
$opt_quite $opt_ignoreerror $opt_tests $opt_blib $opt_help $opt_dbgbreak $opt_finderr
- $opt_ddd $opt_gdb $opt_ab $opt_start $opt_kill) ;
+ $opt_ddd $opt_gdb $opt_ab $opt_start $opt_kill $opt_showcookie) ;
{
local $^W = 0 ;
@@ -496,7 +540,7 @@
$ret = GetOptions ("offline|o", "ep1|1", "cgi|c", "modperl|httpd|h", "execute|e", "nokill|r", "loop|l:i",
"multchild|m", "memcheck|v", "exitonmem|g", "exitonsv", "config|f=s", "nostart|x", "uniquefn|u",
"quite|q", "ignoreerror|i", "tests|t", "blib|b", "help", "dbgbreak", "finderr",
- "ddd", "gdb", "ab:s", "start", "kill") ;
+ "ddd", "gdb", "ab:s", "start", "kill", "showcookie") ;
$opt_help = 1 if ($ret == 0) ;
@@ -564,6 +608,7 @@
print "--ab <numreq> run test thru ApacheBench\n" ;
print "--start start apache only\n" ;
print "--kill kill apache only\n" ;
+ print "--showcookie shows sent and received cookies\n" ;
print "\n\n" ;
print "path\t$EPPATH\n" ;
print "httpd\t" . ($EPHTTPD || '') . "\n" ;
@@ -721,10 +766,11 @@
sub REQ
{
- my ($loc, $file, $query, $ofile, $content, $upload) = @_ ;
+ my ($loc, $file, $query, $ofile, $content, $upload, $cookieaction) = @_ ;
eval 'require LWP::UserAgent' ;
+ $cookieaction |= '' ;
if ($@)
{
@@ -743,14 +789,23 @@
my $ua = new LWP::UserAgent; # create a useragent to test
my($request,$response,$url);
-
+ my $sendcookie = '' ;
if (!$upload)
{
$url = new URI::URL("http://$host:$port/$loc/$file?$query");
$request = new HTTP::Request($content?'POST':'GET', $url);
- $request -> header ('Cookie' => $cookie) if ($cookie && !($query =~ /nocookie/)) ;
+ if ($cookieaction =~ /cookie=(.*?)$/)
+ {
+ $request -> header ('Cookie' => $1) ;
+ $sendcookie = $1 ;
+ }
+ elsif ($cookie && !($cookieaction =~ /nocookie/))
+ {
+ $request -> header ('Cookie' => $cookie) ;
+ $sendcookie = $cookie ;
+ }
$request -> content ($content) if ($content) ;
}
@@ -777,15 +832,23 @@
close FH ;
my $c = $response -> header ('Set-Cookie') || '' ;
- $cookie = $c if (!$cookie && ($c =~ /EMBPERL_UID/)) ;
- $cookie = undef if (($c =~ /EMBPERL_UID=;/)) ;
- #print "Got Cookie $cookie\n" ;
+ $cookie = $c if (($c =~ /EMBPERL_UID/) && !($cookieaction =~ /nosave/)) ;
+ $cookie = undef if (($c =~ /EMBPERL_UID=;/) && !($cookieaction =~ /nosave/)) ;
+ $sendcookie ||= '' ;
+ print "\nSent: $sendcookie, Got: " , ($c||''), "\n" if ($opt_showcookie) ;
+
#print $response -> headers -> as_string () ;
return $response -> message if (!$response->is_success) ;
+
+ my $m = 'ok' ;
+ print "\nExpected new cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectnew/) && ($sendcookie eq $c || !$c)) ;
+ print "\nExpected same cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectsame/) && ($sendcookie ne $c || !$c)) ;
+ print "\nExpected no cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectno/) && $c) ;
+ print "\nExpected expire cookie: Sent: $sendcookie, Got: " , ($c||''), "\n", $m = '' if (($cookieaction =~ /expectexpire/) && !($c =~ /^EMBPERL_UID=; expires=/)) ;
- return "ok" ;
+ return $m ;
}
###########################################################################
@@ -1561,7 +1624,7 @@
}
else
{
- $m = REQ ("$loc$locver", $file, $test -> {query_info}, $outfile, $content, $upload) ;
+ $m = REQ ("$loc$locver", $file, $test -> {query_info}, $outfile, $content, $upload, $test -> {cookie}) ;
}
$t_req += HTML::Embperl::Clock () - $t1 ;
No revision
No revision
1.4.4.2 +75 -23 embperl/Embperl/Session.pm
Index: Session.pm
===================================================================
RCS file: /home/cvs/embperl/Embperl/Session.pm,v
retrieving revision 1.4.4.1
retrieving revision 1.4.4.2
diff -u -r1.4.4.1 -r1.4.4.2
--- Session.pm 2000/11/08 21:40:58 1.4.4.1
+++ Session.pm 2000/11/10 08:52:34 1.4.4.2
@@ -32,8 +32,14 @@
=item create_unknown
Setting this to one causes Apache::Session to create a new session
+with the given id (or a new id, depending on C<recreate_id>)
when the specified session id does not exists. Otherwise it will die.
+=item recreate_id
+
+Setting this to one causes Apache::Session to create a new session id
+when the specified session id does not exists.
+
=item object_store
Specify the class for the object store. (The Apache::Session:: prefix is
@@ -149,6 +155,7 @@
{
args => $args,
data => { _session_id => $session_id },
+ initial_session_id => $session_id,
lock => 0,
lock_manager => undef,
object_store => undef,
@@ -232,34 +239,45 @@
my $session_id = $self->{data}->{_session_id} ;
+ $self->{initial_session_id} ||= $session_id ;
+
$self->populate;
if (defined $session_id && $session_id)
{
- if (exists $self -> {'args'}->{Transaction} && $self -> {'args'}->{Transaction})
- {
- $self->acquire_write_lock;
- }
+ #check the session ID for remote exploitation attempts
+ #this will die() on suspicious session IDs.
+
+ eval { &{$self->{validate}}($self); } ;
+ if (!$@)
+ { # session id is ok
+ if (exists $self -> {'args'}->{Transaction} && $self -> {'args'}->{Transaction})
+ {
+ $self->acquire_write_lock;
+ }
- $self->{status} &= ($self->{status} ^ NEW);
+ $self->{status} &= ($self->{status} ^ NEW);
- if ($self -> {'args'}{'create_unknown'})
- {
- eval { $self -> restore } ;
- #warn "Try to load session: $@" if ($@) ;
- $@ = "" ;
- $session_id = $self->{data}->{_session_id} ;
- }
- else
- {
- $self->restore;
- }
+ if ($self -> {'args'}{'create_unknown'})
+ {
+ eval { $self -> restore } ;
+ #warn "Try to load session: $@" if ($@) ;
+ $@ = "" ;
+ $session_id = $self->{data}->{_session_id} ;
+ }
+ else
+ {
+ $self->restore;
+ }
+ }
}
+ $@ = '' ;
+
if (!($self->{status} & SYNCED))
{
$self->{status} |= NEW();
- if (!$self->{data}->{_session_id})
+ if (!$self->{data}->{_session_id} || $self -> {'args'}{'recreate_id'})
{
if (exists ($self->{generate}))
{ # Apache::Session >= 1.50
@@ -273,6 +291,8 @@
$self->save;
}
+ #warn "Session INIT $self->{initial_session_id};$self->{data}->{_session_id};" ;
+
return $self;
}
@@ -359,6 +379,7 @@
{
my $self = shift;
+ $self->{initial_session_id} = undef ;
if (!$self -> {'status'})
{
$self->{data} = {} ;
@@ -367,12 +388,12 @@
}
$self->save;
- {
- local $SIG{__WARN__} = 'IGNORE' ;
- local $SIG{__DIE__} = 'IGNORE' ;
+ {
+ local $SIG{__WARN__} = 'IGNORE' ;
+ local $SIG{__DIE__} = 'IGNORE' ;
eval { $self -> {object_store} -> close } ; # Try to close file storage
$@ = "" ;
- }
+ }
$self->release_all_locks;
$self->{'status'} = 0 ;
@@ -385,24 +406,34 @@
my $self = shift;
$self->{'status'} = 0 ;
- $self->{data}->{_session_id} = shift ;
+ $self->{data}->{_session_id} = $self->{initial_session_id} = shift ;
+
}
sub getid {
my $self = shift;
- return $self->{data}->{_session_id} ;
+ return $self->{data}->{_session_id} || $self->{'ID'} ;
}
+sub getids {
+ my $self = shift;
+
+ return ($self->{initial_session_id}, $self->{data}->{_session_id} || $self->{'ID'}, $self->{status} & MODIFIED) ;
+}
+
sub delete {
my $self = shift;
return if ($self->{status} & NEW);
+ $self->{initial_session_id} = "!DELETE" ;
+
$self -> init if (!$self -> {'status'}) ;
$self->{status} |= DELETED;
$self->save;
+ $self->{data} = {} ; # Throw away the data
}
@@ -422,7 +453,22 @@
return new {$self -> {'args'}{'lock_manager'}} $self;
}
+#
+# Default validate for Apache::Session < 1.53
+#
+
+sub validate {
+ #This routine checks to ensure that the session ID is in the form
+ #we expect. This must be called before we start diddling around
+ #in the database or the disk.
+ my $session = shift;
+
+ if ($session->{data}->{_session_id} !~ /^[a-fA-F0-9]+$/) {
+ die;
+ }
+}
+
#
# For Apache::Session >= 1.50
#
@@ -440,8 +486,14 @@
$self->{object_store} = new $store $self if ($store) ;
$self->{lock_manager} = new $lock $self if ($lock);
$self->{generate} = \&{$gen . '::generate'} if ($gen);
+ $self->{'validate'} = \&{$gen . '::validate'} if ($gen && defined (&{$gen . '::validate'}));
$self->{serialize} = \&{$ser . '::serialize'} if ($ser);
$self->{unserialize} = \&{$ser . '::unserialize'} if ($ser) ;
+
+ if (!defined ($self->{'validate'}))
+ {
+ $self->{'validate'} = \&validate ;
+ }
return $self;
}
No revision
No revision
1.2.4.1 +2 -11 embperl/test/cmp/delsess.htm
Index: delsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/delsess.htm,v
retrieving revision 1.2
retrieving revision 1.2.4.1
diff -u -r1.2 -r1.2.4.1
--- delsess.htm 2000/09/11 09:53:33 1.2
+++ delsess.htm 2000/11/10 08:52:35 1.2.4.1
@@ -13,20 +13,11 @@
</tr>
</table>
-^ ok \(num=\d+\)<p>
+ ok (num=1)<p>
$mdat{cnt} = -- <br>
$udat{cnt} = -- <br>
- udat after:<br>
- <table>
- <tr>
- <td>a</td><td>1</td>
- </tr>
- </table>
-
-^ ok \(num=\d+\)<p>
-
-</body>
+ </body>
</html>
No revision
No revision
1.2.2.1 +0 -0 embperl/test/cmp/delrdsess.htm
Index: delrdsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/delrdsess.htm,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -r1.2 -r1.2.2.1
1.3.2.1 +0 -0 embperl/test/cmp/delwrsess.htm
Index: delwrsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/delwrsess.htm,v
retrieving revision 1.3
retrieving revision 1.3.2.1
diff -u -r1.3 -r1.3.2.1
1.1.2.1 +0 -0 embperl/test/cmp/getbsess.htm
Index: getbsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/getbsess.htm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -u -r1.1 -r1.1.2.1
1.2.2.1 +0 -0 embperl/test/cmp/setbadsess.htm
Index: setbadsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/setbadsess.htm,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -r1.2 -r1.2.2.1
1.2.2.1 +0 -0 embperl/test/cmp/setunknownsess.htm
Index: setunknownsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/cmp/setunknownsess.htm,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -r1.2 -r1.2.2.1
No revision
No revision
1.2.4.1 +0 -11 embperl/test/html/delsess.htm
Index: delsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/delsess.htm,v
retrieving revision 1.2
retrieving revision 1.2.4.1
diff -u -r1.2 -r1.2.4.1
--- delsess.htm 2000/09/11 09:53:36 1.2
+++ delsess.htm 2000/11/10 08:52:37 1.2.4.1
@@ -22,16 +22,5 @@
[- HTML::Embperl::Req::DeleteSession (undef, 1) ; -]
- udat after:<br>
- [- @ks = grep (!/^_/, sort (keys %udat)) ; $num = keys (%udat) - $#ks - 1 ; -]
-
- <table>
- <tr>
- <td>[+ $ks[$row] +]</td><td>[+ $udat{$ks[$row] || ''} +]</td>
- </tr>
- </table>
-
- [+ $num > 0?"ok (num=$num)":"Not a session hash (num=$num)" +]<p>
-
</body>
</html>
No revision
No revision
1.1.2.1 +0 -0 embperl/test/html/delrdsess.htm
Index: delrdsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/delrdsess.htm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -u -r1.1 -r1.1.2.1
1.2.2.1 +0 -0 embperl/test/html/delwrsess.htm
Index: delwrsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/delwrsess.htm,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -u -r1.2 -r1.2.2.1
1.1.2.1 +0 -0 embperl/test/html/getbsess.htm
Index: getbsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/getbsess.htm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -u -r1.1 -r1.1.2.1
1.1.2.1 +0 -0 embperl/test/html/setbadsess.htm
Index: setbadsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/setbadsess.htm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -u -r1.1 -r1.1.2.1
1.1.2.1 +0 -0 embperl/test/html/setunknownsess.htm
Index: setunknownsess.htm
===================================================================
RCS file: /home/cvs/embperl/test/html/setunknownsess.htm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -u -r1.1 -r1.1.2.1