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