![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to db.cgi CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Local Repository] / db / prgsrc|
Return to db.cgi CVS log | Up to [Local Repository] / db / prgsrc |
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:
1.23 ! roma7 20: $searchin{'question'}=param('Question');
! 21: $searchin{'answer'}=param('Answer');
! 22: $searchin{'comment'}=param('Comment');
1.22 roma7 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: }