1: #!/usr/bin/perl
2:
3: =head1 NAME
4:
5: dbchgk.pm - модуль для работы с базой
6:
7: =head1 SYNOPSIS
8:
9: use chgkfiles.pm
10:
11: =head1 DESCRIPTION
12:
13: Работа с базой
14:
15:
16: =head1 AUTHOR
17:
18: Роман Семизаров
19: =cut
20:
21: package dbchgk;
22: use DBI;
23: use Exporter;
24: use vars qw(@ISA @EXPORT);
25: @ISA=qw(Exporter);
26:
27: @EXPORT = qw(&getbase &getquestions &closebase &getrow $z &in2out &getall &addnf &out2in &mydo
28: &getequalto &forbidden &getquestion &checktable &addword2task &addnest &getwordkeys &getflag &addword2task
29: &updateword2question &updatew2q &knownword &incnf &searchmark &knownnf &getnests
30: &packword &getnfnumbers &getword2question &addauthors) ;
31:
32: my $z;
33: my $qbase;
34: BEGIN {do "chgk.cnf";
35: $qbase = DBI -> connect ("DBI:mysql:$base",'piataev',undef);
36: $qbase->do("SET NAMES koi8r");
37: };
38:
39:
40:
41: sub searchmark
42: {
43: my $a=$_[0];
44: $qbase->do ("UPDATE Questions SET ProcessedBySearch=1 WHERE QuestionId=$a")
45: }
46:
47: sub knownword
48: {
49: my $a=$qbase ->quote (uc $_[0]);
50: my $select = "select distinct w2 from nests where w1=$a";
51: print "$select\n" if $debug;
52: my $z= $qbase -> prepare($select);
53: $z -> execute;
54: my @res;
55: while ( my @ar=$z -> fetchrow)
56: {
57: push (@res,$ar[0])
58: }
59: return @res;
60:
61: }
62:
63: sub knownnf
64: {
65: my $a=$qbase ->quote (uc $_[0]);
66: my $select = "select id from nf where word=$a";
67: print "$select\n" if $debug;
68: my $z= $qbase -> prepare($select);
69: $z -> execute;
70: my @ar=$z -> fetchrow;
71: return $ar[0];
72: }
73:
74: sub incnf
75: {
76: my $a=$_[0];
77: my $b=$_[1]||1;
78: $qbase -> do ("UPDATE nf SET number=number+$b WHERE id=$a")
79: }
80:
81: sub getbase
82: {
83: my $a=join(", ",@_);
84: my $select="select $a FROM Questions WHERE QuestionId<=$qnumber";
85: print "$select\n" if $debug;
86: $z= $qbase -> prepare($select);
87: $z -> execute;
88: }
89:
90: sub getquestions
91: {
92: my $cond=pop @_;
93: my $a=join(", ",@_);
94: my $select="select $a FROM Questions WHERE QuestionId<=$qnumber AND ($cond)";
95: print "$select\n" if $debug;
96: $z= $qbase -> prepare($select);
97: $z -> execute;
98: }
99:
100:
101: sub getword2question
102: {
103: my $select='select word, questions FROM word2question';
104: print "$select\n";
105: $z= $qbase -> prepare($select);
106: $z -> execute;
107: }
108:
109:
110: sub addword2task
111: {
112: ($w1,$w2)=@_;
113: $w2=$qbase -> quote ($w2);
114: $qbase -> do("insert into word2question (word,questions) values ($w1,$w2)");
115: }
116:
117: sub addauthors
118: {
119: my ($charid,$name,$surname,$questions,$nicks,$forbidden)=@_;
120: $_=$qbase ->
121: quote($_) foreach ($charid,$name,$surname,$nicks);
122: my $kvo=scalar grep {!$$forbidden{$_}} @$questions;
123: my $query="insert into Authors (CharId,name,surname,QNumber,Nicks)
124: values ($charid,$name,$surname,".$kvo.",$nicks)";
125:
126: print $query if $debug;
127:
128: $qbase -> do($query);
129: $query="select id from Authors where CharId=$charid";
130: print $query if $debug;
131: my $z= $qbase -> prepare($query);
132: $z -> execute;
133: my @ar=$z->fetchrow;
134: my $id=$ar[0];
135:
136:
137:
138: foreach my $q (@{$questions})
139: {
140: $query="insert into A2Q (Author,Question)
141: values ($id,$q)";
142: print $query if $debug;
143: $qbase -> do($query) ;
144: }
145: }
146:
147:
148: sub packword
149: {
150: my ($fieldnumber,$id,$wordnumber)=@_;
151: die "packword: fieldnumber is $fieldnumber! -- id=$id, word=$wordnumber\n" if $fieldnumber>6;
152: $r=pack("CSC",$fieldnumber|(($id >> 16) << 4),$id%65536,$wordnumber%256);
153: }
154:
155:
156: sub updatew2q {
157: my ($n,$fieldnumber, $id,$wordnumber)=@_;
158: my ($z,@a);
159: $query="replace into w2q (wordId,questionId,fieldNumber,wordNumber) values ($n,$id,$fieldnumber,$wordnumber)";
160: print "$query\n" if $debug;
161: $qbase->do($query);
162: }
163:
164: sub updateword2question
165: {
166: my ($n,$addstring,$was)=@_;
167: $addstring=$qbase->quote($addstring);
168: my ($z,@a);
169:
170: if (!(defined $was))
171: {
172: $query="select word from word2question where word=$n";
173: print "$query\n" if $debug;
174: $z=$qbase->prepare($query);
175: $z->execute;
176: @a=$z->fetchrow;
177: $was=$a[0];
178: }
179: my $select=$was ? "UPDATE word2question set questions = CONCAT(questions,$addstring)
180: where word=$n"
181: :
182: "insert into word2question (word,questions) values
183: ($n,$addstring)";
184: print "$select\n" if $debug;
185: $qbase->do ($select);
186:
187: }
188:
189:
190:
191: sub addnest
192: {
193: my ($w1,$w2)=@_;
194: $w1=$qbase -> quote($w1);
195: my $query="insert into nests (w1,w2) values ($w1,$w2)";
196: print $query if $debug;
197: $qbase -> do($query);
198: }
199:
200: sub addnf
201: {
202: my ($w0,$w1,$w2,$w3)=@_;
203: $w1=$qbase -> quote($w1);
204: $w2=$qbase -> quote($w2);
205: my $query;
206: my $z= $qbase -> prepare("select flag,id FROM nf WHERE word=$w1");
207: $z -> execute;
208: my @a=$z->fetchrow;
209: my $id;
210: if ($a[0])
211: {
212: $query="update nf set flag=$w2, number=$w3 WHERE word=$w1";
213: print "$query\n" if $debug;
214: $qbase -> do($query);
215: return $a[1];
216: }
217: else
218: {
219: if ($w0)
220: {
221: $query="insert into nf (id,word,flag,number) values ($w0,$w1,$w2,$w3)";
222: $qbase -> do($query);
223: return $w0;
224: }
225: else
226: {
227: $query="insert into nf (word,flag,number) values ($w1,$w2,$w3)";
228: $qbase -> do($query);
229: $query="select id from nf where word=$w1";
230: print "$query\n" if $debug;
231: $z=$qbase->prepare($query);
232: $z->execute;
233: ($id)=$z->fetchrow;
234: return $id;
235: }
236: }
237: }
238:
239: sub getwordkeys
240: {
241: $z= $qbase -> prepare("select word, flag FROM nf");
242: $z -> execute;
243: my %h;
244: while ( my ($first, $second)=$z -> fetchrow)
245: {
246: $h{$first}=$second;
247: }
248: $z -> finish;
249: %h;
250: }
251:
252:
253: sub getequalto
254: {
255: $z= $qbase -> prepare("select first, second FROM equalto");
256: $z -> execute;
257: my %h;
258: while ( my ($first, $second)=$z -> fetchrow)
259: {
260: $h{$first}=$second;
261: }
262: $z -> finish;
263: %h;
264: }
265:
266: sub getnfnumbers
267: {
268: $z= $qbase -> prepare("select word, id FROM nf");
269: $z -> execute;
270: my %h;
271: while ( my ($first, $second)=$z -> fetchrow)
272: {
273: $h{$first}=$second;
274: }
275: $z -> finish;
276: %h;
277: }
278:
279:
280: sub getnests
281: {
282: $z= $qbase -> prepare("select w1, w2 FROM nests");
283: $z -> execute;
284: my %h;
285: while ( my ($first, $second)=$z -> fetchrow)
286: {
287: $h{$first}.=" $second";
288: }
289: $z -> finish;
290: %h;
291: }
292:
293:
294: sub getflag
295: {
296: $w=$qbase->quote($_[0]);
297: $z= $qbase -> prepare("select flag, id from nf where word=$w");
298: $z -> execute;
299: @res=$z->fetchrow();
300:
301: @res;
302: }
303:
304:
305: sub closebase
306: {
307: $z -> finish;
308: $qbase -> disconnect;
309: }
310:
311: sub getrow
312: {
313: $z -> fetchrow
314: }
315:
316: sub mydo
317: {
318: $qbase -> do (shift);
319: }
320:
321: sub getall
322: {
323: $z -> fetchall_arrayref;
324: }
325:
326: sub forbidden
327: {
328: keys %getequalto
329: }
330:
331: sub checktable # если $param='delete' удаляет существующую таблицу,
332: # если $param='ask' спрашивает, не удалить ли
333: # если $param не определено -- просто удаляет.
334: # если $param='deletedata' -- удаляет из таблицы данные
335: {
336: my ($TabName,$param) = @_;
337: my ($ans);
338: if (scalar(grep(/\`$TabName$\`/i, &tablelist))) {
339: return 1 unless $param;
340: if ($param =~ /delete/) {$ans='y';}
341: else {
342: print "Table $TabName exists. Do you want to delete it? ";
343: $ans = <STDIN>
344: }
345: if ($ans =~ /[yY]/) {
346: if ($param eq 'delete') {
347: $qbase->do("DROP TABLE $TabName");
348: print "deleted table $TabName\n";
349: } else {
350: $qbase->do("DELETE FROM $TabName");
351: print "Deleted everything from $TabName\n";
352: }
353: return 0;
354: } else {
355: return 1
356: }
357: }
358: 0
359: }
360:
361: sub tablelist
362: {
363: return $qbase->func('_ListTables');
364: }
365:
366: sub in2out
367: {
368: $qid=shift;
369:
370: my $z= $qbase -> prepare ( "select t2.Id, t2.Number, t3.FileName
371: from Questions AS t1, Tournaments AS t2 , Tournaments AS t3
372: where (t1.QuestionId = $qid) && (t1.ParentId = t2.Id) && (t2.ParentId = t3.Id) ");
373:
374: $z -> execute;
375: ($tourid, $tourname, $filename)= $z -> fetchrow;
376:
377:
378: $z= $qbase -> prepare("select QuestionId from Questions WHERE ParentId = $tourid");
379:
380: $z -> execute;
381: my $i;
382: for ($i=1; ($q= $z->fetchrow) && $q!=$qid; $i++){};
383:
384: $_=lc $_;
385: $filename=~s/\.txt$//i;
386: "$filename\.$tourname\.$i";
387: }
388:
389:
390:
391: sub out2in
392: {
393: @q= split(/\./, lc shift);
394:
395: $q[0].='.txt';
396:
397: #
398:
399:
400: $z= $qbase -> prepare ( "select q.QuestionId from Questions as q,
401: Tournaments as t1, Tournaments as t2
402: where (t2.FileName= \"$q[0]\") &&
403: (t1.ParentId = t2.Id) &&
404: (q.ParentId = t1.Id) &&
405: (t1.Number=\"$q[1]\")
406: ");
407:
408: $z -> execute;
409: # ($tourid)=$z -> fetchrow or die "Bad identifier". join (".", @q);
410:
411: # print "--$tourid--";
412:
413: # $z= $qbase -> prepare("select QuestionId from questions WHERE ParentId = $tourid");
414:
415: my $i;
416: $z -> execute;
417: for ($i=1; $i <= $q[2]; $i++){@qq= $z->fetchrow};
418:
419: $z -> finish;
420: $qq[0];
421: }
422:
423:
424: 1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dbchgk.pm CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Local Repository] / db / prgsrc