selfforum-cgi/shared/Posting/Cache.pm

   1 package Posting::Cache;
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        shared/Posting/Cache.pm                                         #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-04-21                          #
   8 #                                                                              #
   9 # Description: Views/Voting Cache class                                        #
  10 #                                                                              #
  11 ################################################################################
  12
  13 use strict;
  14 use vars qw(
  15   $VERSION
  16 );
  17
  18 use Fcntl;
  19 use File::Path;
  20 use Lock qw(:ALL);
  21
  22 ################################################################################
  23 #
  24 # Version check
  25 #
  26 $VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
  27
  28 my $O_BINARY = eval 'local $SIG{__DIE__}; O_BINARY';
  29 $O_BINARY = 0 if ($@);
  30
  31 ### sub new ####################################################################
  32 #
  33 # Constructor
  34 #
  35 # Params: $pathname - full qualified cache path
  36 #
  37 # Return: Posting::Cache object
  38 #
  39 sub new {
  40   my $self = bless {} => shift;
  41
  42   $self -> clear_error;
  43   $self -> set_path (+shift);
  44
  45   $self;
  46 }
  47
  48 ### sub clear_error ############################################################
  49 #
  50 # clear verbal error data
  51 #
  52 # Params: ~none~
  53 #
  54 # Return: ~none~
  55 #
  56 sub clear_error {
  57   my $self = shift;
  58
  59   $self -> {verb_error} = undef;
  60
  61   return;
  62 }
  63
  64 sub error {$_[0]->{verb_error}}
  65
  66 sub set_error {
  67   my $self = shift;
  68
  69   $self -> {verb_error} = +shift;
  70   return;
  71 }
  72
  73 ### sub set_path ###############################################################
  74 #
  75 # set cache file name
  76 #
  77 # Params: $pathname - full qualified cache path
  78 #
  79 sub set_path {
  80   my ($self, $pathname) = @_;
  81
  82   $self -> {cachepath} = $pathname;
  83
  84   return;
  85 }
  86
  87 sub cachepath   {$_[0] -> {cachepath}}
  88 sub threaddir   {$_[0] -> cachepath          . $_[1] -> {thread}}
  89 sub threadpath  {$_[0] -> threaddir  ($_[1]) . '/'}
  90 sub cachefile   {$_[0] -> threadpath ($_[1]) . $_[1] -> {posting} . '.txt'}
  91 sub summaryfile {$_[0] -> cachepath          . 'summary.bin'}
  92
  93 ### sub delete_threads #########################################################
  94 #
  95 # remove threads from cache
  96 #
  97 # Params: @threads - list of threadnumbers
  98 #
  99 # Return: Status Code (Bool)
 100 #
 101 sub delete_threads {
 102   my ($self, @threads) = @_;
 103   my %threads = map {$_ => 1} @threads;
 104
 105   $self -> mod_wrap (
 106     \&r_delete_threads,
 107     \%threads
 108   );
 109 }
 110 sub r_delete_threads {
 111   my ($self, $handle, $threads) = @_;
 112   my $l = length (pack 'L' => 0);
 113   my $reclen = $l << 2;
 114   my $len = -s $handle;
 115   my $num = int ($len / $reclen) -1;
 116   my ($buf, %hash);
 117   local $/;
 118   local $\;
 119
 120   for (0..$num) {
 121     seek $handle, $_ * $reclen + $l, 0                 or return;
 122     read ($handle, $buf, $l) == $l                     or return;
 123     if ($threads->{unpack 'L' => $buf}) {
 124       seek $handle, $_ * $reclen + $l, 0               or return;
 125       print $handle pack ('L' => 0)                    or return;
 126     }
 127   }
 128
 129   rmtree ($self->threaddir({thread => $_}), 0, 0)
 130     for (keys %$threads);
 131
 132   1;
 133 }
 134
 135 ### sub garbage_collection #####################################################
 136 #
 137 # remove old entrys from the beginning of the cache
 138 #
 139 # Params: ~none~
 140 #
 141 # Return: ~none~
 142 #
 143 sub garbage_collection {
 144   my $self = shift;
 145
 146   $self -> purge_wrap (
 147     \&r_garbage_collection
 148   );
 149 }
 150 sub r_garbage_collection {
 151   my ($self, $handle, $file) = @_;
 152
 153   my $reclen  = length (pack 'L', 0) << 2;
 154   my $len = -s $handle;
 155   my $num = int ($len / $reclen) -1;
 156   my ($z, $buf, $h) = 0;
 157   local $/;
 158   local $\;
 159
 160   return; # no GC yet
 161
 162   seek $handle, 0, 0                                 or return;
 163   read ($handle, $buf, $len)                         or return;
 164   for (0..$num) {
 165     (undef, $h) = (unpack 'L2' => substr ($buf, $_ * $reclen, $reclen));
 166     last if $h;
 167     return unless (defined $h);
 168     $z++;
 169   }
 170   substr ($buf, 0, $z * $reclen) = '';
 171
 172   seek $file, 0, 0                                   or return;
 173   print $file $buf                                   or return;
 174
 175   # looks good
 176   1;
 177 }
 178
 179 ### sub find_pos ($$) ##########################################################
 180 #
 181 # find position in cache file
 182 #
 183 # Params: $handle  - summary file handle
 184 #         $posting - posting number
 185 #
 186 # Return: position or false (undef)
 187 #
 188 sub find_pos ($$) {
 189   my ($handle, $posting) = @_;
 190   my $reclen = length (pack 'L',0);
 191   my $lreclen = $reclen << 2;
 192   seek $handle, 0, 0                                       or return;
 193
 194   my $buf;
 195   read ($handle, $buf, $reclen) == $reclen                 or return;
 196
 197   my $first = unpack ('L' => $buf);
 198   $first <= $posting                                       or return;
 199
 200   my $pos = ($posting - $first) * $lreclen;
 201   seek $handle, $pos, 0                                    or return;
 202
 203   $pos;
 204 }
 205
 206 ### sub add_view ###############################################################
 207 #
 208 # increment the views-counter
 209 #
 210 # Params: hash reference
 211 #         (posting, thread)
 212 #
 213 # Return: Status code (Bool)
 214 #
 215 sub add_view {
 216   my ($self, $param) = @_;
 217
 218   $self -> mod_wrap (
 219     \&r_add_view,
 220     $param
 221   );
 222 }
 223 sub r_add_view {
 224   my ($self, $handle, $param) = @_;
 225   my $reclen  = length (pack 'L', 0) << 2;
 226   my $pos;
 227   defined ($pos = find_pos $handle, $param->{posting})                or return;
 228
 229   my $buf;
 230   seek $handle, $pos, 0                                               or return;
 231   read ($handle, $buf, $reclen) == $reclen                            or return;
 232
 233   my ($posting, $thread, $views, $votings) = unpack 'L4' => $buf;
 234   $thread == 0xFFFFFFFF and $thread = $param->{thread};
 235
 236   $param->{thread} == $thread                                         or return;
 237   $param->{posting} == $posting                                       or return;
 238
 239   seek $handle, $pos, 0                                               or return;
 240
 241   local $\;
 242   print $handle pack ('L4' => $posting, $thread, $views+1, $votings)  or return;
 243
 244   1;
 245 }
 246
 247 ### sub pick ###################################################################
 248 #
 249 # read information of one posting
 250 #
 251 # Params: $param - hash reference
 252 #                  (thread, posting)
 253 #
 254 # Return: hash reference or false
 255 #
 256 sub pick {
 257   my ($self, $param) = @_;
 258
 259   $self -> pick_wrap (
 260     \&r_pick,
 261     $self->cachefile($param),
 262     $param
 263   ) ? $self -> {pick}
 264     : return;
 265 }
 266 sub r_pick {
 267   my ($self, $handle, $file, $param) = @_;
 268   my $reclen  = 4 * length (pack 'L' => 0);
 269   my ($buf, $pos);
 270   local $/="\n";
 271
 272   defined($pos = find_pos $handle, $param->{posting})                 or return;
 273
 274   seek $handle, $pos, 0                                               or return;
 275   read ($handle, $buf, $reclen) == $reclen                            or return;
 276
 277   my ($posting, $thread, $views, $votings) = unpack 'L4' => $buf;
 278   $thread == 0xFFFFFFFF and $thread = $param->{thread};
 279
 280   $param->{thread} == $thread                                         or return;
 281   $param->{posting} == $posting                                       or return;
 282
 283   seek $file, 0, 0                                                    or return;
 284   my @records = <$file>;
 285   chomp @records;
 286
 287   $self -> {pick} = {
 288     views   => $views,
 289     votings => $votings,
 290     voteRef  => {
 291       map {
 292         map {
 293           $_->[2] => {
 294             time => $_->[0] || 0,
 295             IP   => $_->[1] || 0
 296           }
 297         } [split ' ' => $_,3]
 298       } @records
 299     }
 300   };
 301
 302   # looks good
 303   1;
 304 }
 305
 306 ### sub summary ################################################################
 307 #
 308 # read out the cache and return a summary
 309 #
 310 # Params: ~none~
 311 #
 312 # Return: hash reference or false
 313 #
 314 sub summary {
 315   my $self = shift;
 316
 317   $self -> read_wrap (\&r_summary)
 318     ? $self -> {summary}
 319     : return;
 320 }
 321 sub r_summary {
 322   my ($self, $handle) = @_;
 323   my $reclen  = length (pack 'L', 0) << 2;
 324   my $len = -s $handle;
 325   my $num = int ($len / $reclen) -1;
 326   my ($buf, %hash);
 327   local $/;
 328
 329   seek $handle, 0, 0                                 or return;
 330   read ($handle, $buf, $len)                         or return;
 331   for (0..$num) {
 332     my ($posting, $thread, $views, $votings)
 333       = (unpack 'L4' => substr ($buf, $_ * $reclen, $reclen));
 334
 335     $hash{$thread} = {} unless $hash{$thread};
 336     $hash{$thread} -> {$posting} = {
 337       views   => $views,
 338       votings => $votings
 339     };
 340   }
 341
 342   $self -> {summary} = \%hash;
 343
 344   # looks good
 345   1;
 346 }
 347
 348 ### sub add_voting #############################################################
 349 #
 350 # add a voting
 351 #
 352 # Params: $param - hash reference
 353 #                  (thread, posting, IP, ID, time)
 354 #
 355 # Return: Status code (Bool)
 356 #
 357 sub add_voting {
 358   my ($self, $param) = @_;
 359
 360   $self -> vote_wrap (
 361     \&r_add_voting,
 362     $param
 363   );
 364 }
 365 sub r_add_voting {
 366   my ($self, $handle, $file, $param) = @_;
 367   my $reclen  = length (pack 'L', 0) << 2;
 368   my $pos;
 369   defined ($pos = find_pos $handle, $param->{posting})          or return;
 370
 371   my $buf;
 372   seek $handle, $pos, 0                                         or return;
 373   read ($handle, $buf, $reclen) == $reclen                      or return;
 374
 375   my ($posting, $thread, $views, $votings) = unpack 'L4' => $buf;
 376   $thread == 0xFFFFFFFF and $thread = $param->{thread};
 377
 378   $param->{thread} == $thread                                   or return;
 379
 380   {
 381     local $\="\n";
 382     seek $file, 0, 2                                            or return;
 383     print $file
 384       join (' ' => $param->{time}, $param->{IP}, $param->{ID})  or return;
 385   }
 386
 387   {
 388     local $\;
 389     seek $handle, $pos, 0                                       or return;
 390     print $handle
 391       pack ('L4' => $posting, $thread, $views, $votings+1)      or return;
 392   }
 393
 394   1;
 395 }
 396
 397 ### sub add_posting ############################################################
 398 #
 399 # add an empty cache entry of a posting
 400 #
 401 # Params: $param - hash reference
 402 #                  (thread, posting)
 403 #
 404 # Return: Status code (Bool)
 405 #
 406 sub add_posting {
 407   my $self = shift;
 408   $self -> add_wrap (
 409     \&r_add_posting,
 410     @_
 411   );
 412 }
 413 sub r_add_posting {
 414   my ($self, $handle, $param) = @_;
 415   local *FILE;
 416   local $\;
 417
 418   unless (-d $self -> threaddir($param)) {
 419     mkdir $self->threaddir($param), 0777             or return;
 420   }
 421   sysopen (FILE,
 422     $self->cachefile($param),
 423     O_WRONLY | O_CREAT | O_TRUNC
 424   )                                                  or return;
 425   close FILE                                         or return;
 426
 427   my $z;
 428   if (-s $handle) {
 429     my $reclen = length (pack 'L' => 0) << 2;
 430     seek $handle, 0-$reclen, 2                       or return;
 431     my $buf;
 432     read ($handle, $buf, $reclen) == $reclen         or return;
 433     $z = unpack 'L' => $buf;
 434     if ($z < $param->{posting}) {
 435       while (++$z < $param->{posting}) {
 436         seek $handle, 0, 2                           or return;
 437         print $handle pack(
 438           'L4' => $z, 0xFFFFFFFF, 0, 0
 439         )                                            or return;
 440       }
 441       $z = undef;
 442     }
 443     else {
 444       my $pos;
 445       defined (
 446         $pos = find_pos $handle, $param->{posting}
 447       )                                              or return;
 448       seek $handle, $pos, 0                          or return;
 449     }
 450   }
 451
 452   unless (defined $z) {
 453     seek $handle, 0, 2                               or return;
 454   }
 455
 456   print $handle pack(
 457     'L4' => $param->{posting}, $param->{thread}, 0, 0
 458   )                                                  or return;
 459
 460   release_file ($self->cachefile($param));
 461
 462   1;
 463 }
 464
 465 ### sub add_wrap ################################################################
 466 #
 467 # file lock, open, execute, close, unlock wrapper
 468 # for adding an empty entry
 469 #
 470 # Params: $gosub - sub reference (for execution)
 471 #         @param - params (for $gosub)
 472 #
 473 # Return: Status code (Bool)
 474 #
 475 sub add_wrap {
 476   my ($self, $gosub, @param) = @_;
 477   my $status;
 478
 479   unless (write_lock_file ($self->summaryfile)) {
 480     violent_unlock_file ($self->summaryfile);
 481     $self->set_error ('could not write-lock summary file '.$self->summaryfile);
 482   }
 483   else {
 484     local *SUM;
 485     unless (sysopen (SUM, $self->summaryfile, $O_BINARY | O_APPEND | O_CREAT | O_RDWR)) {
 486       $self->set_error
 487         ('could not open to read/write/append summary file '.$self->summaryfile);
 488     }
 489     else {
 490       $status = $gosub -> (
 491         $self,
 492         \*SUM,
 493         @param
 494       );
 495       unless (close SUM) {
 496         $status=0;
 497         $self->set_error('could not close summary file '.$self->summaryfile);
 498       }
 499     }
 500     violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
 501   }
 502
 503   # return
 504   $status;
 505 }
 506
 507 ### sub vote_wrap ###############################################################
 508 #
 509 # file lock, open, execute, close, unlock wrapper
 510 # for adding a vote
 511 #
 512 # Params: $gosub - sub reference (for execution)
 513 #         @param - params (for $gosub)
 514 #
 515 # Return: Status code (Bool)
 516 #
 517 sub vote_wrap {
 518   my ($self, $gosub, $param) = @_;
 519   my $status;
 520
 521   unless (write_lock_file ($self->summaryfile)) {
 522     violent_unlock_file ($self->summaryfile);
 523     $self->set_error ('could not write-lock summary file '.$self->summaryfile);
 524   }
 525   else {
 526     local *S;
 527     unless (sysopen (S, $self->summaryfile, O_RDWR | $O_BINARY)) {
 528       $self->set_error ('could not open to read/write summary file '.$self->summaryfile);
 529     }
 530     else {
 531       unless (-d $self->threaddir($param)) {
 532         mkdir $self->threaddir($param), 0777                     or return;
 533       }
 534       my $filename = $self->cachefile($param);
 535
 536       unless (write_lock_file ($filename)) {
 537         violent_unlock_file ($filename);
 538         $self->set_error ('could not write-lock cache file '.$filename);
 539       }
 540       else {
 541         local *CACHE;
 542         unless (sysopen (CACHE, $filename, O_APPEND | O_CREAT | O_RDWR)) {
 543           $self->set_error ('could not open to read/write/append cache file '.$filename);
 544         }
 545         else {
 546           $status = $gosub -> (
 547             $self,
 548             \*S,
 549             \*CACHE,
 550             $param
 551           );
 552           unless (close CACHE) {
 553             $status=0;
 554             $self->set_error('could not close cache file '.$filename);
 555           }
 556         }
 557         violent_unlock_file ($filename) unless (write_unlock_file ($filename));
 558       }
 559       unless (close S) {
 560         $status=0;
 561         $self->set_error('could not close summary file '.$self->summaryfile);
 562       }
 563     }
 564     violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
 565   }
 566
 567   # return
 568   $status;
 569 }
 570
 571 ### sub purge_wrap ##############################################################
 572 #
 573 # file lock, open, execute, close, unlock wrapper
 574 # for garbage collection
 575 #
 576 # Params: $gosub - sub reference (for execution)
 577 #         @param - params (for $gosub)
 578 #
 579 # Return: Status code (Bool)
 580 #
 581 sub purge_wrap {
 582   my ($self, $gosub, @param) = @_;
 583   my $status;
 584   my $filename = $self -> summaryfile . '.temp';
 585
 586   unless (write_lock_file ($self->summaryfile)) {
 587     violent_unlock_file ($self->summaryfile);
 588     $self->set_error ('could not write-lock summary file '.$self->summaryfile);
 589   }
 590   else {
 591     local *TEMP;
 592     unless (sysopen (TEMP, $filename, O_CREAT | O_WRONLY | O_TRUNC | $O_BINARY)) {
 593       $self->set_error ('could not open to write temp summary file '.$filename);
 594     }
 595     else {
 596       local *S;
 597       unless (sysopen (S, $self->summaryfile, O_RDONLY | $O_BINARY)) {
 598         $self->set_error ('could not open to read summary file '.$self->summaryfile);
 599       }
 600       else {
 601         $status = $gosub -> (
 602           $self,
 603           \*S,
 604           \*TEMP,
 605           @param
 606         );
 607         unless (close S) {
 608           $status = 0;
 609           $self->set_error('could not close summary file '.$self->summaryfile);
 610         }
 611       }
 612       unless (close TEMP) {
 613         $status=0;
 614         $self->set_error('could not close temp summary file '.$filename);
 615       }
 616       if ($status) {
 617         unless (rename $filename => $self->summaryfile) {
 618           $status=0;
 619           $self->set_error('could not rename temp summary file '.$filename);
 620         }
 621       }
 622     }
 623     violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
 624   }
 625
 626   # return
 627   $status;
 628 }
 629
 630 ### sub pick_wrap ###############################################################
 631 #
 632 # file lock, open, execute, close, unlock wrapper
 633 # for picking a posting
 634 #
 635 # Params: $gosub - sub reference (for execution)
 636 #         @param - params (for $gosub)
 637 #
 638 # Return: Status code (Bool)
 639 #
 640 sub pick_wrap {
 641   my ($self, $gosub, $filename, @param) = @_;
 642   my $status;
 643
 644   unless (lock_file ($filename)) {
 645     violent_unlock_file ($filename);
 646     $self->set_error ('could not lock cache file '.$filename);
 647   }
 648   else {
 649     local *CACHE;
 650     unless (sysopen (CACHE, $filename, O_RDONLY)) {
 651       $self->set_error ('could not open to read cache file '.$filename);
 652     }
 653     else {
 654       $status = $self -> read_wrap (
 655         $gosub,
 656         \*CACHE,
 657         @param
 658       );
 659       unless (close CACHE) {
 660         $status=0;
 661         $self->set_error('could not close cache file '.$filename);
 662       }
 663     }
 664     violent_unlock_file ($filename) unless (unlock_file ($filename));
 665   }
 666
 667   # return
 668   $status;
 669 }
 670
 671 ### sub read_wrap ###############################################################
 672 #
 673 # file lock, open, execute, close, unlock wrapper
 674 # for reading of summary file
 675 #
 676 # Params: $gosub - sub reference (for execution)
 677 #         @param - params (for $gosub)
 678 #
 679 # Return: Status code (Bool)
 680 #
 681 sub read_wrap {
 682   my ($self, $gosub, @param) = @_;
 683   my $status;
 684
 685   unless (lock_file ($self->summaryfile)) {
 686     violent_unlock_file ($self->summaryfile);
 687     $self->set_error ('could not read-lock summary file '.$self->summaryfile);
 688   }
 689   else {
 690     local *S;
 691     unless (sysopen (S, $self->summaryfile, O_RDONLY | $O_BINARY)) {
 692       $self->set_error ('could not open to read summary file '.$self->summaryfile);
 693     }
 694     else {
 695       $status = $gosub -> (
 696         $self,
 697         \*S,
 698         @param
 699       );
 700       unless (close S) {
 701         $status=0;
 702         $self->set_error('could not close summary file '.$self->summaryfile);
 703       }
 704     }
 705     violent_unlock_file ($self->summaryfile) unless (unlock_file ($self->summaryfile));
 706   }
 707
 708   # return
 709   $status;
 710 }
 711
 712 ### sub mod_wrap ################################################################
 713 #
 714 # file lock, open, execute, close, unlock wrapper
 715 # for modification of summary file
 716 #
 717 # Params: $gosub - sub reference (for execution)
 718 #         @param - params (for $gosub)
 719 #
 720 # Return: Status code (Bool)
 721 #
 722 sub mod_wrap {
 723   my ($self, $gosub, @param) = @_;
 724   my $status;
 725
 726   unless (write_lock_file ($self->summaryfile)) {
 727     violent_unlock_file ($self->summaryfile);
 728     $self->set_error ('could not write-lock summary file '.$self->summaryfile);
 729   }
 730   else {
 731     local *S;
 732     unless (sysopen (S, $self->summaryfile, O_RDWR | $O_BINARY)) {
 733       $self->set_error ('could not open to read/write summary file '.$self->summaryfile);
 734     }
 735     else {
 736       $status = $gosub -> (
 737         $self,
 738         \*S,
 739         @param
 740       );
 741       unless (close S) {
 742         $status=0;
 743         $self->set_error('could not close summary file '.$self->summaryfile);
 744       }
 745     }
 746     violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
 747   }
 748
 749   # return
 750   $status;
 751 }
 752
 753 # keep 'require' happy
 754 #
 755 1;
 756
 757 #
 758 #
 759 ### end of Posting::Cache ######################################################