Gruta/Source/FS.pm

   1 package Gruta::Source::FS;
   2
   3 use base 'Gruta::Source::BASE';
   4
   5 use strict;
   6 use warnings;
   7
   8 use Gruta::Data;
   9
  10 package Gruta::Data::FS::BASE;
  11
  12 use Carp;
  13
  14 sub ext {
  15         return '.M';
  16 }
  17
  18 sub _filename {
  19         my $self        = shift;
  20
  21         $self->_assert();
  22         $self->source->_assert();
  23
  24         return $self->source->{path} . $self->base() .
  25                 $self->get('id') . $self->ext();
  26 }
  27
  28
  29 sub load {
  30         my $self        = shift;
  31         my $driver      = shift;
  32
  33         $self->source( $driver );
  34
  35         # rename old .META files into .M
  36         my $filename = $self->_filename();
  37         rename($filename . 'ETA', $filename);
  38
  39         if (not open F, $filename) {
  40                 return undef;
  41         }
  42
  43     flock F, 1;
  44
  45         while (<F>) {
  46                 chop;
  47
  48                 if(/^([^:]*): (.*)$/) {
  49                         my ($key, $value) = ($1, $2);
  50
  51                         $key =~ s/-/_/g;
  52
  53                         if (grep (/^$key$/, $self->fields())) {
  54                                 $self->set($key, $value);
  55                         }
  56                 }
  57         }
  58
  59         close F;
  60
  61         return $self;
  62 }
  63
  64 sub save {
  65         my $self        = shift;
  66         my $driver      = shift;
  67
  68         $self->source( $driver ) if $driver;
  69
  70         my $filename = $self->_filename();
  71
  72         open F, '>' . $filename or croak "Can't write " . $filename . ': ' . $!;
  73     flock F, 2;
  74
  75         foreach my $k ($self->fields()) {
  76                 my $f = $k;
  77
  78                 $f =~ s/_/-/g;
  79
  80                 print F $f . ': ' . ($self->get($k) || '') . "\n";
  81         }
  82
  83         close F;
  84
  85         return $self;
  86 }
  87
  88
  89 sub delete {
  90         my $self        = shift;
  91         my $driver      = shift;
  92
  93         $self->source( $driver ) if $driver;
  94
  95         unlink $self->_filename();
  96
  97         return $self;
  98 }
  99
 100 package Gruta::Data::FS::Story;
 101
 102 use base 'Gruta::Data::Story';
 103 use base 'Gruta::Data::FS::BASE';
 104
 105 use Carp;
 106
 107 sub base {
 108         return Gruta::Data::FS::Topic::base() . $_[0]->get('topic_id') . '/';
 109 }
 110
 111 sub fields {
 112         grep !/(content|topic_id|abstract|body)/, $_[0]->SUPER::fields();
 113 }
 114
 115 sub vfields {
 116         return ($_[0]->SUPER::vfields(), 'content', 'topic_id', 'abstract', 'body');
 117 }
 118
 119 sub _destroy_index {
 120         my $self        = shift;
 121
 122         my $filename = $self->_filename();
 123
 124         # destroy the topic index, to be rewritten
 125         # in the future by _topic_index()
 126         $filename =~ s!/[^/]+$!/.INDEX!;
 127         unlink $filename;
 128 }
 129
 130 sub save {
 131         my $self        = shift;
 132         my $driver      = shift;
 133
 134         $self->SUPER::save( $driver );
 135
 136         my $filename = $self->_filename();
 137         $filename =~ s/\.M$//;
 138
 139         my @d = ('', 'content', '.A', 'abstract', '.B', 'body');
 140
 141         while (@d) {
 142                 my $ext         = shift(@d);
 143                 my $field       = shift(@d);
 144
 145                 open F, '>' . $filename . $ext or
 146                         croak "Cannot write " . $filename . $ext . ': ' . $!;
 147                 print F $self->get($field) || '';
 148                 close F;
 149         }
 150
 151         $self->_destroy_index();
 152
 153         return $self;
 154 }
 155
 156 sub touch {
 157         my $self = shift;
 158
 159         if (! $self->source->dummy_touch()) {
 160                 my $hits = $self->get('hits') + 1;
 161
 162                 $self->set('hits', $hits);
 163
 164                 # call $self->SUPER::save() instead of $self->save()
 165                 # to avoid saving content (unnecessary) and deleting
 166                 # the topic INDEX (even probably dangerous)
 167                 $self->SUPER::save();
 168
 169                 $self->source->_update_top_ten($hits, $self->get('topic_id'),
 170                         $self->get('id'));
 171         }
 172
 173         return $self;
 174 }
 175
 176 sub tags {
 177         my $self        = shift;
 178         my @ret         = ();
 179
 180         my $filename = $self->_filename();
 181         $filename =~ s/\.M$/.T/;
 182
 183         if (scalar(@_)) {
 184                 if (open F, '>' . $filename) {
 185             flock F, 2;
 186                         print F join(', ', map { s/^\s+//; s/\s+$//; lc($_) } @_), "\n";
 187                         close F;
 188                 }
 189         }
 190         else {
 191                 if (open F, $filename) {
 192             flock F, 1;
 193                         my $l = <F>;
 194                         close F;
 195
 196                         chomp($l);
 197                         @ret = split(/\s*,\s*/, $l);
 198                 }
 199         }
 200
 201         return @ret;
 202 }
 203
 204 sub delete {
 205         my $self        = shift;
 206         my $driver      = shift;
 207
 208         my $file = $self->_filename();
 209
 210         $self->SUPER::delete($driver);
 211
 212         # also delete content and tags
 213         $file =~ s/\.M$//;
 214
 215         unlink $file;
 216         unlink $file . '.A';
 217         unlink $file . '.B';
 218         unlink $file . '.T';
 219
 220         $self->_destroy_index();
 221
 222         return $self;
 223 }
 224
 225
 226 sub load {
 227         my $self        = shift;
 228         my $driver      = shift;
 229
 230         if (!$self->SUPER::load( $driver )) {
 231                 return undef;
 232         }
 233
 234         my $filename = $self->_filename();
 235         $filename =~ s/\.M$//;
 236
 237         rename($filename . '.TAGS', $filename . '.T');
 238
 239         return $self;
 240 }
 241
 242
 243 package Gruta::Data::FS::Topic;
 244
 245 use base 'Gruta::Data::Topic';
 246 use base 'Gruta::Data::FS::BASE';
 247
 248 sub base {
 249         return '/topics/';
 250 }
 251
 252 sub save {
 253         my $self        = shift;
 254         my $driver      = shift;
 255
 256         $self->SUPER::save( $driver );
 257
 258         my $filename = $self->_filename();
 259         $filename =~ s/\.M$//;
 260
 261         mkdir $filename;
 262
 263         return $self;
 264 }
 265
 266 package Gruta::Data::FS::User;
 267
 268 use base 'Gruta::Data::User';
 269 use base 'Gruta::Data::FS::BASE';
 270
 271 sub ext {
 272         return '';
 273 }
 274
 275 sub base {
 276         return '/users/';
 277 }
 278
 279 package Gruta::Data::FS::Session;
 280
 281 use base 'Gruta::Data::Session';
 282 use base 'Gruta::Data::FS::BASE';
 283
 284 sub ext {
 285         return '';
 286 }
 287
 288 sub base {
 289         return '/sids/';
 290 }
 291
 292 package Gruta::Data::FS::Template;
 293
 294 use base 'Gruta::Data::Template';
 295 use base 'Gruta::Data::FS::BASE';
 296
 297 sub base {
 298         return '/templates/';
 299 }
 300
 301 sub ext {
 302         return '';
 303 }
 304
 305 sub load {
 306         my $self        = shift;
 307         my $driver      = shift;
 308
 309         $self->source($driver);
 310
 311         if (not open(F, $self->_filename())) {
 312                 return undef;
 313         }
 314
 315         $self->set('content', join('', <F>));
 316         close F;
 317
 318         return $self;
 319 }
 320
 321
 322 sub save {
 323         my $self        = shift;
 324         my $driver      = shift;
 325
 326         $self->source($driver) if $driver;
 327
 328         if (not open(F, '>' . $self->_filename())) {
 329                 return undef;
 330         }
 331
 332         print F $self->get('content');
 333         close F;
 334
 335         return $self;
 336 }
 337
 338
 339 package Gruta::Data::FS::Comment;
 340
 341 use base 'Gruta::Data::Comment';
 342 use base 'Gruta::Data::FS::BASE';
 343
 344 use Carp;
 345
 346 sub base {
 347         if (!ref($_[0])) {
 348                 return '/comments/';
 349         }
 350
 351         return '/comments/'     . $_[0]->get('topic_id') . '/'
 352                                         . $_[0]->get('story_id') . '/';
 353 }
 354
 355 sub fields {
 356         grep !/content/, $_[0]->SUPER::fields();
 357 }
 358
 359 sub vfields {
 360         return ($_[0]->SUPER::vfields(), 'content');
 361 }
 362
 363
 364 sub pending_file {
 365         my $self        = shift;
 366
 367         my @p = split('/', $self->_filename());
 368         pop(@p);
 369         pop(@p);
 370         pop(@p);
 371
 372         my $pending = join('/', @p) . '/.pending/' .
 373                                 join(':',
 374                                         $self->get('topic_id'),
 375                                         $self->get('story_id'),
 376                                         $self->get('id')
 377                                 );
 378
 379         return $pending;
 380 }
 381
 382
 383 sub save {
 384         my $self        = shift;
 385         my $driver      = shift;
 386
 387         $self->source($driver) if $driver;
 388
 389         # create the directory tree
 390         my @p = split('/', $self->_filename());
 391         pop(@p);
 392         my $s = pop(@p);
 393
 394         my $d = join('/', @p);
 395         if (! -d $d) {
 396                 mkdir $d or croak "Error posting comment: $d, $!";
 397         }
 398
 399         push(@p, $s);
 400
 401         $d = join('/', @p);
 402         if (! -d $d) {
 403                 mkdir $d or croak "Error posting comment: $d, $!";
 404         }
 405
 406         $self->SUPER::save($driver);
 407
 408         # write content
 409         my $filename = $self->_filename();
 410         $filename =~ s/\.M$//;
 411
 412         open F, '>' . $filename or
 413                 croak "Cannot write " . $filename . ': ' . $!;
 414
 415         print F $self->get('content') || '';
 416         close F;
 417
 418         # if not approved, write pending
 419         if (!$self->get('approved')) {
 420                 open F, '>' . $self->pending_file();
 421                 close F;
 422         }
 423
 424         return $self;
 425 }
 426
 427
 428 sub load {
 429         my $self        = shift;
 430         my $driver      = shift;
 431
 432         if (!$self->SUPER::load($driver)) {
 433                 return undef;
 434         }
 435
 436         my $filename = $self->_filename();
 437         $filename =~ s/\.M$//;
 438
 439         if (open F, $filename) {
 440                 $self->set('content', join('', <F>));
 441                 close F;
 442         }
 443
 444         return $self;
 445 }
 446
 447
 448 sub delete {
 449         my $self        = shift;
 450         my $driver      = shift;
 451
 452         # delete content
 453         my $file = $self->_filename();
 454         unlink $file;
 455         $file =~ s/\.M$//;
 456         unlink $file;
 457
 458         # delete (possible) pending
 459         unlink $self->pending_file();
 460 }
 461
 462
 463 sub approve {
 464         my $self        = shift;
 465
 466         $self->set('approved', 1);
 467         $self->save();
 468
 469         # delete (possible) pending
 470         unlink $self->pending_file();
 471
 472         return $self;
 473 }
 474
 475
 476 package Gruta::Source::FS;
 477
 478 use Carp;
 479
 480 sub _assert {
 481         my $self        = shift;
 482
 483         $self->{path} or croak "Invalid path";
 484
 485         return $self;
 486 }
 487
 488 sub _one {
 489         my $self        = shift;
 490         my $id          = shift;
 491         my $class       = shift;
 492
 493         my $o = ${class}->new( id => $id );
 494         $o->load( $self );
 495 }
 496
 497 sub topic {
 498         return _one( @_, 'Gruta::Data::FS::Topic' );
 499 }
 500
 501 sub topics {
 502         my $self        = shift;
 503
 504         my @ret = ();
 505
 506         my $path = $self->{path} . Gruta::Data::FS::Topic::base();
 507
 508         if (opendir D, $path) {
 509                 while (my $id = readdir D) {
 510                         next unless -d $path . $id;
 511                         next if $id =~ /^\./;
 512
 513                         push @ret, $id;
 514                 }
 515
 516                 closedir D;
 517         }
 518
 519         return @ret;
 520 }
 521
 522 sub user {
 523         return _one( @_, 'Gruta::Data::FS::User' );
 524 }
 525
 526 sub users {
 527         my $self        = shift;
 528
 529         my @ret = ();
 530
 531         my $path = $self->{path} . Gruta::Data::FS::User::base();
 532
 533         if (opendir D, $path) {
 534                 while (my $id = readdir D) {
 535                         next if -d $path . $id;
 536                         push @ret, $id;
 537                 }
 538
 539                 closedir D;
 540         }
 541
 542         return @ret;
 543 }
 544
 545 sub template {
 546         return _one(@_, 'Gruta::Data::FS::Template');
 547 }
 548
 549 sub templates {
 550         my $self        = shift;
 551
 552         my @ret = ();
 553
 554         my $path = $self->{path} . Gruta::Data::FS::Template::base();
 555
 556         if (opendir D, $path) {
 557                 while (my $id = readdir D) {
 558                         next if -d $path . $id;
 559                         push @ret, $id;
 560                 }
 561
 562                 closedir D;
 563         }
 564
 565         return @ret;
 566 }
 567
 568
 569 sub comment {
 570         my $self        = shift;
 571         my $topic_id    = shift;
 572         my $story_id    = shift;
 573         my $id          = shift;
 574
 575         my $comment = Gruta::Data::FS::Comment->new(
 576                 topic_id        => $topic_id,
 577                 story_id        => $story_id,
 578                 id                      => $id
 579         );
 580
 581         if (not $comment->load($self)) {
 582                 return undef;
 583         }
 584
 585         return $comment;
 586 }
 587
 588
 589 sub pending_comments {
 590         my $self = shift;
 591
 592         my @ret = ();
 593
 594         my $path = $self->{path} . Gruta::Data::FS::Comment::base()
 595                                                         . '/.pending/';
 596
 597         if (opendir D, $path) {
 598                 while (my $id = readdir D) {
 599                         my $f = $path . $id;
 600
 601                         next if -d $f;
 602
 603                         push @ret, [ split(':', $id) ];
 604                 }
 605
 606                 closedir D;
 607         }
 608
 609         return sort { $b->[2] cmp $a->[2] } @ret;
 610 }
 611
 612
 613 sub comments {
 614         my $self = shift;
 615         my $max = shift;
 616
 617         $max ||= 20;
 618
 619         my @ret = ();
 620
 621         my $path = $self->{path} . Gruta::Data::FS::Comment::base();
 622
 623         if (opendir BASE, $path) {
 624                 while (my $topic_id = readdir BASE) {
 625                         next if $topic_id =~ /^\./;
 626
 627                         my $f = $path . $topic_id;
 628
 629                         if (opendir TOPIC, $f) {
 630                                 while (my $story_id = readdir TOPIC) {
 631                                         next if $story_id =~ /^\./;
 632
 633                                         my $sf = $f . '/' . $story_id;
 634
 635                                         if (opendir STORY, $sf) {
 636                                                 while (my $id = readdir STORY) {
 637                                                         if ($id =~ /^(.+)\.M/) {
 638                                                                 $id = $1;
 639                                                                 my $c = $self->comment($topic_id,
 640                                                                                                 $story_id, $id);
 641
 642                                                                 if ($c && $c->get('approved')) {
 643                                                                         push @ret, [ $topic_id, $story_id, $1 ];
 644                                                                 }
 645                                                         }
 646                                                 }
 647
 648                                                 closedir STORY;
 649                                         }
 650                                 }
 651
 652                                 closedir TOPIC;
 653                         }
 654                 }
 655
 656                 closedir BASE;
 657         }
 658
 659         @ret = sort { $b->[2] cmp $a->[2] } @ret;
 660         @ret = @ret[0 .. ($max - 1)];
 661
 662         return grep { defined $_ } @ret;
 663 }
 664
 665
 666 sub story_comments {
 667         my $self        = shift;
 668         my $story       = shift;
 669         my $all         = shift;
 670
 671         my @ret = ();
 672
 673     my $expire_days = 7;
 674     my $expire_days_t = $self->template('cfg_comment_expire_days');
 675
 676     if ($expire_days_t) {
 677         $expire_days = $expire_days_t->get('content');
 678     }
 679
 680         my $topic_id = $story->get('topic_id');
 681         my $story_id = $story->get('id');
 682
 683         my $base_path = $self->{path} . Gruta::Data::FS::Comment::base();
 684
 685         my $pend_path = $base_path . '/.pending/';
 686         my $path = join('/', ($base_path, $topic_id, $story_id)) . '/';
 687
 688         if (opendir D, $path) {
 689                 while (my $id = readdir D) {
 690                         my $f = $path . $id;
 691
 692                         next if -d $f;
 693                         next if $f =~ /\.M$/;
 694
 695                         my $pf = $pend_path . join(':', ($topic_id, $story_id, $id));
 696
 697                         # too old? delete
 698                         if (-f $pf && -M $f >= $expire_days) {
 699                                 unlink $f;
 700                                 unlink $f . '.M';
 701                                 unlink $pf;
 702                                 next;
 703                         }
 704
 705                         # not all wanted and this comment not approved? skip
 706                         if (!$all && -f $pf) {
 707                                 next;
 708                         }
 709
 710                         push @ret, [ $topic_id, $story_id, $id ];
 711                 }
 712
 713                 closedir D;
 714         }
 715
 716         return sort { $a->[2] cmp $b->[2] } @ret;
 717 }
 718
 719
 720 sub story {
 721         my $self        = shift;
 722         my $topic_id    = shift;
 723         my $id          = shift;
 724
 725         my $story;
 726
 727         if ($story = $self->cache_story($topic_id, $id)) {
 728                 return $story;
 729         }
 730
 731         $story = Gruta::Data::FS::Story->new( topic_id => $topic_id, id => $id );
 732
 733         if (not $story->load( $self )) {
 734
 735                 $story = Gruta::Data::FS::Story->new( topic_id => $topic_id . '-arch',
 736                         id => $id );
 737
 738                 if (not $story->load( $self )) {
 739                         return undef;
 740                 }
 741         }
 742
 743         # now load the content
 744         my $file = $story->_filename();
 745         $file =~ s/\.M$//;
 746
 747         my @d = ('', 'content', '.A', 'abstract', '.B', 'body');
 748
 749         while (@d) {
 750                 my $ext         = shift(@d);
 751                 my $field       = shift(@d);
 752
 753                 if (open F, $file . $ext) {
 754                         $story->set($field, join('', <F>));
 755                         close F;
 756                 }
 757         }
 758
 759         $self->cache_story($topic_id, $id, $story);
 760
 761         return $story;
 762 }
 763
 764 sub stories {
 765         my $self        = shift;
 766         my $topic_id    = shift;
 767
 768         my @ret = ();
 769
 770         if (!$self->topic($topic_id)) {
 771                 return @ret;
 772         }
 773
 774         my $path = $self->{path} . Gruta::Data::FS::Topic::base() . $topic_id;
 775
 776         if (opendir D, $path) {
 777                 while (my $id = readdir D) {
 778                         if ($id =~ s/\.M$// || $id =~ s/\.META$//) {
 779                                 push(@ret, $id);
 780                         }
 781                 }
 782
 783                 closedir D;
 784         }
 785
 786         return @ret;
 787 }
 788
 789
 790 sub _topic_index {
 791         my $self        = shift;
 792         my $topic_id    = shift;
 793
 794         my $index = $self->{path} . Gruta::Data::FS::Topic::base() . $topic_id;
 795
 796         if (! -d $index) {
 797                 return undef;
 798         }
 799
 800         $index .= '/.INDEX';
 801
 802         if (not open I, $index) {
 803
 804                 my @i = ();
 805                 foreach my $id ($self->stories($topic_id)) {
 806                         my $story = $self->story($topic_id, $id);
 807
 808                         push(@i, ($story->get('date') || ('0' x 14)). ':' . $id);
 809                 }
 810
 811                 open I, '>' . $index or croak "Can't create INDEX for $topic_id: $!";
 812                 flock I, 2;
 813
 814                 foreach my $l (reverse(sort(@i))) {
 815                         print I $l, "\n";
 816                 }
 817         }
 818
 819         close I;
 820
 821         return $index;
 822 }
 823
 824
 825 sub _update_top_ten {
 826         my $self        = shift;
 827         my $hits        = shift;
 828         my $topic_id    = shift;
 829         my $id          = shift;
 830
 831         my $index = $self->{path} . Gruta::Data::FS::Topic::base() . '/.top_ten';
 832
 833         my $u = 0;
 834         my @l = ();
 835
 836         if (open F, $index) {
 837                 flock F, 1;
 838                 while (my $l = <F>) {
 839                         chomp($l);
 840
 841                         my ($h, $t, $i) = split(':', $l);
 842
 843                         if ($u == 0 && $h < $hits) {
 844                                 $u = 1;
 845                                 push(@l, "$hits:$topic_id:$id");
 846                         }
 847
 848                         if ($i ne $id or $t ne $topic_id) {
 849                                 push(@l, $l);
 850                         }
 851                 }
 852
 853                 close F;
 854         }
 855
 856         if ($u == 0 && scalar(@l) < $self->{hard_top_ten_limit}) {
 857                 $u = 1;
 858                 push(@l, "$hits:$topic_id:$id");
 859         }
 860
 861         if ($u) {
 862                 if (open F, '>' . $index) {
 863                         flock F, 2;
 864                         my $n = 0;
 865
 866                         foreach my $l (@l) {
 867                                 print F $l, "\n";
 868
 869                                 if (++$n == $self->{hard_top_ten_limit}) {
 870                                         last;
 871                                 }
 872                         }
 873
 874                         close F;
 875                 }
 876         }
 877
 878         return undef;
 879 }
 880
 881
 882 sub _stories_by_date {
 883         my $self        = shift;
 884         my $topic_id    = shift;
 885         my %args        = @_;
 886
 887         my @r = ();
 888
 889         my $i = $self->_topic_index($topic_id) or return @r;
 890         open I, $i or return @r;
 891         flock I, 1;
 892
 893         my $o = 0;
 894
 895         while (<I>) {
 896                 chomp;
 897
 898                 my ($date, $id) = split(/:/);
 899
 900                 # skip future stories
 901                 next if not $args{future} and $date gt Gruta::Data::today();
 902
 903                 # skip if date is above the threshold
 904                 next if $args{'to'} and $date gt $args{'to'};
 905
 906                 # exit if date is below the threshold
 907                 last if $args{'from'} and $date lt $args{'from'};
 908
 909                 # skip offset stories
 910                 next if $args{'offset'} and ++$o <= $args{'offset'};
 911
 912                 push(@r, [ $topic_id, $id, $date ]);
 913
 914                 # exit if we have all we need
 915                 last if $args{'num'} and $args{'num'} == scalar(@r);
 916         }
 917
 918         close I;
 919
 920         return @r;
 921 }
 922
 923
 924 sub stories_by_date {
 925         my $self        = shift;
 926         my $topics      = shift;
 927         my %args        = @_;
 928
 929         my @topics;
 930
 931         if (!$topics) {
 932                 @topics = $self->topics();
 933         }
 934         else {
 935                 @topics = @{ $topics };
 936         }
 937
 938         if (!$args{offset} || $args{offset} < 0) {
 939                 $args{offset} = 0;
 940         }
 941
 942         # only one topic? execute it and return
 943         if (scalar(@topics) == 1) {
 944                 return $self->_stories_by_date($topics[0], %args);
 945         }
 946
 947         # more than one topic; 'num' and 'offset' need to be
 948         # calculated from the full set
 949         my @R = ();
 950
 951         foreach my $topic_id (@topics) {
 952
 953                 my @r = $self->_stories_by_date($topic_id,
 954                         %args, num => 0, offset => 0);
 955
 956                 push(@R, @r);
 957         }
 958
 959         # sort by date
 960         @R = sort { $b->[2] cmp $a->[2] } @R;
 961
 962         # split now
 963         if ($args{num}) {
 964                 @R = @R[$args{offset} .. ($args{offset} + $args{num} - 1)];
 965         }
 966         else {
 967                 @R = @R[$args{offset} .. (scalar(@R) - 1)];
 968         }
 969
 970         return grep { defined $_ } @R;
 971 }
 972
 973 sub search_stories {
 974         my $self        = shift;
 975         my $topic_id    = shift;
 976         my $query       = shift;
 977         my $future      = shift;
 978
 979         my @q = split(/\s+/,$query);
 980
 981         my %r = ();
 982
 983         foreach my $id ($self->stories($topic_id)) {
 984
 985                 my $story = $self->story($topic_id, $id);
 986
 987                 if (!$future and $story->get('date') gt Gruta::Data::today()) {
 988                         next;
 989                 }
 990
 991                 my $content = $story->get('content');
 992                 my $found = 0;
 993
 994                 # try complete query first
 995                 if($content =~ /\b$query\b/i) {
 996                         $found = scalar(@q);
 997                 }
 998                 else {
 999                         # try separate words
1000                         foreach my $q (@q) {
1001                                 if(length($q) > 1 and $content =~ /\b$q\b/i) {
1002                                         $found++;
1003                                 }
1004                         }
1005                 }
1006
1007                 if ($found == scalar(@q)) {
1008                         $r{$id} = $story->get('title');
1009                 }
1010         }
1011
1012         return sort { $r{$a} cmp $r{$b} } keys %r;
1013 }
1014
1015 sub stories_by_text {
1016         my $self        = shift;
1017         my $topics      = shift;
1018         my $query       = shift;
1019         my $future      = shift;
1020
1021         my @ret;
1022         my @topics;
1023
1024         if (!$topics) {
1025                 @topics = $self->topics();
1026         }
1027         else {
1028                 @topics = @{ $topics };
1029         }
1030
1031         foreach my $t (@topics) {
1032                 foreach my $id ($self->search_stories($t, $query, $future)) {
1033                         push(@ret, [ $t, $id ]);
1034                 }
1035         }
1036
1037         return @ret;
1038 }
1039
1040 sub stories_top_ten {
1041         my $self        = shift;
1042         my $num         = shift;
1043
1044         my @r = ();
1045
1046         my $index = $self->{path} . Gruta::Data::FS::Topic::base() . '/.top_ten';
1047
1048         if (open F, $index) {
1049                 flock F, 1;
1050
1051                 while (defined(my $l = <F>) and $num--) {
1052                         chomp($l);
1053                         push(@r, [ split(':', $l) ]);
1054                 }
1055
1056                 close F;
1057         }
1058
1059         return @r;
1060 }
1061
1062
1063 sub _collect_tags {
1064         my $self        = shift;
1065         my @topics      = @_;
1066
1067         my @ret = ();
1068
1069         foreach my $topic_id (@topics) {
1070
1071                 my $topic = $self->topic($topic_id)
1072                         or croak("Bad topic $topic_id");
1073
1074                 my $files = $topic->_filename();
1075                 $files =~ s/\.M$/\/*.T/;
1076
1077                 my @ls = glob($files);
1078
1079         foreach my $f (@ls) {
1080             if (open F, $f) {
1081                 my $tags = <F>;
1082
1083                 if ($tags) {
1084                     chomp $tags;
1085                     close F;
1086
1087                     my ($id) = ($f =~ m{/([^/]+)\.T});
1088
1089                     push(@ret,
1090                         [ $topic_id, $id, [ split(/\s*,\s*/, $tags) ] ]
1091                     );
1092                 }
1093             }
1094         }
1095         }
1096
1097         return @ret;
1098 }
1099
1100
1101 sub stories_by_tag {
1102         my $self        = shift;
1103         my $topics      = shift;
1104         my $tag         = shift;
1105         my $future      = shift;
1106
1107         my @topics;
1108
1109         if (!$topics) {
1110                 @topics = $self->topics();
1111         }
1112         else {
1113                 @topics = @{ $topics };
1114         }
1115
1116     my %r = ();
1117
1118     if ($tag) {
1119         my @tags        = map { lc($_) } split(/\s*,\s*/, $tag);
1120
1121         foreach my $tr ($self->_collect_tags(@topics)) {
1122
1123                 my @ts = @{$tr->[2]};
1124
1125                 # skip stories with less tags than the wanted ones
1126                 if (scalar(@ts) < scalar(@tags)) {
1127                         next;
1128                 }
1129
1130                 # count matches
1131                 my $c = 0;
1132
1133                 foreach my $t (@ts) {
1134                         if (grep(/^$t$/, @tags)) {
1135                                 $c++;
1136                         }
1137                 }
1138
1139                 if ($c >= scalar(@tags)) {
1140
1141                         my $story = $self->story($tr->[0], $tr->[1]);
1142
1143                         # if no future stories are wanted, discard them
1144                         if (!$future) {
1145                                 if ($story->get('date') gt Gruta::Data::today()) {
1146                                         next;
1147                                 }
1148                         }
1149
1150                         $r{$story->get('title')} =
1151                                 [ $tr->[0], $tr->[1], $story->get('date') ];
1152                 }
1153         }
1154     }
1155     else {
1156         # return all those stories without tags
1157         foreach my $topic_id (@topics) {
1158             foreach my $story_id ($self->stories($topic_id)) {
1159                 my $story = $self->story($topic_id, $story_id);
1160
1161                         # if no future stories are wanted, discard them
1162                         if (!$future) {
1163                                 if ($story->get('date') gt Gruta::Data::today()) {
1164                                         next;
1165                                 }
1166                         }
1167
1168                 if (!$story->tags()) {
1169                                 $r{$story->get('title')} =
1170                                         [ $topic_id, $story_id, $story->get('date') ];
1171                 }
1172             }
1173         }
1174     }
1175
1176     return map { $r{$_} } sort keys %r;
1177 }
1178
1179
1180 sub tags {
1181         my $self        = shift;
1182
1183         my @ret = ();
1184         my %h = ();
1185
1186         foreach my $tr ($self->_collect_tags($self->topics())) {
1187
1188                 foreach my $t (@{$tr->[2]}) {
1189                         $h{$t}++;
1190                 }
1191         }
1192
1193         foreach my $k (keys(%h)) {
1194                 push(@ret, [ $k, $h{$k} ]);
1195         }
1196
1197         return sort { $a->[0] cmp $b->[0] } @ret;
1198 }
1199
1200
1201 sub session {
1202         return _one( @_, 'Gruta::Data::FS::Session' );
1203 }
1204
1205 sub purge_old_sessions {
1206         my $self         = shift;
1207
1208         my $path = $self->{path} . Gruta::Data::FS::Session::base();
1209
1210         if (opendir D, $path) {
1211                 while(my $s = readdir D) {
1212                         my $f = $path . $s;
1213
1214                         next if -d $f;
1215
1216                         if (-M $f > 1) {
1217                                 unlink $f;
1218                         }
1219                 }
1220
1221                 closedir D;
1222         }
1223
1224         return undef;
1225 }
1226
1227
1228 sub _insert {
1229         my $self        = shift;
1230         my $obj         = shift;
1231         my $class       = shift;
1232
1233         bless($obj, $class);
1234         $obj->save( $self );
1235
1236         return $obj;
1237 }
1238
1239 sub insert_topic {
1240         $_[0]->_insert($_[1], 'Gruta::Data::FS::Topic');
1241 }
1242
1243 sub insert_user {
1244         $_[0]->_insert($_[1], 'Gruta::Data::FS::User');
1245 }
1246
1247 sub insert_template {
1248         $_[0]->_insert($_[1], 'Gruta::Data::FS::Template');
1249 }
1250
1251 sub insert_comment {
1252         $_[0]->_insert($_[1], 'Gruta::Data::FS::Comment');
1253 }
1254
1255 sub insert_story {
1256         my $self        = shift;
1257         my $story       = shift;
1258
1259         if (not $story->get('id')) {
1260                 # alloc an id for the story
1261                 my $id = undef;
1262
1263                 do {
1264                         $id = $story->new_id();
1265
1266                 } while $self->story($story->get('topic_id'), $id);
1267
1268                 $story->set('id', $id);
1269         }
1270
1271         $self->_insert($story, 'Gruta::Data::FS::Story');
1272         return $story;
1273 }
1274
1275 sub insert_session {
1276         $_[0]->_insert($_[1], 'Gruta::Data::FS::Session');
1277 }
1278
1279
1280 sub create {
1281         my $self        = shift;
1282
1283         my @l = map { $self->{path} . $_ } (
1284                 Gruta::Data::FS::Topic::base(),
1285                 Gruta::Data::FS::User::base(),
1286                 Gruta::Data::FS::Session::base(),
1287                 Gruta::Data::FS::Template::base(),
1288                 Gruta::Data::FS::Comment::base(),
1289                 Gruta::Data::FS::Comment::base() . '/.pending/'
1290         );
1291
1292         foreach my $d (@l) {
1293                 if (! -d $d) {
1294                         mkdir $d, 0755 or die "Cannot mkdir $d";
1295                 }
1296         }
1297
1298         return $self;
1299 }
1300
1301
1302 sub new {
1303         my $class = shift;
1304
1305         my $s = bless( { @_ }, $class);
1306
1307         $s->{hard_top_ten_limit} ||= 100;
1308
1309         $s->_assert();
1310
1311         $s->create();
1312
1313         return $s;
1314 }
1315
1316 1;