[LON-CAPA-cvs] cvs: loncom(version_2_3_X) /lonnet/perl lonnet.pm

[albertel]

albertel		Thu Jan 25 16:10:52 2007 EDT

  Modified files:              (Branch: version_2_3_X)
    /loncom/lonnet/perl	lonnet.pm 
  Log:
  - backport 1.830
  
  
Index: loncom/lonnet/perl/lonnet.pm
diff -u loncom/lonnet/perl/lonnet.pm:1.824 loncom/lonnet/perl/lonnet.pm:1.824.2.1
--- loncom/lonnet/perl/lonnet.pm:1.824	Sat Jan 13 21:01:16 2007
+++ loncom/lonnet/perl/lonnet.pm	Thu Jan 25 16:10:51 2007
@@ -1,7 +1,7 @@
 # The LearningOnline Network
 # TCP networking package
 #
-# $Id: lonnet.pm,v 1.824 2007/01/14 02:01:16 raeburn Exp $
+# $Id: lonnet.pm,v 1.824.2.1 2007/01/25 21:10:51 albertel Exp $
 #
 # Copyright Michigan State University Board of Trustees
 #
@@ -367,6 +367,26 @@
     }
 }
 
+sub timed_flock {
+    my ($file,$lock_type) = @_;
+    my $failed=0;
+    eval {
+	local $SIG{__DIE__}='DEFAULT';
+	local $SIG{ALRM}=sub {
+	    $failed=1;
+	    die("failed lock");
+	};
+	alarm(13);
+	flock($file,$lock_type);
+	alarm(0);
+    };
+    if ($failed) {
+	return undef;
+    } else {
+	return 1;
+    }
+}
+
 # ---------------------------------------------------------- Append Environment
 
 sub appenv {
@@ -381,8 +401,11 @@
             $env{$key}=$newenv{$key};
         }
     }
-    if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
-	    0640)) {
+    open(my $env_file,$env{'user.environment'});
+    if (&timed_flock($env_file,LOCK_EX)
+	&&
+	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
 	while (my ($key,$value) = each(%newenv)) {
 	    $disk_env{$key} = $value;
 	}
@@ -399,8 +422,11 @@
                 "Attempt to delete from environment ".$delthis);
         return 'error';
     }
-    if (tie(my %disk_env,'GDBM_File',$env{'user.environment'},&GDBM_WRITER(),
-	    0640)) {
+    open(my $env_file,$env{'user.environment'});
+    if (&timed_flock($env_file,LOCK_EX)
+	&&
+	tie(my %disk_env,'GDBM_File',$env{'user.environment'},
+	    (&GDBM_WRITER()|&GDBM_NOLOCK()),0640)) {
 	foreach my $key (keys(%disk_env)) {
 	    if ($key=~/^$delthis/) { 
                 delete($env{$key});