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::Source::FS;
 288
 289 use Carp;
 290
 291 sub _assert {
 292         my $self        = shift;
 293
 294         $self->{path} or croak "Invalid path";
 295
 296         return $self;
 297 }
 298
 299 sub _one {
 300         my $self        = shift;
 301         my $id          = shift;
 302         my $class       = shift;
 303
 304         my $o = ${class}->new( id => $id );
 305         $o->load( $self );
 306 }
 307
 308 sub topic {
 309         return _one( @_, 'Gruta::Data::FS::Topic' );
 310 }
 311
 312 sub topics {
 313         my $self        = shift;
 314
 315         my @ret = ();
 316
 317         my $path = $self->{path} . Gruta::Data::FS::Topic::base();
 318
 319         if (opendir D, $path) {
 320                 while (my $id = readdir D) {
 321                         next unless -d $path . $id;
 322                         next if $id =~ /^\./;
 323
 324                         push @ret, $id;
 325                 }
 326
 327                 closedir D;
 328         }
 329
 330         return @ret;
 331 }
 332
 333 sub user {
 334         return _one( @_, 'Gruta::Data::FS::User' );
 335 }
 336
 337 sub users {
 338         my $self        = shift;
 339
 340         my @ret = ();
 341
 342         my $path = $self->{path} . Gruta::Data::FS::User::base();
 343
 344         if (opendir D, $path) {
 345                 while (my $id = readdir D) {
 346                         next if -d $path . $id;
 347                         push @ret, $id;
 348                 }
 349
 350                 closedir D;
 351         }
 352
 353         return @ret;
 354 }
 355
 356 sub story {
 357         my $self        = shift;
 358         my $topic_id    = shift;
 359         my $id          = shift;
 360
 361         my $story;
 362
 363         if ($story = $self->cache_story($topic_id, $id)) {
 364                 return $story;
 365         }
 366
 367         $story = Gruta::Data::FS::Story->new( topic_id => $topic_id, id => $id );
 368
 369         if (not $story->load( $self )) {
 370
 371                 $story = Gruta::Data::FS::Story->new( topic_id => $topic_id . '-arch',
 372                         id => $id );
 373
 374                 if (not $story->load( $self )) {
 375                         return undef;
 376                 }
 377         }
 378
 379         # now load the content
 380         my $file = $story->_filename();
 381         $file =~ s/\.M$//;
 382
 383         my @d = ('', 'content', '.A', 'abstract', '.B', 'body');
 384
 385         while (@d) {
 386                 my $ext         = shift(@d);
 387                 my $field       = shift(@d);
 388
 389                 if (open F, $file . $ext) {
 390                         $story->set($field, join('', <F>));
 391                         close F;
 392                 }
 393         }
 394
 395         $self->cache_story($topic_id, $id, $story);
 396
 397         return $story;
 398 }
 399
 400 sub stories {
 401         my $self        = shift;
 402         my $topic_id    = shift;
 403
 404         my @ret = ();
 405
 406         if (!$self->topic($topic_id)) {
 407                 return @ret;
 408         }
 409
 410         my $path = $self->{path} . Gruta::Data::FS::Topic::base() . $topic_id;
 411
 412         if (opendir D, $path) {
 413                 while (my $id = readdir D) {
 414                         if ($id =~ s/\.M$// || $id =~ s/\.META$//) {
 415                                 push(@ret, $id);
 416                         }
 417                 }
 418
 419                 closedir D;
 420         }
 421
 422         return @ret;
 423 }
 424
 425
 426 sub _topic_index {
 427         my $self        = shift;
 428         my $topic_id    = shift;
 429
 430         my $index = $self->{path} . Gruta::Data::FS::Topic::base() . $topic_id;
 431
 432         if (! -d $index) {
 433                 return undef;
 434         }
 435
 436         $index .= '/.INDEX';
 437
 438         if (not open I, $index) {
 439
 440                 my @i = ();
 441                 foreach my $id ($self->stories($topic_id)) {
 442                         my $story = $self->story($topic_id, $id);
 443
 444                         push(@i, ($story->get('date') || ('0' x 14)). ':' . $id);
 445                 }
 446
 447                 open I, '>' . $index or croak "Can't create INDEX for $topic_id: $!";
 448                 flock I, 2;
 449
 450                 foreach my $l (reverse(sort(@i))) {
 451                         print I $l, "\n";
 452                 }
 453         }
 454
 455         close I;
 456
 457         return $index;
 458 }
 459
 460
 461 sub _update_top_ten {
 462         my $self        = shift;
 463         my $hits        = shift;
 464         my $topic_id    = shift;
 465         my $id          = shift;
 466
 467         my $index = $self->{path} . Gruta::Data::FS::Topic::base() . '/.top_ten';
 468
 469         my $u = 0;
 470         my @l = ();
 471
 472         if (open F, $index) {
 473                 flock F, 1;
 474                 while (my $l = <F>) {
 475                         chomp($l);
 476
 477                         my ($h, $t, $i) = split(':', $l);
 478
 479                         if ($u == 0 && $h < $hits) {
 480                                 $u = 1;
 481                                 push(@l, "$hits:$topic_id:$id");
 482                         }
 483
 484                         if ($i ne $id or $t ne $topic_id) {
 485                                 push(@l, $l);
 486                         }
 487                 }
 488
 489                 close F;
 490         }
 491
 492         if ($u == 0 && scalar(@l) < 100) {
 493                 $u = 1;
 494                 push(@l, "$hits:$topic_id:$id");
 495         }
 496
 497         if ($u) {
 498                 if (open F, '>' . $index) {
 499                         flock F, 2;
 500                         my $n = 0;
 501
 502                         foreach my $l (@l) {
 503                                 print F $l, "\n";
 504
 505                                 if (++$n == 100) {
 506                                         last;
 507                                 }
 508                         }
 509
 510                         close F;
 511                 }
 512         }
 513
 514         return undef;
 515 }
 516
 517
 518 sub _stories_by_date {
 519         my $self        = shift;
 520         my $topic_id    = shift;
 521         my %args        = @_;
 522
 523         my @r = ();
 524
 525         my $i = $self->_topic_index($topic_id) or return @r;
 526         open I, $i or return @r;
 527         flock I, 1;
 528
 529         my $o = 0;
 530
 531         while (<I>) {
 532                 chomp;
 533
 534                 my ($date, $id) = (/^(\d*):(.*)$/);
 535
 536                 # skip future stories
 537                 next if not $args{future} and $date gt Gruta::Data::today();
 538
 539                 # skip if date is above the threshold
 540                 next if $args{'to'} and $date gt $args{'to'};
 541
 542                 # exit if date is below the threshold
 543                 last if $args{'from'} and $date lt $args{'from'};
 544
 545                 # skip offset stories
 546                 next if $args{'offset'} and ++$o <= $args{'offset'};
 547
 548                 push(@r, [ $topic_id, $id, $date ]);
 549
 550                 # exit if we have all we need
 551                 last if $args{'num'} and $args{'num'} == scalar(@r);
 552         }
 553
 554         close I;
 555
 556         return @r;
 557 }
 558
 559
 560 sub stories_by_date {
 561         my $self        = shift;
 562         my $topics      = shift;
 563         my %args        = @_;
 564
 565         my @topics;
 566
 567         if (!$topics) {
 568                 @topics = $self->topics();
 569         }
 570         else {
 571                 @topics = @{ $topics };
 572         }
 573
 574         $args{offset} += 0;
 575         $args{offset} = 0 if $args{offset} < 0;
 576
 577         # only one topic? execute it and return
 578         if (scalar(@topics) == 1) {
 579                 return $self->_stories_by_date($topics[0], %args);
 580         }
 581
 582         # more than one topic; 'num' and 'offset' need to be
 583         # calculated from the full set
 584         my @R = ();
 585
 586         foreach my $topic_id (@topics) {
 587
 588                 my @r = $self->_stories_by_date($topic_id,
 589                         %args, num => 0, offset => 0);
 590
 591                 push(@R, @r);
 592         }
 593
 594         # sort by date
 595         @R = sort { $b->[2] cmp $a->[2] } @R;
 596
 597         # split now
 598         if ($args{num}) {
 599                 @R = @R[$args{offset} .. ($args{offset} + $args{num} - 1)];
 600         }
 601         else {
 602                 @R = @R[$args{offset} .. (scalar(@R) - 1)];
 603         }
 604
 605         return grep { defined $_ } @R;
 606 }
 607
 608 sub search_stories {
 609         my $self        = shift;
 610         my $topic_id    = shift;
 611         my $query       = shift;
 612         my $future      = shift;
 613
 614         my @q = split(/\s+/,$query);
 615
 616         my %r = ();
 617
 618         foreach my $id ($self->stories($topic_id)) {
 619
 620                 my $story = $self->story($topic_id, $id);
 621
 622                 if (!$future and $story->get('date') gt Gruta::Data::today()) {
 623                         next;
 624                 }
 625
 626                 my $content = $story->get('content');
 627                 my $found = 0;
 628
 629                 # try complete query first
 630                 if($content =~ /\b$query\b/i) {
 631                         $found = scalar(@q);
 632                 }
 633                 else {
 634                         # try separate words
 635                         foreach my $q (@q) {
 636                                 if(length($q) > 1 and $content =~ /\b$q\b/i) {
 637                                         $found++;
 638                                 }
 639                         }
 640                 }
 641
 642                 if ($found == scalar(@q)) {
 643                         $r{$id} = $story->get('title');
 644                 }
 645         }
 646
 647         return sort { $r{$a} cmp $r{$b} } keys %r;
 648 }
 649
 650 sub stories_top_ten {
 651         my $self        = shift;
 652         my $num         = shift;
 653
 654         my @r = ();
 655
 656         my $index = $self->{path} . Gruta::Data::FS::Topic::base() . '/.top_ten';
 657
 658         if (open F, $index) {
 659                 flock F, 1;
 660
 661                 while (defined(my $l = <F>) and $num--) {
 662                         chomp($l);
 663                         push(@r, [ split(':', $l) ]);
 664                 }
 665
 666                 close F;
 667         }
 668
 669         return @r;
 670 }
 671
 672
 673 sub _collect_tags {
 674         my $self        = shift;
 675         my @topics      = @_;
 676
 677         my @ret = ();
 678
 679         foreach my $topic_id (@topics) {
 680
 681                 my $topic = $self->topic($topic_id);
 682
 683                 my $files = $topic->_filename();
 684                 $files =~ s/\.M$/\/*.T/;
 685
 686                 my @ls = glob($files);
 687
 688                 foreach my $f (@ls) {
 689                         if (open F, $f) {
 690                                 my $tags = <F>;
 691                                 chomp $tags;
 692                                 close F;
 693
 694                                 my ($id) = ($f =~ m{/([^/]+)\.T});
 695
 696                                 push(@ret,
 697                                         [ $topic_id, $id, [ split(/\s*,\s*/, $tags) ] ]
 698                                 );
 699                         }
 700                 }
 701         }
 702
 703         return @ret;
 704 }
 705
 706
 707 sub stories_by_tag {
 708         my $self        = shift;
 709         my $topics      = shift;
 710         my $tag         = shift;
 711         my $future      = shift;
 712
 713         my @tags        = map { lc($_) } split(/\s*,\s*/, $tag);
 714
 715         my @topics;
 716
 717         if (!$topics) {
 718                 @topics = $self->topics();
 719         }
 720         else {
 721                 @topics = @{ $topics };
 722         }
 723
 724         my %r = ();
 725
 726         foreach my $tr ($self->_collect_tags(@topics)) {
 727
 728                 my @ts = @{$tr->[2]};
 729
 730                 # skip stories with less tags than the wanted ones
 731                 if (scalar(@ts) < scalar(@tags)) {
 732                         next;
 733                 }
 734
 735                 # count matches
 736                 my $c = 0;
 737
 738                 foreach my $t (@ts) {
 739                         if (grep(/^$t$/, @tags)) {
 740                                 $c++;
 741                         }
 742                 }
 743
 744                 if ($c >= scalar(@tags)) {
 745
 746                         my $story = $self->story($tr->[0], $tr->[1]);
 747
 748                         # if no future stories are wanted, discard them
 749                         if (!$future) {
 750                                 if ($story->get('date') gt Gruta::Data::today()) {
 751                                         next;
 752                                 }
 753                         }
 754
 755                         $r{$story->get('title')} =
 756                                 [ $tr->[0], $tr->[1], $story->get('date') ];
 757                 }
 758         }
 759
 760         return map { $r{$_} } sort keys %r;
 761 }
 762
 763
 764 sub tags {
 765         my $self        = shift;
 766
 767         my @ret = ();
 768         my %h = ();
 769
 770         foreach my $tr ($self->_collect_tags($self->topics())) {
 771
 772                 foreach my $t (@{$tr->[2]}) {
 773                         $h{$t}++;
 774                 }
 775         }
 776
 777         foreach my $k (keys(%h)) {
 778                 push(@ret, [ $k, $h{$k} ]);
 779         }
 780
 781         return sort { $a->[0] cmp $b->[0] } @ret;
 782 }
 783
 784
 785 sub session {
 786         return _one( @_, 'Gruta::Data::FS::Session' );
 787 }
 788
 789 sub purge_old_sessions {
 790         my $self         = shift;
 791
 792         my $path = $self->{path} . Gruta::Data::FS::Session::base();
 793
 794         if (opendir D, $path) {
 795                 while(my $s = readdir D) {
 796                         my $f = $path . $s;
 797
 798                         next if -d $f;
 799
 800                         if (-M $f > 1) {
 801                                 unlink $f;
 802                         }
 803                 }
 804
 805                 closedir D;
 806         }
 807
 808         return undef;
 809 }
 810
 811
 812 sub _insert {
 813         my $self        = shift;
 814         my $obj         = shift;
 815         my $class       = shift;
 816
 817         bless($obj, $class);
 818         $obj->save( $self );
 819
 820         return $obj;
 821 }
 822
 823 sub insert_topic {
 824         $_[0]->_insert($_[1], 'Gruta::Data::FS::Topic');
 825 }
 826
 827 sub insert_user {
 828         $_[0]->_insert($_[1], 'Gruta::Data::FS::User');
 829 }
 830
 831 sub insert_story {
 832         my $self        = shift;
 833         my $story       = shift;
 834
 835         if (not $story->get('id')) {
 836                 # alloc an id for the story
 837                 my $id = undef;
 838
 839                 do {
 840                         $id = $story->new_id();
 841
 842                 } while $self->story($story->get('topic_id'), $id);
 843
 844                 $story->set('id', $id);
 845         }
 846
 847         $self->_insert($story, 'Gruta::Data::FS::Story');
 848         return $story;
 849 }
 850
 851 sub insert_session {
 852         $_[0]->_insert($_[1], 'Gruta::Data::FS::Session');
 853 }
 854
 855
 856 sub create {
 857         my $self        = shift;
 858
 859         my @l = map { $self->{path} . $_ } (
 860                 Gruta::Data::FS::Topic::base(),
 861                 Gruta::Data::FS::User::base(),
 862                 Gruta::Data::FS::Session::base()
 863         );
 864
 865         foreach my $d (@l) {
 866                 if (! -d $d) {
 867                         mkdir $d, 0755 or die "Cannot mkdir $d";
 868                 }
 869         }
 870
 871         return $self;
 872 }
 873
 874
 875 sub new {
 876         my $class = shift;
 877
 878         my $s = bless( { @_ }, $class);
 879
 880         $s->_assert();
 881
 882         $s->create();
 883
 884         return $s;
 885 }
 886
 887 1;