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