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         foreach my $s ($self->sources()) {
  34                 if (my $m = $s->can($method)) {
  35                         my @pr = $m->($s, @_);
  36
  37                         if (@pr && $pr[0]) {
  38                                 @r = (@r, @pr);
  39
  40                                 last if $short;
  41                         }
  42                 }
  43         }
  44
  45         return wantarray ? @r : $r[0];
  46 }
  47
  48 sub topic { my $self = shift; return $self->_call('topic', 1, @_); }
  49 sub topics { my $self = shift; return $self->_call('topics', 0); }
  50
  51 sub user { my $self = shift; return $self->_call('user', 1, @_); }
  52 sub users { my $self = shift; return $self->_call('users', 0); }
  53
  54 sub story {
  55         my $self        = shift;
  56         my $topic_id    = shift;
  57         my $id          = shift;
  58
  59         if (! $topic_id || ! $id) {
  60                 return undef;
  61         }
  62
  63         my $story = undef;
  64         my $ck = $topic_id . '/' . $id;
  65
  66         if ($story = $self->{story_cache}->{$ck}) {
  67                 return $story;
  68         }
  69
  70         if (not $story = $self->_call('story', 1, $topic_id, $id)) {
  71                 return undef;
  72         }
  73
  74         my $format = $story->get('format') || 'grutatxt';
  75
  76         if (my $rndr = $self->{renderers_h}->{$format}) {
  77                 $rndr->story($story);
  78         }
  79
  80         return $self->{story_cache}->{$ck} = $story;
  81 }
  82
  83
  84 sub stories { my $self = shift; return $self->_call('stories', 0, @_); }
  85
  86 sub stories_by_date {
  87         my $self        = shift;
  88         my $topics      = shift;
  89         my %opts        = @_;
  90
  91         my @r = sort { $b->[2] cmp $a->[2] } $self->_call('stories_by_date', 0, $topics, %opts);
  92
  93         if ($opts{num} && scalar(@r) > $opts{num}) {
  94                 @r = @r[0 .. $opts{num} - 1];
  95         }
  96
  97         return @r;
  98 }
  99
 100 sub search_stories {
 101         my $self        = shift;
 102         my $topic_id    = shift;
 103
 104         my @l = $self->_call('search_stories', 1, $topic_id, @_);
 105
 106         return sort { $self->story($topic_id, $a)->get('title') cmp
 107                         $self->story($topic_id, $b)->get('title') } @l;
 108 }
 109
 110 sub stories_top_ten {
 111         my $self = shift;
 112
 113         my @l = $self->_call('stories_top_ten', 0, @_);
 114
 115         return sort { $b->[0] <=> $a->[0] } @l;
 116 }
 117
 118 sub stories_by_tag {
 119         my $self = shift;
 120
 121         my @l = $self->_call('stories_by_tag', 0, @_);
 122
 123         return sort { $self->story($a->[0], $a->[1])->get('title') cmp
 124                         $self->story($b->[0], $b->[1])->get('title') } @l;
 125 }
 126
 127 sub tags {
 128         my $self = shift;
 129
 130         my @l = $self->_call('tags', 0, @_);
 131
 132         return sort { $a->[0] cmp $b->[0] } @l;
 133 }
 134
 135 sub insert_topic { my $self = shift; return $self->_call('insert_topic', 1, @_); }
 136 sub insert_user { my $self = shift; return $self->_call('insert_user', 1, @_); }
 137 sub insert_story { my $self = shift; return $self->_call('insert_story', 1, @_); }
 138
 139
 140 sub auth {
 141         my $self        = shift;
 142
 143         if (@_) { $self->{auth} = shift; }      # Gruta::Data::User
 144
 145         return $self->{auth};
 146 }
 147
 148
 149 sub auth_from_sid {
 150         my $self        = shift;
 151         my $sid         = shift;
 152
 153         my $u = undef;
 154
 155         if ($sid) {
 156                 $self->_call('purge_old_sessions', 0);
 157
 158                 if (my $session = $self->_call('session', 1, $sid)) {
 159                         $u = $session->source->user( $session->get('user_id') );
 160                         $u->set('sid', $sid);
 161                         $self->auth($u);
 162                 }
 163         }
 164
 165         return $u;
 166 }
 167
 168
 169 sub login {
 170         my $self        = shift;
 171         my $user_id     = shift;
 172         my $passwd      = shift;
 173
 174         my $sid = undef;
 175
 176         if (my $u = $self->user( $user_id )) {
 177
 178                 # account expired? go!
 179                 if (my $xdate = $u->get('xdate')) {
 180                         if (Gruta::Data::today() > $xdate) {
 181                                 return undef;
 182                         }
 183                 }
 184
 185                 my $p = $u->get('password');
 186
 187                 if (crypt($passwd, $p) eq $p) {
 188                         # create new sid
 189                         $sid = time() . $$;
 190
 191                         my $session = Gruta::Data::Session->new(
 192                                 id      => $sid,
 193                                 time    => time(),
 194                                 user_id => $user_id
 195                         );
 196
 197                         $u->source->insert_session( $session );
 198
 199                         $u->set('sid', $sid);
 200                         $self->auth($u);
 201                 }
 202         }
 203
 204         return $sid;
 205 }
 206
 207
 208 sub logout {
 209         my $self        = shift;
 210
 211         if (my $auth = $self->auth()) {
 212                 if( my $sid = $auth->get('sid')) {
 213                         if (my $session = $auth->source->session( $sid )) {
 214                                 $session->delete() if $session->can('delete');
 215                         }
 216                 }
 217         }
 218
 219         $self->auth( undef );
 220         return $self;
 221 }
 222
 223
 224 sub base_url { $_[0]->{base_url} || '' };
 225
 226 sub _topic_special_uri {
 227         my $self        = shift;
 228         my $topic_id    = shift;
 229
 230         my $ret = undef;
 231
 232         if (my $t = $self->topic($topic_id)) {
 233                 $ret = sprintf('<a href="%s?t=TOPIC;topic=%s">%s</a>',
 234                         $self->base_url(), $topic_id, $t->get('name')
 235                 );
 236         }
 237         else {
 238                 $ret = "Bad topic $topic_id";
 239         }
 240
 241         return $ret;
 242 }
 243
 244
 245 sub _story_special_uri {
 246         my $self        = shift;
 247         my $topic_id    = shift;
 248         my $story_id    = shift;
 249
 250         my $ret = undef;
 251
 252         if (my $s = $self->story($topic_id, $story_id)) {
 253                 $ret = sprintf('<a href="%s?t=STORY;topic=%s;id=%s">%s</a>',
 254                         $self->base_url(), $topic_id, $story_id, $s->get('title')
 255                 );
 256         }
 257         else {
 258                 $ret = "Bad story '$topic_id/$story_id'";
 259         }
 260
 261         return $ret;
 262 }
 263
 264
 265 sub _img_special_uri {
 266         my $self        = shift;
 267         my $src         = shift;
 268         my $class       = shift;
 269
 270         my $r = sprintf('<img src = "%simg/%s" />',
 271                 $self->base_url(), $src
 272         );
 273
 274         if ($class) {
 275                 $r = "<span class = '$class'>" . $r . '</span>';
 276         }
 277
 278         return $r;
 279 }
 280
 281 sub special_uris {
 282         my $self        = shift;
 283         my $string      = shift;
 284
 285         $string =~ s!topic://([\w\d_]+)!$self->_topic_special_uri($1)!ge;
 286         $string =~ s!story://([\w\d_]+)/([\w\d_]+)!$self->_story_special_uri($1,$2)!ge;
 287         $string =~ s!img://([\w\d_\.-]+)/?([\w\d_]*)!$self->_img_special_uri($1,$2)!ge;
 288
 289         return $string;
 290 }
 291
 292
 293 sub transfer_to_source {
 294         my $self        = shift;
 295         my $dst         = shift;
 296
 297         foreach my $id ($self->users()) {
 298                 my $u = $self->user($id);
 299                 $dst->insert_user($u);
 300         }
 301
 302         foreach my $topic_id (sort $self->topics()) {
 303                 my $t = $self->topic($topic_id);
 304
 305                 my $nti = $topic_id;
 306
 307                 # is it an archive?
 308                 if ($nti =~ /-arch$/) {
 309                         # don't insert topic, just rename
 310                         $nti =~ s/-arch$//;
 311                 }
 312                 else {
 313                         $dst->insert_topic($t);
 314                 }
 315
 316                 foreach my $id ($self->stories($topic_id)) {
 317
 318                         # get story and its tags
 319                         my $s = $self->story($topic_id, $id);
 320                         my @tags = $s->tags();
 321
 322                         # set new topic
 323                         $s->set('topic_id', $nti);
 324
 325                         my $ns = $dst->insert_story($s);
 326
 327                         if (@tags) {
 328                                 $ns->tags(@tags);
 329                         }
 330                 }
 331         }
 332
 333         return $self;
 334 }
 335
 336
 337 sub flush_story_cache {
 338         my $self        = shift;
 339
 340         $self->{story_cache} = {};
 341 }
 342
 343
 344 sub new {
 345         my $class       = shift;
 346
 347         my $g = bless( { @_ } , $class);
 348
 349         $g->{id} ||= 'Gruta';
 350         $g->{story_cache} = {};
 351         $g->{renderers_h} = {};
 352
 353         if (ref($g->{sources}) ne 'ARRAY') {
 354                 $g->{sources} = [ $g->{sources} ];
 355         }
 356
 357         if ($g->{renderers}) {
 358                 if (ref($g->{renderers}) ne 'ARRAY') {
 359                         $g->{renderers} = [ $g->{renderers} ];
 360                 }
 361
 362                 foreach my $r (@{$g->{renderers}}) {
 363                         $g->{renderers_h}->{$r->{renderer_id}} = $r;
 364                 }
 365         }
 366
 367         if ($g->{template}) {
 368                 $g->template->data($g);
 369         }
 370
 371         if ($g->{cgi}) {
 372                 $g->cgi->data($g);
 373         }
 374
 375         my @u;
 376
 377         if (not @u = $g->users()) {
 378                 my $u = Gruta::Data::User->new(
 379                         id              => 'admin',
 380                         is_admin        => 1,
 381                         can_upload      => 1,
 382                         username        => 'Admin',
 383                         email           => 'webmaster@localhost'
 384                 );
 385
 386                 $u->password('admin');
 387                 $g->insert_user($u);
 388         }
 389
 390         return $g;
 391 }
 392
 393 sub run {
 394         my $self        = shift;
 395
 396         if ($self->{cgi}) {
 397                 $self->cgi->run();
 398         }
 399 }
 400
 401 1;