Listing: 1 IMPLEMENTATION MODULE DBIndxes; 2 (*# check(overflow=>off) *) 3 (*/NOCHECK O *) 4 (* 5 * ModBase 6 * Release 3.0 7 * (c) Copyright 1986 - 1990 Donald G. Fletcher 8 * (c) Copyright 1986 - 1991 PMI 9 Copyright 1988 - 1991 John McMonagle 10 * P.O. Box 8402 11 * Green Bay Wi 53308 12 * All Rights Reserved 13 *) 14 15 16 (* 17 - DBIndex 18 - Bug in CloseIndex fixed April 2, 1987 19 - DeleteEntry rewritten April 2, 1987 20 - CloseIndex does not write its rootnode unless ndx^.open is TRUE 21 - Most FOR loops have been rewritten to use Move or ShiftArrayRight 22 - September 14, 1987 - Rewritten with LONGINT for Logitech 3.0 23 *) 24 (*System modules*) 25 FROM SYSTEM IMPORT ADR,ADDRESS,SIZE,BYTE; 26 FROM M2Strings IMPORT Assign,CompareStr, Copy,Length,Concat; 27 (*PMI modules*) 28 FROM LowLevel IMPORT Move, Fill, ShiftArrayRight,Address8086, 29 BitwiseAnd,ShiftLeft; 30 IMPORT StringIO; (*from Repertoire*) 31 IMPORT HandleIO,FAPI; (*from Repertoire*) 32 FROM Numbers IMPORT Max; 33 FROM StrEdit IMPORT CrunchBlanks,CAPstr,Append; 34 FROM PosUtils IMPORT Equal; 35 FROM NumTypes IMPORT Real8; 36 (*ModBase modules*) 37 FROM ErrorManager IMPORT WARN; 38 FROM StrConv IMPORT StrToReal; 39 FROM ModBase3 IMPORT DBFile, ReadDBRec, GetField, SetDBBuffer, 40 UpDateIndexes,SetRecordMode,OpenDBF,Appending,SetIndexList, 41 IndexList,NumberRecords,FieldList,BufferSize,PosOfField,Record, 42 DBFieldPtr,Deleted; 43 FROM VStorage IMPORT 44 DosAlloc, DosDealloc,DosAvail; 45 (* IMPORT ChkInd; *) 46 (*key numbering convention node[0] contains the number of keys but 47 getkey etc. the first one is 1 not 0. *) 48 IMPORT Locks,ModBase3; ***** ^ duplicate identifier 49 PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL); 50 BEGIN 51 DosDealloc(loc,size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 52 END DEALLOCATE; ***** ^ not supported yet 53 54 PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL); 55 BEGIN 56 DosAlloc(loc,size); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 57 END ALLOCATE; ***** ^ not supported yet 58 59 CONST 60 FirstKey = 0; (* the number of the first key in a node *) 61 MaxKey = 128; 62 RecNumLen = 4; 63 NodeSize = 512; 64 IndexNameLength = 80; 65 MaxField = 128; 66 MaxDepth = 24; 67 FirstNode = 0; 68 RootNodePtrPos = 4; 69 NextFreeNodePtrPos = 8; 70 KeyLenPos = 12; 71 KeyEntPos = 14; 72 KeyTypePos = 22; 73 KeyExpPos = 24; 74 DepthPosition = 256; 75 InitCode =56317; 76 Bins=128; 77 78 TYPE 79 HeaderNodeType= 80 RECORD 81 rootptr, 82 nextfreenode, 83 FreeList :LONGINT; (* this may not be true dbase compatable *) 84 keylength, 85 keyspernode:CARDINAL; 86 NumType,fill:BOOLEAN; 87 entrylength:CARDINAL; 88 Flag, 89 fill2:CARDINAL; 90 KeyExpression:ARRAY[0..487] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 91 END (* record *); ***** ^ not supported yet 92 93 NodeType = ARRAY [0..NodeSize-1] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 94 95 IndexBuffer = POINTER TO NodeBuffType; ***** ^ undeclared identifier 96 97 NodeBuffType = 98 RECORD 99 node: NodeType; 100 (* clean:CARDINAL; diag to test for overwriting node *) 101 number: LONGINT; 102 next, prev,NHash,PHash: IndexBuffer; 103 Lock,NeedToWrite:BOOLEAN; 104 END; ***** ^ not supported yet 105 106 KeyPosType = RECORD 107 buffer: IndexBuffer ; 108 keynum : CARDINAL; 109 END; ***** ^ not supported yet 110 111 Route = ARRAY [0..MaxDepth] OF KeyPosType; ***** ^ not supported yet ***** ^ not supported yet 112 113 EntryType = 114 RECORD 115 lowernode: LONGINT; 116 recordnum: LONGINT; 117 value : ARRAY [0..MaxKey] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 118 END; ***** ^ not supported yet 119 120 KeyPointer=POINTER TO EntryType; ***** ^ not supported yet 121 122 RealEntry = 123 RECORD 124 lowernode: LONGINT; 125 recordnum: LONGINT; 126 key:Real8; 127 END; ***** ^ not supported yet 128 129 RealKeyPointer=POINTER TO RealEntry; ***** ^ not supported yet 130 131 CompareType=(LT,EQ,GT); 132 133 CompareProc= PROCEDURE( ADDRESS,ADDRESS,CARDINAL): CompareType; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 134 135 136 DBIndex= POINTER TO IndexRec; ***** ^ undeclared identifier 137 IndexRec = 138 RECORD 139 name: ARRAY [1..IndexNameLength] OF CHAR; ***** ^ not supported yet ***** ^ not supported yet 140 f: CARDINAL; (* this is the file handle *) 141 Locked:CARDINAL; (* indicates file is locked *) 142 includedeleted, 143 Exclusive, (* indicates file locking not needed *) 144 Changed, 145 open: BOOLEAN; 146 Safety: BOOLEAN; 147 KeyNumber, 148 depth, 149 Init:CARDINAL; 150 alias:DBFile; 151 Header:HeaderNodeType; 152 KeyProc :KeyProcedure; ***** ^ undeclared identifier 153 posarray: Route; 154 CASE :BOOLEAN OF ***** ^ not supported yet ***** ^ 'POINTER' expected 155 TRUE: currentkey: KeyPointer;| 156 FALSE: numkey : RealKeyPointer; 157 END; 158 first, last: IndexBuffer; 159 currsize: CARDINAL; 160 buffsize: CARDINAL; 161 (* number of Nodes in Buffer *) 162 UpdateList:DBIndex;(* consider having list in seperate record 163 so that Index can be updated from more than one DBF *) 164 Hash:ARRAY[0..Bins-1] OF IndexBuffer; 165 END; 166 167 PROCEDURE HashP(number:LONGINT):CARDINAL; 168 TYPE 169 LSet=SET OF [0..31]; 170 BEGIN 171 RETURN VAL(CARDINAL,LONGINT(LSet(127)*LSet(number) ) ); 172 END HashP; 173 174 PROCEDURE AddToTable(ndx:DBIndex;BufPtr:IndexBuffer); 175 VAR 176 ptr:IndexBuffer; 177 h:CARDINAL; 178 BEGIN 179 h:=HashP(BufPtr^.number); 180 ptr:=ndx^.Hash[h]; 181 BufPtr^.NHash:=ptr; 182 IF ptr#NIL THEN 183 ptr^.PHash:=BufPtr 184 END; 185 BufPtr^.PHash:=NIL; 186 ndx^.Hash[h]:=BufPtr; 187 END AddToTable; 188 189 PROCEDURE RemoveFromTable(ndx:DBIndex;BufPtr:IndexBuffer); 190 BEGIN 191 IF BufPtr^.PHash=NIL THEN 192 ndx^.Hash[HashP(BufPtr^.number)]:=BufPtr^.NHash; 193 ELSE 194 BufPtr^.PHash^.NHash:=BufPtr^.NHash 195 END; 196 IF BufPtr^.NHash#NIL THEN 197 BufPtr^.NHash^.PHash:=BufPtr^.PHash; 198 END; 199 BufPtr^.PHash:=NIL; 200 BufPtr^.NHash:=NIL; 201 END RemoveFromTable; 202 203 PROCEDURE InitPosarray( ndx: DBIndex); 204 VAR 205 i:CARDINAL; 206 BEGIN 207 FOR i:= 0 TO MaxDepth DO 208 ndx^.posarray[i].buffer:=NIL; 209 END; 210 END InitPosarray; 211 212 PROCEDURE InBuffer( ndx: DBIndex; nodenumber: LONGINT; VAR 213 BufPtr: IndexBuffer): BOOLEAN; 214 215 BEGIN 216 BufPtr:=ndx^.Hash[HashP(nodenumber)]; 217 IF BufPtr = NIL THEN 218 RETURN FALSE 219 ELSE 220 LOOP 221 WITH BufPtr^ DO 222 IF (number = nodenumber) THEN 223 RETURN TRUE 224 END; 225 IF (NHash = NIL) THEN 226 RETURN FALSE 227 END; 228 END (* WITH *); 229 BufPtr := BufPtr^.NHash; 230 END; (* loop *) 231 END; 232 END InBuffer; 233 234 PROCEDURE AddBuffer( ndx:DBIndex;VAR buffer: IndexBuffer ); 235 BEGIN 236 (* always add to top *) 237 buffer^.next:=ndx^.first; 238 buffer^.prev:=NIL; 239 IF buffer^.next=NIL 240 THEN 241 ndx^.last:=buffer; 242 ELSE 243 ndx^.first^.prev:=buffer; 244 END; 245 ndx^.first:=buffer; 246 buffer^.Lock:=TRUE; 247 INC(ndx^.currsize); 248 END AddBuffer; 249 250 PROCEDURE RemoveBuffer(ndx:DBIndex;VAR buffer: IndexBuffer ); 251 BEGIN 252 IF buffer^.next=NIL 253 THEN 254 IF buffer^.prev=NIL 255 THEN 256 ndx^.first:=NIL; 257 ndx^.last:=NIL; 258 ELSE 259 ndx^.last:=buffer^.prev; 260 buffer^.prev^.next:=buffer^.next; 261 END; 262 ELSE 263 IF buffer^.prev=NIL 264 THEN 265 ndx^.first:=buffer^.next; 266 buffer^.next^.prev:=buffer^.prev; 267 ELSE 268 buffer^.next^.prev:=buffer^.prev; 269 buffer^.prev^.next:=buffer^.next; 270 END; 271 END; 272 DEC(ndx^.currsize); 273 END RemoveBuffer; 274 275 276 PROCEDURE WriteNode( ndx: DBIndex; nodenumber: LONGINT; 277 VAR nodeblock: NodeType); 278 VAR pos: LONGINT; 279 FileError: StringIO.ErrorMessage; 280 281 (*PROCEDURE Errorchk;(* diag *) 282 VAR 283 buffer:IndexBuffer; 284 i:CARDINAL; 285 BEGIN 286 IF NOT InBuffer(ndx,nodenumber,buffer) 287 THEN 288 HALT; 289 END; 290 FOR i:=0 TO 511 DO 291 IF buffer^.node[i]#nodeblock[i] 292 THEN 293 HALT; 294 END; 295 END; 296 END Errorchk;*) 297 298 BEGIN 299 (* IF nodenumber>VAL(LONGINT,1) 300 THEN 301 Errorchk 302 END; *) 303 pos := nodenumber * VAL(LONGINT, NodeSize); 304 HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, pos); 305 FileError := HandleIO.BlockWrite(ndx^.f, ADR(nodeblock), NodeSize); 306 IF FileError # StringIO.NoError THEN 307 WARN('Block write failure in WriteNode'); 308 END; 309 IF ndx^.Safety 310 THEN 311 HandleIO.UpdateDisk(ndx^.f); 312 END; 313 314 END WriteNode; 315 316 PROCEDURE InitNode(VAR node: NodeType); 317 BEGIN 318 Fill(ADR(node), NodeSize, 0C); 319 END InitNode; 320 321 PROCEDURE FindFreeBuffer( ndx:DBIndex;VAR buffer: IndexBuffer ):BOOLEAN; 322 BEGIN 323 buffer:=ndx^.last; 324 WHILE buffer^.Lock 325 DO 326 IF buffer^.prev=NIL 327 THEN 328 RETURN FALSE; 329 END; 330 buffer:=buffer^.prev; 331 END; 332 (* if one is looking for buffer it will be reused so write it 333 out if safety is off *) 334 IF buffer^.NeedToWrite 335 THEN 336 WriteNode(ndx,buffer^.number,buffer^.node); 337 END; 338 RETURN TRUE; 339 END FindFreeBuffer; 340 341 PROCEDURE GetBuffer( ndx:DBIndex;VAR buffer: IndexBuffer; 342 NodeNumber:LONGINT ); 343 BEGIN 344 IF (( ndx^.buffsize>ndx^.currsize) AND DosAvail(8000)) 345 THEN 346 DosAlloc(buffer,SIZE(buffer^)); 347 ELSE; 348 IF FindFreeBuffer(ndx,buffer) 349 THEN 350 RemoveBuffer(ndx,buffer); 351 RemoveFromTable(ndx,buffer); 352 ELSE 353 DosAlloc(buffer,SIZE(buffer^)); 354 END; 355 END; 356 AddBuffer(ndx,buffer); 357 (* init buffer *) 358 buffer^.number:=NodeNumber; 359 AddToTable(ndx,buffer); 360 (* buffer^.clean:=37513; diag *) 361 buffer^.NeedToWrite:=FALSE; 362 buffer^.Lock:=FALSE; 363 InitNode(buffer^.node); 364 END GetBuffer; 365 366 PROCEDURE ReadNode( ndx: DBIndex; 367 nodenumber: LONGINT; 368 VAR buffer: IndexBuffer); 369 (* the file associated with the index must already be open *) 370 VAR pos: LONGINT; 371 FileError: StringIO.ErrorMessage; 372 BEGIN 373 IF InBuffer(ndx,nodenumber,buffer) 374 THEN 375 RemoveBuffer(ndx,buffer); 376 AddBuffer(ndx,buffer); 377 RETURN 378 END; 379 GetBuffer(ndx,buffer,nodenumber); 380 (*buffer^.number:=nodenumber;*) 381 pos := nodenumber * VAL(LONGINT, NodeSize); 382 HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, pos); 383 FileError := HandleIO.BlockRead(ndx^.f, ADR(buffer^.node), NodeSize); 384 IF FileError # StringIO.NoError THEN 385 WARN('Block read failure in ReadNode'); 386 END; 387 END ReadNode; 388 389 PROCEDURE NewNode( ndx:DBIndex;VAR buffer:IndexBuffer) ; 390 BEGIN 391 IF ndx^.Header.FreeList=VAL(LONGINT,0) 392 THEN 393 GetBuffer(ndx,buffer,ndx^.Header.nextfreenode); 394 (*buffer^.number:=ndx^.Header.nextfreenode;*) 395 INC(ndx^.Header.nextfreenode) 396 ELSE 397 ReadNode(ndx,ndx^.Header.FreeList,buffer); 398 Move(ADR(buffer^.node),ADR(ndx^.Header.FreeList),4); 399 InitNode(buffer^.node); 400 END; 401 402 END NewNode; 403 404 PROCEDURE ReadIntoArray( ndx :DBIndex; 405 nodenumber: LONGINT; 406 level :CARDINAL); 407 BEGIN 408 IF ndx^.posarray[level].buffer#NIL 409 THEN 410 ndx^.posarray[level].buffer^.Lock:=FALSE; 411 END; 412 ReadNode(ndx, nodenumber, ndx^.posarray[level].buffer); 413 ndx^.posarray[level].buffer^.number:=nodenumber; 414 ndx^.posarray[level].buffer^.Lock:=TRUE; 415 END ReadIntoArray; 416 417 PROCEDURE ReadHeader( ndx:DBIndex); 418 BEGIN 419 HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, 0); 420 StringIO.PrintMessage(HandleIO.BlockRead(ndx^.f,ADR(ndx^.Header), 421 SIZE(ndx^.Header))) 422 END ReadHeader; 423 424 PROCEDURE WriteHeader( ndx:DBIndex); 425 BEGIN 426 HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, 0); 427 StringIO.PrintMessage(HandleIO.BlockWrite(ndx^.f,ADR(ndx^.Header), 428 SIZE(ndx^.Header))) 429 430 END WriteHeader; 431 432 PROCEDURE GetKeyPtr(VAR node: NodeType; 433 ndx: DBIndex; 434 keynumber: CARDINAL):KeyPointer; 435 436 BEGIN 437 RETURN ADR(node[4 +(keynumber * ndx^.Header.entrylength)]); 438 END GetKeyPtr; 439 440 PROCEDURE GetKey(VAR node: NodeType; 441 ndx: DBIndex; 442 keynumber: CARDINAL; 443 VAR key: EntryType); 444 445 BEGIN 446 (* entire procedure should be eliminated and placed in line. 447 changes are based on assumption that the max key size is 128 448 and 129 are avalable. error checking could be done in buildindex!!!!*) 449 Move(ADR(node[4 +(keynumber * ndx^.Header.entrylength)]), ADR(key), 450 ndx^.Header.entrylength); 451 key.value[ndx^.Header.keylength]:=0C; 452 END GetKey; 453 454 (* 455 PROCEDURE CompareKeyReal( ad1,ad2 : ADDRESS;size:CARDINAL) : CompareType; 456 TYPE 457 rp= RECORD 458 CASE:CARDINAL OF 459 1: 460 r:POINTER TO Real8; 461 | 2: 462 b:POINTER TO ARRAY[0..7] OF BYTE; 463 | 3: 464 a:ADDRESS; 465 END; 466 END; 467 VAR 468 r1,r2:rp; 469 BEGIN 470 r1.a:=ad1; 471 r2.a:=ad2; 472 IF (r1.r^ < r2.r^) THEN 473 RETURN LT 474 ELSIF (r1.b^ = r2.b^) THEN 475 RETURN EQ 476 ELSE 477 RETURN GT 478 END; 479 END CompareKeyReal; 480 *) 481 PROCEDURE CompareKeyReal(s1, s2 : ADDRESS;size:CARDINAL) : CompareType; 482 TYPE 483 rp= RECORD 484 CASE:CARDINAL OF 485 1: 486 r:POINTER TO Real8; 487 | 2: 488 c:POINTER TO CARDINAL; 489 | 3: 490 a:ADDRESS; 491 | 4: 492 off,seg:CARDINAL; 493 | 5: 494 b:POINTER TO BITSET; 495 END; 496 END; 497 498 VAR 499 TmpAdr1, TmpAdr2 : rp; 500 cnt : CARDINAL; 501 neg:BOOLEAN; 502 BEGIN 503 TmpAdr1.a := s1; 504 TmpAdr2.a := s2; 505 INC(TmpAdr1.off,6); 506 INC(TmpAdr2.off,6); 507 neg:=(15 IN TmpAdr1.b^) OR (15 IN TmpAdr2.b^); 508 cnt := 0; 509 WHILE cnt<4 DO 510 IF TmpAdr1.c^#TmpAdr2.c^ THEN 511 IF TmpAdr1.c^>TmpAdr2.c^ THEN 512 IF neg THEN 513 RETURN LT 514 ELSE 515 RETURN GT 516 END; 517 ELSE 518 IF neg THEN 519 RETURN GT 520 ELSE 521 RETURN LT; 522 END; 523 END; 524 ELSE 525 INC(cnt); 526 DEC(TmpAdr1.off,2); 527 DEC(TmpAdr2.off,2); 528 END; 529 END; 530 RETURN EQ; 531 END CompareKeyReal; 532 533 PROCEDURE CompareKey(s1, s2 : ADDRESS;size:CARDINAL) : CompareType; 534 VAR 535 TmpAdr1, TmpAdr2 : Address8086; 536 cnt : CARDINAL; 537 BEGIN 538 TmpAdr1.a := s1; 539 TmpAdr2.a := s2; 540 cnt := 0; 541 WHILE cntTmpAdr2.b^ THEN 544 RETURN GT; 545 ELSE 546 RETURN LT; 547 END; 548 ELSE 549 IF (TmpAdr1.b^=0C) 550 THEN (* if on 0C were done *) 551 RETURN EQ 552 END; 553 INC(cnt); 554 INC(TmpAdr1.off); 555 INC(TmpAdr2.off); 556 END; 557 END; 558 RETURN EQ; 559 END CompareKey; 560 561 PROCEDURE FindPosition( ndx: DBIndex; 562 KeyValue: ADDRESS; 563 VAR found: BOOLEAN; 564 CompareP:CompareProc); 565 566 VAR level, keysinnode, 567 diff, 568 Top,Bottom, 569 crrntkeynum: CARDINAL; 570 done: BOOLEAN; 571 keyptr:KeyPointer; 572 nextnode: LONGINT; 573 BEGIN 574 IF OpenIndex(ndx)=FALSE 575 THEN 576 WARN('Error opening Index in FindPosition'); 577 END; 578 nextnode := ndx^.Header.rootptr; (* start search with root node *) 579 level := 0; 580 found:=FALSE; 581 REPEAT 582 ReadIntoArray(ndx, nextnode, level); 583 WITH ndx^.posarray[level] DO 584 keysinnode := ORD(buffer^.node[0]); 585 Top:=keysinnode; 586 Bottom:=0; 587 crrntkeynum:=(Top)DIV 2;(* use shift operator? *) 588 done := FALSE; 589 (* IF buffer^.clean# 37513 THEN HALT END; diag *) 590 LOOP 591 keyptr:=GetKeyPtr(buffer^.node, ndx, crrntkeynum); 592 WITH keyptr^ DO 593 CASE CompareP(KeyValue,ADR(value),ndx^.Header.keylength) OF 594 LT: (* key is less than tested value *) 595 diff:=crrntkeynum-Bottom; 596 IF diff<1 597 THEN 598 EXIT; (* done *) 599 END; 600 Top:=crrntkeynum; (* check lower half *) 601 crrntkeynum:=Bottom+(diff DIV 2); 602 |GT: (* key is greater than test *) 603 diff:=Top-crrntkeynum; 604 IF diff<=1 605 THEN 606 crrntkeynum:=Top; (*done but currect one was top*) 607 keyptr:=GetKeyPtr(buffer^.node, ndx, crrntkeynum); 608 EXIT; 609 END; 610 Bottom:=crrntkeynum; (* Next check upper half *) 611 crrntkeynum:=Bottom+(diff DIV 2); 612 |EQ: 613 614 (* * * * * * * * * * * * * * * * * * * *testing stuff for ed *) 615 (* found a position - might not be the first one though *) 616 (* loop backwards through the index to find the first if many *) 617 LOOP 618 IF crrntkeynum < 1 619 THEN EXIT; 620 END; (* at the first *) 621 DEC(crrntkeynum); 622 keyptr := GetKeyPtr(buffer^.node,ndx,crrntkeynum); 623 IF CompareP(KeyValue,ADR(keyptr^.value),ndx^.Header.keylength) = GT 624 THEN INC(crrntkeynum); 625 keyptr := GetKeyPtr(buffer^.node,ndx,crrntkeynum); 626 EXIT; 627 END; 628 (* * * * * * * * * * * End of stuff by ed * * * * * * * * * * *) 629 630 631 632 END; (* end of loop and end of my stuff *) 633 found:= TRUE; 634 EXIT; 635 END; (* CASE *) 636 END; 637 END (*loop*); 638 639 (* compare the key to the keys in the rootnode until the fieldstring 640 <= currentkey or the last entry in the node is encountered *) 641 keynum := crrntkeynum; 642 (* currentkey set by getkey *) 643 nextnode:=keyptr^.lowernode; 644 END; 645 INC(level); 646 UNTIL nextnode=VAL(LONGINT,0); 647 ndx^.depth:=level-1; 648 ndx^.currentkey:=keyptr; 649 END FindPosition; 650 651 PROCEDURE FindPositionCh( ndx: DBIndex; 652 keystr: ARRAY OF CHAR; 653 VAR found: BOOLEAN); 654 VAR 655 TestStr:ARRAY[0..MaxKey] OF CHAR; 656 BEGIN 657 Fill(ADR(TestStr),MaxKey,' '); 658 Copy(keystr,0,Length(keystr),TestStr); 659 FindPosition(ndx,ADR(TestStr),found,CompareKey); 660 END FindPositionCh; 661 662 PROCEDURE FindPositionR( ndx: DBIndex; 663 KeyValue: Real8; 664 VAR found: BOOLEAN); 665 BEGIN 666 FindPosition(ndx,ADR(KeyValue),found,CompareKeyReal); 667 END FindPositionR; 668 669 PROCEDURE FindPositionN(ndx: DBIndex; 670 keystr: ARRAY OF CHAR; 671 VAR found: BOOLEAN); 672 VAR 673 KeyValue:Real8; 674 BEGIN 675 IF NOT StrToReal(keystr, 0,KeyValue) THEN KeyValue:=0.0 END; 676 FindPositionR(ndx,KeyValue,found); 677 END FindPositionN; 678 679 PROCEDURE AddRecord( alias: DBFile; 680 ndx: DBIndex); 681 VAR 682 fieldstring: ARRAY [1..MaxField] OF CHAR; 683 found: BOOLEAN; 684 key: 685 RECORD 686 CASE :BOOLEAN OF 687 TRUE:num:Real8;| 688 FALSE:str:ARRAY[0..7] OF CHAR; 689 END; 690 END; 691 692 BEGIN 693 IF OpenIndex(ndx)=FALSE 694 THEN 695 WARN('Error opening Index in AddRecord'); 696 END; 697 EnterLock(ndx); 698 (* get key from record *); 699 ndx^.KeyProc(alias,ndx,fieldstring); 700 IF ndx^.Header.NumType THEN 701 IF NOT StrToReal(fieldstring, 0,key.num) THEN key.num:=0.0 END; 702 FindPositionR(ndx, key.num, found); 703 InsertEntry(ndx, key.str, Record(alias)); 704 ELSE 705 FindPositionCh(ndx, fieldstring, found); 706 InsertEntry(ndx, fieldstring, Record(alias)); 707 END; (* Now we have the position where the new Entry 708 should be inserted *) 709 ExitLock(ndx); 710 END AddRecord; 711 712 PROCEDURE DefaultKeyProcedure(alias: DBFile; ndx: DBIndex; 713 VAR str:ARRAY OF CHAR ); 714 BEGIN 715 GetField(alias, ndx^.KeyNumber, str); 716 717 END DefaultKeyProcedure; 718 719 PROCEDURE AdjustUpperNode( ndx: DBIndex;VAR KeyStr:ARRAY OF CHAR; 720 level: CARDINAL); 721 (* need to pass keystring because may be fixing at the current level 722 but not in the route level-1 must point to worknode!!*) 723 VAR offset: CARDINAL; 724 upkey,key:KeyPointer; 725 BEGIN 726 (* do not check to see if it is nessary but make sure level#0 *) 727 IF (level=0) THEN RETURN END; 728 (*Adjust upernode*) 729 IF (ndx^.posarray[level-1].keynum# 730 ORD(ndx^.posarray[level-1].buffer^.node[0])) 731 THEN (* can simplify when changing upkey to upkey^ *) 732 upkey:=GetKeyPtr(ndx^.posarray[level-1].buffer^.node,ndx, 733 ndx^.posarray[level-1].keynum); 734 Move(ADR(KeyStr), ADR(upkey^.value), ndx^.Header.keylength); 735 IF ndx^.Safety OR NOT ndx^.Exclusive 736 THEN 737 WriteNode(ndx, ndx^.posarray[level-1].buffer^.number, 738 ndx^.posarray[level-1].buffer^.node); 739 ELSE 740 ndx^.posarray[level-1].buffer^.NeedToWrite:=TRUE; 741 END; 742 ELSE 743 AdjustUpperNode(ndx,KeyStr,level-1); 744 END; 745 END AdjustUpperNode; 746 747 PROCEDURE DeleteEntry(ndx: DBIndex; 748 deletelevel: CARDINAL); 749 VAR offset: CARDINAL; 750 upkey,key:KeyPointer; 751 empty:BOOLEAN; 752 BEGIN 753 (* 4/21/89 notes for changes pos is not need as parameter 754 if top node is changed need to fix all the way down if 755 needed not just one as it is there is some chance of error. 756 cosider making procedure to fix uper node as it is used in 757 move keys also *) 758 (* Find the offset of the keyentry following 759 the entry to be deleted, and then shift the rest of the 760 node up to cover the deleted node *) 761 ndx^.Changed:=TRUE; 762 offset := ((ndx^.posarray[deletelevel].keynum + 1) * (ndx^.Header.entrylength)) + 4; 763 Move(ADR(ndx^.posarray[deletelevel].buffer^.node[offset]), 764 ADR(ndx^.posarray[deletelevel].buffer^.node[offset-ndx^.Header.entrylength]), 765 NodeSize-offset); 766 (* not correct or nessisary ? 767 Fill(ADR(ndx^.posarray[deletelevel].buffer^. 768 node[offset -ndx^.Header.entrylength]), ndx^.Header.entrylength, 0C);*) 769 770 (* Next decrement the number of keys in the node and 771 write the decremented number in the first byte of the 772 node. *) 773 empty:=FALSE; 774 empty:=(ndx^.posarray[deletelevel].buffer^.node[0])=0C; 775 IF NOT empty THEN 776 DEC(ndx^.posarray[deletelevel].buffer^.node[0]); 777 empty:=(ndx^.posarray[deletelevel].buffer^.node[0]=0C) AND 778 (deletelevel =ndx^.depth) 779 END; 780 IF (deletelevel > 0) 781 THEN 782 IF empty 783 THEN (* THE NODE IS EMPTY *) 784 (* posarray must be good *) 785 (* put in freenode list *) 786 Move(ADR(ndx^.Header.FreeList), 787 ADR(ndx^.posarray[deletelevel].buffer^.node),4); 788 ndx^.Header.FreeList:=ndx^.posarray[deletelevel].buffer^.number; 789 DeleteEntry(ndx,deletelevel-1); 790 ELSE; 791 (* Check to see if deleted top node *) 792 IF deletelevel=ndx^.depth 793 THEN 794 offset:=1 795 ELSE 796 offset:=0 797 END; 798 IF ndx^.posarray[deletelevel].keynum = 799 ( ORD(ndx^.posarray[deletelevel].buffer^.node[0])+1-offset) 800 THEN 801 key:=GetKeyPtr(ndx^.posarray[deletelevel].buffer^.node, 802 ndx,ndx^.posarray[deletelevel].keynum-1); 803 AdjustUpperNode(ndx, 804 key^.value, 805 deletelevel); 806 END; 807 END; 808 END; (* if *) 809 810 IF ndx^.Safety OR NOT ndx^.Exclusive 811 THEN 812 WriteNode(ndx, ndx^.posarray[deletelevel].buffer^.number, 813 ndx^.posarray[deletelevel].buffer^.node); 814 ELSE 815 ndx^.posarray[deletelevel].buffer^.NeedToWrite:=TRUE; 816 END; 817 END DeleteEntry; 818 819 820 PROCEDURE DeleteCurrentEntry( ndx: DBIndex); 821 VAR 822 rec:LONGINT; 823 BEGIN 824 IF OpenIndex(ndx)=FALSE 825 THEN 826 WARN('Error opening Index in DeleteCurrentEntry'); 827 END; 828 rec:=ndx^.currentkey^.recordnum; 829 EnterLock(ndx); 830 IF rec=ndx^.currentkey^.recordnum THEN (* do not delete if not there *) 831 DeleteEntry(ndx, ndx^.depth); 832 END; 833 ExitLock(ndx); 834 END DeleteCurrentEntry; 835 836 PROCEDURE UpdateIndexHeader(ndx :DBIndex ); 837 838 VAR 839 Buffer:IndexBuffer; 840 BEGIN 841 IF NOT ndx^.open 842 THEN 843 RETURN; 844 END; 845 HandleIO.SetFilePtr(ndx^.f,HandleIO.FromStart,VAL(LONGINT,0)); 846 StringIO.PrintMessage( 847 HandleIO.BlockWrite(ndx^.f,ADR(ndx^.Header),SIZE(ndx^.Header))); 848 IF NOT ndx^.Safety AND ndx^.Exclusive 849 THEN (* Write out Buffers if safety off*) 850 Buffer:=ndx^.first; 851 WHILE Buffer#NIL 852 DO 853 IF Buffer^.NeedToWrite 854 THEN 855 WriteNode(ndx,Buffer^.number,Buffer^.node); 856 Buffer^.NeedToWrite:=FALSE; 857 END; 858 Buffer:=Buffer^.next; 859 END; 860 END; 861 END UpdateIndexHeader; 862 863 864 865 PROCEDURE InsertEntry( ndx: DBIndex; 866 kstr: ARRAY OF CHAR; 867 recno: LONGINT); 868 VAR i, level, middle: CARDINAL; 869 tempkey:EntryType; 870 NewRoot,NewBuffer:IndexBuffer; 871 noOverflow,InHighNode: BOOLEAN; 872 (*diag,*)oldnodenum, newnodenum, lowernodenum: LONGINT; 873 key: 874 RECORD 875 CASE :BOOLEAN OF 876 TRUE:num:Real8;| 877 FALSE:str:ARRAY[0..7] OF CHAR; 878 END; 879 END; 880 881 882 883 PROCEDURE AddKeyTo( lower, recnum: LONGINT; VAR node: NodeType; 884 val: ARRAY OF CHAR; NewKey:BOOLEAN); 885 (* This procedure assumes that there is room in the node for another 886 key entry; it does not test for correct positioning, it assumes 887 that the ndx^.posarray has been correctly updated by all prior 888 operations *) 889 VAR moveblocksize, i, entrypos, keystomove : CARDINAL; 890 891 BEGIN 892 (* consider changing to copy into entry then move all *) 893 entrypos := ndx^.posarray[level].keynum; 894 keystomove := ORD(node[0])-entrypos+1; 895 node[0] := CHR(ORD(node[0])+1); 896 i := 4 + (entrypos * ndx^.Header.entrylength); (* 4 bytes reserved for key count *) 897 (* make space for the new entry *) 898 moveblocksize := keystomove*ndx^.Header.entrylength+4; 899 ShiftArrayRight((* from *) ADR(node[i]), 900 (* size *) moveblocksize , 901 (* distance *) ndx^.Header.entrylength); 902 Move(ADR(recnum), ADR(node[i+4]), 4); 903 (* trims to size *) 904 Move(ADR(val),ADR(node[i+8]), ndx^.Header.entrylength - 8); 905 Move(ADR(lower), ADR(node[i]), 4); 906 (* the Move statement modifies the pointer after the inserted key 907 so that it points to the appropriate node. It is hard to 908 remember that the only reason an entry would be inserted into 909 a node other than a leaf node is because the lower node was split. *) 910 IF (ndx^.depth=level) 911 THEN 912 IF NewKey THEN 913 ndx^.currentkey:=ADR(node[i]) 914 END; 915 IF (keystomove=1) 916 THEN 917 AdjustUpperNode(ndx,val,level) 918 END; 919 END; 920 END AddKeyTo; 921 922 PROCEDURE Split(VAR old, new: IndexBuffer); 923 VAR 924 c:CHAR; 925 key:EntryType; 926 i, j, middlekeypos, 927 keysinold: CARDINAL; 928 BEGIN 929 keysinold := ORD(old^.node[0]); 930 new^.node := old^.node; 931 (* if a key has been handed up from a split node it points to the 932 newnode created by the last split *) 933 (* save node numbers in case root node is being split *) 934 newnodenum:=new^.number; 935 oldnodenum:=old^.number; 936 middle := (ndx^.Header.keyspernode DIV 2); 937 keysinold := keysinold - middle; 938 middlekeypos := 4 + (middle)* ndx^.Header.entrylength; 939 (* middlekeypos is the END of the middlekey *) 940 Fill(ADR(new^.node[middlekeypos]), NodeSize - middlekeypos, 0C); 941 (* the new node gets the first keys, the rest are nulled out *) 942 Move(ADR((*from*) old^.node[middlekeypos]), 943 (* to *) ADR(old^.node[4]), 944 (*size*) (NodeSize-middlekeypos)); 945 Fill(ADR(old^.node[8+keysinold*ndx^.Header.entrylength]), 946 NodeSize-(8+keysinold*ndx^.Header.entrylength),0C); 947 new^.node[0] := CHR(middle); 948 old^.node[0] := CHR(keysinold); 949 (* IF new=old 950 THEN 951 HALT; 952 END; (* diag *) 953 *) 954 IF ndx^.posarray[level].keynum <= middle THEN 955 (* insert into new node ( lowernode ) *) 956 (* new is yet in posarray so must trick Addkeyto to not 957 try and adjust upper node as it will be inserted latter*) 958 INC(new^.node[0]); 959 AddKeyTo(lowernodenum, recno, new^.node, kstr,TRUE); 960 DEC(new^.node[0]); 961 INC(middle); (* because an entry has been inserted ahead of it *) 962 GetKey(new^.node,ndx,middle-1,key); (* get key value to 963 insert in lowernode before we lose it *) 964 IF lowernodenum#VAL(LONGINT,0) 965 THEN (* not at leaf DBASEIII does not store entire lastkey in non leaf 966 nodes *) 967 DEC(new^.node[0]) 968 END; 969 (* force new pos array *) 970 InHighNode:=FALSE; 971 (* need to put writes here because the readintoarray 972 will lose a node *) 973 IF ndx^.Safety OR NOT ndx^.Exclusive 974 THEN 975 WriteNode(ndx, new^.number, new^.node); 976 WriteNode(ndx, old^.number, old^.node); 977 ELSE 978 new^.NeedToWrite:=TRUE; 979 old^.NeedToWrite:=TRUE; 980 END; 981 ReadIntoArray(ndx, new^.number, level); 982 old^.Lock:=FALSE;(* unlock other buffer *) 983 ELSE 984 (* insert into old (high) node *) 985 GetKey(new^.node,ndx,middle-1,key); (* get key value to 986 insert in lowernode before we lose it *) 987 IF lowernodenum#VAL(LONGINT,0) 988 THEN (* not at leaf DBASEIII does not store entire lastkey in non leaf 989 nodes *) 990 DEC(new^.node[0]) 991 END; 992 ndx^.posarray[level].keynum := (ndx^.posarray[level].keynum - middle) ; 993 AddKeyTo(lowernodenum, recno, old^.node, kstr,TRUE); 994 IF ndx^.Safety OR NOT ndx^.Exclusive 995 THEN 996 WriteNode(ndx, new^.number, new^.node); 997 WriteNode(ndx, old^.number, old^.node); 998 ELSE 999 new^.NeedToWrite:=TRUE; 1000 old^.NeedToWrite:=TRUE; 1001 END; 1002 InHighNode:=TRUE; 1003 (* force new pos array *) 1004 (* ReadIntoArray(ndx, old^.number, level); not neeed *) 1005 new^.Lock:=FALSE;(* unlock other buffer *) 1006 END; 1007 1008 (* in order to place new node in tree, act as if was inserting 1009 the last key in the lower(new) node, so must save info *) 1010 lowernodenum:=newnodenum; 1011 Assign(key.value,kstr); 1012 recno:=key.recordnum; 1013 END Split; 1014 1015 PROCEDURE Balance(level:CARDINAL); 1016 VAR 1017 offset, 1018 count, 1019 insertpos, 1020 keystomove, 1021 keys, 1022 downkeys, 1023 upkeys:CARDINAL; 1024 UpBuffer,DownBuffer:IndexBuffer; 1025 upkey,tempkey:EntryType; 1026 (* found:BOOLEAN;(*diag *) *) 1027 1028 PROCEDURE Movekeys ; 1029 BEGIN 1030 1031 noOverflow:=TRUE; 1032 IF upkeys > downkeys 1033 THEN (* move to lower node *) 1034 keystomove:=(keys-downkeys+1) DIV 2; 1035 count:=keystomove; 1036 WHILE count>0 DO 1037 (* get key to move and save*) 1038 (* remove from bottom place on top *) 1039 GetKey(ndx^.posarray[level].buffer^.node, 1040 ndx, 0, tempkey); 1041 ndx^.posarray[level].keynum:=0; 1042 DeleteEntry(ndx, level); 1043 ndx^.posarray[level].keynum:=ORD(DownBuffer^.node[0]); 1044 DEC(ndx^.posarray[level-1].keynum); 1045 AddKeyTo(tempkey.lowernode,tempkey.recordnum, 1046 DownBuffer^.node,tempkey.value,FALSE);(* addkey does not write *) 1047 INC(ndx^.posarray[level-1].keynum); 1048 DEC(count); 1049 END (* while *); 1050 IF insertpos >= keystomove THEN 1051 (* insert into new node ( lowernode ) *) 1052 ndx^.posarray[level].keynum:=insertpos-keystomove; 1053 AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE); 1054 (* force new pos array *) 1055 (* need to put writes here because the readintoarray 1056 will lose a node *) 1057 IF ndx^.Safety OR NOT ndx^.Exclusive 1058 THEN 1059 WriteNode(ndx, ndx^.posarray[level].buffer^.number, 1060 ndx^.posarray[level].buffer^.node); 1061 WriteNode(ndx, DownBuffer^.number, DownBuffer^.node); 1062 ELSE 1063 ndx^.posarray[level].buffer^.NeedToWrite:=TRUE; 1064 DownBuffer^.NeedToWrite:=TRUE; 1065 END; 1066 ELSE 1067 (* insert into other node *) 1068 ndx^.posarray[level].keynum :=downkeys+insertpos; 1069 DEC(ndx^.posarray[level-1].keynum); 1070 AddKeyTo(lowernodenum, recno, DownBuffer^.node, kstr,TRUE); 1071 IF ndx^.Safety OR NOT ndx^.Exclusive 1072 THEN 1073 WriteNode(ndx, ndx^.posarray[level].buffer^.number, 1074 ndx^.posarray[level].buffer^.node); 1075 WriteNode(ndx, DownBuffer^.number, DownBuffer^.node); 1076 ELSE 1077 ndx^.posarray[level].buffer^.NeedToWrite:=TRUE; 1078 DownBuffer^.NeedToWrite:=TRUE; 1079 END; 1080 (* force new pos array *) 1081 ReadIntoArray(ndx, DownBuffer^.number, level); 1082 END; 1083 1084 ELSE (* move to upper *) 1085 keystomove:=(keys-upkeys+1) DIV 2; 1086 count:=keystomove; 1087 WHILE count>0 DO 1088 (* get key to move and save*) 1089 (* remove from top place on bottom *) 1090 GetKey(ndx^.posarray[level].buffer^.node, 1091 ndx,ORD(ndx^.posarray[level].buffer^.node[0])-1, tempkey); 1092 ndx^.posarray[level].keynum:= 1093 ORD(ndx^.posarray[level].buffer^.node[0])-1; 1094 DeleteEntry(ndx, level); 1095 ndx^.posarray[level].keynum:=0; 1096 AddKeyTo(tempkey.lowernode,tempkey.recordnum, 1097 UpBuffer^.node,tempkey.value,FALSE);(* addkey does not write *) 1098 DEC(count); 1099 END (* while *); 1100 1101 (* delete key fixed upper node *) 1102 IF insertpos < ORD(ndx^.posarray[level].buffer^.node[0]) THEN 1103 (* insert into old node *) 1104 ndx^.posarray[level].keynum:=insertpos; 1105 AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE); 1106 (* force new pos array *) 1107 (* need to put writes here because the readintoarray 1108 will lose a node *) 1109 IF ndx^.Safety OR NOT ndx^.Exclusive 1110 THEN 1111 WriteNode(ndx, ndx^.posarray[level].buffer^.number, 1112 ndx^.posarray[level].buffer^.node); 1113 WriteNode(ndx, UpBuffer^.number, UpBuffer^.node); 1114 ELSE 1115 ndx^.posarray[level].buffer^.NeedToWrite:=TRUE; 1116 UpBuffer^.NeedToWrite:=TRUE; 1117 END; 1118 ELSE 1119 (* insert into other node *) 1120 ndx^.posarray[level].keynum := 1121 insertpos-ORD(ndx^.posarray[level].buffer^.node[0]); 1122 INC(ndx^.posarray[level-1].keynum); 1123 AddKeyTo(lowernodenum, recno, UpBuffer^.node, kstr,TRUE); 1124 IF ndx^.Safety OR NOT ndx^.Exclusive 1125 THEN 1126 WriteNode(ndx, ndx^.posarray[level].buffer^.number, 1127 ndx^.posarray[level].buffer^.node); 1128 WriteNode(ndx, UpBuffer^.number, UpBuffer^.node); 1129 ELSE 1130 ndx^.posarray[level].buffer^.NeedToWrite:=TRUE; 1131 UpBuffer^.NeedToWrite:=TRUE; 1132 END; 1133 (* force new pos array *) 1134 ReadIntoArray(ndx, UpBuffer^.number, level); 1135 END; 1136 1137 END; 1138 1139 END Movekeys ; 1140 1141 PROCEDURE CanBalance():BOOLEAN ; 1142 BEGIN 1143 IF (upkeys>=keys) AND (downkeys>=keys) 1144 THEN 1145 RETURN FALSE; 1146 ELSIF (upkeys>downkeys) AND (keys-downkeys=1) 1147 THEN (* downkey has only one place *) 1148 IF ndx^.posarray[level].keynum=0 THEN 1149 RETURN FALSE; 1150 END; 1151 ELSIF (upkeys<=downkeys) AND (keys-upkeys=1) 1152 THEN (* upkey has only one place *) 1153 IF (ndx^.posarray[level].keynum+1)>=keys THEN 1154 RETURN FALSE; 1155 END; 1156 END; 1157 RETURN TRUE; 1158 1159 END CanBalance; 1160 1161 BEGIN (*balance *) 1162 downkeys:=65000; 1163 upkeys:=65000; 1164 DownBuffer:=NIL; 1165 UpBuffer:=NIL; 1166 IF (level=0) OR (level#ndx^.depth) 1167 THEN 1168 (* Because of complications do not balace nonleaf nodes *) 1169 NewNode(ndx,NewBuffer); 1170 Split(ndx^.posarray[level].buffer, NewBuffer); 1171 RETURN; 1172 END; 1173 insertpos:=ndx^.posarray[level].keynum; 1174 keys:=ORD(ndx^.posarray[level].buffer^.node[0]); 1175 IF ndx^.posarray[level-1].keynum < 1176 (ORD(ndx^.posarray[level-1].buffer^.node[0])-1) 1177 THEN (* get uper node (same level *) 1178 GetKey(ndx^.posarray[level-1].buffer^.node, 1179 ndx, ndx^.posarray[level-1].keynum+1, tempkey); 1180 ReadNode(ndx,tempkey.lowernode,UpBuffer); 1181 UpBuffer^.Lock:=TRUE; 1182 upkeys:=ORD(UpBuffer^.node[0]); 1183 END; 1184 IF ndx^.posarray[level-1].keynum > 0 1185 THEN (* get lowernode (same level) *) 1186 GetKey(ndx^.posarray[level-1].buffer^.node, 1187 ndx, ndx^.posarray[level-1].keynum-1, tempkey); 1188 ReadNode(ndx,tempkey.lowernode,DownBuffer); 1189 DownBuffer^.Lock:=TRUE; 1190 downkeys:=ORD(DownBuffer^.node[0]); 1191 END; 1192 (* determine if one can just move keys *) 1193 IF CanBalance() 1194 THEN 1195 Movekeys; 1196 (* ChkInd.NDXChk(ndx); 1197 FindPositionCh(ndx,kstr,found); 1198 IF NOT found THEN HALT END;*) 1199 ELSE 1200 NewNode(ndx,NewBuffer); 1201 Split(ndx^.posarray[level].buffer, NewBuffer); 1202 END; 1203 IF DownBuffer#NIL THEN DownBuffer^.Lock:=FALSE END; 1204 IF UpBuffer#NIL THEN UpBuffer^.Lock:=FALSE END; 1205 END Balance; 1206 1207 BEGIN (* Insert Entry *) 1208 (* update current key to keep all up to date *) 1209 EnterLock(ndx); 1210 (* diag:=recno (* diag *);*) 1211 ndx^.Changed:=TRUE; 1212 InHighNode:=FALSE; 1213 (*IF ndx^.Header.NumType 1214 THEN 1215 Move(ADR(kstr),ADR(NewKey.value),8); 1216 ELSE 1217 Assign(kstr,NewKey.value); 1218 END; 1219 NewKey.lowernode:=VAL(LONGINT,0); 1220 NewKey.recordnum:=recno; *) 1221 level := ndx^.depth; 1222 lowernodenum := VAL(LONGINT,0); 1223 REPEAT 1224 noOverflow := ORD(ndx^.posarray[level].buffer^.node[0]) < ndx^.Header.keyspernode; 1225 IF noOverflow THEN 1226 AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE); 1227 IF InHighNode 1228 THEN 1229 INC(ndx^.posarray[level].keynum); 1230 END; 1231 IF ndx^.Safety OR NOT ndx^.Exclusive 1232 THEN 1233 WriteNode(ndx, ndx^.posarray[level].buffer^.number, 1234 ndx^.posarray[level].buffer^.node); 1235 ELSE 1236 ndx^.posarray[level].buffer^.NeedToWrite:=TRUE; 1237 END; 1238 ELSE 1239 Balance(level); 1240 (* find out where kstr belongs and insert it *) 1241 IF level = 0 THEN (* the root node was split *) 1242 INC(ndx^.buffsize,2);(* enlarge buffer *) 1243 INC(ndx^.depth); (* prepare to add another level to the map *) 1244 FOR i := ndx^.depth TO 1 BY -1 DO 1245 ndx^.posarray[i] := ndx^.posarray[i-1] 1246 END; (* slide all the keypositions in the map up one notch *) 1247 NewNode(ndx,NewRoot); 1248 (* force NewRoot into root position *) 1249 ndx^.Header.rootptr := NewRoot^.number; 1250 ReadIntoArray(ndx, NewRoot^.number, 0); 1251 (* KEYNUMBERS BEGIN at ZERO *) 1252 ndx^.posarray[0].keynum := 0; 1253 NewBuffer^.Lock:=FALSE; 1254 AddKeyTo(oldnodenum, VAL(LONGINT,0), NewRoot^.node, '',FALSE); 1255 (* the new node initially contains no key but points to the 1256 new node which was written when the old root was split *) 1257 (* the number of entries in the node is now 1 *) 1258 (* now a key is inserted ahead of the 'keyless' pointer *) 1259 AddKeyTo(newnodenum, recno, NewRoot^.node, kstr,TRUE); 1260 ndx^.posarray[0].buffer^.node[0]:= 1C;(* top key does not count *) 1261 IF ndx^.posarray[1].buffer^.number = newnodenum THEN 1262 ndx^.posarray[0].keynum := 0 1263 ELSE 1264 ndx^.posarray[0].keynum := 1 1265 END; 1266 IF ndx^.Safety OR NOT ndx^.Exclusive 1267 THEN 1268 WriteNode(ndx, ndx^.Header.rootptr, NewRoot^.node); 1269 ELSE 1270 NewRoot^.NeedToWrite:=TRUE; 1271 END; 1272 noOverflow := TRUE; 1273 END (* if *); 1274 (* if safety is on update header when a node splits *) 1275 IF ndx^.Safety OR NOT ndx^.Exclusive 1276 THEN 1277 UpdateIndexHeader(ndx); 1278 END; 1279 1280 END (* if *); 1281 IF level > 0 THEN 1282 DEC(level); 1283 END (* if *); 1284 UNTIL noOverflow; 1285 ExitLock(ndx); 1286 (* ChkInd.NDXChk(ndx);*) 1287 (* !!!! diag *) 1288 (* IF diag # ndx^.currentkey^.recordnum 1289 THEN HALT END (*diag *); *) 1290 END InsertEntry; 1291 1292 PROCEDURE BuildIndex(ndx: DBIndex; 1293 keyexp: ARRAY OF CHAR):CARDINAL; 1294 VAR 1295 Fptr:DBFieldPtr; 1296 BEGIN 1297 IF NOT OpenDBF(ndx^.alias) 1298 THEN (* check to make sure the file is open *) 1299 WARN('Not able to DBFile file in BuildIndex'); 1300 END; 1301 CrunchBlanks(keyexp); 1302 CAPstr(keyexp); 1303 ndx^.KeyNumber:=PosOfField(ndx^.alias,keyexp); 1304 IF ndx^.KeyNumber=0 THEN 1305 WARN('Bad index expression in BuildIndex'); 1306 END; 1307 Fptr:=FieldList(ndx^.alias); 1308 RETURN BuildCompIndex(ndx,Fptr^[ndx^.KeyNumber].fldtype, 1309 keyexp,Fptr^[ndx^.KeyNumber].size); 1310 END BuildIndex; 1311 1312 PROCEDURE BuildCompIndex( ndx: DBIndex; 1313 type:CHAR; (* C or N *) 1314 keyexp:ARRAY OF CHAR; 1315 size: CARDINAL 1316 ):CARDINAL; 1317 VAR oldbuffsize, 1318 olddbbuffersize, 1319 i, 1320 ActionTaken: CARDINAL; 1321 worknode: NodeType; 1322 recordnumber: LONGINT; 1323 oldsafety, 1324 oldexclusive:BOOLEAN; 1325 FileError: StringIO.ErrorMessage; 1326 1327 BEGIN 1328 IF NOT OpenDBF(ndx^.alias) THEN 1329 WARN('Unable to open DBFile in BuildCompIndex'); 1330 END; 1331 CloseIndex(ndx); 1332 IF ndx^.Init#InitCode 1333 THEN 1334 WARN('Uninitalized DBIndex in BuildCompIndex'); 1335 END; 1336 InitPosarray(ndx); 1337 (* open exclusive *) 1338 (* create if the file does not exist; truncate if it does exist *) 1339 FileError := FAPI.DOSOPEN( ADR(ndx^.name), 1340 ADR(ndx^.f), ADR(ActionTaken), VAL(LONGINT,1024), 1341 FAPI.FILE_NORMAL,CARDINAL( {1,4}),CARDINAL( {1,4}), 1342 VAL(LONGINT,0) ); 1343 IF FileError#0 THEN RETURN FileError END; 1344 Fill(ADR(ndx^.Header),SIZE(ndx^.Header),0); 1345 olddbbuffersize:=BufferSize(ndx^.alias); 1346 oldbuffsize:=ndx^.buffsize; 1347 oldsafety := ndx^.Safety; 1348 oldexclusive:=ndx^.Exclusive; 1349 SetDBBuffer( ndx^.alias,32000 ); 1350 IF ndx^.buffsize<400 THEN SetIndexBuffers(ndx,400) END; 1351 WITH ndx^ DO 1352 FOR i:=0 TO (Bins-1) DO 1353 Hash[i]:=NIL; 1354 END; 1355 Safety:=FALSE; 1356 Exclusive:=TRUE; 1357 Assign(keyexp,Header.KeyExpression); 1358 CrunchBlanks(Header.KeyExpression); 1359 CAPstr(Header.KeyExpression); 1360 KeyNumber := PosOfField(alias,Header.KeyExpression); 1361 Append(Header.KeyExpression,' ');(* do this to mimic dbase3 *) 1362 Header.rootptr := VAL(LONGINT,1); (* the root begins as the second block *) 1363 (* The anchor node is 0 *) 1364 Header.NumType := (type#'C'); 1365 IF type#'C' 1366 THEN 1367 Header.keylength:=8; 1368 Header.entrylength :=16; 1369 ELSE 1370 Header.keylength := size; 1371 Header.entrylength := Header.keylength + 2 * RecNumLen+1; 1372 (*add 1 and make even to mimic dbase3 *) 1373 IF ODD(Header.entrylength) THEN INC(Header.entrylength) END; 1374 END; 1375 1376 Header.keyspernode := (NodeSize - 8) DIV (Header.entrylength); 1377 (* a key 'entry' is made up of a pointer to a lower node and a 1378 record number in addition to the key value . After the last key 1379 entry there is a pointer to a lowerlevel node containing keys with 1380 values greater than or equal to the the value of the key in the 1381 last key entry *) 1382 Header.nextfreenode := VAL(LONGINT,2); 1383 open := TRUE; 1384 depth := 0; 1385 END; 1386 InitNode(worknode); 1387 WriteNode(ndx, VAL(LONGINT,1), worknode); 1388 recordnumber := VAL(LONGINT,1); 1389 WHILE recordnumber <= NumberRecords(ndx^.alias) DO 1390 ReadDBRec(ndx^.alias, recordnumber); 1391 (* change by ed ross*) 1392 IF ndx^.includedeleted OR NOT Deleted(ndx^.alias) 1393 THEN 1394 AddRecord(ndx^.alias, ndx); 1395 END; 1396 (* * *End of change by ed *) 1397 INC(recordnumber); 1398 END; 1399 CloseIndex(ndx); 1400 ndx^.Exclusive:=oldexclusive; 1401 ndx^.Safety:=oldsafety; 1402 ndx^.buffsize:= oldbuffsize; 1403 SetIndexBuffers(ndx,oldbuffsize); 1404 SetDBBuffer( ndx^.alias,olddbbuffersize ); 1405 RETURN 0; 1406 END BuildCompIndex; 1407 1408 PROCEDURE GoTop(ndx: DBIndex); 1409 VAR nextnodeptr: LONGINT; 1410 level: CARDINAL; 1411 BEGIN 1412 IF OpenIndex(ndx)=FALSE 1413 THEN 1414 WARN('Error opening Index in GoTop'); 1415 END; 1416 EnterLock(ndx); 1417 level := 0; 1418 ReadIntoArray(ndx, ndx^.Header.rootptr, level); 1419 Move(ADR(ndx^.posarray[level].buffer^.node[4]), ADR(nextnodeptr), 4); 1420 (* all searches commence with the root *) 1421 ndx^.posarray[level].keynum := FirstKey; 1422 WHILE nextnodeptr#VAL(LONGINT,0) DO 1423 INC(level); 1424 ReadIntoArray(ndx, nextnodeptr, level); 1425 ndx^.posarray[level].keynum := FirstKey; 1426 Move(ADR(ndx^.posarray[level].buffer^.node[4]), ADR(nextnodeptr), 4); 1427 END; 1428 ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx, FirstKey); 1429 ndx^.depth:=level; 1430 ExitLock(ndx); 1431 END GoTop; 1432 1433 PROCEDURE GoBottom( ndx: DBIndex); 1434 VAR 1435 level: CARDINAL; 1436 BEGIN 1437 IF OpenIndex(ndx)=FALSE 1438 THEN 1439 WARN('Error opening Index in GoBottom'); 1440 END; 1441 EnterLock(ndx); 1442 level := 0; 1443 ReadIntoArray(ndx, ndx^.Header.rootptr, level); 1444 ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx, 1445 ORD(ndx^.posarray[level].buffer^.node[0])); 1446 (* all searches commence with the root *) 1447 ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0]); 1448 WHILE ndx^.currentkey^.lowernode # VAL(LONGINT,0) DO 1449 INC(level); 1450 ReadIntoArray(ndx, ndx^.currentkey^.lowernode, level); 1451 ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0]); 1452 ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx, 1453 ORD(ndx^.posarray[level].buffer^.node[0])); 1454 END; 1455 ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0])-1; 1456 ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx, 1457 ORD(ndx^.posarray[level].buffer^.node[0])-1 ); 1458 ndx^.depth:=level; 1459 ExitLock(ndx); 1460 END GoBottom; 1461 1462 1463 PROCEDURE AddToUpdateList( alias: DBFile; ndx: 1464 DBIndex); 1465 BEGIN 1466 ndx^.UpdateList:=IndexList(alias); 1467 SetIndexList(alias,ndx); 1468 1469 END AddToUpdateList; 1470 1471 1472 PROCEDURE UpdateDBIndxes(alias:DBFile); 1473 VAR 1474 ndx:DBIndex; 1475 1476 PROCEDURE Update ; 1477 VAR 1478 NewKey,OldKey:ARRAY[0..MaxField-1] OF CHAR; 1479 found:BOOLEAN; 1480 num:LONGINT; 1481 1482 PROCEDURE KeyLocatedC():BOOLEAN ; 1483 VAR 1484 found:BOOLEAN; 1485 BEGIN 1486 FindPositionCh(ndx,OldKey,found); 1487 LOOP 1488 IF NOT Equal(OldKey,ndx^.currentkey^.value) 1489 THEN 1490 RETURN FALSE; 1491 END; 1492 IF (Record(alias) = ndx^.currentkey^.recordnum) 1493 THEN 1494 RETURN TRUE; 1495 END; 1496 IF NOT NextRecord(ndx,num) 1497 THEN 1498 RETURN FALSE; 1499 END; 1500 END; 1501 END KeyLocatedC ; 1502 1503 PROCEDURE KeyLocatedN():BOOLEAN ; 1504 VAR 1505 found:BOOLEAN; 1506 key:Real8; 1507 BEGIN 1508 IF NOT StrToReal(OldKey, 0,key) THEN key:=0.0 END; 1509 FindPositionN(ndx,OldKey,found); 1510 LOOP 1511 IF ndx^.numkey^.key # key 1512 THEN 1513 RETURN FALSE; 1514 END; 1515 IF (Record(alias) = ndx^.currentkey^.recordnum) 1516 THEN 1517 RETURN TRUE; 1518 END; 1519 IF NOT NextRecord(ndx,num) 1520 THEN 1521 RETURN FALSE; 1522 END; 1523 END; 1524 END KeyLocatedN ; 1525 1526 BEGIN 1527 IF NOT Appending(alias) 1528 THEN 1529 SetRecordMode(alias,ModBase3.Buffer); 1530 ndx^.KeyProc(alias,ndx,OldKey); 1531 SetRecordMode(alias,ModBase3.CurrentRec); 1532 ndx^.KeyProc(alias,ndx,NewKey); 1533 (* * * * * * * * * Changed by ed - delete index if deleting record* * * *) 1534 IF ndx^.includedeleted OR NOT Deleted(alias) 1535 THEN IF Equal(OldKey,NewKey) 1536 THEN 1537 RETURN 1538 END; 1539 END; 1540 IF Record(alias) # ndx^.currentkey^.recordnum 1541 THEN 1542 (* find and delete old key if exists *) 1543 IF ndx^.Header.NumType 1544 THEN 1545 found:=KeyLocatedN(); 1546 ELSE 1547 found:=KeyLocatedC(); 1548 END; 1549 ELSE 1550 found :=TRUE; 1551 END; 1552 IF found 1553 THEN 1554 DeleteCurrentEntry(ndx); 1555 ELSE 1556 found:=FALSE; (* debugger trap *) 1557 END; 1558 END; 1559 (* * * * * * * * Changed by Ed - same as above ** ** * * * *) 1560 IF ndx^.includedeleted OR NOT Deleted(alias) 1561 THEN 1562 AddRecord(alias,ndx); 1563 END; 1564 END Update; 1565 1566 BEGIN 1567 (* Nul Value of IndexList should be checked in Modbase *) 1568 ndx:=IndexList(alias); 1569 WHILE ndx#NIL DO 1570 IF OpenIndex(ndx)=FALSE 1571 THEN 1572 WARN('Error opening Index in UpdateDBIndxes'); 1573 END; 1574 EnterLock(ndx); 1575 Update; 1576 ExitLock(ndx); 1577 ndx:=ndx^.UpdateList; 1578 END (* while *); 1579 END UpdateDBIndxes; 1580 1581 PROCEDURE UpdateUnique( alias: DBFile; ndx: DBIndex):BOOLEAN; 1582 VAR 1583 NewKey,OldKey:ARRAY[0..MaxField-1] OF CHAR; 1584 found:BOOLEAN; 1585 1586 BEGIN 1587 IF OpenIndex(ndx)=FALSE 1588 THEN 1589 WARN('Error opening Index in UpdateUnique'); 1590 END; 1591 EnterLock(ndx); 1592 SetRecordMode(alias,ModBase3.CurrentRec); 1593 ndx^.KeyProc(alias,ndx,NewKey); 1594 IF NOT Appending(alias) 1595 THEN 1596 SetRecordMode(alias,ModBase3.Buffer); 1597 ndx^.KeyProc(alias,ndx,OldKey); 1598 SetRecordMode(alias,ModBase3.CurrentRec); 1599 IF Equal(OldKey,NewKey) 1600 THEN 1601 ExitLock(ndx); 1602 RETURN TRUE; 1603 END; 1604 END; 1605 IF ndx^.Header.NumType 1606 THEN 1607 FindPositionN(ndx,NewKey,found); 1608 ELSE 1609 FindPositionCh(ndx,NewKey,found); 1610 END; 1611 ExitLock(ndx); 1612 RETURN NOT found; 1613 END UpdateUnique; 1614 1615 1616 PROCEDURE SetSafetyOn( ndx: DBIndex); 1617 BEGIN 1618 UpdateIndex(ndx); 1619 ndx^.Safety:=TRUE; 1620 END SetSafetyOn; 1621 1622 1623 PROCEDURE SetSafetyOff( ndx: DBIndex); 1624 BEGIN 1625 ndx^.Safety:=FALSE; 1626 1627 END SetSafetyOff; 1628 1629 PROCEDURE SetIndexBuffers( ndx: DBIndex;Buffers:CARDINAL); 1630 VAR 1631 buffer:IndexBuffer; 1632 BEGIN 1633 WITH ndx^ DO 1634 buffsize := Max(Buffers,depth+6); 1635 buffer:=last; 1636 WHILE buffsize 0; 1875 IF anotherkey THEN 1876 (* there is another entry in the node *) 1877 (* note that the first entry is 0, so the number of the last entry 1878 is one less than the number of keys in the node *) 1879 WITH ndx^.posarray[level] DO 1880 DEC(keynum); 1881 key:=GetKeyPtr(buffer^.node, ndx, keynum); 1882 END; 1883 EXIT; 1884 ELSE 1885 IF level = 0 THEN 1886 EXIT 1887 ELSE 1888 DEC(level) 1889 END; 1890 END; 1891 END; (* LOOP *) 1892 IF anotherkey THEN 1893 LOOP 1894 IF key^.lowernode#VAL(LONGINT,0) THEN (* node is not a leaf node *) 1895 INC(level); 1896 ReadIntoArray(ndx, key^.lowernode, level); 1897 WITH ndx^.posarray[level] DO 1898 lastkey := ORD(buffer^.node[0]); 1899 keynum := lastkey; 1900 key:=GetKeyPtr(buffer^.node, ndx, lastkey); 1901 IF key^.lowernode=VAL(LONGINT,0) 1902 THEN (* backup one*) 1903 DEC(lastkey); 1904 keynum := lastkey; 1905 key:=GetKeyPtr(buffer^.node, ndx, lastkey); 1906 END; 1907 END; 1908 ELSE 1909 EXIT 1910 END; 1911 END; (* LOOP2 *) 1912 ndx^.depth:=level; 1913 ndx^.currentkey:=key; 1914 RETURN TRUE; 1915 ELSE 1916 ndx^.depth:=level; 1917 ndx^.currentkey:=key; 1918 RETURN FALSE; 1919 END; 1920 END PrevEntry; 1921 BEGIN 1922 IF OpenIndex(ndx)=FALSE 1923 THEN 1924 WARN('Error opening Index in PrevRecord'); 1925 END; 1926 EnterLock(ndx); 1927 IF PrevEntry(ndx, ndx^.depth) THEN 1928 recno := ndx^.currentkey^.recordnum; 1929 ExitLock(ndx); 1930 RETURN TRUE 1931 ELSE 1932 ExitLock(ndx); 1933 RETURN FALSE 1934 END; 1935 END PrevRecord; 1936 1937 PROCEDURE UpdateIndex( ndx :DBIndex); 1938 1939 BEGIN 1940 IF ndx^.open 1941 THEN 1942 EnterLock(ndx); 1943 UpdateIndexHeader(ndx); 1944 HandleIO.UpdateDisk(ndx^.f); 1945 ExitLock(ndx); 1946 END; 1947 END UpdateIndex; 1948 1949 PROCEDURE CloseIndex( ndx: DBIndex); 1950 VAR 1951 buffer:IndexBuffer; 1952 FileError: StringIO.ErrorMessage; 1953 BEGIN 1954 IF ndx = NIL 1955 THEN 1956 RETURN; 1957 END; 1958 IF NOT ndx^.open 1959 THEN 1960 RETURN; 1961 END; 1962 IF ndx^.Exclusive AND NOT ndx^.Safety 1963 THEN 1964 UpdateIndexHeader( ndx ); 1965 END; 1966 FileError := HandleIO.CloseHandle(ndx^.f); 1967 ndx^.open := FALSE; 1968 WHILE ndx^.currsize#0 DO 1969 buffer:=ndx^.last; 1970 RemoveBuffer(ndx,buffer); 1971 DosDealloc(buffer,SIZE(buffer^)); 1972 END; 1973 1974 END CloseIndex; 1975 1976 (* file locking procedures start here *) 1977 PROCEDURE EnterLock( ndx:DBIndex); 1978 VAR 1979 realkey:Real8; 1980 strkey:ARRAY[0..127] OF CHAR; 1981 buffer:IndexBuffer; 1982 ok,found:BOOLEAN; 1983 i, 1984 code, 1985 Old :CARDINAL; 1986 key,OldRecord:LONGINT; 1987 BEGIN 1988 (* lock file if needed *) 1989 INC(ndx^.Locked); 1990 IF (ndx^.Locked>1) OR ndx^.Exclusive THEN RETURN END; 1991 (* read Header*) 1992 StringIO.PrintMessage(Locks.LockFileRetry(ndx^.f,100,ndx^.name)); 1993 ndx^.Changed:=FALSE; 1994 IF ndx^.open=FALSE THEN RETURN END;(* this should only be in open index *) 1995 Old:=ndx^.Header.Flag; 1996 ReadHeader(ndx); 1997 IF Old=ndx^.Header.Flag THEN RETURN END; 1998 OldRecord:=ndx^.currentkey^.recordnum; 1999 IF ndx^.Header.NumType 2000 THEN 2001 realkey:=ndx^.numkey^.key; 2002 ELSE 2003 Assign(ndx^.currentkey^.value,strkey); 2004 END; 2005 (* purge buffers*) 2006 WHILE ndx^.currsize#0 DO 2007 buffer:=ndx^.last; (* it is forbidden here to have unwritten data *) 2008 IF buffer^.NeedToWrite THEN (* not needed when debugged *) 2009 WARN('buffer not writen in EnterLock'); 2010 END; 2011 RemoveBuffer(ndx,buffer); 2012 RemoveFromTable(ndx,buffer); 2013 DosDealloc(buffer,SIZE(buffer^)); 2014 END; 2015 FOR i:= 0 TO ndx^.depth DO 2016 ndx^.posarray[i].buffer:=NIL; 2017 END; 2018 IF ndx^.Header.NumType 2019 THEN 2020 FindPositionR(ndx,realkey,found); 2021 ELSE 2022 FindPositionCh(ndx,strkey,found); 2023 END; 2024 IF NOT found 2025 THEN RETURN (* key must have been removed *) 2026 END; 2027 REPEAT 2028 IF OldRecord=ndx^.currentkey^.recordnum 2029 THEN RETURN END; (* we got it*) 2030 found:=NextRecord(ndx,key); 2031 IF ndx^.Header.NumType 2032 THEN 2033 ok:=(realkey=ndx^.numkey^.key); 2034 ELSE 2035 ok:=Equal(ndx^.currentkey^.value,strkey); 2036 END; 2037 UNTIL NOT found OR NOT ok; 2038 found:=PrevRecord(ndx,key); (* goback one*) 2039 END EnterLock; 2040 2041 PROCEDURE ExitLock( ndx:DBIndex); 2042 VAR 2043 code:CARDINAL; 2044 BEGIN 2045 DEC(ndx^.Locked); 2046 (* If No change or exclusive *) 2047 IF ndx^.Exclusive OR ( ndx^.Locked#0) THEN RETURN END; 2048 IF ndx^.Changed 2049 THEN 2050 INC(ndx^.Header.Flag); (* indicate change *) 2051 WriteHeader(ndx); (* write header *) 2052 END; (* if ndx^ changed *) 2053 code:=Locks.UnLockFile(ndx^.f); 2054 IF code#0 THEN WARN('Lock error in ExitLock') END; 2055 END ExitLock; 2056 2057 BEGIN; 2058 UpDateIndexes:=UpdateDBIndxes; 2059 2060 END DBIndxes. 2061 36 errors