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