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