home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / locking.pl < prev    next >
Text File  |  2009-11-06  |  6KB  |  159 lines
  1. # FILE: locking.pl
  2. # DESCRIPTION: File Locking
  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 $PARAMS $DCONF);
  17.  
  18. ###
  19. ### directory_file_based_file_lock
  20. ###
  21. ### Directory-file file locking
  22. ###
  23.  
  24. sub directory_file_based_file_lock {
  25.     my ($files, $subr_locker, $max) = @_;
  26.     my @files = @{ $files };
  27.     while (my $file = shift @files) {
  28.         my $filenm = ( $file =~ m|.*/(.*)| ? $1 : $file );
  29.         performance_string("# LOCK: requested on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  30.         $PARAMS->{files_locked}++;
  31.         if ($file eq "*") {
  32.             my $success = _lock("GLOBAL");
  33.             if (! $success) {
  34.                 my $es = read_language()->{'FILELOCKREGEN'}; $es =~ s/\%sec/7/g;
  35.                 log_error("locking.pl", "directory_file_based_file_lock", "Request for lock on $filenm failed... [$$] (GLOBAL LOCK exists)");
  36.                 error_message(read_language()->{'FILELOCKERROR'}, "$es [$filenm]", 0, 1);
  37.             }
  38.             next;
  39.         } else {
  40.             if (open (GLOBAL, "$DCONF->{admin_dir}/locks/GLOBAL")) {
  41.                 my @file = <GLOBAL>;
  42.                 close (GLOBAL);
  43.                 my $process_file = chomp $file[0];
  44.                 my $ip_file = chomp $file[1];
  45.                 my $time_file = chomp $file[2];
  46.                 if (time - $time_file <= 7) {
  47.                     my $es = read_language()->{'FILELOCKREGEN'}; $es =~ s/\%sec/7/g;
  48.                     log_error("locking.pl", "directory_file_based_file_lock", "Request for lock on $filenm failed... [$$] (GLOBAL LOCK exists)");
  49.                     error_message(read_language()->{'FILELOCKERROR'}, "$es [$filenm]", 0, 1);
  50.                 } else {
  51.                     log_error("locking.pl", "directory_file_based_file_lock", "Stale lock canceled (GLOBAL): " . (time-$time_file) . " seconds old [$process_file,$$]");
  52.                     unlink("$DCONF->{admin_dir}/locks/GLOBAL") if $process_file != $$;
  53.                 }
  54.             }
  55.             my $success = $subr_locker eq "change_board_colors" ? _lock($filenm, 5) : _lock($filenm, 50);
  56.             if ($success) {
  57.                 next;
  58.             } else {
  59.                 performance_string("# LOCK: *FAILED* lock on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  60.                 return 0 if $subr_locker eq "change_board_colors";
  61.                 log_error("locking.pl", "directory_file_based_file_lock", "Request for lock on $filenm failed... [$subr_locker,$$]");
  62.                 error_message(read_language()->{'FILELOCKERROR'}, join("<br>", read_language()->{FILEISLOCKED}, "[$filenm]"), 0, 1);
  63.             }
  64.         }
  65.     }
  66.     return 1;
  67. }
  68.  
  69. sub _lock {
  70.     my ($filename, $cutoff_tries, $process, $ip, $time) = @_;
  71.     $process = $$ if ! defined $process;
  72.     $ip = $ENV{REMOTE_ADDR} if ! defined $ip;
  73.     $time = time if ! defined $time;
  74.     my $tries = 0;
  75.     my $tries_2 = 0;
  76.     my $warned = 0;
  77.     $cutoff_tries = 50 if ! $cutoff_tries;
  78.     my $begun_time = time;
  79.     while (1) {
  80.         $tries_2++;
  81.         return 0 if $tries_2 >= 50;
  82.         while (-e "$DCONF->{admin_dir}/locks/$filename") {
  83.             if (open(FILE, "< $DCONF->{admin_dir}/locks/$filename")) {
  84.                 my @file = <FILE>;
  85.                 close (FILE);
  86.                 my $process_file = $file[0]; chomp $process_file;
  87.                 my $ip_file = $file[1]; chomp $ip_file;
  88.                 my $time_file = $file[2]; chomp $time_file;
  89.                 if ($process_file eq $process && $ip_file eq $ip && ! $warned) {
  90.                     log_error("locking.pl", "_lock", "Attempt to re-lock $filename by process $process; previous file lock by [$process_file]");
  91.                     $warned = 1;
  92.                 }
  93.                 if ($time - $time_file >= 10) {
  94.                     log_error("locking.pl", "_lock", "Stale lock canceled ($filename): " . ($time-$time_file) . " seconds old [$process,$process_file]");
  95.                     unlink "$DCONF->{admin_dir}/locks/$filename";
  96.                 }
  97.                 $tries++;
  98.                 return 0 if $tries >= $cutoff_tries;
  99.                 return 0 if time - $begun_time >= 7;
  100.             }
  101.         }
  102.         my $mask = umask(0333);
  103.         if (open(LOCK, "> $DCONF->{admin_dir}/locks/$filename")) {
  104.             eval 'flock LOCK, 2; seek LOCK, 0, 2;';
  105.             print LOCK "$process\n$ip\n$time\n";
  106.             eval 'flock LOCK, 8;';            
  107.             close (LOCK);
  108.             umask($mask);
  109.             if (open(LOCK, "< $DCONF->{admin_dir}/locks/$filename")) {
  110.                 my @file = <LOCK>;
  111.                 close (LOCK);
  112.                 next if defined $file[3];
  113.                 my $process_file = $file[0]; chomp $process_file;
  114.                 my $ip_file = $file[1]; chomp $ip_file;
  115.                 my $time_file = $file[2]; chomp $time_file;
  116.                 return 1 if $process_file == $process && $ip_file eq $ip;                
  117.             }
  118.         } else {
  119.             umask($mask);
  120.             error_message("File Locking Error", "Could not write to file [$filename] in 'locks' directory");
  121.         }
  122.     }
  123. }
  124.  
  125. ###
  126. ### directory_file_based_file_unlock
  127. ###
  128. ### Unlock file with this scheme
  129. ###
  130.  
  131. sub directory_file_based_file_unlock {
  132.     my ($files) = @_;
  133.     my @files = @{ $files };
  134.     foreach my $file (@files) {
  135.         performance_string("# LOCK: Unlock $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  136.         $PARAMS->{files_unlocked}++;
  137.         if ($file eq "*") {
  138.             unlink("$DCONF->{admin_dir}/locks/GLOBAL") || log_error("src-board-subs-common", "unlock", "Could not remove file 'GLOBAL' from locks directory: $!");
  139.         } else {
  140.             $file =~ m|(.*)/(.*)|; my $dir = $1; my $filenm = $2;
  141.             if (!unlink("$DCONF->{admin_dir}/locks/$filenm")) {
  142.                 if (-e "$DCONF->{admin_dir}/locks/$filenm") {
  143.                     log_error("locking.pl", "directory_file_based_file_unlock", "Could not remove file '$filenm' from locks directory: [$!]");
  144.                     if ($GLOBAL_OPTIONS->{'lockerror_disable'} == 1 || $GLOBAL_OPTIONS->{'lockerror_disable'} eq "") {
  145.                         open (BACKUPS, ">$DCONF->{admin_dir}/backups/QUOTA.txt");
  146.                         print BACKUPS time, "\n";
  147.                         print BACKUPS escape("Unlocking file $filenm -- could not remove file from $DCONF->{admin_dir}/locks because of system error [$!].  If this says 'Permission Denied' you need to fix your permissions as directed at <A HREF=http://www.discusware.com/support/resources/windows/nt_permissions.html>this page</A>.  If allowed to continue this way, your disk quota will fill up quickly, and your users will get 'File Locking Errors' more often than they should"), "\n";
  148.                         close (BACKUPS);
  149.                         quota_err();
  150.                     }
  151.                 }
  152.             }
  153.         }
  154.     }
  155.     return 1;    
  156. }
  157.  
  158. 1;
  159.