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.0.0';
  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]->{base_url} || '' };
 235
 236 sub _topic_special_uri {
 237         my $self        = shift;
 238         my $topic_id    = shift;
 239
 240         my $ret = undef;
 241
 242         if (my $t = $self->topic($topic_id)) {
 243                 $ret = sprintf('<a href="%s?t=TOPIC;topic=%s">%s</a>',
 244                         $self->base_url(), $topic_id, $t->get('name')
 245                 );
 246         }
 247         else {
 248                 $ret = "Bad topic $topic_id";
 249         }
 250
 251         return $ret;
 252 }
 253
 254
 255 sub _story_special_uri {
 256         my $self        = shift;
 257         my $topic_id    = shift;
 258         my $story_id    = shift;
 259
 260         my $ret = undef;
 261
 262         if (my $s = $self->story($topic_id, $story_id)) {
 263                 $ret = sprintf('<a href="%s?t=STORY;topic=%s;id=%s">%s</a>',
 264                         $self->base_url(), $topic_id, $story_id, $s->get('title')
 265                 );
 266         }
 267         else {
 268                 $ret = "Bad story '$topic_id/$story_id'";
 269         }
 270
 271         return $ret;
 272 }
 273
 274
 275 sub _img_special_uri {
 276         my $self        = shift;
 277         my $src         = shift;
 278         my $class       = shift;
 279
 280         my $r = sprintf('<img src = "%simg/%s" />',
 281                 $self->base_url(), $src
 282         );
 283
 284         if ($class) {
 285                 $r = "<span class = '$class'>" . $r . '</span>';
 286         }
 287
 288         return $r;
 289 }
 290
 291 sub special_uris {
 292         my $self        = shift;
 293         my $string      = shift;
 294
 295         $string =~ s!topic://([\w\d_]+)!$self->_topic_special_uri($1)!ge;
 296         $string =~ s!story://([\w\d_]+)/([\w\d_]+)!$self->_story_special_uri($1,$2)!ge;
 297         $string =~ s!img://([\w\d_\.-]+)/?([\w\d_]*)!$self->_img_special_uri($1,$2)!ge;
 298
 299         return $string;
 300 }
 301
 302
 303 sub transfer_to_source {
 304         my $self        = shift;
 305         my $dst         = shift;
 306
 307         foreach my $id ($self->users()) {
 308                 my $u = $self->user($id);
 309                 $dst->insert_user($u);
 310         }
 311
 312         foreach my $topic_id (sort $self->topics()) {
 313                 my $t = $self->topic($topic_id);
 314
 315                 my $nti = $topic_id;
 316
 317                 # is it an archive?
 318                 if ($nti =~ /-arch$/) {
 319                         # don't insert topic, just rename
 320                         $nti =~ s/-arch$//;
 321                 }
 322                 else {
 323                         $dst->insert_topic($t);
 324                 }
 325
 326                 foreach my $id ($self->stories($topic_id)) {
 327
 328                         # get story and its tags
 329                         my $s = $self->story($topic_id, $id);
 330                         my @tags = $s->tags();
 331
 332                         # set new topic
 333                         $s->set('topic_id', $nti);
 334
 335                         my $ns = $dst->insert_story($s);
 336
 337                         if (@tags) {
 338                                 $ns->tags(@tags);
 339                         }
 340                 }
 341         }
 342
 343         return $self;
 344 }
 345
 346
 347 sub flush_story_cache {
 348         my $self        = shift;
 349
 350         $self->{story_cache} = {};
 351 }
 352
 353
 354 sub new {
 355         my $class       = shift;
 356
 357         my $g = bless( { @_ } , $class);
 358
 359         $g->{id} ||= 'Gruta';
 360
 361         $g->{story_cache}       = {};
 362         $g->{renderers_h}       = {};
 363         $g->{calls}             = {};
 364
 365         if (ref($g->{sources}) ne 'ARRAY') {
 366                 $g->{sources} = [ $g->{sources} ];
 367         }
 368
 369         if ($g->{renderers}) {
 370                 if (ref($g->{renderers}) ne 'ARRAY') {
 371                         $g->{renderers} = [ $g->{renderers} ];
 372                 }
 373
 374                 foreach my $r (@{$g->{renderers}}) {
 375                         $g->{renderers_h}->{$r->{renderer_id}} = $r;
 376                 }
 377         }
 378
 379         if ($g->{template}) {
 380                 $g->template->data($g);
 381         }
 382
 383         if ($g->{cgi}) {
 384                 $g->cgi->data($g);
 385         }
 386
 387         return $g;
 388 }
 389
 390 sub run {
 391         my $self        = shift;
 392
 393         if ($self->{cgi}) {
 394                 $self->cgi->run();
 395         }
 396 }
 397
 398 1;