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 &cformula
29: &updateword2question &knownword &incnf &searchmark &knownnf &getnests
30: &packword &getnfnumbers &getword2question) ;
31:
32: my $z;
33: my $qbase;
34: BEGIN {do "chgk.cnf";
35: $qbase = DBI -> connect ("DBI:mysql:$base",'piataev',undef);
36: };
37:
38:
39:
40: sub searchmark
41: {
42: my $a=$_[0];
43: $qbase->do ("UPDATE Questions SET ProcessedBySearch=1 WHERE QuestionId=$a")
44: }
45:
46: sub knownword
47: {
48: my $a=$qbase ->quote (uc $_[0]);
49: my $select = "select distinct w2 from nests where w1=$a";
50: print "$select\n" if $debug;
51: my $z= $qbase -> prepare($select);
52: $z -> execute;
53: my @res;
54: while ( my @ar=$z -> fetchrow)
55: {
56: push (@res,$ar[0])
57: }
58: return @res;
59:
60: }
61:
62: sub knownnf
63: {
64: my $a=$qbase ->quote (uc $_[0]);
65: my $select = "select id from nf where word=$a";
66: print "$select\n" if $debug;
67: my $z= $qbase -> prepare($select);
68: $z -> execute;
69: my @ar=$z -> fetchrow;
70: return $ar[0];
71: }
72:
73: sub incnf
74: {
75: my $a=$_[0];
76: my $b=$_[1]||1;
77: $qbase -> do ("UPDATE nf SET number=number+$b WHERE id=$a")
78: }
79:
80: sub getbase
81: {
82: my $a=join(", ",@_);
83: my $select="select $a FROM Questions WHERE QuestionId<=$qnumber";
84: print "$select\n" if $debug;
85: $z= $qbase -> prepare($select);
86: $z -> execute;
87: }
88:
89: sub getquestions
90: {
91: my $cond=pop @_;
92: my $a=join(", ",@_);
93: my $select="select $a FROM Questions WHERE QuestionId<=$qnumber AND ($cond)";
94: print "$select\n" if $debug;
95: $z= $qbase -> prepare($select);
96: $z -> execute;
97: }
98:
99:
100: sub getword2question
101: {
102: my $select='select word, questions FROM word2question';
103: print "$select\n";
104: $z= $qbase -> prepare($select);
105: $z -> execute;
106: }
107:
108:
109: sub addword2task
110: {
111: ($w1,$w2)=@_;
112: $w2=$qbase -> quote ($w2);
113: $qbase -> do("insert into word2question (word,questions) values ($w1,$w2)");
114: }
115:
116: sub packword
117: {
118: my ($fieldnumber,$id,$wordnumber)=@_;
119: die "packword: fieldnumber is $fieldnumber! -- id=$id, word=$wordnumber\n" if $fieldnumber>6;
120: pack("CSC",$fieldnumber,$id,$wordnumber%256)
121: }
122:
123: sub updateword2question
124: {
125: my ($n,$addstring,$was)=@_;
126: $addstring=$qbase->quote($addstring);
127: my ($z,@a);
128:
129: if (!(defined $was))
130: {
131: $query="select word from word2question where word=$n";
132: print "$query\n" if $debug;
133: $z=$qbase->prepare($query);
134: $z->execute;
135: @a=$z->fetchrow;
136: $was=$a[0];
137: }
138: my $select=$was ? "UPDATE word2question set questions = CONCAT(questions,$addstring)
139: where word=$n"
140: :
141: "insert into word2question (word,questions) values
142: ($n,$addstring)";
143: print "$select\n" if $debug;
144: $qbase->do ($select);
145:
146: }
147:
148:
149:
150: sub addnest
151: {
152: my ($w1,$w2)=@_;
153: $w1=$qbase -> quote($w1);
154: my $query="insert into nests (w1,w2) values ($w1,$w2)";
155: print $query if $debug;
156: $qbase -> do($query);
157: }
158:
159: sub addnf
160: {
161: my ($w0,$w1,$w2,$w3)=@_;
162: $w1=$qbase -> quote($w1);
163: $w2=$qbase -> quote($w2);
164: my $query;
165: my $z= $qbase -> prepare("select flag,id FROM nf WHERE word=$w1");
166: $z -> execute;
167: my @a=$z->fetchrow;
168: my $id;
169: if ($a[0])
170: {
171: $query="update nf set flag=$w2, number=$w3 WHERE word=$w1";
172: print "$query\n" if $debug;
173: $qbase -> do($query);
174: return $a[1];
175: }
176: else
177: {
178: if ($w0)
179: {
180: $query="insert into nf (id,word,flag,number) values ($w0,$w1,$w2,$w3)";
181: $qbase -> do($query);
182: return $w0;
183: }
184: else
185: {
186: $query="insert into nf (word,flag,number) values ($w1,$w2,$w3)";
187: $qbase -> do($query);
188: $query="select id from nf where word=$w1";
189: print "$query\n" if $debug;
190: $z=$qbase->prepare($query);
191: $z->execute;
192: ($id)=$z->fetchrow;
193: return $id;
194: }
195: }
196: }
197:
198: sub getwordkeys
199: {
200: $z= $qbase -> prepare("select word, flag FROM nf");
201: $z -> execute;
202: my %h;
203: while ( my ($first, $second)=$z -> fetchrow)
204: {
205: $h{$first}=$second;
206: }
207: $z -> finish;
208: %h;
209: }
210:
211:
212: sub getequalto
213: {
214: $z= $qbase -> prepare("select first, second FROM equalto");
215: $z -> execute;
216: my %h;
217: while ( my ($first, $second)=$z -> fetchrow)
218: {
219: $h{$first}=$second;
220: }
221: $z -> finish;
222: %h;
223: }
224:
225: sub getnfnumbers
226: {
227: $z= $qbase -> prepare("select word, id FROM nf");
228: $z -> execute;
229: my %h;
230: while ( my ($first, $second)=$z -> fetchrow)
231: {
232: $h{$first}=$second;
233: }
234: $z -> finish;
235: %h;
236: }
237:
238:
239: sub getnests
240: {
241: $z= $qbase -> prepare("select w1, w2 FROM nests");
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 getflag
254: {
255: $w=$qbase->quote($_[0]);
256: $z= $qbase -> prepare("select flag, id from nf where word=$w");
257: $z -> execute;
258: @res=$z->fetchrow();
259:
260: @res;
261: }
262:
263:
264: sub closebase
265: {
266: $z -> finish;
267: $qbase -> disconnect;
268: }
269:
270: sub getrow
271: {
272: $z -> fetchrow
273: }
274:
275: sub mydo
276: {
277: $qbase -> do (shift);
278: }
279:
280: sub getall
281: {
282: $z -> fetchall_arrayref;
283: }
284:
285: sub forbidden
286: {
287: keys %getequalto
288: }
289:
290: sub checktable # если $param='delete' удаляет существующую таблицу,
291: # если $param='ask' спрашивает, не удалить ли
292: # если $param не определено -- просто удаляет.
293: # если $param='deletedata' -- удаляет из таблицы данные
294: {
295: my ($TabName,$param) = @_;
296: my ($ans);
297: if (scalar(grep(/^$TabName$/i, &tablelist))) {
298: return 1 unless $param;
299: if ($param =~ /delete/) {$ans='y';}
300: else {
301: print "Table $TabName exists. Do you want to delete it? ";
302: $ans = <STDIN>
303: }
304: if ($ans =~ /[yY]/) {
305: if ($param eq 'delete') {
306: $qbase->do("DROP TABLE $TabName");
307: print "deleted table $TabName\n";
308: } else {
309: $qbase->do("DELETE FROM $TabName");
310: print "Deleted everything from $TabName\n";
311: }
312: return 0;
313: } else {
314: return 1
315: }
316: }
317: 0
318: }
319:
320: sub tablelist
321: {
322: $qbase->func( '_ListTables' );
323: }
324:
325: sub in2out
326: {
327: $qid=shift;
328:
329: my $z= $qbase -> prepare ( "select t2.Id, t2.Number, t3.FileName
330: from Questions AS t1, Tournaments AS t2 , Tournaments AS t3
331: where (t1.QuestionId = $qid) && (t1.ParentId = t2.Id) && (t2.ParentId = t3.Id) ");
332:
333: $z -> execute;
334: ($tourid, $tourname, $filename)= $z -> fetchrow;
335:
336:
337: $z= $qbase -> prepare("select QuestionId from Questions WHERE ParentId = $tourid");
338:
339: $z -> execute;
340: my $i;
341: for ($i=1; ($q= $z->fetchrow) && $q!=$qid; $i++){};
342:
343: $_=lc $_;
344: $filename=~s/\.txt$//i;
345: "$filename\.$tourname\.$i";
346: }
347:
348:
349:
350: sub out2in
351: {
352: @q= split(/\./, lc shift);
353:
354: $q[0].='.txt';
355:
356: #
357:
358:
359: $z= $qbase -> prepare ( "select q.QuestionId from Questions as q,
360: Tournaments as t1, Tournaments as t2
361: where (t2.FileName= \"$q[0]\") &&
362: (t1.ParentId = t2.Id) &&
363: (q.ParentId = t1.Id) &&
364: (t1.Number=\"$q[1]\")
365: ");
366:
367: $z -> execute;
368: # ($tourid)=$z -> fetchrow or die "Bad identifier". join (".", @q);
369:
370: # print "--$tourid--";
371:
372: # $z= $qbase -> prepare("select QuestionId from questions WHERE ParentId = $tourid");
373:
374: my $i;
375: $z -> execute;
376: for ($i=1; $i <= $q[2]; $i++){@qq= $z->fetchrow};
377:
378: $z -> finish;
379: $qq[0];
380: }
381:
382:
383: 1;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>