]> git.p6c8.net - selfforum.git/blob - selfforum-cgi/shared/Posting/Cache.pm
-n/a-
[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-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 ######################################################

patrick-canterino.de