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