home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
rtsi.com
/
2014.01.www.rtsi.com.tar
/
www.rtsi.com
/
OS9
/
FAQ
/
cgi-bin
/
discus4_00
/
source
/
lockfile.pl
< prev
next >
Wrap
Text File
|
2009-11-06
|
4KB
|
128 lines
# FILE: lockfile.pl
# DESCRIPTION: Older file-based file locking which we hope you don't have to use
#-------------------------------------------------------------------------------
# DISCUS COPYRIGHT NOTICE
#
# Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
# The use of Discus is governed by the Discus License Agreement which is
# available from the Discus WWW site at:
# http://www.discusware.com/discus/license
#
# Pursuant to the Discus License Agreement, this copyright notice may not be
# removed or altered in any way.
#-------------------------------------------------------------------------------
use strict;
use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
###
### file_based_file_unlock
###
### Unlocks a file or files
###
sub file_based_file_unlock {
my @files = @_;
my $tcache = time;
undef my %files;
foreach my $line (@files) {
$line = (split(/\t/, $line))[0];
$line = $1 if $line =~ m|.*/(.*)|;
$files{$line} = 1;
}
open (LOCKS, "$DCONF->{admin_dir}/locks.txt");
my @locks = <LOCKS>;
close (LOCKS);
foreach my $line (@locks) {
$line =~ s/\s+$//;
my ($x, $y) = split(/\t/, $line);
$line = "" if $files{$x};
$line = "" if $tcache > ($y + 15);
$line .= "\n";
}
@locks = grep(/\S/, @locks);
open (LOCKS, ">$DCONF->{admin_dir}/locks.txt");
print LOCKS "#\n";
print LOCKS @locks;
close (LOCKS);
return 1;
}
###
### file_based_file_lock
###
### Attempts to gain a file-based file lock on a given file
###
sub file_based_file_lock {
my ($file) = @_;
if (!-e "$DCONF->{'admin_dir'}/locks.txt") {
error_message("File Locking Error", "The locks.txt file in administration directory does not exist.");
}
if (!-w "$DCONF->{'admin_dir'}/locks.txt") {
my $msg = "The locks.txt file in your administration directory is not writable by the server.\n";
$msg .= "On unix, make sure the permissions on the locks.txt\n";
$msg .= "file are set to 0777 (rwxrwxrwx). On NT, have the system\n";
$msg .= "administrator make the administration directory writable by\n";
$msg .= "the WWW server. This is a permissions problem and is between\n";
$msg .= "you and your web host to work out. DiscusWare, LLC cannot help you\n";
$msg .= "resolve this problem. <A HREF=\"http://www.discusware.com/support/resources/errors/fle.html\" TARGET=_top>Click here</A> for assistance.\n";
error_message("File Locking Error", $msg . "<P><B>\$!: <FONT COLOR=#ff0000>Permission Denied</FONT></B>", 0, 1);
}
my $begun_time = time;
my $subr_locker = "";
undef my %files;
$files{$file} = 1;
undef my @global;
while (scalar(keys(%files))) {
my $flag = 1; my $ctr = time;
open (LOCKS, "$DCONF->{admin_dir}/locks.txt");
my @global = <LOCKS>;
close (LOCKS);
undef my %lockfiles;
foreach my $file (@global) {
my ($filenm, $time, $ps) = split(/\t/, $file);
$lockfiles{$filenm} = $time;
}
I: foreach my $kfile (keys(%files)) {
undef my $filenm;
if ($kfile =~ m|.*/(.*)|) {
$filenm = $1;
} else {
$filenm = $kfile;
}
if ($lockfiles{$filenm} == 0 && $files{"*"} == 0) {
push (@global, "$filenm\t$ctr\t$$\n");
delete $files{$kfile};
next I;
}
if ($ctr - $lockfiles{$filenm} >= 10 && $filenm ne "*") {
push (@global, "$filenm\t$ctr\t$$\n");
delete $files{$kfile};
next I;
}
if ($ctr - $lockfiles{$filenm} >= 15 && $filenm eq "*") {
push (@global, "$filenm\t$ctr\t$$\n");
delete $files{$kfile};
next I;
}
}
if (time - $begun_time >= 5) {
if (time > ($begun_time + 5)) {
my $filenm = (keys(%files))[0];
log_error("lockfile.pl", "file_based_file_lock", "Request for lock on $filenm failed... [$subr_locker,$$]");
my $L = read_language();
error_message("$L->{'FILELOCKERROR'}", "$L->{FILEISLOCKED}<BR>[$filenm]", 0, 1);
}
}
return 0 if ($subr_locker eq "src-board-subs-common");
}
@global = grep(/\S/, @global);
open (LOCKS, ">$DCONF->{admin_dir}/locks.txt") || error_message("File Locking Error", "Could not write locks.txt file!");
print LOCKS @global;
close (LOCKS);
return 1;
}
1;