[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--