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

patrick-canterino.de