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