[LON-CAPA-cvs] cvs: modules /albertel lond_locktest.pl

[albertel]

albertel		Thu Jan 19 16:45:17 2006 EDT

  Added files:                 
    /modules/albertel	lond_locktest.pl 
  Log:
  - test script for fixing bug#4476
  
  

Index: modules/albertel/lond_locktest.pl
+++ modules/albertel/lond_locktest.pl
use GDBM_File;
use Fcntl qw(:flock);
use strict;
$|=1;
my $file='lock.db';
for my $child (1..10) {
    sleep(1);
    my $pid=fork();
    if (!$pid) {
	my $length = int(rand(10));
	my ($lock, $client, $mode);
	if ($$%2) {
	    $lock=LOCK_SH;
	    $client='read ';
	    $mode=&GDBM_READER()|&GDBM_NOLOCK();
	} elsif (not $$%2) {
	    $lock=LOCK_EX;
	    $client='write';
	    $mode=&GDBM_WRCREAT()|&GDBM_NOLOCK();
	}
	print("$client ($child) for $length".$/);
	open(LOCK,$file);
	print("$client ($child) attempt lock".$/);
	my $failed=0;
	local $SIG{ALRM}=sub { 
	    $failed=1;
	    die;
	};
	eval {
	    alarm(3);
	    flock(LOCK,$lock);
	    alarm(0);
	};
	if ($failed) {
	    print("$client ($child) got failed lock".$/);
	    exit;
	}
	print("$client ($child) got lock".$/);
	my %hash;
	if (!tie(%hash,'GDBM_File',$file,$mode,0640)) {
	    print("$client ($child) error: ".ord($!)." $! \n");
	    die();
	}
	if ($client eq 'write') {
	    print("$client ($child) ".($hash{'pid'}=$$).$/);
	}
	if ($client eq 'read ') {
	    print("$client ($child) ".$hash{'pid'}.$/);
	}
	sleep($length);
	untie(%hash);
	print("$client ($child) releasing lock".$/);
	close(LOCK);
	sleep(100);
	exit;
    }
}