[LON-CAPA-cvs] cvs: loncom /auth lonauth.pm /cgi loncgi.pm userstatus.pl /lonnet/perl lonnet.pm
albertel
lon-capa-cvs@mail.lon-capa.org
Tue, 19 Sep 2006 21:36:43 -0000
This is a MIME encoded message
--albertel1158701803
Content-Type: text/plain
albertel Tue Sep 19 17:36:43 2006 EDT
Modified files:
/loncom/auth lonauth.pm
/loncom/cgi loncgi.pm userstatus.pl
/loncom/lonnet/perl lonnet.pm
Log:
- change sesion env into a .db file
(simplifies the appenv/delenv process)
--albertel1158701803
Content-Type: text/plain
Content-Disposition: attachment; filename="albertel-20060919173643.txt"
Index: loncom/auth/lonauth.pm
diff -u loncom/auth/lonauth.pm:1.82 loncom/auth/lonauth.pm:1.83
--- loncom/auth/lonauth.pm:1.82 Wed Aug 30 18:12:11 2006
+++ loncom/auth/lonauth.pm Tue Sep 19 17:36:24 2006
@@ -1,7 +1,7 @@
# The LearningOnline Network
# User Authentication Module
#
-# $Id: lonauth.pm,v 1.82 2006/08/30 22:12:11 albertel Exp $
+# $Id: lonauth.pm,v 1.83 2006/09/19 21:36:24 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -40,7 +40,7 @@
use Apache::lonmenu();
use Fcntl qw(:flock);
use Apache::lonlocal;
-
+use GDBM_File;
my %FORM;
# ------------------------------------------------------------ Successful login
@@ -171,19 +171,19 @@
}
$env{'user.environment'} = "$lonids/$cookie.id";
- open(my $idf,">$lonids/$cookie.id");
- unless (flock($idf,LOCK_EX)) {
+
+ if (tie(my %disk_env,'GDBM_File',"$lonids/$cookie.id",
+ &GDBM_WRCREAT(),0640)) {
+ &add_to_env(\%disk_env,\%initial_env);
+ &add_to_env(\%disk_env,\%userenv,'environment.');
+ &add_to_env(\%disk_env,$userroles);
+ &add_to_env(\%disk_env,$extra_env);
+ untie(%disk_env);
+ } else {
&Apache::lonnet::logthis("<font color=blue>WARNING: ".
- 'Could not obtain exclusive lock in lonauth: '.$!);
- close($idf);
+ 'Could not create environment storage in lonauth: '.$!);
return 'error: '.$!;
}
-
- &add_to_env($idf,\%initial_env);
- &add_to_env($idf,\%userenv,'environment.');
- &add_to_env($idf,$userroles);
- &add_to_env($idf,$extra_env);
- close($idf);
}
$env{'request.role'}='cm';
$env{'request.role.adv'}=$env{'user.adv'};
@@ -252,8 +252,8 @@
sub add_to_env {
my ($idf,$env_data,$prefix) = @_;
while (my ($key,$value) = each(%$env_data)) {
- print $idf (&escape($prefix.$key).'='.&escape($value)."\n");
- $env{$prefix.$key} = $value;
+ $idf->{$prefix.$key} = $value;
+ $env{$prefix.$key} = $value;
}
}
Index: loncom/cgi/loncgi.pm
diff -u loncom/cgi/loncgi.pm:1.7 loncom/cgi/loncgi.pm:1.8
--- loncom/cgi/loncgi.pm:1.7 Thu May 18 10:24:06 2006
+++ loncom/cgi/loncgi.pm Tue Sep 19 17:36:31 2006
@@ -1,7 +1,7 @@
#
# LON-CAPA helpers for cgi-bin scripts
#
-# $Id: loncgi.pm,v 1.7 2006/05/18 14:24:06 albertel Exp $
+# $Id: loncgi.pm,v 1.8 2006/09/19 21:36:31 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -59,6 +59,7 @@
use Fcntl qw(:flock);
use LONCAPA;
use LONCAPA::Configuration();
+use GDBM_File;
my $lonidsdir;
@@ -143,19 +144,10 @@
#############################################
sub transfer_profile_to_env {
my ($handle)=@_;
- my @profile;
- {
- open(IDFILE, "<$lonidsdir/$handle.id");
- flock(IDFILE,LOCK_SH);
- @profile=<IDFILE>;
- close(IDFILE);
- }
- foreach my $envrow (@profile) {
- chomp($envrow);
- my ($envname,$envvalue)=split(/=/,$envrow,2);
- $envname = &unescape($envname);
- $envvalue = &unescape($envvalue);
- $Apache::lonnet::env{$envname} = $envvalue;
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
+ 0640)) {
+ %Apache::lonnet::env = %disk_env;
+ untie(%disk_env);
}
$Apache::lonnet::env{'user.environment'} = "$lonidsdir/$handle.id";
return undef;
Index: loncom/cgi/userstatus.pl
diff -u loncom/cgi/userstatus.pl:1.14 loncom/cgi/userstatus.pl:1.15
--- loncom/cgi/userstatus.pl:1.14 Fri Sep 1 06:54:08 2006
+++ loncom/cgi/userstatus.pl Tue Sep 19 17:36:31 2006
@@ -1,7 +1,7 @@
#!/usr/bin/perl
$|=1;
# User Status
-# $Id: userstatus.pl,v 1.14 2006/09/01 10:54:08 albertel Exp $
+# $Id: userstatus.pl,v 1.15 2006/09/19 21:36:31 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -32,7 +32,7 @@
use LONCAPA::Configuration;
use LONCAPA;
use HTTP::Headers;
-use IO::File;
+use GDBM_File;
my %usercount;
@@ -98,15 +98,11 @@
&add_count('Domain',$userinfo{'user.domain'},$userclass);
unless ($oneline) {
- my $fh=IO::File->new($$perlvar{'lonIDsDir'}.'/'.$filename);
- while (my $line=<$fh>) {
- chomp($line);
- my ($name,$value)=split(/\=/,$line);
- $name = &unescape($name);
- $value = &unescape($value);
- $userinfo{$name}=$value;
+ if (!tie(%userinfo,'GDBM_File',
+ $$perlvar{'lonIDsDir'}.'/'.$filename,
+ &GDBM_READER(),0640)) {
+ next;
}
- $fh->close();
if (!$justsummary) {
$users{$userclass}{$filename} .=
'<font color="'.$color.'">'.
@@ -148,6 +144,7 @@
"</font>";
}
}
+ untie(%userinfo);
}
if (!$oneline && !$justsummary) {
foreach my $class (@actl) {
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.782 loncom/lonnet/perl/lonnet.pm:1.783
--- loncom/lonnet/perl/lonnet.pm:1.782 Tue Sep 19 15:03:24 2006
+++ loncom/lonnet/perl/lonnet.pm Tue Sep 19 17:36:41 2006
@@ -1,7 +1,7 @@
# The LearningOnline Network
# TCP networking package
#
-# $Id: lonnet.pm,v 1.782 2006/09/19 19:03:24 albertel Exp $
+# $Id: lonnet.pm,v 1.783 2006/09/19 21:36:41 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -292,6 +292,30 @@
return undef;
}
+sub convert_and_load_session_env {
+ my ($lonidsdir,$handle)=@_;
+ my @profile;
+ {
+ open(my $idf,"$lonidsdir/$handle.id");
+ flock($idf,LOCK_SH);
+ @profile=<$idf>;
+ close($idf);
+ }
+ my %temp_env;
+ foreach my $line (@profile) {
+ chomp($line);
+ my ($envname,$envvalue)=split(/=/,$line,2);
+ $temp_env{&unescape($envname)} = &unescape($envvalue);
+ }
+ unlink("$lonidsdir/$handle.id");
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_WRCREAT(),
+ 0640)) {
+ %disk_env = %temp_env;
+ @env{keys(%temp_env)} = @disk_env{keys(%temp_env)};
+ untie(%disk_env);
+ }
+}
+
# ------------------------------------------- Transfer profile into environment
my $env_loaded;
sub transfer_profile_to_env {
@@ -305,30 +329,26 @@
($handle) = ($env{'user.environment'} =~m|/([^/]+)\.id$| );
}
- my @profile;
- {
- open(my $idf,"$lonidsdir/$handle.id");
- flock($idf,LOCK_SH);
- @profile=<$idf>;
- close($idf);
+ my %remove;
+ if (tie(my %disk_env,'GDBM_File',"$lonidsdir/$handle.id",&GDBM_READER(),
+ 0640)) {
+ @env{keys(%disk_env)} = @disk_env{keys(%disk_env)};
+ untie(%disk_env);
+ } else {
+ &convert_and_load_session_env($lonidsdir,$handle);
}
- my $envi;
- my %Remove;
- for ($envi=0;$envi<=$#profile;$envi++) {
- chomp($profile[$envi]);
- my ($envname,$envvalue)=split(/=/,$profile[$envi],2);
- $envname=&unescape($envname);
- $envvalue=&unescape($envvalue);
- $env{$envname} = $envvalue;
+
+ while ( my $envname = each(%env) ) {
if (my ($key,$time) = ($envname =~ /^(cgi\.(\d+)_\d+\.)/)) {
if ($time < time-300) {
- $Remove{$key}++;
+ $remove{$key}++;
}
}
}
+
$env{'user.environment'} = "$lonidsdir/$handle.id";
$env_loaded=1;
- foreach my $expired_key (keys(%Remove)) {
+ foreach my $expired_key (keys(%remove)) {
&delenv($expired_key);
}
}
@@ -347,54 +367,13 @@
$env{$key}=$newenv{$key};
}
}
- foreach my $key (keys(%newenv)) {
- my $value = &escape($newenv{$key});
- delete($newenv{$key});
- $newenv{&escape($key)}=$value;
- }
-
- my $lockfh;
- unless (open($lockfh,"$env{'user.environment'}")) {
- return 'error: '.$!;
- }
- unless (flock($lockfh,LOCK_EX)) {
- &logthis("<font color=\"blue\">WARNING: ".
- 'Could not obtain exclusive lock in appenv: '.$!);
- close($lockfh);
- return 'error: '.$!;
- }
-
- my @oldenv;
- {
- my $fh;
- unless (open($fh,"$env{'user.environment'}")) {
- return 'error: '.$!;
- }
- @oldenv=<$fh>;
- close($fh);
- }
- for (my $i=0; $i<=$#oldenv; $i++) {
- chomp($oldenv[$i]);
- if ($oldenv[$i] ne '') {
- my ($name,$value)=split(/=/,$oldenv[$i],2);
- unless (defined($newenv{$name})) {
- $newenv{$name}=$value;
- }
- }
- }
- {
- my $fh;
- unless (open($fh,">$env{'user.environment'}")) {
- return 'error';
- }
- my $newname;
- foreach $newname (keys %newenv) {
- print $fh $newname.'='.$newenv{$newname}."\n";
+ if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+ 0640)) {
+ while (my ($key,$value) = each(%newenv)) {
+ $disk_env{$key} = $value;
}
- close($fh);
+ untie(%disk_env);
}
-
- close($lockfh);
return 'ok';
}
# ----------------------------------------------------- Delete from Environment
@@ -406,43 +385,15 @@
"Attempt to delete from environment ".$delthis);
return 'error';
}
- my @oldenv;
- {
- my $fh;
- unless (open($fh,"$env{'user.environment'}")) {
- return 'error';
- }
- unless (flock($fh,LOCK_SH)) {
- &logthis("<font color=\"blue\">WARNING: ".
- 'Could not obtain shared lock in delenv: '.$!);
- close($fh);
- return 'error: '.$!;
- }
- @oldenv=<$fh>;
- close($fh);
- }
- {
- my $fh;
- unless (open($fh,">$env{'user.environment'}")) {
- return 'error';
- }
- unless (flock($fh,LOCK_EX)) {
- &logthis("<font color=\"blue\">WARNING: ".
- 'Could not obtain exclusive lock in delenv: '.$!);
- close($fh);
- return 'error: '.$!;
- }
- foreach my $cur_key (@oldenv) {
- my $unescaped_cur_key = &unescape($cur_key);
- if ($unescaped_cur_key=~/^$delthis/) {
- my ($key) = split('=',$cur_key,2);
- $key = &unescape($key);
+ if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
+ 0640)) {
+ foreach my $key (keys(%disk_env)) {
+ if ($key=~/^$delthis/) {
delete($env{$key});
- } else {
- print $fh $cur_key;
+ delete($disk_env{$key});
}
}
- close($fh);
+ untie(%disk_env);
}
return 'ok';
}
@@ -1200,6 +1151,15 @@
return $protocol.$host_name;
}
+sub absolute_url {
+ my ($host_name) = @_;
+ my $protocol = ($ENV{'SERVER_PORT'} == 443?'https://':'http://');
+ if ($host_name eq '') {
+ $host_name = $ENV{'SERVER_NAME'};
+ }
+ return $protocol.$host_name;
+}
+
sub ssi {
my ($fn,%form)=@_;
--albertel1158701803--