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.1-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         if ($self->{args}->{static_urls}) {
 244                 my $kn = scalar(keys(%args));
 245
 246                 if ($st eq 'INDEX' && $kn == 0) {
 247                         return $ret;
 248                 }
 249                 elsif ($st eq 'TOPIC' && $kn == 1) {
 250                         return $ret . $args{topic} . '/';
 251                 }
 252                 elsif ($st eq 'STORY' && $kn == 2) {
 253                         return $ret . $args{topic} . '/' . $args{id} . '.html';
 254                 }
 255         }
 256
 257         if ($st) {
 258                 $args{t} = $st;
 259
 260                 $ret .= '?' . join(';', map { "$_=$args{$_}" } sort keys(%args));
 261         }
 262
 263         return $ret;
 264 }
 265
 266
 267 sub _topic_special_uri {
 268         my $self        = shift;
 269         my $topic_id    = shift;
 270
 271         my $ret = undef;
 272
 273         if (my $t = $self->topic($topic_id)) {
 274                 $ret = sprintf('<a href="%s">%s</a>',
 275                         $self->url('TOPIC', 'topic' => $topic_id),
 276                         $t->get('name')
 277                 );
 278         }
 279         else {
 280                 $ret = "Bad topic $topic_id";
 281         }
 282
 283         return $ret;
 284 }
 285
 286
 287 sub _story_special_uri {
 288         my $self        = shift;
 289         my $topic_id    = shift;
 290         my $story_id    = shift;
 291
 292         my $ret = undef;
 293
 294         if (my $s = $self->story($topic_id, $story_id)) {
 295                 $ret = sprintf('<a href="%s">%s</a>',
 296                         $self->url('STORY',
 297                                 'topic' => $topic_id,
 298                                 'id' => $story_id
 299                         ),
 300                         $s->get('title')
 301                 );
 302         }
 303         else {
 304                 $ret = "Bad story '$topic_id/$story_id'";
 305         }
 306
 307         return $ret;
 308 }
 309
 310
 311 sub _img_special_uri {
 312         my $self        = shift;
 313         my $src         = shift;
 314         my $class       = shift;
 315
 316         my $r = sprintf('<img src = "%simg/%s" />',
 317                 $self->base_url(), $src
 318         );
 319
 320         if ($class) {
 321                 $r = "<span class = '$class'>" . $r . '</span>';
 322         }
 323
 324         return $r;
 325 }
 326
 327
 328 sub _content_special_uri {
 329         my $self        = shift;
 330         my $topic_id    = shift;
 331         my $story_id    = shift;
 332         my $field       = shift;
 333
 334         my $ret = undef;
 335
 336         if (my $s = $self->story($topic_id, $story_id)) {
 337                 $ret = $self->special_uris($s->get($field));
 338         }
 339         else {
 340                 $ret = "Bad story '$topic_id/$story_id'";
 341         }
 342
 343         return $ret;
 344 }
 345
 346
 347
 348 sub special_uris {
 349         my $self        = shift;
 350         my $string      = shift;
 351
 352         $string =~ s!topic://([\w\d_-]+)!$self->_topic_special_uri($1)!ge;
 353         $string =~ s!story://([\w\d_-]+)/([\w\d_-]+)!$self->_story_special_uri($1,$2)!ge;
 354         $string =~ s!img://([\w\d_\.-]+)/?([\w\d_-]*)!$self->_img_special_uri($1,$2)!ge;
 355         $string =~ s!body://([\w\d_-]+)/([\w\d_-]+)!$self->_content_special_uri($1,$2,'body')!ge;
 356         $string =~ s!abstract://([\w\d_-]+)/([\w\d_-]+)!$self->_content_special_uri($1,$2,'abstract')!ge;
 357
 358         return $string;
 359 }
 360
 361
 362 sub transfer_to_source {
 363         my $self        = shift;
 364         my $dst         = shift;
 365
 366         foreach my $id ($self->users()) {
 367                 my $u = $self->user($id);
 368                 $dst->insert_user($u);
 369         }
 370
 371         foreach my $topic_id (sort $self->topics()) {
 372                 my $t = $self->topic($topic_id);
 373
 374                 my $nti = $topic_id;
 375
 376                 # is it an archive?
 377                 if ($nti =~ /-arch$/) {
 378                         # don't insert topic, just rename
 379                         $nti =~ s/-arch$//;
 380                 }
 381                 else {
 382                         $dst->insert_topic($t);
 383                 }
 384
 385                 foreach my $id ($self->stories($topic_id)) {
 386
 387                         # get story and its tags
 388                         my $s = $self->story($topic_id, $id);
 389                         my @tags = $s->tags();
 390
 391                         # set new topic
 392                         $s->set('topic_id', $nti);
 393
 394                         my $ns = $dst->insert_story($s);
 395
 396                         if (@tags) {
 397                                 $ns->tags(@tags);
 398                         }
 399                 }
 400         }
 401
 402         return $self;
 403 }
 404
 405
 406 sub flush_story_cache {
 407         my $self        = shift;
 408
 409         $self->{story_cache} = {};
 410 }
 411
 412
 413 sub new {
 414         my $class       = shift;
 415
 416         my $g = bless( { @_ } , $class);
 417
 418         $g->{id}                ||= 'Gruta';
 419         $g->{args}              ||= {};
 420
 421         $g->{story_cache}       = {};
 422         $g->{renderers_h}       = {};
 423         $g->{calls}             = {};
 424
 425         if ($g->{sources}) {
 426                 if (ref($g->{sources}) ne 'ARRAY') {
 427                         $g->{sources} = [ $g->{sources} ];
 428                 }
 429
 430                 foreach my $s (@{$g->{sources}}) {
 431                         $s->data($g);
 432                 }
 433         }
 434
 435         if ($g->{renderers}) {
 436                 if (ref($g->{renderers}) ne 'ARRAY') {
 437                         $g->{renderers} = [ $g->{renderers} ];
 438                 }
 439
 440                 foreach my $r (@{$g->{renderers}}) {
 441                         $g->{renderers_h}->{$r->{renderer_id}} = $r;
 442                 }
 443         }
 444
 445         if ($g->{template}) {
 446                 $g->template->data($g);
 447         }
 448
 449         if ($g->{cgi}) {
 450                 $g->cgi->data($g);
 451         }
 452
 453         return $g;
 454 }
 455
 456 sub run {
 457         my $self        = shift;
 458
 459         if ($self->{cgi}) {
 460                 $self->cgi->run();
 461         }
 462 }
 463
 464 1;