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