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
  15 use Fcntl;
  16 use Lock qw(:ALL);
  17
  18 my $O_BINARY = eval "O_BINARY";
  19 $O_BINARY = 0 if ($@);
  20
  21 ### sub new ####################################################################
  22 #
  23 # Constructor
  24 #
  25 # Params: $filename - full qualified cache file name
  26 #
  27 # Return: Posting::Cache object
  28 #
  29 sub new {
  30   my $self = bless {} => shift;
  31
  32   $self -> clear_error;
  33   $self -> set_file (+shift);
  34
  35   $self -> repair_cache or do {
  36     $self -> set_error ('cache '.$self->cachefile.' is broken and not repairable.')
  37   };
  38
  39   $self;
  40 }
  41
  42 ### sub clear_error ############################################################
  43 #
  44 # clear verbal error data
  45 #
  46 # Params: ~none~
  47 #
  48 # Return: ~none~
  49 #
  50 sub clear_error {
  51   my $self = shift;
  52
  53   $self -> {verb_error} = undef;
  54
  55   return;
  56 }
  57
  58 sub error {$_[0]->{verb_error}}
  59
  60 sub set_error {
  61   my $self = shift;
  62
  63   $self -> {verb_error} = +shift;
  64   return;
  65 }
  66
  67 ### sub set_file ###############################################################
  68 #
  69 # set cache file name
  70 #
  71 # Params: $filename - full qualified cache file name
  72 #
  73 sub set_file {
  74   my ($self, $filename) = @_;
  75
  76   $self -> {cachefile} = $filename;
  77
  78   return;
  79 }
  80
  81 sub cachefile {$_[0] -> {cachefile}}
  82 sub indexfile {$_[0] -> cachefile . '.index'}
  83 sub temp_cachefile {$_[0] -> cachefile . '.temp'}
  84 sub temp_indexfile {$_[0] -> indexfile . '.temp'}
  85
  86 ### sub find_pos ($$) ##########################################################
  87 #
  88 # find position in cache file
  89 # (binary search in index file)
  90 #
  91 # Params: $handle  - index file handle
  92 #         $posting - posting number
  93 #
  94 # Return: position or false (undef)
  95 #
  96 sub find_pos ($$) {
  97   my ($I, $posting) = @_;
  98   my $reclen = 2 * length pack 'L',0;
  99   my $end = (-s $I) / $reclen;
 100
 101   $end == int $end                                         or return;
 102
 103   my ($start, $buf, $current) = 0;
 104
 105   while ($start <= $end) {
 106     seek $I, ($current = ($start + $end) >> 1)*$reclen, 0  or return;
 107     $reclen == read ($I, $buf, $reclen)                    or return;
 108
 109     my ($num, $found) = unpack 'L2',$buf;
 110
 111     if ($num == $posting) {
 112       return $found;
 113     }
 114     elsif ($num < $posting) {
 115       $start = $current+1
 116     }
 117     else {
 118       $end   = $current-1
 119     }
 120   }
 121
 122   return;
 123 }
 124
 125 ### sub add_view ###############################################################
 126 #
 127 # increment the views-counter
 128 #
 129 # Params: ~none~
 130 #
 131 # Return: Status code (Bool)
 132 #
 133 sub r_add_view {
 134   my ($self, $h, $param) = @_;
 135   my ($C, $I) = ($h->{C}, $h->{I});
 136   my $reclen  = 4 * length pack 'L', 0;
 137   my $pos;
 138   defined ($pos = find_pos $I, $param->{posting})                or return;
 139
 140   my $buf;
 141   seek $C, $pos, 0                                               or return;
 142   read ($C, $buf, $reclen) == $reclen                            or return;
 143
 144   my ($posting, $thread, $views, $votings) = unpack 'L4',$buf;
 145   $thread == $param->{thread}                                    or return;
 146   seek $C, $pos, 0                                               or return;
 147   print $C pack ('L4' => $posting, $thread, $views+1, $votings)  or return;
 148
 149   1;
 150 }
 151
 152 sub add_view {
 153   my ($self, $param) = @_;
 154
 155   $self -> write_wrap (
 156     \&r_add_view,
 157     $param
 158   );
 159 }
 160
 161 ### sub pick ###################################################################
 162 #
 163 # read information of one posting
 164 #
 165 # Params: $param - hash reference
 166 #                  (thread, posting)
 167 #
 168 # Return: hash reference or false
 169 #
 170 sub r_pick {
 171   my ($self, $h, $param) = @_;
 172   my ($C, $I) = ($h->{C}, $h->{I});
 173   my $reclen  = 4 * length pack 'L', 0;
 174   my ($buf, $pos);
 175   local $/="\012";
 176
 177   defined($pos = find_pos $I, $param->{posting})      or return;
 178
 179   seek $C, $pos, 0                                    or return;
 180   read ($C, $buf, $reclen) == $reclen                 or return;
 181
 182   my ($posting, $thread, $views, $votings) = unpack 'L4', $buf;
 183   $buf = <$C>; chomp $buf;
 184   $self -> {pick} = {
 185     views   => $views,
 186     votings => $votings,
 187     voteRef  => {
 188       map {
 189         map {
 190           $_->[2] => {
 191             time => $_->[0] || 0,
 192             IP   => $_->[1] || 0
 193           }
 194         } [split /;/]
 195       } split ' ' => $buf
 196     }
 197   };
 198
 199   # looks good
 200   1;
 201 }
 202
 203 sub pick {
 204   my ($self, $param) = @_;
 205
 206   $self -> read_wrap (\&r_pick, $param)
 207     ? $self -> {pick}
 208     : return;
 209 }
 210
 211 ### sub summary ################################################################
 212 #
 213 # read out the cache and return a summary
 214 #
 215 # Params: ~none~
 216 #
 217 # Return: hash reference or false
 218 #
 219 sub r_summary {
 220   my ($self, $h) = @_;
 221   my ($C, $I) = ($h->{C}, $h->{I});
 222   my $reclen  = length pack 'L', 0;
 223   my $ireclen = 2 * $reclen;
 224   my $creclen = 4 * $reclen;
 225   my ($buf, $pos, %hash);
 226
 227
 228   while ($ireclen == read ($I, $buf, $ireclen)) {
 229     (undef, $pos) = unpack 'L2', $buf;
 230
 231     seek $C, $pos, 0                                 or return;
 232     read ($C, $buf, $creclen) == $creclen            or return;
 233
 234     my ($posting, $thread, $views, $votings) = unpack 'L4', $buf;
 235     $hash{$thread} = {} unless $hash{$thread};
 236     $hash{$thread} -> {$posting} = {
 237       views   => $views,
 238       votings => $votings
 239     };
 240   }
 241
 242   $self -> {summary} = \%hash;
 243
 244   # looks good
 245   1;
 246 }
 247
 248 sub summary {
 249   my $self = shift;
 250
 251   $self -> read_wrap (\&r_summary)
 252     ? $self -> {summary}
 253     : return;
 254 }
 255
 256 ### sub repair_cache ###########################################################
 257 #
 258 # check on cache consistance and repair if broken
 259 #
 260 # Params: ~none~
 261 #
 262 # Return: sucess code (Bool)
 263 #
 264 sub r_repair_cache {
 265   my ($self, $h) = @_;
 266   my ($C, $TC, $TI) = ($h->{C}, $h->{TC}, $h->{TI});
 267   my $pos = tell $TC;
 268   my ($block);
 269   my $reclen = 4 * length pack 'L',0;
 270   local $/="\012";
 271   local $\;
 272
 273   while ($reclen == read $C, $block, $reclen) {
 274     my $msg = unpack ('L' => $block);
 275     my $rest = <$C>;
 276     chomp $rest;
 277     print $TC $block. $rest. $/;
 278     print $TI pack ('L2' => $msg, $pos);
 279     $pos = tell $TC;
 280   }
 281
 282   1;
 283 }
 284
 285 sub repair_cache {
 286   my $self = shift;
 287
 288   return unless ($self->cachefile and $self->indexfile);
 289   return 1 if (-f $self->cachefile and -f $self->indexfile);
 290
 291   unless (-f $self->cachefile) {
 292     return if (-f $self->indexfile);
 293
 294     local *FILE;
 295     return unless (open FILE, '>'.$self->cachefile);
 296     return unless (close FILE);
 297     return unless (open FILE, '>'.$self->indexfile);
 298     return unless (close FILE);
 299
 300     release_file ($self->cachefile);
 301     release_file ($self->indexfile);
 302     release_file ($self->temp_indexfile);
 303     release_file ($self->temp_cachefile);
 304
 305     return 1;
 306   }
 307
 308   $self -> open_wrap (\&r_repair_cache);
 309 }
 310
 311 ### sub add_posting ############################################################
 312 #
 313 # add an empty cache entry of a posting
 314 #
 315 # Params: $param - hash reference
 316 #                  (thread, posting)
 317 #
 318 # Return: Status code (Bool)
 319 #
 320 sub r_add_posting {
 321   my ($self, $h, $param) = @_;
 322   my ($C, $TC, $TI) = ($h->{C}, $h->{TC}, $h->{TI});
 323   my $pos = tell $TC;
 324   my ($block, $ins, $msg);
 325   my $reclen = 4 * length pack 'L',0;
 326   local $/="\012";
 327   local $\;
 328
 329   while ($reclen == read $C, $block, $reclen) {
 330     $msg = unpack ('L' => $block);
 331
 332     if ($param -> {posting} == $msg) {
 333       $self->set_error("double defined posting id 'm$msg'");
 334       return;
 335     };
 336     next if ($param -> {posting} > $msg or $ins);
 337
 338     print $TC pack('L4' => $param->{posting}, $param->{thread}, 0, 0), $/;
 339     print $TI pack('L2' => $param->{posting}, $pos);
 340     $pos = tell $TC;
 341     $ins = 1;
 342   }
 343   continue {
 344     my $rest = <$C>;
 345     chomp $rest;
 346     print $TC $block. $rest. $/;
 347     print $TI pack ('L2' => $msg, $pos);
 348     $pos = tell $TC;
 349   }
 350   unless ($ins) {
 351     print $TC pack('L4' => $param->{posting}, $param->{thread}, 0, 0), $/;
 352     print $TI pack('L2' => $param->{posting}, $pos);
 353   }
 354
 355   1;
 356 }
 357
 358 sub add_posting {
 359   my $self = shift;
 360   $self -> open_wrap (
 361     \&r_add_posting,
 362     @_
 363   );
 364 }
 365
 366 ### sub add_voting #############################################################
 367 #
 368 # add a voting (increment vote counter and log the vote data)
 369 #
 370 # Params: $param - hash reference
 371 #                  (thread, posting, IP, time, ID)
 372 #
 373 # Return: Status code (Bool)
 374 #
 375 sub r_add_voting {
 376   my ($self, $h, $param) = @_;
 377   my ($C, $TC, $TI) = ($h->{C}, $h->{TC}, $h->{TI});
 378   my $pos = tell $TC;
 379   my $block;
 380   my $reclen = 4 * length pack 'L',0;
 381   local $/="\012";
 382   local $\;
 383
 384   while ($reclen == read $C, $block, $reclen) {
 385     my $rest = <$C>;
 386     chomp $rest;
 387     my ($msg, $thread, $views, $votings) = unpack ('L4' => $block);
 388
 389     $param -> {posting} != $msg or do {
 390       $rest = join ' ' => (length $rest ? $rest: (), join ';' => ($param->{time}, $param->{IP}, $param->{ID}));
 391       $votings++;
 392     };
 393
 394     print $TC pack ('L4' => ($msg, $thread, $views, $votings)), $rest, $/;
 395     print $TI pack ('L2' => $msg, $pos);
 396     $pos = tell $TC;
 397   }
 398
 399   1;
 400 }
 401
 402 sub add_voting {
 403   my $self = shift;
 404   $self -> open_wrap (
 405     \&r_add_voting,
 406     @_
 407   );
 408 }
 409
 410 ### sub open_wrap ##############################################################
 411 #
 412 # file lock, open, execute, close, unlock wrapper
 413 # for writing into temp files
 414 #
 415 # Params: $gosub - sub reference (for execution)
 416 #         @param - params (for $gosub)
 417 #
 418 # Return: Status code (Bool)
 419 #
 420 sub open_wrap {
 421   my ($self, $gosub, @param) = @_;
 422   my $status;
 423
 424   unless (write_lock_file ($self->temp_cachefile)) {
 425     violent_unlock_file ($self->temp_cachefile);
 426     $self->set_error ('could not write-lock temp cache file '.$self->temp_cachefile);
 427   }
 428   else {
 429     unless (write_lock_file ($self->temp_indexfile)) {
 430       violent_unlock_file ($self->temp_indexfile);
 431       $self->set_error ('could not write-lock temp index file '.$self->temp_indexfile);
 432     }
 433     else {
 434       unless (lock_file ($self->cachefile)) {
 435         violent_unlock_file ($self->cachefile);
 436         $self->set_error ('could not read-lock cache file '.$self->cachefile);
 437       }
 438       else {
 439         unless (lock_file ($self->indexfile)) {
 440           violent_unlock_file ($self->indexfile);
 441           $self->set_error ('could not read-lock index file '.$self->indexfile);
 442         }
 443         else {
 444           local (*C, *TC, *TI);
 445           unless (sysopen (C, $self->cachefile, O_RDONLY | $O_BINARY)) {
 446             $self->set_error ('could not open to read cache file '.$self->cachefile);
 447           }
 448           else {
 449             unless (sysopen (TC, $self->temp_cachefile, O_WRONLY | O_TRUNC | O_CREAT | $O_BINARY)) {
 450               $self->set_error ('could not open to write temp cache file '.$self->temp_cachefile);
 451             }
 452             else {
 453               unless (sysopen (TI, $self->temp_indexfile, O_WRONLY | O_TRUNC | O_CREAT | $O_BINARY)) {
 454                 $self->set_error ('could not open to write temp index file '.$self->temp_indexfile);
 455               }
 456               else {
 457                 $status = $gosub -> (
 458                   $self,
 459                   { C  => \*C,
 460                     TC => \*TC,
 461                     TI => \*TI
 462                   },
 463                   @param
 464                 );
 465                 unless (close TI) {
 466                   $status=0;
 467                   $self->set_error('could not close temp index file '.$self->temp_indexfile);
 468                 }
 469               }
 470               unless (close TC) {
 471                 $status=0;
 472                 $self->set_error('could not close temp cache file '.$self->temp_cachefile);
 473               }
 474             }
 475             unless (close C) {
 476               $status=0;
 477               $self->set_error('could not close cache file '.$self->cachefile);
 478             }
 479             if ($status) {
 480               unless (write_lock_file ($self->cachefile) and write_lock_file ($self->indexfile)) {
 481                 $status=0;
 482                 $self->set_error('could not write-lock cache or index file');
 483               }
 484               else {
 485                 unless (unlink $self->indexfile or !-f $self->indexfile) {
 486                   $status=0;
 487                   $self->set_error('could not unlink '.$self->indexfile);
 488                 }
 489                 else {
 490                   unless (rename $self->temp_cachefile => $self->cachefile) {
 491                     $status=0;
 492                     $self->set_error('could not rename '.$self->temp_cachefile);
 493                   }
 494                   else {
 495                     unless (rename $self->temp_indexfile => $self->indexfile) {
 496                       $status=0;
 497                       $self->set_error('could not rename '.$self->temp_indexfile);
 498                     }
 499                   }
 500                 }
 501               }
 502             }
 503           }
 504           violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
 505         }
 506         violent_unlock_file ($self->cachefile) unless (unlock_file ($self->cachefile));
 507       }
 508       violent_unlock_file ($self->temp_indexfile) unless (write_unlock_file ($self->temp_indexfile));
 509     }
 510     violent_unlock_file ($self->temp_cachefile) unless (write_unlock_file ($self->temp_cachefile));
 511   }
 512
 513   # return
 514   $status;
 515 }
 516
 517 ### sub read_wrap ##############################################################
 518 #
 519 # file lock, open, execute, close, unlock wrapper
 520 # for reading
 521 #
 522 # Params: $gosub - sub reference (for execution)
 523 #         @param - params (for $gosub)
 524 #
 525 # Return: Status code (Bool)
 526 #
 527 sub read_wrap {
 528   my ($self, $gosub, @param) = @_;
 529   my $status;
 530
 531   unless (lock_file ($self->cachefile)) {
 532     violent_unlock_file ($self->cachefile);
 533     $self->set_error ('could not read-lock cache file '.$self->cachefile);
 534   }
 535   else {
 536     unless (lock_file ($self->indexfile)) {
 537       violent_unlock_file ($self->indexfile);
 538       $self->set_error ('could not read-lock index file '.$self->indexfile);
 539     }
 540     else {
 541       local (*C, *I);
 542       unless (sysopen (C, $self->cachefile, O_RDONLY | $O_BINARY)) {
 543         $self->set_error ('could not open to read cache file '.$self->cachefile);
 544       }
 545       else {
 546         unless (sysopen (I, $self->indexfile, O_RDONLY | $O_BINARY)) {
 547           $self->set_error ('could not open to read index file '.$self->indexfile);
 548         }
 549         else {
 550           $status = $gosub -> (
 551             $self,
 552             { C  => \*C,
 553               I => \*I,
 554             },
 555             @param
 556           );
 557           unless (close I) {
 558             $status=0;
 559             $self->set_error('could not close index file '.$self->indexfile);
 560           }
 561         }
 562         unless (close C) {
 563           $status=0;
 564           $self->set_error('could not close cache file '.$self->cachefile);
 565         }
 566       }
 567       violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
 568     }
 569     violent_unlock_file ($self->cachefile) unless (unlock_file ($self->cachefile));
 570   }
 571
 572   # return
 573   $status;
 574 }
 575
 576 ### sub write_wrap ##############################################################
 577 #
 578 # file lock, open, execute, close, unlock wrapper
 579 # for reading
 580 #
 581 # Params: $gosub - sub reference (for execution)
 582 #         @param - params (for $gosub)
 583 #
 584 # Return: Status code (Bool)
 585 #
 586 sub write_wrap {
 587   my ($self, $gosub, @param) = @_;
 588   my $status;
 589
 590   unless (write_lock_file ($self->temp_cachefile)) {
 591     violent_unlock_file ($self->temp_cachefile);
 592     $self->set_error ('could not write-lock temp cache file '.$self->temp_cachefile);
 593   }
 594   else {
 595     unless (write_lock_file ($self->cachefile)) {
 596       violent_unlock_file ($self->cachefile);
 597       $self->set_error ('could not write-lock cache file '.$self->cachefile);
 598     }
 599     else {
 600       unless (lock_file ($self->indexfile)) {
 601         violent_unlock_file ($self->indexfile);
 602         $self->set_error ('could not read-lock index file '.$self->indexfile);
 603       }
 604       else {
 605         local (*C, *I);
 606         unless (sysopen (C, $self->cachefile, O_RDWR | $O_BINARY)) {
 607           $self->set_error ('could not open to read/write cache file '.$self->cachefile);
 608         }
 609         else {
 610           unless (sysopen (I, $self->indexfile, O_RDONLY | $O_BINARY)) {
 611             $self->set_error ('could not open to read index file '.$self->indexfile);
 612           }
 613           else {
 614             $status = $gosub -> (
 615               $self,
 616               { C  => \*C,
 617                 I => \*I,
 618               },
 619               @param
 620             );
 621             unless (close I) {
 622               $status=0;
 623               $self->set_error('could not close index file '.$self->indexfile);
 624             }
 625           }
 626           unless (close C) {
 627             $status=0;
 628             $self->set_error('could not close cache file '.$self->cachefile);
 629           }
 630         }
 631         violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
 632       }
 633       violent_unlock_file ($self->cachefile) unless (write_unlock_file ($self->cachefile));
 634     }
 635     violent_unlock_file ($self->temp_cachefile) unless (write_unlock_file ($self->temp_cachefile));
 636   }
 637
 638   # return
 639   $status;
 640 }
 641
 642 # keep 'require' happy
 643 #
 644 1;
 645
 646 #
 647 #
 648 ### end of Posting::Cache ######################################################