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