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