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
  16 use vars qw(
  17   @EXPORT_OK
  18   %EXPORT_TAGS
  19   $Timeout
  20   $violentTimeout
  21   $masterTimeout
  22   $iAmMaster
  23 );
  24
  25 ################################################################################
  26 #
  27 # Export
  28 #
  29 use base qw(Exporter);
  30
  31 @EXPORT_OK   = qw(
  32   lock_file
  33   unlock_file
  34   write_lock_file
  35   write_unlock_file
  36   violent_unlock_file
  37   set_master_lock
  38   release_file
  39 );
  40
  41 %EXPORT_TAGS = (
  42   READ  => [qw(
  43     lock_file
  44     unlock_file
  45     violent_unlock_file
  46   )],
  47   WRITE => [qw(
  48     write_lock_file
  49     write_unlock_file
  50     violent_unlock_file
  51   )],
  52   ALL   => [qw(
  53     lock_file
  54     unlock_file
  55     write_lock_file
  56     write_unlock_file
  57     violent_unlock_file
  58     set_master_lock
  59     release_file
  60   )]
  61 );
  62
  63 ################################################################################
  64 #
  65 # Windows section (no symlinks)
  66 #
  67
  68 ### sub w_lock_file ($;$) ######################################################
  69 #
  70 # set read lock (shared lock)
  71 # (for no-symlink-systems)
  72 #
  73 # Params: $filename - file to lock
  74 #         $timeout  - Lock Timeout (sec.)
  75 #
  76 # Return: Status Code (Bool)
  77 #
  78 sub w_lock_file ($;$) {
  79   my $filename = shift;
  80   my $timeout  = +shift || $Timeout;
  81
  82   if (-f &masterlockfile($filename)) {
  83     for (0..$timeout) {
  84
  85       # try to increment the reference counter
  86       #
  87       &set_ref($filename,1,$timeout) and return 1;
  88       sleep (1);
  89     }
  90    }
  91
  92   else {
  93     # master lock is set
  94     # or file has not been realeased yet
  95     #
  96     return;
  97   }
  98
  99   # time out
 100   # maybe the system is occupied
 101   0;
 102 }
 103
 104 ### sub w_unlock_file ($;$) ####################################################
 105 #
 106 # remove read lock (shared lock)
 107 # (for no-symlink-systems)
 108 #
 109 # Params: $filename - locked file
 110 #         $timeout  - timeout (sec.)
 111 #
 112 # Return: Status Code (Bool)
 113 #
 114 sub w_unlock_file ($;$) {
 115   my $filename = shift;
 116   my $timeout  = shift || $Timeout;
 117
 118   if (-f &masterlockfile($filename)) {
 119
 120     # try do decrement the reference counter
 121     #
 122     &set_ref($filename,-1,$timeout) and return 1;
 123   }
 124
 125   # time out
 126   # maybe the system is occupied
 127   # or file has not been released yet
 128   #
 129   return;
 130 }
 131
 132 ### sub w_write_lock_file ($;$) ################################################
 133 #
 134 # set write lock (exclusive lock)
 135 # (for no-symlink-systems)
 136 #
 137 # Params: $filename - file to lock
 138 #         $timeout  - timeout (sec.)
 139 #
 140 # Return: Status Code (Bool)
 141 #
 142 sub w_write_lock_file ($;$) {
 143   my $filename=shift;
 144   my $timeout= shift || $Timeout;
 145
 146   if (-f &masterlockfile($filename) or $iAmMaster) {
 147
 148     # announce the write lock
 149     # and wait $timeout seconds for
 150     # references == 0 (no shared locks set)
 151     #
 152     &simple_lock ($filename,$timeout) or return;
 153     for (0..$timeout) {
 154       # lock reference counter
 155       # or fail
 156       #
 157       unless (&simple_lock (&reffile($filename),$timeout)) {
 158         &simple_unlock($filename,$timeout);
 159         return;
 160       }
 161
 162       # ready if we have no shared locks
 163       #
 164       return 1 if (&get_ref ($filename) == 0);
 165
 166       # release reference counter
 167       # shared locks get the chance to be removed
 168       #
 169       unless (&simple_unlock (&reffile($filename),$timeout)) {
 170         &simple_unlock($filename,$timeout);
 171         return;
 172       }
 173       sleep(1);
 174     }
 175
 176     # write lock failed
 177     # remove the announcement
 178     #
 179     &simple_unlock ($filename);}
 180
 181   else {
 182     # master lock is set
 183     # or file has not been released yet
 184     #
 185     return;}
 186
 187   # time out
 188   # maybe the system is occupied
 189   #
 190   0;
 191 }
 192
 193 ### sub w_write_unlock_file ($;$) ##############################################
 194 #
 195 # remove write lock (exclusive lock)
 196 # (for no-symlink-systems)
 197 #
 198 # Params: $filename - locked file
 199 #         $timeout  - timeout (sec.)
 200 #
 201 # Return: Status Code (Bool)
 202 #
 203 sub w_write_unlock_file ($;$) {
 204   my $filename = shift;
 205   my $timeout  = shift || $Timeout;
 206
 207   if (-f &masterlockfile($filename) or $iAmMaster) {
 208
 209     # remove reference counter lock
 210     #
 211     &simple_unlock (&reffile($filename),$timeout) or return;
 212
 213     # remove the write lock announce
 214     #
 215     &simple_unlock ($filename,$timeout) or return;}
 216
 217   # done
 218   1;
 219 }
 220
 221 ### sub w_violent_unlock_file ($) ##############################################
 222 #
 223 # remove any lock violent  (excl. master lock)
 224 # (for no-symlink-systems)
 225 #
 226 # Params: $filename - locked file
 227 #
 228 # Return: -none- (the success is not defined)
 229 #
 230 sub w_violent_unlock_file ($) {
 231   my $filename = shift;
 232
 233   if (-f &masterlockfile($filename)) {
 234
 235     # find out last modification time
 236     # and do nothing unless 'violent-timout' is over
 237     #
 238     my $reffile;
 239     if (-f ($reffile = $filename) or -f ($reffile = &lockfile($filename))) {
 240       my $time = (stat $reffile)[9];
 241       return if ((time - $time) < $violentTimeout);}
 242
 243     write_lock_file ($filename,1);       # last try, to set an exclusive lock on $filename
 244     unlink (&reffile($filename));        # reference counter = 0
 245     simple_unlock (&reffile($filename)); # release reference counter file
 246     simple_unlock ($filename);}          # release file
 247
 248   return;
 249 }
 250
 251 ### sub w_set_master_lock ($;$) ################################################
 252 #
 253 # set master lock
 254 # (for no-symlink-systems)
 255 #
 256 # Params: $filename - file to lock
 257 #         $timeout  - timeout (sec.)
 258 #
 259 # Return: Status Code (Bool)
 260 #
 261 sub w_set_master_lock ($;$) {
 262   my $filename = shift;
 263   my $timeout  = shift || $masterTimeout;
 264
 265   # set exclusive lock or fail
 266   #
 267   return unless (&write_lock_file ($filename,$timeout));
 268
 269   # set master lock
 270   #
 271   unlink &masterlockfile($filename) and return 1;
 272
 273   # no chance (occupied?, master lock set yet?)
 274   return;
 275 }
 276
 277 ### sub w_release_file ($) #####################################################
 278 #
 279 # remove any locks (incl. master lock)
 280 # (for no-symlink-systems)
 281 #
 282 # Params: $filename - file to lock
 283 #         $timeout  - timeout (sec.)
 284 #
 285 # Return: Status Code (Bool)
 286 #
 287 sub w_release_file ($) {
 288   my $filename=shift;
 289
 290   unlink (&reffile($filename));                              # reference counter = 0
 291   return if (-f &reffile($filename));                      # really?
 292   return unless (simple_unlock (&reffile($filename)));     # release reference counter
 293   return unless (&simple_unlock ($filename));              # remove any write lock announce
 294   return unless (&simple_unlock (&masterfile($filename))); # remove master lock
 295
 296   # done
 297   1;
 298 }
 299
 300 ################################################################################
 301 #
 302 # *n*x section (symlinks possible)
 303 #
 304
 305 ### sub x_lock_file ($;$) ######################################################
 306 #
 307 # set read lock (shared lock)
 308 # (symlinks possible)
 309 #
 310 # Params: $filename - file to lock
 311 #         $timeout  - Lock Timeout (sec.)
 312 #
 313 # Return: Status Code (Bool)
 314 #
 315 sub x_lock_file ($;$) {
 316   my $filename = shift;
 317   my $timeout  = shift || $Timeout;
 318
 319   unless (-l &masterlockfile($filename)) {
 320     for (0..$timeout) {
 321
 322       # try to increment the reference counter
 323       #
 324       &set_ref($filename,1,$timeout) and return 1;
 325       sleep (1);
 326     }
 327   }
 328
 329   else {
 330     # master lock is set
 331     # or file has not been realeased yet
 332     #
 333     return;
 334   }
 335
 336   # time out
 337   # maybe the system is occupied
 338   0;
 339 }
 340
 341 ### sub x_unlock_file ($;$) ####################################################
 342 #
 343 # remove read lock (shared lock)
 344 # (symlinks possible)
 345 #
 346 # Params: $filename - locked file
 347 #         $timeout  - timeout (sec.)
 348 #
 349 # Return: Status Code (Bool)
 350 #
 351 sub x_unlock_file ($;$) {
 352   my $filename=shift;
 353   my ($timeout)=(shift (@_) or $Timeout);
 354
 355   unless (-l &masterlockfile($filename)) {
 356     # try do decrement the reference counter
 357     #
 358     &set_ref($filename,-1,$timeout) and return 1;}
 359
 360   # time out
 361   # maybe the system is occupied
 362   # or file has not been released yet
 363   #
 364   return;
 365 }
 366
 367 ### sub x_write_lock_file ($;$) ################################################
 368 #
 369 # set write lock (exclusive lock)
 370 # (symlinks possible)
 371 #
 372 # Params: $filename - file to lock
 373 #         $timeout  - timeout (sec.)
 374 #
 375 # Return: Status Code (Bool)
 376 #
 377 sub x_write_lock_file ($;$) {
 378   my $filename = shift;
 379   my $timeout  = shift || $Timeout;
 380
 381   unless (-l &masterlockfile($filename) and not $iAmMaster) {
 382     # announce the write lock
 383     # and wait $timeout seconds for
 384     # references == 0 (no shared locks set)
 385     #
 386     &simple_lock ($filename,$timeout) or return;
 387     for (0..$timeout) {
 388
 389       # lock reference counter
 390       # or fail
 391       #
 392       unless (&simple_lock (&reffile($filename),$timeout)) {
 393         &simple_unlock($filename,$timeout);
 394         return;
 395       }
 396
 397       # ready if we have no shared locks
 398       #
 399       return 1 if (&get_ref ($filename) == 0);
 400
 401       # release reference counter
 402       # shared locks get the chance to be removed
 403       #
 404       unless (&simple_unlock (&reffile($filename),$timeout)) {
 405         &simple_unlock($filename,$timeout);
 406         return;
 407       }
 408       sleep(1);
 409     }
 410
 411     # write lock failed
 412     # remove the announcement
 413     #
 414     &simple_unlock ($filename);}
 415
 416   else {
 417     # master lock is set
 418     # or file has not been released yet
 419     #
 420     return;
 421   }
 422
 423   # time out
 424   # maybe the system is occupied
 425   #
 426   0;
 427 }
 428
 429 ### sub x_write_unlock_file ($;$) ##############################################
 430 #
 431 # remove write lock (exclusive lock)
 432 # (symlinks possible)
 433 #
 434 # Params: $filename - locked file
 435 #         $timeout  - timeout (sec.)
 436 #
 437 # Return: Status Code (Bool)
 438 #
 439 sub x_write_unlock_file ($;$) {
 440   my $filename = shift;
 441   my $timeout  = shift || $Timeout;
 442
 443   unless (-l &masterlockfile($filename) and not $iAmMaster) {
 444     # remove reference counter lock
 445     #
 446     &simple_unlock (&reffile($filename),$timeout) or return;
 447
 448     # remove the write lock announce
 449     #
 450     &simple_unlock ($filename,$timeout) or return;
 451   }
 452
 453   # done
 454   1;
 455 }
 456
 457 ### sub x_violent_unlock_file ($) ##############################################
 458 #
 459 # remove any lock violent  (excl. master lock)
 460 # (symlinks possible)
 461 #
 462 # Params: $filename - locked file
 463 #
 464 # Return: -none- (the success is not defined)
 465 #
 466 sub x_violent_unlock_file ($) {
 467   my $filename=shift;
 468
 469   unless (-l &masterlockfile($filename)) {
 470
 471     # find out last modification time
 472     # and do nothing unless 'violent-timout' is over
 473     #
 474     my ($reffile,$time);
 475
 476     if (-f ($reffile = $filename)) {
 477       $time = (stat $reffile)[9];}
 478
 479     elsif (-l ($reffile = &lockfile($filename))) {
 480       $time = (lstat $reffile)[9];}
 481
 482     if ($reffile) {
 483       return if ((time - $time) < $violentTimeout);}
 484
 485     write_lock_file ($filename,1);       # last try, to set an exclusive lock on $filename
 486     unlink (&reffile($filename));        # reference counter = 0
 487     simple_unlock (&reffile($filename)); # release reference counter file
 488     simple_unlock ($filename);}          # release file
 489 }
 490
 491 ### sub x_set_master_lock ($;$) ################################################
 492 #
 493 # set master lock
 494 # (symlinks possible)
 495 #
 496 # Params: $filename - file to lock
 497 #         $timeout  - timeout (sec.)
 498 #
 499 # Return: Status Code (Bool)
 500 #
 501 sub x_set_master_lock ($;$) {
 502   my $filename = shift;
 503   my $timeout  = shift || $masterTimeout;
 504
 505   # set exclusive lock or fail
 506   #
 507   return unless (&write_lock_file ($filename,$timeout));
 508
 509   # set master lock
 510   #
 511   symlink $filename, &masterlockfile($filename) and return 1;
 512
 513   # no chance (occupied?, master lock set yet?)
 514   return;
 515 }
 516
 517 ### sub x_release_file ($) #####################################################
 518 #
 519 # remove any locks (incl. master lock)
 520 # (symlinks possible)
 521 #
 522 # Params: $filename - file to lock
 523 #         $timeout  - timeout (sec.)
 524 #
 525 # Return: Status Code (Bool)
 526 #
 527 sub x_release_file ($) {
 528   my $filename=shift;
 529
 530   unlink (&reffile($filename));                            # reference counter = 0
 531   return if (-f &reffile($filename));                      # really?
 532   return unless (simple_unlock (&reffile($filename)));     # release reference counter
 533   return unless (&simple_unlock ($filename));              # remove any write lock announce
 534   return unless (&simple_unlock (&masterfile($filename))); # remove master lock
 535
 536   # done
 537   1;
 538 }
 539
 540 ################################################################################
 541 #
 542 # private subs
 543 #
 544
 545 ### sub ~file ($) ##############################################################
 546 #
 547 # create lock file names
 548 #
 549 sub reffile ($) {
 550   "$_[0].lock.ref";
 551 }
 552 sub lockfile ($) {
 553   "$_[0].lock";
 554 }
 555 sub masterlockfile ($) {
 556   &lockfile(&masterfile($_[0]));
 557 }
 558 sub masterfile ($) {
 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 ################################################################