selfforum-cgi/shared/Lock.pm

   1 package Lock;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/Lock.pm                                                  #
   6 #                                                                              #
   7 # Authors:     Andre Malo       <nd@o3media.de>, 2001-04-01                    #
   8 #                                                                              #
   9 # Description: file locking                                                    #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use Carp;
  15 use vars qw(
  16   @EXPORT_OK
  17   %EXPORT_TAGS
  18   $Timeout
  19   $violentTimeout
  20   $masterTimeout
  21   $iAmMaster
  22 );
  23
  24 ################################################################################
  25 #
  26 # Export
  27 #
  28 use base qw(Exporter);
  29
  30 @EXPORT_OK   = qw(
  31   lock_file
  32   unlock_file
  33   write_lock_file
  34   write_unlock_file
  35   violent_unlock_file
  36   set_master_lock
  37   release_file
  38 );
  39
  40 %EXPORT_TAGS = (
  41   READ  => [qw(
  42     lock_file
  43     unlock_file
  44     violent_unlock_file
  45   )],
  46   WRITE => [qw(
  47     write_lock_file
  48     write_unlock_file
  49     violent_unlock_file
  50   )],
  51   ALL   => [qw(
  52     lock_file
  53     unlock_file
  54     write_lock_file
  55     write_unlock_file
  56     violent_unlock_file
  57     set_master_lock
  58     release_file
  59   )]
  60 );
  61
  62 ################################################################################
  63 #
  64 # Windows section (no symlinks)
  65 #
  66
  67 ### sub w_lock_file ($;$) ######################################################
  68 #
  69 # set read lock (shared lock)
  70 # (for no-symlink-systems)
  71 #
  72 # Params: $filename - file to lock
  73 #         $timeout  - Lock Timeout (sec.)
  74 #
  75 # Return: Status Code (Bool)
  76 #
  77 sub w_lock_file ($;$) {
  78   my $filename = shift;
  79   my $timeout  = +shift || $Timeout;
  80
  81   if (-f &masterlockfile($filename)) {
  82     for (0..$timeout) {
  83
  84       # try to increment the reference counter
  85       #
  86       &set_ref($filename,1,$timeout) and return 1;
  87       sleep (1);
  88     }
  89    }
  90
  91   else {
  92     # master lock is set
  93     # or file has not been realeased yet
  94     #
  95     return;
  96   }
  97
  98   # time out
  99   # maybe the system is occupied
 100   0;
 101 }
 102
 103 ### sub w_unlock_file ($;$) ####################################################
 104 #
 105 # remove read lock (shared lock)
 106 # (for no-symlink-systems)
 107 #
 108 # Params: $filename - locked file
 109 #         $timeout  - timeout (sec.)
 110 #
 111 # Return: Status Code (Bool)
 112 #
 113 sub w_unlock_file ($;$) {
 114   my $filename = shift;
 115   my $timeout  = shift || $Timeout;
 116
 117   if (-f &masterlockfile($filename)) {
 118
 119     # try do decrement the reference counter
 120     #
 121     &set_ref($filename,-1,$timeout) and return 1;
 122   }
 123
 124   # time out
 125   # maybe the system is occupied
 126   # or file has not been released yet
 127   #
 128   return;
 129 }
 130
 131 ### sub w_write_lock_file ($;$) ################################################
 132 #
 133 # set write lock (exclusive lock)
 134 # (for no-symlink-systems)
 135 #
 136 # Params: $filename - file to lock
 137 #         $timeout  - timeout (sec.)
 138 #
 139 # Return: Status Code (Bool)
 140 #
 141 sub w_write_lock_file ($;$) {
 142   my $filename=shift;
 143   my $timeout= shift || $Timeout;
 144
 145   if (-f &masterlockfile($filename) or $iAmMaster) {
 146
 147     # announce the write lock
 148     # and wait $timeout seconds for
 149     # references == 0 (no shared locks set)
 150     #
 151     &simple_lock ($filename,$timeout) or return 0;
 152     for (0..$timeout) {
 153       # lock reference counter
 154       # or fail
 155       #
 156       unless (&simple_lock (&reffile($filename),$timeout)) {
 157         &simple_unlock($filename,$timeout);
 158         return 0;
 159       }
 160
 161       # ready if we have no shared locks
 162       #
 163       return 1 if (&get_ref ($filename) == 0);
 164
 165       # release reference counter
 166       # shared locks get the chance to be removed
 167       #
 168       unless (&simple_unlock (&reffile($filename),$timeout)) {
 169         &simple_unlock($filename,$timeout);
 170         return 0;
 171       }
 172       sleep(1);
 173     }
 174
 175     # write lock failed
 176     # remove the announcement
 177     #
 178     &simple_unlock ($filename);}
 179
 180   else {
 181     # master lock is set
 182     # or file has not been released yet
 183     #
 184     return;}
 185
 186   # time out
 187   # maybe the system is occupied
 188   #
 189   0;
 190 }
 191
 192 ### sub w_write_unlock_file ($;$) ##############################################
 193 #
 194 # remove write lock (exclusive lock)
 195 # (for no-symlink-systems)
 196 #
 197 # Params: $filename - locked file
 198 #         $timeout  - timeout (sec.)
 199 #
 200 # Return: Status Code (Bool)
 201 #
 202 sub w_write_unlock_file ($;$) {
 203   my $filename = shift;
 204   my $timeout  = shift || $Timeout;
 205
 206   if (-f &masterlockfile($filename) or $iAmMaster) {
 207
 208     # remove reference counter lock
 209     #
 210     &simple_unlock (&reffile($filename),$timeout) or return;
 211
 212     # remove the write lock announce
 213     #
 214     &simple_unlock ($filename,$timeout) or return;}
 215
 216   # done
 217   1;
 218 }
 219
 220 ### sub w_violent_unlock_file ($) ##############################################
 221 #
 222 # remove any lock violent  (excl. master lock)
 223 # (for no-symlink-systems)
 224 #
 225 # Params: $filename - locked file
 226 #
 227 # Return: -none- (the success is not defined)
 228 #
 229 sub w_violent_unlock_file ($) {
 230   my $filename = shift;
 231
 232   if (-f &masterlockfile($filename)) {
 233
 234     # find out last modification time
 235     # and do nothing unless 'violent-timout' is over
 236     #
 237     my $reffile;
 238     if (-f ($reffile = $filename) or -f ($reffile = &lockfile($filename))) {
 239       my $time = (stat $reffile)[9];
 240       return if ((time - $time) < $violentTimeout);}
 241
 242     write_lock_file ($filename,1);       # last try, to set an exclusive lock on $filename
 243     unlink (&reffile($filename));        # reference counter = 0
 244     simple_unlock (&reffile($filename)); # release reference counter file
 245     simple_unlock ($filename);}          # release file
 246
 247   return;
 248 }
 249
 250 ### sub w_set_master_lock ($;$) ################################################
 251 #
 252 # set master lock
 253 # (for no-symlink-systems)
 254 #
 255 # Params: $filename - file to lock
 256 #         $timeout  - timeout (sec.)
 257 #
 258 # Return: Status Code (Bool)
 259 #
 260 sub w_set_master_lock ($;$) {
 261   my $filename = shift;
 262   my $timeout  = shift || $masterTimeout;
 263
 264   # set exclusive lock or fail
 265   #
 266   return unless (&write_lock_file ($filename,$timeout));
 267
 268   # set master lock
 269   #
 270   unlink &masterlockfile($filename) and return 1;
 271
 272   # no chance (occupied?, master lock set yet?)
 273   return;
 274 }
 275
 276 ### sub w_release_file ($) #####################################################
 277 #
 278 # remove any locks (incl. master lock)
 279 # (for no-symlink-systems)
 280 #
 281 # Params: $filename - file to lock
 282 #         $timeout  - timeout (sec.)
 283 #
 284 # Return: Status Code (Bool)
 285 #
 286 sub w_release_file ($) {
 287   my $filename=shift;
 288
 289   unlink (&reffile($filename));                              # reference counter = 0
 290   return if (-f &reffile($filename));                      # really?
 291   return unless (simple_unlock (&reffile($filename)));     # release reference counter
 292   return unless (&simple_unlock ($filename));              # remove any write lock announce
 293   return unless (&simple_unlock (&masterfile($filename))); # remove master lock
 294
 295   # done
 296   1;
 297 }
 298
 299 ################################################################################
 300 #
 301 # *n*x section (symlinks possible)
 302 #
 303
 304 ### sub x_lock_file ($;$) ######################################################
 305 #
 306 # set read lock (shared lock)
 307 # (symlinks possible)
 308 #
 309 # Params: $filename - file to lock
 310 #         $timeout  - Lock Timeout (sec.)
 311 #
 312 # Return: Status Code (Bool)
 313 #
 314 sub x_lock_file ($;$) {
 315   my $filename = shift;
 316   my $timeout  = shift || $Timeout;
 317
 318   unless (-l &masterlockfile($filename)) {
 319     for (0..$timeout) {
 320
 321       # try to increment the reference counter
 322       #
 323       &set_ref($filename,1,$timeout) and return 1;
 324       sleep (1);
 325     }
 326   }
 327
 328   else {
 329     # master lock is set
 330     # or file has not been realeased yet
 331     #
 332     return;
 333   }
 334
 335   # time out
 336   # maybe the system is occupied
 337   0;
 338 }
 339
 340 ### sub x_unlock_file ($;$) ####################################################
 341 #
 342 # remove read lock (shared lock)
 343 # (symlinks possible)
 344 #
 345 # Params: $filename - locked file
 346 #         $timeout  - timeout (sec.)
 347 #
 348 # Return: Status Code (Bool)
 349 #
 350 sub x_unlock_file ($;$) {
 351   my $filename=shift;
 352   my ($timeout)=(shift (@_) or $Timeout);
 353
 354   unless (-l &masterlockfile($filename)) {
 355     # try do decrement the reference counter
 356     #
 357     &set_ref($filename,-1,$timeout) and return 1;}
 358
 359   # time out
 360   # maybe the system is occupied
 361   # or file has not been released yet
 362   #
 363   return;
 364 }
 365
 366 ### sub x_write_lock_file ($;$) ################################################
 367 #
 368 # set write lock (exclusive lock)
 369 # (symlinks possible)
 370 #
 371 # Params: $filename - file to lock
 372 #         $timeout  - timeout (sec.)
 373 #
 374 # Return: Status Code (Bool)
 375 #
 376 sub x_write_lock_file ($;$) {
 377   my $filename = shift;
 378   my $timeout  = shift || $Timeout;
 379
 380   unless (-l &masterlockfile($filename) and not $iAmMaster) {
 381     # announce the write lock
 382     # and wait $timeout seconds for
 383     # references == 0 (no shared locks set)
 384     #
 385     &simple_lock ($filename,$timeout) or return 0;
 386     for (0..$timeout) {
 387
 388       # lock reference counter
 389       # or fail
 390       #
 391       unless (&simple_lock (&reffile($filename),$timeout)) {
 392         &simple_unlock($filename,$timeout);
 393         return 0;
 394       }
 395
 396       # ready if we have no shared locks
 397       #
 398       return 1 if (&get_ref ($filename) == 0);
 399
 400       # release reference counter
 401       # shared locks get the chance to be removed
 402       #
 403       unless (&simple_unlock (&reffile($filename),$timeout)) {
 404         &simple_unlock($filename,$timeout);
 405         return 0;
 406       }
 407       sleep(1);
 408     }
 409
 410     # write lock failed
 411     # remove the announcement
 412     #
 413     &simple_unlock ($filename);}
 414
 415   else {
 416     # master lock is set
 417     # or file has not been released yet
 418     #
 419     return;
 420   }
 421
 422   # time out
 423   # maybe the system is occupied
 424   #
 425   0;
 426 }
 427
 428 ### sub x_write_unlock_file ($;$) ##############################################
 429 #
 430 # remove write lock (exclusive lock)
 431 # (symlinks possible)
 432 #
 433 # Params: $filename - locked file
 434 #         $timeout  - timeout (sec.)
 435 #
 436 # Return: Status Code (Bool)
 437 #
 438 sub x_write_unlock_file ($;$) {
 439   my $filename = shift;
 440   my $timeout  = shift || $Timeout;
 441
 442   unless (-l &masterlockfile($filename) and not $iAmMaster) {
 443     # remove reference counter lock
 444     #
 445     &simple_unlock (&reffile($filename),$timeout) or return;
 446
 447     # remove the write lock announce
 448     #
 449     &simple_unlock ($filename,$timeout) or return;
 450   }
 451
 452   # done
 453   1;
 454 }
 455
 456 ### sub x_violent_unlock_file ($) ##############################################
 457 #
 458 # remove any lock violent  (excl. master lock)
 459 # (symlinks possible)
 460 #
 461 # Params: $filename - locked file
 462 #
 463 # Return: -none- (the success is not defined)
 464 #
 465 sub x_violent_unlock_file ($) {
 466   my $filename=shift;
 467
 468   unless (-l &masterlockfile($filename)) {
 469
 470     # find out last modification time
 471     # and do nothing unless 'violent-timout' is over
 472     #
 473     my ($reffile,$time);
 474
 475     if (-f ($reffile = $filename)) {
 476       $time = (stat $reffile)[9];}
 477
 478     elsif (-l ($reffile = &lockfile($filename))) {
 479       $time = (lstat $reffile)[9];}
 480
 481     if ($reffile) {
 482       return if ((time - $time) < $violentTimeout);}
 483
 484     write_lock_file ($filename,1);       # last try, to set an exclusive lock on $filename
 485     unlink (&reffile($filename));        # reference counter = 0
 486     simple_unlock (&reffile($filename)); # release reference counter file
 487     simple_unlock ($filename);}          # release file
 488 }
 489
 490 ### sub x_set_master_lock ($;$) ################################################
 491 #
 492 # set master lock
 493 # (symlinks possible)
 494 #
 495 # Params: $filename - file to lock
 496 #         $timeout  - timeout (sec.)
 497 #
 498 # Return: Status Code (Bool)
 499 #
 500 sub x_set_master_lock ($;$) {
 501   my $filename = shift;
 502   my $timeout  = shift || $masterTimeout;
 503
 504   # set exclusive lock or fail
 505   #
 506   return unless (&write_lock_file ($filename,$timeout));
 507
 508   # set master lock
 509   #
 510   symlink $filename, &masterlockfile($filename) and return 1;
 511
 512   # no chance (occupied?, master lock set yet?)
 513   return;
 514 }
 515
 516 ### sub x_release_file ($) #####################################################
 517 #
 518 # remove any locks (incl. master lock)
 519 # (symlinks possible)
 520 #
 521 # Params: $filename - file to lock
 522 #         $timeout  - timeout (sec.)
 523 #
 524 # Return: Status Code (Bool)
 525 #
 526 sub x_release_file ($) {
 527   my $filename=shift;
 528
 529   unlink (&reffile($filename));                            # reference counter = 0
 530   return if (-f &reffile($filename));                      # really?
 531   return unless (simple_unlock (&reffile($filename)));     # release reference counter
 532   return unless (&simple_unlock ($filename));              # remove any write lock announce
 533   return unless (&simple_unlock (&masterfile($filename))); # remove master lock
 534
 535   # done
 536   1;
 537 }
 538
 539 ################################################################################
 540 #
 541 # private subs
 542 #
 543
 544 ### sub ~file ($) ##############################################################
 545 #
 546 # create lock file names
 547 #
 548 sub reffile ($) {
 549   "$_[0].lock.ref";
 550 }
 551 sub lockfile ($) {
 552   "$_[0].lock";
 553 }
 554 sub masterlockfile ($) {
 555   &lockfile(&masterfile($_[0]));
 556 }
 557 sub masterfile ($) {
 558   confess unless defined $_[0];
 559   "$_[0].master";
 560 }
 561
 562 ### sub w_simple_lock ($;$) ####################################################
 563 ### sub w_simple_unlock ($) ####################################################
 564 #
 565 # simple file lock/unlock
 566 # (for no-symlink-systems: kill/create lockfile)
 567 #
 568 # Params: $filename  - file to lock
 569 #         [ $timeout - Lock time out (sec.) ]
 570 #
 571 # Return: Status Code (Bool)
 572 #
 573 sub w_simple_lock ($;$) {
 574   my $filename = shift;
 575   my $timeout  = shift || $Timeout;
 576   my $lockfile = lockfile $filename;
 577
 578   for (0..$timeout) {
 579     unlink $lockfile and return 1;
 580     sleep(1);
 581   }
 582
 583   # timeout
 584   # occupied?
 585   return;
 586 }
 587
 588 sub w_simple_unlock ($) {
 589   my $filename = shift;
 590   my $lockfile = lockfile $filename;
 591   local *LF;
 592
 593   if (open(LF, "> $lockfile")) {
 594     return 1 if close (LF);
 595   }
 596
 597   # not able to create lockfile, hmmm...
 598   #
 599   return;
 600 }
 601
 602 ### sub w_simple_lock ($;$) ####################################################
 603 ### sub w_simple_unlock ($) ####################################################
 604 #
 605 # simple file lock/unlock
 606 # (symlinks possible: create/unlink symlink)
 607 #
 608 # Params: $filename  - file to lock
 609 #         [ $timeout - Lock time out (sec.) ]
 610 #
 611 # Return: Status Code (Bool)
 612 #
 613 sub x_simple_lock ($;$) {
 614   my $filename = shift;
 615   my $timeout  = shift || $Timeout;
 616   my $lockfile = lockfile $filename;
 617
 618   for (0..$timeout) {
 619     symlink $filename,$lockfile and return 1;
 620     sleep(1);
 621   }
 622
 623   # time out
 624   # locking failed (occupied?)
 625   #
 626   return;
 627 }
 628
 629 sub x_simple_unlock ($) {
 630   my $filename=shift;
 631
 632   unlink (&lockfile($filename)) and return 1;
 633
 634   # not able to unlink symlink, hmmm...
 635   #
 636   return;
 637 }
 638
 639 ### sub w_set_ref ($$$) ########################################################
 640 #
 641 # add $_[1] to reference counter
 642 # (may be negative...)
 643 # (for no-symlink-systems)
 644 #
 645 # Params: $filename - file, reference counter belongs to
 646 #         $z        - value, added to reference counter
 647 #         $timeout  - lock time out
 648 #
 649 # Return: Status Code (Bool)
 650 #
 651 sub w_set_ref ($$$) {
 652   my $filename = shift;
 653   my $z        = shift;
 654   my $timeout  = shift || $Timeout;
 655   my $old;
 656   my $reffile = reffile $filename;
 657   local *REF;
 658
 659   # if write lock announced, only count down allowed
 660   #
 661   if ($z > 0) {
 662     return unless(-f lockfile($filename));
 663   }
 664
 665   # lock reference counter file
 666   #
 667   return unless(&simple_lock ($reffile,$timeout));
 668
 669   # load reference counter
 670   #
 671   unless (open REF,"<$reffile") {
 672     $old=0;
 673   }
 674   else {
 675     $old=<REF>;
 676     chomp $old;
 677     close REF or return;
 678   }
 679
 680   # compute and write new ref. counter
 681   #
 682   $old += $z;
 683   $old = 0 if ($old < 0);
 684
 685   # kill reference counter file
 686   # if ref. counter == 0
 687   #
 688   if ($old == 0) {
 689     unlink $reffile or return;
 690   }
 691   else {
 692     open REF,">$reffile" or return;
 693     print REF $old or return;
 694     close REF or return;
 695   }
 696
 697   # release ref. counter file
 698   #
 699   return unless(&simple_unlock($reffile));
 700
 701   # done
 702   1;
 703 }
 704
 705 ### sub x_set_ref ($$$) ########################################################
 706 #
 707 # add $_[1] to reference counter
 708 # (may be negative...)
 709 # (symlinks possible)
 710 #
 711 # Params: $filename - file, reference counter belongs to
 712 #         $z        - value, added to reference counter
 713 #         $timeout  - lock time out
 714 #
 715 # Return: Status Code (Bool)
 716 #
 717 sub x_set_ref ($$$) {
 718   my $filename = shift;
 719   my $z        = shift;
 720   my $timeout  = shift || $Timeout;
 721   my $old;
 722   my $reffile = reffile $filename;
 723   local *REF;
 724
 725   # if write lock announced, only count down allowed
 726   #
 727   if ($z > 0) {
 728     return if(-l &lockfile($filename));
 729   }
 730
 731   # lock reference counter file
 732   #
 733   return unless(&simple_lock ($reffile,$timeout));
 734
 735   # load reference counter
 736   #
 737   unless (open REF,"<$reffile") {
 738     $old=0;
 739   }
 740   else {
 741     $old=<REF>;
 742     chomp $old;
 743     close REF or return;
 744   }
 745
 746   # compute and write new ref. counter
 747   #
 748   $old += $z;
 749   $old = 0 if ($old < 0);
 750   if ($old == 0) {
 751     unlink $reffile or return;
 752   }
 753   else {
 754     open REF,">$reffile" or return;
 755     print REF $old or return;
 756     close REF or return;
 757   }
 758
 759   # release ref. counter file
 760   #
 761   return unless(&simple_unlock($reffile));
 762
 763   # done
 764   1;
 765 }
 766
 767 ### sub get_ref ($) ############################################################
 768 #
 769 # read out the reference counter
 770 # (system independant)
 771 # no locking here!
 772 #
 773 # Params: $filename - file, the ref. counter belongs to
 774 #
 775 # Return: reference counter
 776 #
 777 sub get_ref ($$) {
 778   my $filename = shift;
 779   my $reffile  = reffile $filename;
 780   my $old;
 781   local *REF;
 782
 783   unless (open REF,"< $reffile") {
 784     $old = 0;
 785   }
 786   else {
 787     $old=<REF>;
 788     chomp $old;
 789     close REF;
 790   }
 791
 792   # return value
 793   $old;
 794 }
 795
 796 ################################################################################
 797 #
 798 # initializing the module
 799 #
 800 BEGIN {
 801   # global variables (time in seconds)
 802   #
 803   $Timeout        =  10; # normal timeout
 804   $violentTimeout = 600; # violent timeout (10 minutes)
 805   $masterTimeout  =  20; # master timeout
 806
 807   $iAmMaster = 0;        # default: I am nobody
 808
 809   # assign the aliases to the needed functions
 810   # (perldoc -f symlink)
 811
 812   if ( eval {local $SIG{__DIE__}; symlink('',''); 1 } ) {
 813     *lock_file           = \&x_lock_file;
 814     *unlock_file         = \&x_unlock_file;
 815     *write_lock_file     = \&x_write_lock_file;
 816     *write_unlock_file   = \&x_write_unlock_file;
 817     *violent_unlock_file = \&x_violent_unlock_file;
 818     *set_master_lock     = \&x_set_master_lock;
 819     *release_file        = \&x_release_file;
 820
 821     *simple_lock         = \&x_simple_lock;
 822     *simple_unlock       = \&x_simple_unlock;
 823     *set_ref             = \&x_set_ref;
 824   }
 825
 826   else {
 827     *lock_file           = \&w_lock_file;
 828     *unlock_file         = \&w_unlock_file;
 829     *write_lock_file     = \&w_write_lock_file;
 830     *write_unlock_file   = \&w_write_unlock_file;
 831     *violent_unlock_file = \&w_violent_unlock_file;
 832     *set_master_lock     = \&w_set_master_lock;
 833     *release_file        = \&w_release_file;
 834
 835     *simple_lock         = \&w_simple_lock;
 836     *simple_unlock       = \&w_simple_unlock;
 837     *set_ref             = \&w_set_ref;
 838   }
 839 }
 840
 841 # keeping require happy
 842 1;
 843
 844 #
 845 #
 846 ### end of Lock ################################################################