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