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-06-22                          #
   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;
  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 "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   my $newfile = new Lock ($self->cachefile($param));
 416   local $\;
 417
 418   unless (-d $self -> threaddir($param)) {
 419     mkdir $self->threaddir($param), 0777             or return;
 420   }
 421   $newfile -> open (O_WRONLY | O_CREAT | O_TRUNC)    or return;
 422   $newfile -> close                                  or return;
 423
 424   my $z;
 425   if (-s $handle) {
 426     my $reclen = length (pack 'L' => 0) << 2;
 427     seek $handle, 0-$reclen, 2                       or return;
 428     my $buf;
 429     read ($handle, $buf, $reclen) == $reclen         or return;
 430     $z = unpack 'L' => $buf;
 431     if ($z < $param->{posting}) {
 432       while (++$z < $param->{posting}) {
 433         seek $handle, 0, 2                           or return;
 434         print $handle pack(
 435           'L4' => $z, 0xFFFFFFFF, 0, 0
 436         )                                            or return;
 437       }
 438       $z = undef;
 439     }
 440     else {
 441       my $pos;
 442       defined (
 443         $pos = find_pos $handle, $param->{posting}
 444       )                                              or return;
 445       seek $handle, $pos, 0                          or return;
 446     }
 447   }
 448
 449   unless (defined $z) {
 450     seek $handle, 0, 2                               or return;
 451   }
 452
 453   print $handle pack(
 454     'L4' => $param->{posting}, $param->{thread}, 0, 0
 455   )                                                  or return;
 456
 457   $newfile -> release;
 458
 459   1;
 460 }
 461
 462 ### sub add_wrap ################################################################
 463 #
 464 # file lock, open, execute, close, unlock wrapper
 465 # for adding an empty entry
 466 #
 467 # Params: $gosub - sub reference (for execution)
 468 #         @param - params (for $gosub)
 469 #
 470 # Return: Status code (Bool)
 471 #
 472 sub add_wrap {
 473   my ($self, $gosub, @param) = @_;
 474   my $status;
 475   my $summary = new Lock ($self -> summaryfile);
 476
 477   unless ($summary -> lock (LH_EXCL)) {
 478     $self->set_error ('could not write-lock summary file '.$summary -> filename);
 479   }
 480   else {
 481     unless ($summary -> open($O_BINARY | O_APPEND | O_CREAT | O_RDWR)) {
 482       $self->set_error
 483         ('could not open to read/write/append summary file '.$summary->filename);
 484     }
 485     else {
 486       $status = $gosub -> (
 487         $self,
 488         $summary,
 489         @param
 490       );
 491       unless ($summary -> close) {
 492         $status=0;
 493         $self->set_error('could not close summary file '.$summary -> filename);
 494       }
 495     }
 496     $summary -> unlock;
 497   }
 498
 499   # return
 500   $status;
 501 }
 502
 503 ### sub vote_wrap ###############################################################
 504 #
 505 # file lock, open, execute, close, unlock wrapper
 506 # for adding a vote
 507 #
 508 # Params: $gosub - sub reference (for execution)
 509 #         @param - params (for $gosub)
 510 #
 511 # Return: Status code (Bool)
 512 #
 513 sub vote_wrap {
 514   my ($self, $gosub, $param) = @_;
 515   my $status;
 516   my $summary = new Lock ($self -> summaryfile);
 517
 518   unless ($summary -> lock (LH_EXCL)) {
 519     $self->set_error ('could not write-lock summary file '.$summary -> filename);
 520   }
 521   else {
 522     unless ($summary -> open (O_RDWR | $O_BINARY)) {
 523       $self->set_error ('could not open to read/write summary file '.$summary -> filename);
 524     }
 525     else {
 526       unless (-d $self->threaddir($param)) {
 527         mkdir $self->threaddir($param), 0777                     or return;
 528       }
 529       my $cache = new Lock ($self->cachefile($param));
 530
 531       unless ($cache -> lock (LH_EXCL)) {
 532         $self->set_error ('could not write-lock cache file '.$cache -> filename);
 533       }
 534       else {
 535         unless ($cache -> open (O_APPEND | O_CREAT | O_RDWR)) {
 536           $self->set_error ('could not open to read/write/append cache file '.$cache -> filename);
 537         }
 538         else {
 539           $status = $gosub -> (
 540             $self,
 541             $summary,
 542             $cache,
 543             $param
 544           );
 545           unless ($cache -> close) {
 546             $status=0;
 547             $self->set_error('could not close cache file '.$cache -> filename);
 548           }
 549         }
 550         $cache -> unlock;
 551       }
 552       unless ($summary -> close) {
 553         $status=0;
 554         $self->set_error('could not close summary file '.$summary -> filename);
 555       }
 556     }
 557     $summary -> unlock;
 558   }
 559
 560   # return
 561   $status;
 562 }
 563
 564 ### sub purge_wrap ##############################################################
 565 #
 566 # file lock, open, execute, close, unlock wrapper
 567 # for garbage collection
 568 #
 569 # Params: $gosub - sub reference (for execution)
 570 #         @param - params (for $gosub)
 571 #
 572 # Return: Status code (Bool)
 573 #
 574 sub purge_wrap {
 575   my ($self, $gosub, @param) = @_;
 576   my $status;
 577   my $summary = new Lock ($self -> summaryfile);
 578
 579   unless ($summary -> lock (LH_EXSH)) {
 580     $self->set_error ('could not write-lock summary file '.$summary -> filename);
 581   }
 582   else {
 583     my $temp = new Lock::Handle ($summary -> filename . '.temp');
 584     unless ($temp -> open (O_CREAT | O_WRONLY | O_TRUNC | $O_BINARY)) {
 585       $self->set_error ('could not open to write temp summary file '.$temp -> filename);
 586     }
 587     else {
 588       unless ($summary -> open (O_RDONLY | $O_BINARY)) {
 589         $self->set_error ('could not open to read summary file '.$summary -> filename);
 590       }
 591       else {
 592         $status = $gosub -> (
 593           $self,
 594           $summary,
 595           $temp,
 596           @param
 597         );
 598         unless ($summary -> close) {
 599           $status = 0;
 600           $self->set_error('could not close summary file '.$summary -> filename);
 601         }
 602       }
 603       unless ($temp -> close) {
 604         $status=0;
 605         $self->set_error('could not close temp summary file '.$temp -> filename);
 606       }
 607       unless ($summary -> lock (LH_EXCL)) {
 608         $status=0;
 609         $self->set_error ('could not write-lock summary file '.$summary -> filename);
 610       }
 611       if ($status) {
 612         unless (rename $temp -> filename => $summary -> filename) {
 613           $status=0;
 614           $self->set_error('could not rename temp summary file '.$temp -> filename);
 615         }
 616       }
 617     }
 618     $summary -> unlock;
 619   }
 620
 621   # return
 622   $status;
 623 }
 624
 625 ### sub pick_wrap ###############################################################
 626 #
 627 # file lock, open, execute, close, unlock wrapper
 628 # for picking a posting
 629 #
 630 # Params: $gosub - sub reference (for execution)
 631 #         @param - params (for $gosub)
 632 #
 633 # Return: Status code (Bool)
 634 #
 635 sub pick_wrap {
 636   my ($self, $gosub, $filename, @param) = @_;
 637   my $status;
 638   my $cache = new Lock ($filename);
 639
 640   unless ($cache -> lock (LH_SHARED)) {
 641     $self->set_error ('could not lock cache file '.$cache -> filename);
 642   }
 643   else {
 644     unless ($cache -> open (O_RDONLY)) {
 645       $self->set_error ('could not open to read cache file '.$cache -> filename);
 646     }
 647     else {
 648       $status = $self -> read_wrap (
 649         $gosub,
 650         $cache,
 651         @param
 652       );
 653       unless ($cache -> close) {
 654         $status=0;
 655         $self->set_error('could not close cache file '.$cache -> filename);
 656       }
 657     }
 658     $cache -> unlock;
 659   }
 660
 661   # return
 662   $status;
 663 }
 664
 665 ### sub read_wrap ###############################################################
 666 #
 667 # file lock, open, execute, close, unlock wrapper
 668 # for reading of summary file
 669 #
 670 # Params: $gosub - sub reference (for execution)
 671 #         @param - params (for $gosub)
 672 #
 673 # Return: Status code (Bool)
 674 #
 675 sub read_wrap {
 676   my ($self, $gosub, @param) = @_;
 677   my $status;
 678   my $summary = new Lock ($self -> summaryfile);
 679
 680   unless ($summary -> lock (LH_SHARED)) {
 681     $self->set_error ('could not read-lock summary file '.$summary -> filename);
 682   }
 683   else {
 684     unless ($summary -> open (O_RDONLY | $O_BINARY)) {
 685       $self->set_error ('could not open to read summary file '.$summary -> filename);
 686     }
 687     else {
 688       $status = $gosub -> (
 689         $self,
 690         $summary,
 691         @param
 692       );
 693       unless ($summary -> close) {
 694         $status=0;
 695         $self->set_error('could not close summary file '.$summary -> filename);
 696       }
 697     }
 698     $summary -> unlock;
 699   }
 700
 701   # return
 702   $status;
 703 }
 704
 705 ### sub mod_wrap ################################################################
 706 #
 707 # file lock, open, execute, close, unlock wrapper
 708 # for modification of summary file
 709 #
 710 # Params: $gosub - sub reference (for execution)
 711 #         @param - params (for $gosub)
 712 #
 713 # Return: Status code (Bool)
 714 #
 715 sub mod_wrap {
 716   my ($self, $gosub, @param) = @_;
 717   my $status;
 718   my $summary = new Lock ($self -> summaryfile);
 719
 720   unless ($summary -> lock (LH_EXCL)) {
 721     $self->set_error ('could not write-lock summary file '.$summary -> filename);
 722   }
 723   else {
 724     unless ($summary -> open (O_RDWR | $O_BINARY)) {
 725       $self->set_error ('could not open to read/write summary file '.$summary -> filename);
 726     }
 727     else {
 728       $status = $gosub -> (
 729         $self,
 730         $summary,
 731         @param
 732       );
 733       unless ($summary -> close) {
 734         $status=0;
 735         $self->set_error('could not close summary file '.$summary -> filename);
 736       }
 737     }
 738     $summary -> unlock;
 739   }
 740
 741   # return
 742   $status;
 743 }
 744
 745 # keep 'require' happy
 746 #
 747 1;
 748
 749 #
 750 #
 751 ### end of Posting::Cache ######################################################