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