Gruta.pm

   1 package Gruta;
   2
   3 use strict;
   4 use warnings;
   5
   6 use locale;
   7
   8 use Gruta::Data;
   9
  10 $Gruta::VERSION = '2.1.0-dev';
  11
  12 sub sources { return @{$_[0]->{sources}}; }
  13 sub template { return $_[0]->{template}; }
  14 sub cgi { return $_[0]->{cgi}; }
  15
  16 sub version { return $Gruta::VERSION; }
  17
  18 sub log {
  19         my $self        = shift;
  20         my $msg         = shift;
  21
  22         print STDERR $self->{id}, ' ', scalar(localtime), ': ', $msg, "\n";
  23 }
  24
  25
  26 sub _call {
  27         my $self        = shift;
  28         my $method      = shift;
  29         my $short       = shift;
  30
  31         my @r = ();
  32
  33         if (!exists($self->{calls}->{$method})) {
  34
  35                 # cache all calls in the sources
  36                 my @c = ();
  37
  38                 foreach my $s ($self->sources()) {
  39                         if (my $m = $s->can($method)) {
  40                                 push(@c, sub { return $m->($s, @_) });
  41                         }
  42                 }
  43
  44                 $self->{calls}->{$method} = [ @c ];
  45         }
  46
  47         foreach my $m (@{ $self->{calls}->{$method}}) {
  48                 my @pr = $m->(@_);
  49
  50                 if (@pr && $pr[0]) {
  51                         @r = (@r, @pr);
  52
  53                         last if $short;
  54                 }
  55         }
  56
  57         return wantarray ? @r : $r[0];
  58 }
  59
  60 sub topic { my $self = shift; return $self->_call('topic', 1, @_); }
  61 sub topics { my $self = shift; return $self->_call('topics', 0); }
  62
  63 sub user { my $self = shift; return $self->_call('user', 1, @_); }
  64 sub users { my $self = shift; return $self->_call('users', 0); }
  65
  66 sub story {
  67         my $self        = shift;
  68         my $topic_id    = shift;
  69         my $id          = shift;
  70
  71         if (! $topic_id || ! $id) {
  72                 return undef;
  73         }
  74
  75         my $story = undef;
  76         my $ck = $topic_id . '/' . $id;
  77
  78         if ($story = $self->{story_cache}->{$ck}) {
  79                 return $story;
  80         }
  81
  82         if (not $story = $self->_call('story', 1, $topic_id, $id)) {
  83                 return undef;
  84         }
  85
  86         my $format = $story->get('format') || 'grutatxt';
  87
  88         if (my $rndr = $self->{renderers_h}->{$format}) {
  89                 $rndr->story($story);
  90         }
  91
  92         return $self->{story_cache}->{$ck} = $story;
  93 }
  94
  95
  96 sub stories { my $self = shift; return $self->_call('stories', 0, @_); }
  97
  98 sub stories_by_date {
  99         my $self        = shift;
 100         my $topics      = shift;
 101         my %opts        = @_;
 102
 103         my @r = sort { $b->[2] cmp $a->[2] } $self->_call('stories_by_date', 0, $topics, %opts);
 104
 105         if ($opts{num} && scalar(@r) > $opts{num}) {
 106                 @r = @r[0 .. $opts{num} - 1];
 107         }
 108
 109         return @r;
 110 }
 111
 112 sub search_stories {
 113         my $self        = shift;
 114         my $topic_id    = shift;
 115
 116         my @l = $self->_call('search_stories', 1, $topic_id, @_);
 117
 118         return sort { $self->story($topic_id, $a)->get('title') cmp
 119                         $self->story($topic_id, $b)->get('title') } @l;
 120 }
 121
 122 sub stories_top_ten {
 123         my $self = shift;
 124
 125         my @l = $self->_call('stories_top_ten', 0, @_);
 126
 127         return sort { $b->[0] <=> $a->[0] } @l;
 128 }
 129
 130 sub stories_by_tag {
 131         my $self = shift;
 132
 133         my @l = $self->_call('stories_by_tag', 0, @_);
 134
 135         return sort { $self->story($a->[0], $a->[1])->get('title') cmp
 136                         $self->story($b->[0], $b->[1])->get('title') } @l;
 137 }
 138
 139 sub tags {
 140         my $self = shift;
 141
 142         my @l = $self->_call('tags', 0, @_);
 143
 144         return sort { $a->[0] cmp $b->[0] } @l;
 145 }
 146
 147 sub insert_topic { my $self = shift; return $self->_call('insert_topic', 1, @_); }
 148 sub insert_user { my $self = shift; return $self->_call('insert_user', 1, @_); }
 149 sub insert_story { my $self = shift; return $self->_call('insert_story', 1, @_); }
 150
 151
 152 sub auth {
 153         my $self        = shift;
 154
 155         if (@_) { $self->{auth} = shift; }      # Gruta::Data::User
 156
 157         return $self->{auth};
 158 }
 159
 160
 161 sub auth_from_sid {
 162         my $self        = shift;
 163         my $sid         = shift;
 164
 165         my $u = undef;
 166
 167         if ($sid) {
 168                 $self->_call('purge_old_sessions', 0);
 169
 170                 if (my $session = $self->_call('session', 1, $sid)) {
 171                         $u = $session->source->user( $session->get('user_id') );
 172
 173                         if ($u) {
 174                                 $u->set('sid', $sid);
 175                                 $self->auth($u);
 176                         }
 177                 }
 178         }
 179
 180         return $u;
 181 }
 182
 183
 184 sub login {
 185         my $self        = shift;
 186         my $user_id     = shift;
 187         my $passwd      = shift;
 188
 189         my $sid = undef;
 190
 191         if (my $u = $self->user( $user_id )) {
 192
 193                 # account expired? go!
 194                 if (my $xdate = $u->get('xdate')) {
 195                         if (Gruta::Data::today() > $xdate) {
 196                                 return undef;
 197                         }
 198                 }
 199
 200                 my $p = $u->get('password');
 201
 202                 if (Gruta::Data::crypt($passwd, $p) eq $p) {
 203                         # create new sid
 204                         my $session = Gruta::Data::Session->new(user_id => $user_id);
 205
 206                         $u->source->insert_session( $session );
 207
 208                         $sid = $session->get('id');
 209                         $u->set('sid', $sid);
 210                         $self->auth($u);
 211                 }
 212         }
 213
 214         return $sid;
 215 }
 216
 217
 218 sub logout {
 219         my $self        = shift;
 220
 221         if (my $auth = $self->auth()) {
 222                 if( my $sid = $auth->get('sid')) {
 223                         if (my $session = $auth->source->session( $sid )) {
 224                                 $session->delete() if $session->can('delete');
 225                         }
 226                 }
 227         }
 228
 229         $self->auth( undef );
 230         return $self;
 231 }
 232
 233
 234 sub base_url { $_[0]->{args}->{base_url} || '' };
 235
 236 sub url {
 237         my $self        = shift;
 238         my $st          = shift || '';
 239         my %args        = @_;
 240
 241         my $ret = $self->base_url();
 242
 243         # strip all undefined or empty arguments
 244         %args = map { $_, $args{$_} } grep { $args{$_} } keys(%args);
 245
 246         if ($self->{args}->{static_urls}) {
 247                 my $kn = scalar(keys(%args));
 248
 249                 if ($st eq 'INDEX' && $kn == 0) {
 250                         return $ret;
 251                 }
 252                 elsif ($st eq 'TOPIC' && $kn == 1) {
 253                         return $ret . $args{topic} . '/';
 254                 }
 255                 elsif ($st eq 'STORY' && $kn == 2) {
 256                         return $ret . $args{topic} . '/' . $args{id} . '.html';
 257                 }
 258         }
 259
 260         if ($st) {
 261                 $args{t} = $st;
 262
 263                 $ret .= '?' . join(';', map { "$_=$args{$_}" } sort keys(%args));
 264         }
 265
 266         return $ret;
 267 }
 268
 269
 270 sub _topic_special_uri {
 271         my $self        = shift;
 272         my $topic_id    = shift;
 273
 274         my $ret = undef;
 275
 276         if (my $t = $self->topic($topic_id)) {
 277                 $ret = sprintf('<a href="%s">%s</a>',
 278                         $self->url('TOPIC', 'topic' => $topic_id),
 279                         $t->get('name')
 280                 );
 281         }
 282         else {
 283                 $ret = "Bad topic $topic_id";
 284         }
 285
 286         return $ret;
 287 }
 288
 289
 290 sub _story_special_uri {
 291         my $self        = shift;
 292         my $topic_id    = shift;
 293         my $story_id    = shift;
 294
 295         my $ret = undef;
 296
 297         if (my $s = $self->story($topic_id, $story_id)) {
 298                 $ret = sprintf('<a href="%s">%s</a>',
 299                         $self->url('STORY',
 300                                 'topic' => $topic_id,
 301                                 'id' => $story_id
 302                         ),
 303                         $s->get('title')
 304                 );
 305         }
 306         else {
 307                 $ret = "Bad story '$topic_id/$story_id'";
 308         }
 309
 310         return $ret;
 311 }
 312
 313
 314 sub _img_special_uri {
 315         my $self        = shift;
 316         my $src         = shift;
 317         my $class       = shift;
 318
 319         my $r = sprintf('<img src = "%simg/%s" />',
 320                 $self->base_url(), $src
 321         );
 322
 323         if ($class) {
 324                 $r = "<span class = '$class'>" . $r . '</span>';
 325         }
 326
 327         return $r;
 328 }
 329
 330
 331 sub _content_special_uri {
 332         my $self        = shift;
 333         my $topic_id    = shift;
 334         my $story_id    = shift;
 335         my $field       = shift;
 336
 337         my $ret = undef;
 338
 339         if (my $s = $self->story($topic_id, $story_id)) {
 340                 $ret = $self->special_uris($s->get($field));
 341         }
 342         else {
 343                 $ret = "Bad story '$topic_id/$story_id'";
 344         }
 345
 346         return $ret;
 347 }
 348
 349
 350
 351 sub special_uris {
 352         my $self        = shift;
 353         my $string      = shift;
 354
 355         $string =~ s!topic://([\w\d_-]+)!$self->_topic_special_uri($1)!ge;
 356         $string =~ s!story://([\w\d_-]+)/([\w\d_-]+)!$self->_story_special_uri($1,$2)!ge;
 357         $string =~ s!img://([\w\d_\.-]+)/?([\w\d_-]*)!$self->_img_special_uri($1,$2)!ge;
 358         $string =~ s!body://([\w\d_-]+)/([\w\d_-]+)!$self->_content_special_uri($1,$2,'body')!ge;
 359         $string =~ s!abstract://([\w\d_-]+)/([\w\d_-]+)!$self->_content_special_uri($1,$2,'abstract')!ge;
 360
 361         return $string;
 362 }
 363
 364
 365 sub transfer_to_source {
 366         my $self        = shift;
 367         my $dst         = shift;
 368
 369         foreach my $id ($self->users()) {
 370                 my $u = $self->user($id);
 371                 $dst->insert_user($u);
 372         }
 373
 374         foreach my $topic_id (sort $self->topics()) {
 375                 my $t = $self->topic($topic_id);
 376
 377                 my $nti = $topic_id;
 378
 379                 # is it an archive?
 380                 if ($nti =~ /-arch$/) {
 381                         # don't insert topic, just rename
 382                         $nti =~ s/-arch$//;
 383                 }
 384                 else {
 385                         $dst->insert_topic($t);
 386                 }
 387
 388                 foreach my $id ($self->stories($topic_id)) {
 389
 390                         # get story and its tags
 391                         my $s = $self->story($topic_id, $id);
 392                         my @tags = $s->tags();
 393
 394                         # set new topic
 395                         $s->set('topic_id', $nti);
 396
 397                         my $ns = $dst->insert_story($s);
 398
 399                         if (@tags) {
 400                                 $ns->tags(@tags);
 401                         }
 402                 }
 403         }
 404
 405         return $self;
 406 }
 407
 408
 409 sub flush_story_cache {
 410         my $self        = shift;
 411
 412         $self->{story_cache} = {};
 413 }
 414
 415
 416 sub new {
 417         my $class       = shift;
 418
 419         my $g = bless( { @_ } , $class);
 420
 421         $g->{id}                ||= 'Gruta';
 422         $g->{args}              ||= {};
 423
 424         $g->{story_cache}       = {};
 425         $g->{renderers_h}       = {};
 426         $g->{calls}             = {};
 427
 428         if ($g->{sources}) {
 429                 if (ref($g->{sources}) ne 'ARRAY') {
 430                         $g->{sources} = [ $g->{sources} ];
 431                 }
 432
 433                 foreach my $s (@{$g->{sources}}) {
 434                         $s->data($g);
 435                 }
 436         }
 437
 438         if ($g->{renderers}) {
 439                 if (ref($g->{renderers}) ne 'ARRAY') {
 440                         $g->{renderers} = [ $g->{renderers} ];
 441                 }
 442
 443                 foreach my $r (@{$g->{renderers}}) {
 444                         $g->{renderers_h}->{$r->{renderer_id}} = $r;
 445                 }
 446         }
 447
 448         if ($g->{template}) {
 449                 $g->template->data($g);
 450         }
 451
 452         if ($g->{cgi}) {
 453                 $g->cgi->data($g);
 454         }
 455
 456         return $g;
 457 }
 458
 459 sub run {
 460         my $self        = shift;
 461
 462         if ($self->{cgi}) {
 463                 $self->cgi->run();
 464         }
 465 }
 466
 467 1;