home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / Libraries / PNL Libraries / MyAssocStrings.p < prev    next >
Encoding:
Text File  |  1994-12-14  |  2.9 KB  |  147 lines  |  [TEXT/CWIE]
  1. unit MyAssocStrings;
  2.  
  3. interface
  4.  
  5. {$IFC undefined THINK_Pascal}
  6.     uses
  7.         Memory;
  8. {$ENDC}
  9.  
  10.     procedure AssocCreate (var h: handle);
  11.     procedure AssocDestroy (var h: handle);
  12.     function AssocCount (h: handle): longInt;
  13.     procedure AssocGetIndexedKey (h: handle; index: longInt; var key, data: str255);
  14.     procedure AssocGet (h: handle; key: str255; var data: str255);
  15.     procedure AssocSet (h: handle; key, data: str255);
  16.     procedure AssocDelete (h: handle; key: str255);
  17.  
  18. implementation
  19.  
  20.     uses
  21. {$IFC undefined THINK_Pascal}
  22.         Packages,ToolUtils,
  23. {$ENDC}
  24.         QLowLevel;
  25.  
  26.     function GetByte (p: univ Ptr; offset: longint): integer;
  27.     inline
  28.         $201F, $D09F, $2040, $4240, $1010, $3E80;
  29.  
  30.     procedure AssocCreate (var h: handle);
  31.     begin
  32.         h := NewHandle(0);
  33.     end;
  34.  
  35.     procedure AssocDestroy (var h: handle);
  36.     begin
  37.         DisposeHandle(h);
  38.         h := nil;
  39.     end;
  40.  
  41.     procedure Next (h: handle; var pos: longInt);
  42.     begin
  43.         pos := pos + GetByte(h^, pos) + 1;
  44.     end;
  45.  
  46.     procedure CopyString (h: handle; pos: longInt; var s: str255);
  47.     begin
  48.         BlockMove(AddPtrLong(h^, pos), @s, GetByte(h^, pos) + 1);
  49.     end;
  50.  
  51.     function AssocCount (h: handle): longInt;
  52.         var
  53.             pos, size: longInt;
  54.             count: longInt;
  55.     begin
  56.         count := 0;
  57.         size := GetHandleSize(h);
  58.         pos := 0;
  59.         while pos < size do begin
  60.             Next(h, pos);
  61.             Next(h, pos);
  62.             count := count + 1;
  63.         end;
  64.         AssocCount := count;
  65.     end;
  66.  
  67.     procedure AssocGetIndexedKey (h: handle; index: longInt; var key, data: str255);
  68.         var
  69.             pos, size: longInt;
  70.     begin
  71.         size := GetHandleSize(h);
  72.         pos := 0;
  73.         while (pos < size) & (index > 1) do begin
  74.             Next(h, pos);
  75.             Next(h, pos);
  76.             index := index - 1;
  77.         end;
  78.         if (pos < size) & (index = 1) then begin
  79.             CopyString(h, pos, key);
  80.             Next(h, pos);
  81.             CopyString(h, pos, data);
  82.         end
  83.         else begin
  84.             key := '';
  85.             data := '';
  86.         end;
  87.     end;
  88.  
  89.     function GetPos (h: handle; var key: str255; var pos: longInt): boolean;
  90.         var
  91.             size: longInt;
  92.             thiskey: str255;
  93.     begin
  94.         GetPos := false;
  95.         size := GetHandleSize(h);
  96.         pos := 0;
  97.         while pos < size do begin
  98.             CopyString(h, pos, thiskey);
  99.             if IUEqualString(thiskey, key) = 0 then begin
  100.                 GetPos := true;
  101.                 leave;
  102.             end;
  103.             Next(h, pos);
  104.             Next(h, pos);
  105.         end;
  106.     end;
  107.  
  108.     procedure AssocGet (h: handle; key: str255; var data: str255);
  109.         var
  110.             pos: longInt;
  111.     begin
  112.         data := '';
  113.         if GetPos(h, key, pos) then begin
  114.             Next(h, pos);
  115.             CopyString(h, pos, data);
  116.         end;
  117.     end;
  118.  
  119.     procedure AssocSet (h: handle; key, data: str255);
  120.         var
  121.             err: OSErr;
  122.             pos: longInt;
  123.     begin
  124.         if GetPos(h, key, pos) then begin
  125.             Next(h, pos);
  126.             pos := Munger(h, pos, nil, GetByte(h^, pos) + 1, @data, length(data) + 1);
  127.         end
  128.         else begin
  129.             err := PtrAndHand(@key, h, length(key) + 1);
  130.             err := PtrAndHand(@data, h, length(data) + 1);
  131.         end;
  132.     end;
  133.  
  134.     procedure AssocDelete (h: handle; key: str255);
  135.         var
  136.             err: OSErr;
  137.             pos, posn: longInt;
  138.     begin
  139.         if GetPos(h, key, pos) then begin
  140.             posn := pos;
  141.             Next(h, posn);
  142.             Next(h, posn);
  143.             pos := Munger(h, pos, nil, posn - pos, @pos, 0);
  144.         end;
  145.     end;
  146.  
  147. end.