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