Annotation of db/prgsrc/db.cgi, revision 1.22
1.22 ! roma7 1: #!/usr/local/bin/perl -w
1.1 boris 2:
3: use DBI;
4: use CGI ':all';
1.15 roma7 5: use Text::Query;
1.1 boris 6: use strict;
7: use Time::Local;
8: use POSIX qw(locale_h);
1.22 ! roma7 9: use locale;
! 10: open STDERR, ">errors";
! 11: my $printqueries=1;
! 12: my %fieldname= (0,'Question', 1, 'Answer', 2, 'Comments');
! 13: my %searchin;
! 14:
! 15:
! 16:
! 17: my $thislocale;
! 18:
! 19:
! 20: $searchin{'question'}=param('question');
! 21: $searchin{'answer'}=param('answer');
! 22: $searchin{'comment'}=param('comment');
! 23: my $all=param('all');
! 24: $all=0 if lc $all eq 'no';
1.1 boris 25: my ($PWD) = `pwd`;
26: chomp $PWD;
1.3 boris 27: my ($SRCPATH) = "$PWD/../dimrub/src";
1.8 boris 28: my ($ZIP) = "/home/piataev/bin/zip";
1.11 boris 29: my $DUMPFILE = "/tmp/chgkdump";
1.1 boris 30: my ($SENDMAIL) = "/usr/sbin/sendmail";
31: my ($TMSECS) = 30*24*60*60;
32: my (%RevMonths) =
33: ('Jan', '0', 'Feb', '1', 'Mar', '2', 'Apr', '3', 'May', '4', 'Jun', '5',
34: 'Jul', '6', 'Aug', '7', 'Sep', '8', 'Oct', '9', 'Nov', '10',
1.3 boris 35: 'Dec', '11',
36: 'Янв', '0', 'Фев', 1, 'Мар', 2, 'Апр', 3, 'Май', '4',
37: 'Июн', '5', 'Июл', 6, 'Авг', '7', 'Сен', '8',
38: 'Окт', '9', 'Ноя', '19', 'Дек', '11');
1.1 boris 39:
40: # Determine whether the given time is within 2 months from now.
41: sub NewEnough {
42: my ($a) = @_;
43: my ($year, $month, $day) = split('-', $a);
44:
45: return (time - timelocal(0, 0, 0, $day, $month -1, $year) < $TMSECS);
46: }
47:
48: # Reads one question from the DB. Gets DB handler and Question ID.
49: sub GetTournament {
50: my ($dbh, $Id) = @_;
51: my (%Tournament, $field, @arr);
52:
53: return %Tournament if ($Id == 0);
54:
55: my ($sth) = $dbh->prepare("SELECT * FROM Tournaments WHERE Id=$Id");
56: $sth->execute;
57:
58: @arr = $sth->fetchrow;
59: my($i, $name) = 0;
60: foreach $name (@{$sth->{NAME}}) {
61: $Tournament{$name} = $arr[$i++];
62: }
63:
64: return %Tournament;
65: }
66:
67: # Reads one question from the DB. Gets DB handler and Question ID.
68: sub GetQuestion {
69: my ($dbh, $QuestionId) = @_;
70: my (%Question, $field, @arr);
71:
72: my($sth) = $dbh->prepare("
73: SELECT * FROM Questions WHERE QuestionId=$QuestionId
74: ");
75:
76: $sth->execute;
77:
78: @arr = $sth->fetchrow;
79: my($i, $name) = 0;
80: foreach $name (@{$sth->{NAME}}) {
81: $Question{$name} = $arr[$i++];
82: }
83:
84: return %Question;
85: }
86:
87: # Gets numbers of all the questions from the given tour.
88: sub GetTourQuestions {
89: my ($dbh, $ParentId) = @_;
90: my (@arr, @Questions);
91:
92: my ($sth) = $dbh->prepare("SELECT QuestionId FROM Questions
93: WHERE ParentId=$ParentId ORDER BY QuestionId");
94:
95: $sth->execute;
96:
97: while (@arr = $sth->fetchrow) {
98: push @Questions, $arr[0];
99: }
100:
101: return @Questions;
102: }
103:
104: # Returns list of children of the given tournament.
105: sub GetTours {
106: my ($dbh, $ParentId) = @_;
107: my (@arr, @Tours);
108:
109: my ($sth) = $dbh->prepare("SELECT Id FROM Tournaments
110: WHERE ParentId=$ParentId ORDER BY Id");
111:
112: $sth->execute;
113:
114: while (@arr = $sth->fetchrow) {
115: push @Tours, $arr[0];
116: }
117:
118: return @Tours;
119: }
120:
1.22 ! roma7 121: sub russearch {
! 122: my ($dbh, $sstr, $all,$allnf)=@_;
! 123: my (@qw,@w,@tasks,$qw,@arr,$nf,$sth,@nf,$w,$where,$e,@where,%good,$i,%where,$from);
! 124: my($number,@good,$t,$task,@rho,$rank,%rank,$r2,$r1,$word,$n,@last,$good,@words,%number,$taskid);
! 125: my ($hi, $lo, $wordnumber,$query,$blob,$field,$sf,$ii);
! 126: my @frequence;
! 127: my (@arr1,@ar,@sf,@arr2);
! 128: my %tasks;
! 129: my $tasks;
! 130: my @verybad;
! 131: my %nf;
! 132: my %tasksof;
! 133: my %wordsof;
! 134: my %relevance;
! 135: my @blob;
! 136: my %count;
! 137:
! 138: $sstr=~tr/йцукенгшщзхъфывапролджэячсмитьбю/ЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ/;
! 139: @qw=@w =split (' ', uc $sstr);
! 140:
! 141: #-----------
! 142: foreach $i (0..$#w) # заполняем массив @nf начальных форм
! 143: # $nf[$i] -- ссылка на массив возможных
! 144: # начальных форм словоформы $i
! 145: {
! 146: $qw= $dbh->quote (uc $w[$i]);
! 147: $query=" select distinct w2 from nests
! 148: where w1=$qw";
! 149: print "$query",br if $printqueries;
! 150: $sth=$dbh -> prepare($query);
! 151: $sth -> execute;
! 152: @{$nf[$i]}=();
! 153: while (@arr = $sth->fetchrow)
! 154: {
! 155: push (@{$nf[$i]},$arr[0])
! 156: }
! 157: }
! 158:
! 159: my @bad=grep {!$nf[$_]} 0..$#w; # @bad -- номера словоформ,
! 160: # которых нет в словаре
! 161:
! 162: if (@bad) #есть неопознанные словоформы
! 163: {
! 164: require "cw.pl";
! 165: foreach $i(@bad)
! 166: {
! 167: if (@arr=checkword($dbh,$w[$i]))
! 168: {push (@{$nf[$i]}, @arr);}
! 169: else
! 170: {push (@verybad,$i);}
! 171: }
! 172: }
! 173: return () if ($all && @verybad);
! 174:
! 175: my $kvo=0;
! 176: push @$allnf, @{$_} foreach @nf;
! 177:
! 178: foreach $i (0..$#w) #запросы в базу...
! 179: {
! 180: @arr=@{$nf[$i]} if $nf[$i];
! 181: @arr2=@arr1=@arr;
! 182:
! 183:
! 184:
! 185:
! 186: $_= " word2question.word=".$_. ' ' foreach @arr;
! 187: $_= " nf.id=".$_. ' ' foreach @arr1;
! 188:
! 189: # $_= " nests.w2=".$_. ' ' foreach @arr2;
! 190: # $query="select w1 from nests where". (join ' OR ', @arr2);
! 191: #print $query if $printqueries;
! 192: # $sth=$dbh -> prepare($query);
! 193: # $sth->execute;
! 194: # while (@ar=$sth->fetchrow)
! 195: # {
! 196: # $ar[0]=~s/(.)/&nocase($1)/ge;
! 197: # push(@sf,'(?:'.$ar[0].')');
! 198: # }
! 199: # $selectshablon=join '|',@sf;
! 200:
! 201: #print $selectshablon,br if $printqueries;
! 202:
! 203: # $selectshablon=qr/$selectshablon/i;
! 204:
! 205:
! 206:
! 207:
! 208: $query="select questions from word2question where". (join ' OR ', @arr);
! 209: print "$query\n",br if $printqueries;
! 210:
! 211: $sth=$dbh -> prepare($query);
! 212: $sth->execute;
! 213:
! 214: @blob=();
! 215: while (@arr=$sth->fetchrow)
! 216: {
! 217: @blob=(@blob,unpack 'C*',$arr[0]);
! 218: }
! 219: print "blob=@blob";
! 220: $query="select number from nf where ".(join ' OR ', @arr1);
! 221: print "$query\n",br if $printqueries;
! 222: $sth=$dbh -> prepare($query);
! 223: $sth->execute;
! 224:
! 225: while (@arr=$sth->fetchrow)
! 226: {
! 227: $frequence[$i]+=$arr[0];
! 228: }
! 229:
! 230:
! 231:
! 232:
! 233: if (@blob < 4)
! 234: {
! 235: $tasksof{$i}=undef;
! 236: } else
! 237: {
! 238: $kvo++;
! 239: $ii=0;
! 240: while ($ii<$#blob) # создаём хэш %tasksof, ключи которого --
! 241: # номера искомых словоформ, а значения --
! 242: # списки вопросов, в которых есть соответствующа
! 243: # словоформа.
! 244: # Каждый список в свою очередь также оформлен в
! 245: # виде хэша, ключи которого -- номера вопросов,
! 246: # а значения -- списки номеров вхождений. Вот.
! 247: {
! 248: ($field,$hi,$lo,$wordnumber)=@blob[$ii..($ii+3)];
! 249: $ii+=4;
! 250: $number=$lo+$hi*256;
! 251: print "f1=$field\n";
! 252: $field=$fieldname{$field};
! 253: print "f2=$field\n";
! 254: if ($searchin{lc $field})
! 255: {
! 256:
! 257: push @{$tasksof{$i}{$number}}, $wordnumber;
! 258: # дополнили в хэше, висящем на
! 259: # словоформе $i в %tasksof список
! 260: # вхождений $i в вопрос $number.
! 261: push @{$wordsof{$number}{$i}}, $wordnumber;
! 262: # дополнили в хэше, висящем на
! 263: # вопросе $number в %wordsof список
! 264: # вхождений $i в вопрос $number.
! 265:
! 266:
! 267: }
! 268: } #while ($ii<$#blob)
! 269: }
! 270: } #foreach $i
! 271:
! 272: print "keys tasksof", keys %tasksof;
! 273: #Ищем пересечение или объединение списков вопросов (значений %tasksof)
! 274: foreach $sf (keys %tasksof)
! 275: {
! 276: $count{$_}++ foreach keys %{$tasksof{$sf}};
! 277: }
! 278: @tasks= ($all ? (grep {$count{$_}==$kvo} keys %count) :
! 279: keys %count) ;
! 280:
! 281:
! 282: #print "\n\$#tasks=",$#tasks,br;
! 283: ############ Сортировка найденных вопросов
! 284:
! 285: foreach (keys %wordsof)
! 286: {
! 287: $relevance{$_}=&relevance($#w,$wordsof{$_},\@frequence) if $_
! 288: }
! 289:
! 290: @tasks=sort {$relevance{$b}<=>$relevance{$a}} @tasks;
! 291:
! 292:
! 293: ############
! 294:
! 295: print "tasks=@tasks";
! 296:
! 297: #print "$_ $relevance{$_} | " foreach @tasks;
! 298: #print br;
! 299: print "allnf=@$allnf",br if $printqueries;
! 300: return @tasks;
! 301: }
! 302:
! 303:
! 304: sub distance {
! 305: # на входе -- номера словоформ и ссылки на
! 306: # списки вхождений. На выходе -- расстояние,
! 307: # вычисляемое по формуле min(|b-a-pb+pa|)
! 308: # pb,pa
! 309: # (pb и pa -- позиции слов b и a)
! 310: my ($a,$b,$lista,$listb)=@_;
! 311: my ($pa,$pb,$min,$curmin);
! 312: $min=10000;
! 313: foreach $pa (@$lista)
! 314: {
! 315: foreach $pb (@$listb)
! 316: {
! 317: $curmin=abs($b-$a-$pb+$pa);
! 318: $min= $curmin if $curmin<$min;
! 319: }
! 320: }
! 321: return $min;
! 322:
! 323: }
! 324:
! 325: sub relevance {
! 326: # На входе -- количество искомых словоформ -1 и
! 327: # ссылка на hash, ключи которого --
! 328: # номера словоформ, а значения -- списки вхождений
! 329:
! 330: my ($n,$words,$frequence)=@_;
! 331: my $relevance=0;
! 332: my ($first,$second,$d);
! 333: foreach $first (0..$n)
! 334: {
! 335: $relevance+=scalar @{$$words{$first}}+1000+1000/$$frequence[$first]
! 336: if $$words{$first};
! 337: foreach $second ($first+1..$n)
! 338: {
! 339: $d=&distance($first,$second,$$words{$first},$$words{$second});
! 340: $relevance+=($d>10?0:10-$d)*10;
! 341: }
! 342: }
! 343: return $relevance;
! 344: }
! 345:
! 346:
1.1 boris 347:
348: # Returns list of QuestionId's, that have the search string in them.
349: sub Search {
1.22 ! roma7 350: my ($dbh, $sstr,$metod,$all,$allnf) = @_;
1.1 boris 351: my (@arr, @Questions, @fields);
1.14 roma7 352: my (@sar, $i, $sth,$where);
1.1 boris 353:
1.6 boris 354: # push @fields, 'Question';
1.14 roma7 355:
1.22 ! roma7 356: if ($metod eq 'rus')
! 357: {
! 358: my @tasks=russearch($dbh,$sstr,$all,$allnf);
! 359: return @tasks
! 360: }
! 361:
! 362:
1.14 roma7 363: ###Simple and advanced query processing. Added by R7
364: if ($metod eq 'simple' || $metod eq 'advanced')
365: {
366: foreach (qw/Question Answer Sources Authors Comments/) {
367: if (param($_)) {
368: push @fields, $_;
369: }
370: }
371:
1.22 ! roma7 372:
1.14 roma7 373: @fields=(qw/Question Answer Sources Authors Comments/) unless scalar @fields;
374: my $fields=join ",", @fields;
375: my $q=new Text::Query($sstr,
376: -parse => 'Text::Query::'.
377: (($metod eq 'simple') ? 'ParseSimple':'ParseAdvanced'),
378: -solve => 'Text::Query::SolveSQL',
379: -build => 'Text::Query::BuildSQLMySQL',
380: -fields_searched => $fields);
381:
382: $where= $$q{'matchexp'};
383: my $query= "SELECT Questionid FROM Questions
384: WHERE $where";
1.22 ! roma7 385: print br."Query is: $query".br if $printqueries;
1.14 roma7 386:
387: $sth = $dbh->prepare($query);
388: } else
389: ######
390: {
391:
392:
393: foreach (qw/Question Answer Sources Authors Comments/) {
1.1 boris 394: if (param($_)) {
395: push @fields, "IFNULL($_, '')";
396: }
1.14 roma7 397: }
1.1 boris 398:
1.14 roma7 399: @sar = split " ", $sstr;
400: for $i (0 .. $#sar) {
1.1 boris 401: $sar[$i] = $dbh->quote("%${sar[$i]}%");
1.14 roma7 402: }
1.1 boris 403:
1.14 roma7 404: my($f) = "CONCAT(" . join(',', @fields) . ")";
405: if (param('all') eq 'yes') {
1.1 boris 406: $sstr = join " AND $f LIKE ", @sar;
1.14 roma7 407: } else {
1.1 boris 408: $sstr = join " OR $f LIKE ", @sar;
1.14 roma7 409: }
1.21 roma7 410:
1.22 ! roma7 411: my $query="SELECT QuestionId FROM Questions
! 412: WHERE $f LIKE $sstr ORDER BY QuestionId";
! 413: print $query if $printqueries;
! 414: $sth = $dbh->prepare($query)
1.1 boris 415:
1.14 roma7 416: } #else -- processing old-style query (R7)
417:
1.1 boris 418: $sth->execute;
419: while (@arr = $sth->fetchrow) {
420: push @Questions, $arr[0];
421: }
1.22 ! roma7 422:
1.1 boris 423: return @Questions;
424: }
425:
426: # Substitute every letter by a pair (for case insensitive search).
427: my (@letters) = qw/аА бБ вВ гГ дД еЕ жЖ зЗ иИ йЙ кК лЛ мМ нН оО
428: пП рР сС тТ уУ фФ хХ цЦ чЧ шШ щЩ ьЬ ыЫ эЭ юЮ яЯ/;
429:
430: sub NoCase {
431: my ($sstr) = shift;
432: my ($res);
433:
434: if (($res) = grep(/$sstr/, @letters)) {
435: return "[$res]";
436: } else {
437: return $sstr;
438: }
439: }
440:
441: sub PrintSearch {
1.14 roma7 442: my ($dbh, $sstr, $metod) = @_;
1.22 ! roma7 443: my @allnf;
! 444: my (@Questions) = &Search($dbh, $sstr,$metod,$all,\@allnf);
1.1 boris 445: my ($output, $i, $suffix, $hits) = ('', 0, '', $#Questions + 1);
446:
1.22 ! roma7 447: my $shablon;
! 448:
! 449:
! 450: if ($metod eq 'rus')
! 451: {
! 452: my $where='0';
! 453: $where.= " or w2=$_ " foreach @allnf;
! 454: my $query="select w1 from nests where $where";
! 455: my $sth=$dbh->prepare($query);
! 456: print "$query" if $printqueries;
! 457:
! 458: $sth->execute;
! 459: my @shablon;
! 460: while (my @arr = $sth->fetchrow)
! 461: {
! 462: push @shablon,"(?:$arr[0])";
! 463: }
! 464: $shablon= join "|", @shablon;
! 465: $shablon=~s/[её]/\[ЕЁ\]/gi;
! 466: # $shablon=~s/([йцукенгшщзхъфывапролджэячсмитьбюЙЦУКЕНГШЩЗХЪФЫВАПРОЛДЖЭЯЧСМИТЬБЮ])/&NoCase($1)/ge;
! 467: $shablon=qr/$shablon/i;
! 468: print "!$shablon!",br if $printqueries;
! 469: }
! 470:
! 471:
! 472:
1.1 boris 473: if ($hits =~ /1.$/ || $hits =~ /[5-90]$/) {
474: $suffix = 'й';
475: } elsif ($hits =~ /1$/) {
476: $suffix = 'е';
477: } else {
478: $suffix = 'я';
479: }
480:
481: print p({align=>"center"}, "Результаты поиска на " . strong($sstr)
482: . " : $hits попадани$suffix.");
483:
484: if (param('word')) {
485: $sstr = '[ \.\,:;]' . $sstr . '[ \.\,:\;]';
486: }
487:
488: $sstr =~ s/(.)/&NoCase($1)/ge;
489:
1.13 roma7 490: my(@sar) = split(' ', $sstr);
1.1 boris 491: for ($i = 0; $i <= $#Questions; $i++) {
492: $output = &PrintQuestion($dbh, $Questions[$i], 1, $i + 1, 1);
1.22 ! roma7 493: if (param('metod') eq 'rus')
! 494: {
! 495: $output=~s/\b($shablon)\b/\<strong\>$1\<\/strong\>/gi;
! 496: } else {
1.1 boris 497: foreach (@sar) {
498: $output =~ s/$_/<strong>$&<\/strong>/gs;
1.22 ! roma7 499: }}
1.1 boris 500: print $output;
501: }
502: }
503:
504: sub PrintRandom {
505: my ($dbh, $type, $num, $text) = @_;
506: my (@Questions) = &Get12Random($dbh, $type, $num);
507: my ($output, $i) = ('', 0);
508:
509: if ($text) {
510: $output .= " $num случайных вопросов.\n\n";
511: } else {
512: $output .=
513: h2({align=>"center"}, "$num случайных вопросов.");
514: }
515:
516: for ($i = 0; $i <= $#Questions; $i++) {
517: # Passing DB handler, question ID, print answer, question
518: # number, print title, print text/html
519: $output .=
520: &PrintQuestion($dbh, $Questions[$i], 1, $i + 1, 0, $text);
521: }
522: return $output;
523: }
524:
525: sub PrintTournament {
526: my ($dbh, $Id, $answer) = @_;
527: my (%Tournament, @Tours, $i, $list, $qnum, $imgsrc, $alt,
528: $SingleTour);
529: my ($output) = '';
530:
531: %Tournament = &GetTournament($dbh, $Id) if ($Id);
532:
533: my ($URL) = $Tournament{'URL'};
534: my ($Info) = $Tournament{'Info'};
535: my ($Copyright) = $Tournament{'Copyright'};
536:
537: @Tours = &GetTours($dbh, $Id);
538:
539: if ($Id) {
540: for ($Tournament{'Type'}) {
541: /Г/ && do {
542: $output .= h2({align=>"center"},
1.6 boris 543: "Группа: $Tournament{'Title'} ",
544: "$Tournament{'PlayedAt'}") . p . "\n";
1.1 boris 545: last;
546: };
547: /Ч/ && do {
548: return &PrintTour($dbh, $Tours[0], $answer)
549: if ($#Tours == 0);
1.6 boris 550:
551: my $title="Пакет: $Tournament{'Title'}";
552: if ($Tournament{'PlayedAt'}) {
553: $title .= " $Tournament{'PlayedAt'}";
554: }
1.1 boris 555:
556: $output .= h2({align=>"center"},
1.6 boris 557: "$title") . p . "\n";
1.1 boris 558: last;
559: };
560: /Т/ && do {
561: return &PrintTour($dbh, $Id, $answer);
562: };
563: }
564: } else {
565: my ($qnum) = GetQNum($dbh);
566: $output .= h2("Банк Вопросов: $qnum вопросов") . p . "\n";
567: }
568:
569: for ($i = 0; $i <= $#Tours; $i++) {
570: %Tournament = &GetTournament($dbh, $Tours[$i]);
571:
572: if ($Tournament{'Type'} =~ /Ч/) {
573: $SingleTour = 0;
574: my (@Tours) = &GetTours($dbh, $Tournament{'Id'});
575: $SingleTour = 1
576: if ($#Tours == 0);
577: }
578: if ($Tournament{'QuestionsNum'} > 0) {
579: $qnum = " ($Tournament{'QuestionsNum'} вопрос" .
580: &Suffix($Tournament{'QuestionsNum'}) . ")\n";
581: } else {
582: $qnum = '';
583: }
584: if ($Tournament{'Type'} =~ /Г/) {
585: $imgsrc = "/icons/folder.gif";
586: $alt = "[*]";
587: } else {
588: $imgsrc = "/icons/folder.gif";
589: $alt = "[-]";
590: }
591:
592: if ($SingleTour or $Tournament{'Type'} =~ /Т/) {
593: $list .= dd(img({src=>$imgsrc, alt=>$alt})
1.6 boris 594: . " " . $Tournament{'Title'} . " " .
595: $Tournament{'PlayedAt'} . $qnum) .
1.1 boris 596: dl(
597: dd("["
598: . a({href=>url . "?tour=$Tournament{'Id'}&answer=0"},
599: "вопросы") . "] ["
600: . a({href=>url . "?tour=$Tournament{'Id'}&answer=1"},
601: "вопросы + ответы") . "]")
602: );
603: } else {
604: $list .= dd(a({href=>url . "?tour=$Tournament{'Id'}&comp=1"},
605: img({src=>'/icons/compressed.gif', alt=>'[ZIP]', border=>1}))
606: . " " . img({src=>$imgsrc, alt=>$alt})
607: . " " . a({href=>url . "?tour=$Tournament{'Id'}&answer=0"},
1.6 boris 608: $Tournament{'Title'}. " ".
609: $Tournament{'PlayedAt'}) . $qnum);
1.1 boris 610: }
611: }
612: $output .= dl($list);
613:
614: if ($URL) {
615: $output .=
616: p("Дополнительная информация об этом турнире - по адресу " .
617: a({-'href'=>$URL}, $URL));
618: }
619:
620: if ($Copyright) {
621: $output .= p("Копирайт: " . $Copyright);
622: }
623:
624: if ($Info) {
625: $output .= p($Info);
626: }
627:
628: return $output;
629: }
630:
631: sub Suffix {
632: my ($qnum) = @_;
633: my ($suffix) = 'а' if $qnum =~ /[234]$/;
634: $suffix = '' if $qnum =~ /1$/;
635: $suffix = 'ов' if $qnum =~ /[567890]$/ || $qnum =~ /1.$/;
636: return $suffix;
637: }
638:
639: sub IsTour {
640: my ($dbh, $Id) = @_;
641: my ($sth) = $dbh->prepare("SELECT Type FROM Tournaments
642: WHERE Id=$Id");
643: $sth->execute;
644: return ($sth->fetchrow)[0] =~ /Т/;
645: }
646:
647: # Gets a DB handler (ofcourse) and a tour Id. Prints all the
648: # question of that tour, according to the options.
649: sub PrintTour {
650: my ($dbh, $Id, $answer) = @_;
651: my ($output, $q, $bottom, $field) = ('', 0, '', '');
652:
653: my (%Tour) = &GetTournament($dbh, $Id);
654: my (@Tours) = &GetTours($dbh, $Tour{'ParentId'});
655: my (%Tournament) = &GetTournament($dbh, $Tour{'ParentId'});
656:
657: return 0
658: if ($Tour{'Type'} !~ /Т/);
659:
660: my ($qnum) = $Tour{'QuestionsNum'};
661: my ($suffix) = &Suffix($qnum);
662:
1.4 boris 663: $output .= h2({align=>"center"}, $Tournament{"Title"},
1.6 boris 664: $Tournament{'PlayedAt'},
1.4 boris 665: "<br>", $Tour{"Title"} .
1.1 boris 666: " ($qnum вопрос$suffix)\n") . p;
667:
668: my (@Questions) = &GetTourQuestions($dbh, $Id);
669: for ($q = 0; $q <= $#Questions; $q++) {
670: $output .= &PrintQuestion($dbh, $Questions[$q], $answer, 0);
671: }
672:
673: $output .= hr({-'align'=>'center', -'width'=>'80%'});
674:
675: if ($Tournament{'URL'}) {
676: $output .=
677: p("Дополнительная информация об этом турнире - по адресу " .
678: a({-'href'=>$Tournament{'URL'}}, $Tournament{'URL'}));
679: }
680:
681: if ($Tournament{'Copyright'}) {
682: $output .= p("Копирайт: " . $Tournament{'Copyright'});
683: }
684:
685: if ($Tournament{'Info'}) {
686: $output .= p($Tournament{'Info'});
687: }
688:
689:
690: if ($answer == 0) {
691: $bottom .=
692: "[" . a({href=>url . "?tour=$Id&answer=1"}, "ответы") . "] " . br;
693: }
694: if (&IsTour($dbh, $Id - 1)) {
695: $bottom .=
696: "[" . a({href=>url . "?tour=" . ($Id - 1) . "&answer=0"},
697: "предыдущий тур") . "] ";
698: $bottom .=
699: "[" . a({href=>url . "?tour=" . ($Id - 1) . "&answer=1"},
700: "предыдущий тур с ответами") . "] " . br;
701: }
702: if (&IsTour($dbh, $Id + 1)) {
703: $bottom .=
704: "[" . a({href=>url . "?tour=" . ($Id + 1) . "&answer=0"},
705: "следующий тур") . "] ";
706: $bottom .=
707: "[" . a({href=>url . "?tour=" . ($Id + 1) . "&answer=1"},
708: "следующий тур с ответами") . "] ";
709: }
710:
711: $output .=
712: p({align=>"center"}, font({size=>-1}, $bottom));
713:
714: return $output;
715: }
716:
717: sub PrintField {
718: my ($header, $value, $text) = @_;
719: if ($text) {
1.5 boris 720: $value =~ s/<[\/\w]*>//sg;
721: } else {
722: $value =~ s/^\s+/<br> /mg;
723: $value =~ s/^\|([^\n]*)/<pre>$1<\/pre>/mg;
1.1 boris 724: }
725: return $text ? "$header:\n$value\n\n" :
726: strong("$header: ") . $value . p . "\n";
727: }
728:
729: # Gets a DB handler (ofcourse) and a question Id. Prints
730: # that question, according to the options.
731: sub PrintQuestion {
732: my ($dbh, $Id, $answer, $qnum, $title, $text) = @_;
733: my ($output, $titles) = ('', '');
734:
735: my (%Question) = &GetQuestion($dbh, $Id);
736: if (!$text) {
737: $output .= hr({width=>"50%"});
738: if ($title) {
739: my (%Tour) = GetTournament($dbh, $Question{'ParentId'});
740: my (%Tournament) = GetTournament($dbh, $Tour{'ParentId'});
741: $titles .=
742: dd(img({src=>"/icons/folder.open.gif"}) . " " .
1.6 boris 743: a({href=>url . "?tour=$Tournament{'Id'}"}, $Tournament{'Title'}, $Tournament{'PlayedAt'}));
1.1 boris 744: $titles .=
745: dl(dd(img({src=>"/icons/folder.open.gif"}) . " " .
746: a({href=>url . "?tour=$Tour{'Id'}"}, $Tour{'Title'})));
747: }
748: $output .= dl(strong($titles));
749: }
750:
751: $qnum = $Question{'Number'}
752: if ($qnum == 0);
753:
754: $output .=
755: &PrintField("Вопрос $qnum", $Question{'Question'}, $text);
756:
757: if ($answer) {
758: $output .=
759: &PrintField("Ответ", $Question{'Answer'}, $text);
760:
761: if ($Question{'Authors'}) {
762: $output .= &PrintField("Автор(ы)", $Question{'Authors'}, $text);
763: }
764:
765: if ($Question{'Sources'}) {
766: $output .= &PrintField("Источник(и)", $Question{'Sources'}, $text);
767: }
768:
769: if ($Question{'Comments'}) {
770: $output .= &PrintField("Комментарии", $Question{'Comments'}, $text);
771: }
772: }
773: return $output;
774: }
775:
776: # Returns the total number of questions currently in the DB.
777: sub GetQNum {
778: my ($dbh) = @_;
779: my ($sth) = $dbh->prepare("SELECT COUNT(*) FROM Questions");
780: $sth->execute;
781: return ($sth->fetchrow)[0];
782: }
1.12 boris 783: sub GetMaxQId {
784: my ($dbh) = @_;
785: my ($sth) = $dbh->prepare("SELECT MAX(QuestionId) FROM Questions");
786: $sth->execute;
787: return ($sth->fetchrow)[0];
788: }
1.1 boris 789:
790: # Returns Id's of 12 random questions
791: sub Get12Random {
792: my ($dbh, $type, $num) = @_;
793: my ($i, @questions, $q, $t, $sth);
1.12 boris 794: my ($qnum) = &GetMaxQId($dbh);
1.1 boris 795: my (%chosen);
796: srand;
797:
1.11 boris 798: for ($i = 0; $i < $num; $i++) {
799: do {
800: $q = int(rand($qnum));
801: $sth = $dbh->prepare("SELECT Type FROM Questions
1.1 boris 802: WHERE QuestionId=$q");
1.11 boris 803: $sth->execute;
804: $t = ($sth->fetchrow)[0];
805: } until !$chosen{$q} && $t && $type =~ /[$t]/;
806: $chosen{$q} = 'y';
807: push @questions, $q;
808: }
809: return @questions;
1.1 boris 810: }
811:
812: sub Include_virtual {
813: my ($fn, $output) = (@_, '');
814:
815: open F , $fn
1.2 boris 816: or return; #die "Can't open the file $fn: $!\n";
1.1 boris 817:
818: while (<F>) {
819: if (/<!--#include/o) {
820: s/<!--#include virtual="\/(.*)" -->/&Include_virtual($1)/e;
821: }
822: if (/<!--#exec/o) {
823: s/<!--#exec.*cmd\s*=\s*"([^"]*)".*-->/`$1`/e;
824: }
825: $output .= $_;
826: }
827: return $output;
828: }
829:
830: sub PrintArchive {
831: my($dbh, $Id) = @_;
832: my ($output, @list, $i);
833:
834: my (%Tournament) = &GetTournament($dbh, $Id);
835: my (@Tours) = &GetTours($dbh, $Id);
836:
837: if ($Tournament{'Type'} =~ /Г/ || $Id == 0) {
838: for ($i = 0; $i <= $#Tours; $i++) {
839: push(@list ,&PrintArchive($dbh, $Tours[$i]));
840: }
841: return @list;
842: }
843: return "$SRCPATH/$Tournament{'FileName'} ";
844: }
845:
846: sub PrintAll {
847: my ($dbh, $Id) = @_;
848: my ($output, $list, $i);
849:
850: my (%Tournament) = &GetTournament($dbh, $Id);
851: my (@Tours) = &GetTours($dbh, $Id);
852: my ($New) = ($Id and $Tournament{'Type'} eq 'Ч' and
853: &NewEnough($Tournament{"CreatedAt"})) ?
854: img({src=>"/znatoki/dimrub/db/new-sml.gif", alt=>"NEW!"}) : "";
855:
856: if ($Id == 0) {
857: $output = h3("Все турниры");
858: } else {
859: $output .= dd(img({src=>"/icons/folder.gif", alt=>"[*]"}) .
860: " " . a({href=>url . "?tour=$Tournament{'Id'}&answer=0"},
1.6 boris 861: $Tournament{'Title'}) ." " . $Tournament{'PlayedAt'} . " $New");
1.1 boris 862: }
863: if ($Id == 0 or $Tournament{'Type'} =~ /Г/) {
864: for ($i = 0; $i <= $#Tours; $i++) {
865: $list .= &PrintAll($dbh, $Tours[$i]);
866: }
867: $output .= dl($list);
868: }
869: return $output;
870: }
871:
872: sub PrintDates {
873: my ($dbh) = @_;
874: my ($from) = param('from_year') . "-" . param('from_month') .
875: "-" . param('from_day');
876: my ($to) = param('to_year') . "-" . param('to_month') . "-" . param('to_day');
877: $from = $dbh->quote($from);
878: $to = $dbh->quote($to);
879: my ($sth) = $dbh->prepare("
880: SELECT DISTINCT Id
881: FROM Tournaments
882: WHERE PlayedAt >= $from AND PlayedAt <= $to
883: AND Type = 'Ч'
884: ");
885: $sth->execute;
886: my (%Tournament, @array, $output, $list);
887:
888: $output = h3("Список турниров, проходивших между $from и $to.");
889: while (@array = $sth->fetchrow) {
890: next
891: if (!$array[0]);
892: %Tournament = &GetTournament($dbh, $array[0]);
893: $list .= dd(img({src=>"/icons/folder.gif", alt=>"[*]"}) .
894: " " . a({href=>url . "?tour=$Tournament{'Id'}&answer=0"},
1.6 boris 895: $Tournament{'Title'}, $Tournament{'PlayedAt'}));
1.1 boris 896: }
897: $output .= dl($list);
898: return $output;
899: }
900:
901: MAIN:
902: {
903: setlocale(LC_CTYPE,'russian');
904: my($i, $tour);
905: my($text) = (param('text')) ? 1 : 0;
906: my($dbh) = DBI->connect("DBI:mysql:chgk", "piataev", "")
907: or do {
908: print h1("Временные проблемы") . "База данных временно не
909: работает. Заходите попозже.";
910: print &Include_virtual("../dimrub/db/reklama.html");
911: print end_html;
912: die "Can't connect to DB chgk\n";
913: };
1.11 boris 914: if (!param('comp') and !param('sqldump') and !$text) {
1.1 boris 915: print header;
916: print start_html(-"title"=>'Database of the questions',
917: -author=>'dimrub@icomverse.com',
918: -bgcolor=>'#fff0e0',
919: -vlink=>'#800020');
920: print &Include_virtual("../dimrub/db/reklama.html");
921: }
1.22 ! roma7 922:
! 923: if ($^O =~ /win/i) {
! 924: $thislocale = "Russian_Russia.20866";
! 925: } else {
! 926: $thislocale = "ru_RU.KOI8-R";
! 927: }
! 928: POSIX::setlocale( &POSIX::LC_ALL, $thislocale );
! 929:
! 930: if ((uc 'а') ne 'А') {print "Koi8-r locale not installed!\n"};
! 931:
1.1 boris 932:
933: if ($text) {
934: print header('text/plain');
935: }
936:
937: if (param('rand')) {
1.7 boris 938: my ($type, $qnum) = ('', 12);
939: $type .= 'Б' if (param('brain'));
940: $type .= 'Ч' if (param('chgk'));
1.1 boris 941: $qnum = param('qnum') if (param('qnum') =~ /^\d+$/);
1.7 boris 942: $qnum = 0 if (!$type);
1.1 boris 943: if (param('email') && -x $SENDMAIL &&
944: open(F, "| $SENDMAIL -t -n")) {
945: my ($Email) = param('email');
946: my ($mime_type) = $text ? "plain" : "html";
947: print F <<EOT;
948: To: $Email
1.8 boris 949: From: olegstemanov\@mail.ru
1.1 boris 950: Subject: Sluchajnij Paket Voprosov "Chto? Gde? Kogda?"
951: MIME-Version: 1.0
952: Content-type: text/$mime_type; charset="koi8-r"
953:
954: EOT
955: print F &PrintRandom($dbh, $type, $qnum, $text);
956: close F;
957: print "Пакет случайно выбранных вопросов послан. Нажмите
958: на <B>Reload</B> для получения еще одного пакета";
959: } else {
960: print &PrintRandom($dbh, $type, $qnum, $text);
961: }
962: } elsif (param('sstr')) {
1.14 roma7 963: &PrintSearch($dbh, param('sstr'), param('metod'));
1.1 boris 964: } elsif (param('all')) {
965: print &PrintAll($dbh, 0);
966: } elsif (param('from_year') && param('to_year')) {
967: print &PrintDates($dbh);
968: } elsif (param('comp')) {
1.9 boris 969: print header(
970: -'Content-Type' => 'application/x-zip-compressed; name="db.zip"',
971: -'Content-Disposition' => 'attachment; filename="db.zip"'
972: );
973: $tour = (param('tour')) ? param('tour') : 0;
974: my (@files) = &PrintArchive($dbh, $tour);
975: open F, "$ZIP -j - $SRCPATH/COPYRIGHT @files |";
976: print (<F>);
977: close F;
978: $dbh->disconnect;
979: exit;
980: } elsif (param('sqldump')) {
981: print header(
982: -'Content-Type' => 'application/x-zip-compressed; name="dump.zip"',
983: -'Content-Disposition' => 'attachment; filename="dump.zip"'
984: );
1.10 boris 985: open F, "$ZIP -j - $DUMPFILE |";
1.9 boris 986: print (<F>);
987: close F;
988: $dbh->disconnect;
989: exit;
990:
1.1 boris 991: } else {
992: $tour = (param('tour')) ? param('tour') : 0;
993: if ($tour !~ /^[0-9]*$/) {
994: my ($sth) = $dbh->prepare("SELECT Id FROM Tournaments
995: WHERE FileName = '$tour.txt'");
996: $sth->execute;
997: $tour = ($sth->fetchrow)[0];
998: }
999: print &PrintTournament($dbh, $tour, param('answer'));
1000: }
1001: if (!$text) {
1002: print &Include_virtual("../dimrub/db/footer.html");
1003: print end_html;
1004: }
1005: $dbh->disconnect;
1006: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>