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