home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / lockfile.pl < prev    next >
Text File  |  2009-11-06  |  4KB  |  128 lines
  1. # FILE: lockfile.pl
  2. # DESCRIPTION: Older file-based file locking which we hope you don't have to use
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### file_based_file_unlock
  20. ###
  21. ### Unlocks a file or files
  22. ###
  23.  
  24. sub file_based_file_unlock {
  25.     my @files = @_;
  26.     my $tcache = time;
  27.     undef my %files;
  28.     foreach my $line (@files) {
  29.         $line = (split(/\t/, $line))[0];
  30.         $line = $1 if $line =~ m|.*/(.*)|;
  31.         $files{$line} = 1;
  32.     }
  33.     open (LOCKS, "$DCONF->{admin_dir}/locks.txt");
  34.     my @locks = <LOCKS>;
  35.     close (LOCKS);
  36.     foreach my $line (@locks) {
  37.         $line =~ s/\s+$//;
  38.         my ($x, $y) = split(/\t/, $line);
  39.         $line = "" if $files{$x};
  40.         $line = "" if $tcache > ($y + 15);
  41.         $line .= "\n";
  42.     }
  43.     @locks = grep(/\S/, @locks);
  44.     open (LOCKS, ">$DCONF->{admin_dir}/locks.txt");
  45.     print LOCKS "#\n";
  46.     print LOCKS @locks;
  47.     close (LOCKS);
  48.     return 1;
  49. }
  50.  
  51. ###
  52. ### file_based_file_lock
  53. ###
  54. ### Attempts to gain a file-based file lock on a given file
  55. ###
  56.  
  57. sub file_based_file_lock {
  58.     my ($file) = @_;
  59.     if (!-e "$DCONF->{'admin_dir'}/locks.txt") {
  60.         error_message("File Locking Error", "The locks.txt file in administration directory does not exist.");
  61.     }
  62.     if (!-w "$DCONF->{'admin_dir'}/locks.txt") {
  63.         my $msg = "The locks.txt file in your administration directory is not writable by the server.\n";
  64.         $msg .= "On unix, make sure the permissions on the locks.txt\n";
  65.         $msg .= "file are set to 0777 (rwxrwxrwx).  On NT, have the system\n";
  66.         $msg .= "administrator make the administration directory writable by\n";
  67.         $msg .= "the WWW server.  This is a permissions problem and is between\n";
  68.         $msg .= "you and your web host to work out.  DiscusWare, LLC cannot help you\n";
  69.         $msg .= "resolve this problem.  <A HREF=\"http://www.discusware.com/support/resources/errors/fle.html\" TARGET=_top>Click here</A> for assistance.\n";
  70.         error_message("File Locking Error", $msg . "<P><B>\$!: <FONT COLOR=#ff0000>Permission Denied</FONT></B>", 0, 1);
  71.     }
  72.     my $begun_time = time;
  73.     my $subr_locker = "";
  74.     undef my %files;
  75.     $files{$file} = 1;
  76.     undef my @global;
  77.     while (scalar(keys(%files))) {
  78.         my $flag = 1; my $ctr = time;
  79.         open (LOCKS, "$DCONF->{admin_dir}/locks.txt");
  80.         my @global = <LOCKS>;
  81.         close (LOCKS);
  82.         undef my %lockfiles;
  83.         foreach my $file (@global) {
  84.             my ($filenm, $time, $ps) = split(/\t/, $file);
  85.             $lockfiles{$filenm} = $time;
  86.         }
  87. I:        foreach my $kfile (keys(%files)) {
  88.             undef my $filenm;
  89.             if ($kfile =~ m|.*/(.*)|) {
  90.                 $filenm = $1;
  91.             } else {
  92.                 $filenm = $kfile;
  93.             }
  94.             if ($lockfiles{$filenm} == 0 && $files{"*"} == 0) {
  95.                 push (@global, "$filenm\t$ctr\t$$\n");
  96.                 delete $files{$kfile};
  97.                 next I;
  98.             }
  99.             if ($ctr - $lockfiles{$filenm} >= 10 && $filenm ne "*") {
  100.                 push (@global, "$filenm\t$ctr\t$$\n");
  101.                 delete $files{$kfile};
  102.                 next I;
  103.             }
  104.             if ($ctr - $lockfiles{$filenm} >= 15 && $filenm eq "*") {
  105.                 push (@global, "$filenm\t$ctr\t$$\n");
  106.                 delete $files{$kfile};
  107.                 next I;
  108.             }
  109.         }
  110.         if (time - $begun_time >= 5) {
  111.             if (time > ($begun_time + 5)) {
  112.                 my $filenm = (keys(%files))[0];
  113.                 log_error("lockfile.pl", "file_based_file_lock", "Request for lock on $filenm failed... [$subr_locker,$$]");
  114.                 my $L = read_language();
  115.                 error_message("$L->{'FILELOCKERROR'}", "$L->{FILEISLOCKED}<BR>[$filenm]", 0, 1);
  116.             }
  117.         }
  118.         return 0 if ($subr_locker eq "src-board-subs-common");
  119.     }
  120.     @global = grep(/\S/, @global);
  121.     open (LOCKS, ">$DCONF->{admin_dir}/locks.txt") || error_message("File Locking Error", "Could not write locks.txt file!");
  122.     print LOCKS @global;
  123.     close (LOCKS);
  124.     return 1;
  125. }
  126.  
  127. 1;
  128.