cgi-bin/LJ/QotD.pm

   1 package LJ::QotD;
   2 use strict;
   3 use Carp qw(croak);
   4 use List::Util qw(shuffle);
   5
   6 sub get_domains {
   7     my $class = shift;
   8
   9     return ( homepage => "Homepage",
  10              (map { $_->name, $_->display_name } LJ::Widget::VerticalContentControl->verticals_remote_can_moderate),
  11              'ljru' => "LJ.ru");
  12 }
  13
  14 sub is_valid_domain {
  15     my $class = shift;
  16     my $domain = shift;
  17
  18     return scalar(grep { $_ eq $domain } $class->get_domains) ? 1 : 0;
  19 }
  20
  21 # returns 'current' or 'old' depending on given start and end times
  22 sub get_type {
  23     my $class = shift;
  24     my %times = @_;
  25
  26     return $class->is_current(%times) ? 'current' : 'old';
  27 }
  28
  29 # given a start and end time, returns if now is between those two times
  30 sub is_current {
  31     my $class = shift;
  32     my %times = @_;
  33
  34     return 0 unless $times{start} && $times{end};
  35
  36     my $now = time();
  37     return $times{start} <= $now && $times{end} >= $now;
  38 }
  39
  40 sub memcache_key {
  41     my $class = shift;
  42     my $type = shift;
  43
  44     return "qotd:$type";
  45 }
  46
  47 sub cache_get {
  48     my $class = shift;
  49     my $type = shift;
  50
  51     # first, is it in our per-request cache?
  52     my $questions = $LJ::QotD::REQ_CACHE_QOTD{$type};
  53     return $questions if $questions;
  54
  55     my $memkey = $class->memcache_key($type);
  56     my $memcache_data = LJ::MemCache::get($memkey);
  57     if ($memcache_data) {
  58         # fill the request cache since it was empty
  59         $class->request_cache_set($type, $memcache_data);
  60     }
  61     return $memcache_data;
  62 }
  63
  64 sub request_cache_set {
  65     my $class = shift;
  66     my $type = shift;
  67     my $val = shift;
  68
  69     $LJ::QotD::REQ_CACHE_QOTD{$type} = $val;
  70 }
  71
  72 sub cache_set {
  73     my $class = shift;
  74     my $type = shift;
  75     my $val = shift;
  76
  77     # first set in request cache
  78     $class->request_cache_set($type, $val);
  79
  80     # now set in memcache
  81     my $memkey = $class->memcache_key($type);
  82     my $expire = 60*5; # 5 minutes
  83     return LJ::MemCache::set($memkey, $val, $expire);
  84 }
  85
  86 sub cache_clear {
  87     my $class = shift;
  88     my $type = shift;
  89
  90     # clear request cache
  91     delete $LJ::QotD::REQ_CACHE_QOTD{$type};
  92
  93     # clear memcache
  94     my $memkey = $class->memcache_key($type);
  95     return LJ::MemCache::delete($memkey);
  96 }
  97
  98 # returns the current active questions
  99 sub load_current_questions {
 100     my $class = shift;
 101     my %opts = @_;
 102
 103     my $questions = $class->cache_get('current');
 104     return _sort_cur_questions(@$questions) if $questions;
 105
 106     my $dbh = LJ::get_db_writer()
 107         or die "no global database writer for QotD";
 108
 109     my $sth = $dbh->prepare(
 110         "SELECT * FROM qotd WHERE time_start <= UNIX_TIMESTAMP() AND time_end >= UNIX_TIMESTAMP() AND active='Y' ORDER BY time_start desc"
 111     );
 112     $sth->execute;
 113
 114     my @rows = ();
 115     while (my $row = $sth->fetchrow_hashref) {
 116         push @rows, $row;
 117     }
 118
 119     @rows = _sort_cur_questions(@rows);
 120     $class->cache_set('current', \@rows);
 121
 122     return @rows;
 123 }
 124
 125 # returns the non-current active questions that
 126 # have an end time more recent than a month ago
 127 sub load_old_questions {
 128     my $class = shift;
 129     my %opts = @_;
 130
 131     my $questions = $class->cache_get('old');
 132     return _sort_old_questions(@$questions) if $questions;
 133
 134     my $dbh = LJ::get_db_writer()
 135         or die "no global database writer for QotD";
 136
 137     my $sth = $dbh->prepare(
 138         "SELECT * FROM qotd WHERE time_end >= UNIX_TIMESTAMP()-86400*31 AND time_end < UNIX_TIMESTAMP() AND active='Y' ORDER BY time_end desc"
 139     );
 140     $sth->execute;
 141
 142     my @rows = ();
 143     while (my $row = $sth->fetchrow_hashref) {
 144         push @rows, $row;
 145     }
 146
 147     @rows = _sort_old_questions(@rows);
 148     $class->cache_set('old', \@rows);
 149
 150     return @rows;
 151 }
 152
 153
 154 sub _sort_cur_questions {
 155     my @questions = @_;
 156     # sponsored should be first
 157     @questions =
 158         map  { delete $_->{is_special_num}; $_ }                             # remove 'is_special_num' member
 159         sort { $b->{is_special_num} <=> $a->{is_special_num} }               # sort by is_special_num
 160         map  { $_->{is_special_num} = $_->{is_special} eq 'Y' ? 1 : 0; $_  } # is_special as num
 161         @questions;
 162     return @questions;
 163 }
 164
 165 sub _sort_old_questions {
 166     my @questions = @_;
 167     # sort questions by end day then by 'is_special' flag
 168     @questions =
 169         map  {
 170                 # remove temporary fields
 171                 delete $_->{day_end};
 172                 delete $_->{is_special_num};
 173
 174                 # mark this question loaded as 'old'
 175                 $_->{old} = 1;
 176
 177                 $_;
 178                 }
 179         sort {
 180                 $b->{day_end} <=> $a->{day_end}                  # first by day
 181                 || $b->{is_special_num} <=> $a->{is_special_num} # then sponsored first
 182              }
 183         map  { $_->{is_special_num} = $_->{is_special} eq 'Y' ? 1 : 0; $_  } # is_special as num
 184         map  { $_->{day_end} = int $_->{time_end} / 86400; $_ } # add DAY of question
 185         @questions;
 186
 187     return @questions;
 188 }
 189
 190 sub filter_by_domain {
 191     my $class = shift;
 192     my $u = shift;
 193     my $domain = shift;
 194     my @questions = @_;
 195
 196     my @questions_ret;
 197     foreach my $q (@questions) {
 198         push @questions_ret, $q if $q->{domain} eq $domain;
 199     }
 200
 201     return @questions_ret;
 202 }
 203
 204 sub filter_by_eff_class {
 205     my $class = shift;
 206     my $u = shift;
 207     my @questions = @_;
 208
 209     my $eff_class = LJ::run_hook("qotd_get_eff_class", $u);
 210     return @questions unless $eff_class;
 211
 212     my @questions_ret;
 213     if ($eff_class eq "logged_out") {
 214         foreach my $q (@questions) {
 215             push @questions_ret, $q if $q->{show_logged_out} eq "Y";
 216         }
 217     } else {
 218         my @classes = ( $eff_class );
 219         my $class_mask = LJ::mask_from_classes(@classes);
 220         foreach my $q (@questions) {
 221             push @questions_ret, $q if ($q->{cap_mask} & $class_mask) > 0;
 222         }
 223     }
 224
 225     return @questions_ret;
 226 }
 227
 228 sub filter_by_country {
 229     my $class = shift;
 230     my $u = shift;
 231     my @questions = @_;
 232
 233     # split the list into a list of questions with countries and a list of questions without countries
 234     my @questions_with_countries;
 235     my @questions_without_countries;
 236     foreach my $question (@questions) {
 237         if ($question->{countries}) {
 238             push @questions_with_countries, $question;
 239         } else {
 240             push @questions_without_countries, $question;
 241         }
 242     }
 243
 244     # get the user's country if defined, otherwise the country of the remote IP
 245     my $country;
 246     $country = lc $u->country if $u;
 247     $country = lc LJ::country_of_remote_ip() unless $country;
 248
 249     my @questions_ret;
 250
 251     # get the questions that are targeted at the user's country
 252     if ($country) {
 253         foreach my $question (@questions_with_countries) {
 254             next unless grep { $_ eq $country } split(",", $question->{countries});
 255             push @questions_ret, $question;
 256         }
 257     }
 258
 259     return (@questions_ret, @questions_without_countries);
 260 }
 261
 262 sub get_questions {
 263     my $class = shift;
 264     my %opts = @_;
 265
 266     my $skip   = defined $opts{skip} ? int($opts{skip}) : 0;
 267     my $domain = defined $opts{domain} ? lc $opts{domain} : "homepage";
 268
 269     # if true, get all questions for this user from the last month
 270     # overrides value of $skip
 271     my $all = defined $opts{all} ? $opts{all} : 0;
 272
 273     # direct the questions at the given $u, or remote if no $u given
 274     my $u = $opts{user} && LJ::isu($opts{user}) ? $opts{user} : LJ::get_remote();
 275
 276     my @questions = ( $class->load_current_questions, $class->load_old_questions );
 277
 278     @questions = $class->filter_by_domain($u, $domain, @questions) unless $all;
 279     @questions = $class->filter_by_eff_class($u, @questions);
 280     @questions = $class->filter_by_country($u, @questions);
 281
 282     @questions = grep { ref $_ } @questions;
 283
 284     # resort questions
 285     my @cur = grep { not $_->{old} } @questions;
 286     my @old = grep { $_->{old}     } @questions;
 287     @questions = (_sort_cur_questions(@cur), _sort_old_questions(@old));
 288
 289     # just amount of suitable questions in queue
 290     return scalar @questions if $opts{count};
 291
 292     return @questions if $all or $opts{all_filtered}; #
 293
 294     # is there any question?
 295     return unless @questions;
 296
 297     # just one question...
 298     my $index = $skip > 0 ? $skip - 1 : 0;
 299     return $questions[$index];
 300
 301 }
 302
 303 sub store_question {
 304     my $class = shift;
 305     my %vals = @_;
 306
 307     my $dbh = LJ::get_db_writer()
 308         or die "Unable to store question: no global dbh";
 309
 310     my @classes = split(/\s*,\s*/, $vals{classes});
 311     $vals{cap_mask} = LJ::mask_from_classes(@classes);
 312     $vals{show_logged_out} = $vals{show_logged_out} ? 'Y' : 'N';
 313
 314     # update existing question
 315     if ($vals{qid}) {
 316         $dbh->do("UPDATE qotd SET time_start=?, time_end=?, active=?, subject=?, text=?, tags=?, " .
 317                  "from_user=?, img_url=?, extra_text=?, cap_mask=?, show_logged_out=?, countries=?, link_url=?, domain=?, impression_url=?, is_special=? WHERE qid=?",
 318                  undef, (map { $vals{$_} } qw(time_start time_end active subject text tags from_user img_url extra_text cap_mask show_logged_out countries link_url domain impression_url is_special qid)))
 319             or die "Error updating qotd: " . $dbh->errstr;
 320     }
 321     # insert new question
 322     else {
 323         $dbh->do("INSERT INTO qotd VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)",
 324                  undef, "null", (map { $vals{$_} } qw(time_start time_end active subject text tags from_user img_url extra_text cap_mask show_logged_out countries link_url domain impression_url is_special)))
 325             or die "Error adding qotd: " . $dbh->errstr;
 326     }
 327
 328     # insert/update question subject and text in translation system
 329     my $qid = $vals{qid} || $dbh->{mysql_insertid};
 330     my $ml_key = LJ::Widget::QotD->ml_key("$qid.text");
 331     LJ::Widget->ml_set_text($ml_key => $vals{text});
 332     $ml_key = LJ::Widget::QotD->ml_key("$qid.subject");
 333     LJ::Widget->ml_set_text($ml_key => $vals{subject});
 334
 335     # insert/update extra text in translation system
 336     $ml_key = LJ::Widget::QotD->ml_key("$qid.extra_text");
 337     if ($vals{extra_text}) {
 338         LJ::Widget->ml_set_text($ml_key => $vals{extra_text});
 339     } else {
 340         my $string = LJ::no_ml_cache(sub { LJ::Widget->ml($ml_key) });
 341         LJ::Widget->ml_remove_text($ml_key) unless LJ::Widget->ml_is_missing_string($string);
 342     }
 343
 344     # clear cache
 345     my $type = $class->get_type( start => $vals{time_start}, end => $vals{time_end} );
 346     $class->cache_clear($type);
 347
 348     return $qid;
 349 }
 350
 351 # returns all questions that started during the given month
 352 sub get_all_questions_starting_during_month {
 353     my $class = shift;
 354     my ($year, $month) = @_;
 355
 356     my $dbh = LJ::get_db_writer()
 357         or die "Error: no global dbh";
 358
 359     my $time_start = DateTime->new( year => $year, month => $month, time_zone => 'America/Los_Angeles' );
 360     my $time_end = $time_start->clone;
 361     $time_end = $time_end->add( months => 1 );
 362     $time_end = $time_end->subtract( seconds => 1 ); # we want time_end to be the end of the last day of the month
 363
 364     my $sth = $dbh->prepare("SELECT * FROM qotd WHERE time_start >= ? AND time_start <= ?");
 365     $sth->execute($time_start->epoch, $time_end->epoch)
 366         or die "Error getting this month's questions: " . $dbh->errstr;
 367
 368     my @rows = ();
 369     while (my $row = $sth->fetchrow_hashref) {
 370         push @rows, $row;
 371     }
 372
 373     # sort questions in descending order by start time (newest first)
 374     @rows =
 375         sort { $b->{time_start} <=> $a->{time_start} }
 376         grep { ref $_ } @rows;
 377
 378     return @rows;
 379 }
 380
 381 # returns all questions that are running during the given month
 382 sub get_all_questions_running_during_month {
 383     my $class = shift;
 384     my ($year, $month) = @_;
 385
 386     my $dbh = LJ::get_db_writer()
 387         or die "Error: no global dbh";
 388
 389     my $time_start = DateTime->new( year => $year, month => $month, time_zone => 'America/Los_Angeles' );
 390     my $time_end = $time_start->clone;
 391     $time_end = $time_end->add( months => 1 );
 392     $time_end = $time_end->subtract( seconds => 1 ); # we want time_end to be the end of the last day of the month
 393
 394     my $time_start_epoch = $time_start->epoch;
 395     my $time_end_epoch = $time_end->epoch;
 396
 397     my $sth = $dbh->prepare(
 398         "SELECT * FROM qotd WHERE " .
 399         # starts before the start of the month and ends after the start of the month
 400         "(time_start <= ? AND time_end >= ?) OR " .
 401         # starts before the end of the month and ends after the end of the month
 402         "(time_start <= ? AND time_end >= ?) OR " .
 403         # starts after the start of the month and ends before the end of the month
 404         "(time_start >= ? AND time_end <= ?) OR " .
 405         # starts before the start of the month and ends after the end of the month
 406         "(time_start <= ? AND time_end >= ?)"
 407     );
 408     $sth->execute(
 409         $time_start_epoch, $time_start_epoch, $time_end_epoch, $time_end_epoch, $time_start_epoch, $time_end_epoch, $time_start_epoch, $time_end_epoch
 410     )
 411         or die "Error getting this month's questions: " . $dbh->errstr;
 412
 413     my @rows = ();
 414     while (my $row = $sth->fetchrow_hashref) {
 415         push @rows, $row;
 416     }
 417
 418     # sort questions in descending order by start time (newest first)
 419     @rows =
 420         sort { $b->{time_start} <=> $a->{time_start} }
 421         grep { ref $_ } @rows;
 422
 423     return @rows;
 424 }
 425
 426 # given an id for a question, returns the info for it
 427 sub get_single_question {
 428     my $class = shift;
 429     my $qid = shift;
 430
 431     my $dbh = LJ::get_db_writer()
 432         or die "Error: no global dbh";
 433
 434    my $sth = $dbh->prepare("SELECT * FROM qotd WHERE qid = ?");
 435     $sth->execute($qid)
 436         or die "Error getting single question: " . $dbh->errstr;
 437
 438     return $sth->fetchrow_hashref;
 439 }
 440
 441 # change the active status of the given question
 442 sub change_active_status {
 443     my $class = shift;
 444     my $qid = shift;
 445
 446     my %opts = @_;
 447     my $to = delete $opts{to};
 448     croak "invalid 'to' field" unless $to =~ /^(active|inactive)$/;
 449
 450     my $question = $class->get_single_question($qid)
 451         or die "Invalid question: $qid";
 452
 453     my $dbh = LJ::get_db_writer()
 454         or die "Error: no global dbh";
 455
 456     my $active_val = $to eq 'active' ? 'Y' : 'N';
 457     my $rv = $dbh->do("UPDATE qotd SET active = ? WHERE qid = ?", undef, $active_val, $qid)
 458         or die "Error updating active status of question: " . $dbh->errstr;
 459
 460     my $type = $class->get_type( start => $question->{time_start}, end => $question->{time_end} );
 461     $class->cache_clear($type);
 462
 463     return $rv;
 464 }
 465
 466 # given a comma-separated list of tags, remove the default tag(s) from the list
 467 sub remove_default_tags {
 468     my $class = shift;
 469     my $tag_list = shift;
 470
 471     my $tag = $class->entry_tag;
 472     $tag_list =~ s/\s*${tag},?\s*//g;
 473
 474     return $tag_list;
 475 }
 476
 477 # given a comma-separated list of tags, add the default tag(s) to the list
 478 sub add_default_tags {
 479     my $class = shift;
 480     my $tag_list = shift;
 481
 482     my $tag = $class->entry_tag;
 483
 484     if ($tag_list) {
 485         return "$tag, " . $tag_list;
 486     } else {
 487         return $tag;
 488     }
 489 }
 490
 491 # tag given to QotD entries
 492 sub entry_tag { "writer's block" }
 493
 494 # parse the given URL
 495 # * replace '[[uniq]]' with a unique identifier
 496 sub parse_url {
 497     my $class = shift;
 498     my %opts = @_;
 499
 500     my $qid = $opts{qid};
 501     my $url = $opts{url};
 502
 503     my $uniq = LJ::pageview_unique_string() . $qid;
 504     $uniq = Digest::SHA1::sha1_hex($uniq);
 505
 506     $url =~ s/\[\[uniq\]\]/$uniq/g;
 507
 508     return $url;
 509 }
 510
 511 sub get_count {
 512     my $calss = shift;
 513     my $qid   = shift;
 514
 515     return undef unless $qid;
 516
 517     my $qlength = LJ::MemCache::get("qotd_count:$qid");
 518     return $qlength if defined $qlength;
 519
 520     my $queue = LJ::queue("latest_qotd_$qid");
 521     if ($queue) {
 522         $qlength = $queue->length;
 523         LJ::MemCache::set("qotd_count:$qid", $qlength);
 524         return $qlength;
 525     }
 526
 527     return undef;
 528 }
 529
 530
 531 sub question_info {
 532     my $class    = shift;
 533     my $question = shift;
 534     my $u        = shift;
 535     my $domain   = shift;
 536
 537     # Get some additinal info to draw controlls
 538     my @all_questions =
 539         map {
 540             # for OLD questions we should display the end day as day of question
 541             # for CURRENT questions we display today as day of questsion.
 542             $_->{day} = $_->{old}
 543                 ? int ($_->{time_end} / 86400)
 544                 : int (time / 86400);
 545             #
 546             $_;
 547         }
 548         $class->get_questions( user => $u, all_filtered => 1, domain => $domain );
 549
 550     $question->{day} = $question->{old}
 551                             ? int ($question->{time_end} / 86400)
 552                             : int (time / 86400);
 553
 554     my @total_this_day =
 555         grep { $_->{day} eq $question->{day} }
 556         @all_questions;
 557
 558     my $total = scalar @total_this_day;
 559
 560     # number of current question in this day questions
 561     my $num = 0;
 562     my @ar = @total_this_day;
 563     while (my $q = shift @ar){
 564         $num ++;
 565         last if $q->{qid} eq $question->{qid};
 566     }
 567
 568     # date
 569     my ($day, $month_num) = (gmtime( $question->{day} * 86400 + 1))[3, 4];
 570     my $month_short = LJ::Lang::month_short($month_num + 1);
 571
 572     return ($month_short, $day, $num, $total);
 573
 574 }
 575
 576
 577
 578 1;