Path: utzoo!utgpu!news-server.csri.toronto.edu!bonnie.concordia.ca!thunder.mcrcim.mcgill.edu!snorkelwacker.mit.edu!ira.uka.de!smurf!urlichs
From: urlichs@smurf.sub.org (Matthias Urlichs)
Newsgroups: comp.lang.perl
Subject: Re: While learning PERL... a suggestion
Keywords: perl file learn suggest
Message-ID: <"_mdh2.1m4@smurf.sub.org>
Date: 22 Jan 91 09:26:46 GMT
References: <118879@uunet.UU.NET> <1991Jan21.092204.11944@ux1.cso.uiuc.edu> <119430@uunet.UU.NET>
Organization: University of Karlsruhe, FRG
Lines: 94

In comp.lang.perl, article <119430@uunet.UU.NET>,
  rbj@uunet.UU.NET (Root Boy Jim) writes:
< 
< Another thing perl needs is the ability to create lock files. Sysopen?
< 

## code fragment from my UUCP job file mangler
# usage: &start;
# if &lock("RESOURCE") {
#    ...
#    &unlock("RESOURCE");
# } ...
# &end;
#
# lock files are assumed to contain the process ID as a binary integer.
# Modification for ASCII PIDs is trivial.
# Dead lock files are automagically deleted -- race conditions are possible
#   here!
#
# If you want to convert this to a package, go ahead.

$basedir = '/usr/local/uucp/';
$lockdir = $basedir . 'lock/';

sub readlock {
   local($lock) = @_;
   local($pid) = 0;
   local($spid);
   if (open (LF, $lock)) {
      if (read (LF, $spid, 4) == 4) {
         ($pid) = unpack ("L", $spid);
      }
      close(LF);
   }
   $pid;
}

sub exists {
  local($proc) = @_;
  if ($proc) {
     if (kill (0,$proc)) {
	1;
     } else {
	if($! == 3) { # ESRCH -- process does not exist
	   0;
	} else {
	   1;
	}
     }
  } else {
     0;
  }
}

sub lock {
   local($lock) = @_;
   $lock = $lockdir . 'LCK..' . $lock;
   if (link ($locktemp, $lock)) {
      1;
   } else {
      local($pid) = &readlock ($lock);
      if (&exists($pid)) {
	 0;
      } else {
	 unlink($lock);
	 sleep 2;
	 link($locktemp,$lock);
      }
   }
}

sub unlock {
   local($lock) = @_;
   $lock = $lockdir . 'LCK..' . $lock;
   unlink ($lock);
}


sub start {
   $locktemp = $lockdir . 'PID..' . $$;
   open(LOCK, '>'.$locktemp) || die 'open ' . $locktemp;
   print LOCK pack('I', $$);
   close(LOCK);
}

sub end {
   &unlock($curlock);
   unlink($locktemp);
}


-- 
Matthias Urlichs -- urlichs@smurf.sub.org -- urlichs@smurf.ira.uka.de     /(o\
Humboldtstrasse 7 - 7500 Karlsruhe 1 - FRG -- +49+721+621127(0700-2330)   \o)/