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: {
294: my ($TabName,$param) = @_;
295: my ($ans);
296: if (scalar(grep(/^$TabName$/i, &tablelist))) {
297: return 1 unless $param;
298: if ($param eq 'delete') {$ans='y';}
299: else {
300: print "Table $TabName exists. Do you want to delete it? ";
301: $ans = <STDIN>
302: }
303: if ($ans =~ /[yY]/) {
304: $qbase->do("DROP TABLE $TabName");
305: print "deleted table $TabName\n";
306: return 0;
307: } else {
308: return 1
309: }
310: }
311: 0
312: }
313:
314: sub tablelist
315: {
316: $qbase->func( '_ListTables' );
317: }
318:
319: sub in2out
320: {
321: $qid=shift;
322:
323: my $z= $qbase -> prepare ( "select t2.Id, t2.Number, t3.FileName
324: from Questions AS t1, Tournaments AS t2 , Tournaments AS t3
325: where (t1.QuestionId = $qid) && (t1.ParentId = t2.Id) && (t2.ParentId = t3.Id) ");
326:
327: $z -> execute;
328: ($tourid, $tourname, $filename)= $z -> fetchrow;
329:
330:
331: $z= $qbase -> prepare("select QuestionId from Questions WHERE ParentId = $tourid");
332:
333: $z -> execute;
334: my $i;
335: for ($i=1; ($q= $z->fetchrow) && $q!=$qid; $i++){};
336:
337: $_=lc $_;
338: $filename=~s/\.txt$//i;
339: "$filename\.$tourname\.$i";
340: }
341:
342:
343:
344: sub out2in
345: {
346: @q= split(/\./, lc shift);
347:
348: $q[0].='.txt';
349:
350: #
351:
352:
353: $z= $qbase -> prepare ( "select q.QuestionId from Questions as q,
354: Tournaments as t1, Tournaments as t2
355: where (t2.FileName= \"$q[0]\") &&
356: (t1.ParentId = t2.Id) &&
357: (q.ParentId = t1.Id) &&
358: (t1.Number=\"$q[1]\")
359: ");
360:
361: $z -> execute;
362: # ($tourid)=$z -> fetchrow or die "Bad identifier". join (".", @q);
363:
364: # print "--$tourid--";
365:
366: # $z= $qbase -> prepare("select QuestionId from questions WHERE ParentId = $tourid");
367:
368: my $i;
369: $z -> execute;
370: for ($i=1; $i <= $q[2]; $i++){@qq= $z->fetchrow};
371:
372: $z -> finish;
373: $qq[0];
374: }
375:
376:
377: 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