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