Store1.pas

   1 UNIT Store1;
   2 {Take tracks of files in store}
   3 {just simple, no cleaning, etc}
   4 INTERFACE
   5 uses SysUtils;
   6
   7 type
   8 tfid=array [0..19] of byte;
   9 tStoreObjectInfo=object
  10  final:boolean;    {hash matched}
  11  rc:Word; {0=no error 1=not found, other}
  12  length:LongWord;  {the whole file}
  13  seglen:longword;  {from cur to end of segment}
  14  offset:LongWord;  {only valid when reading}
  15  name:tFID;
  16
  17  procedure Open(const fid:tfid);
  18  procedure Close;
  19  procedure ReadSeg(into:pointer; ofs:LongWord; len:word);
  20  function  SegmentLength(ofs:LongWord): LongWord;
  21  procedure GetSegAfter(ofs:LongWord; out base:LongWord; out limit:LongWord);
  22  procedure EnableWrite(const fid:tFID);
  23  procedure SetFLength(len:LongWord);
  24  procedure WriteSeg(ofs:LongWord;len:word;data:pointer);
  25  procedure VerifyAndReset;
  26  procedure GetMiss(out ofs:LongWord; out len:LongWord; var state:pointer); unimplemented;
  27  procedure GetMiss(out ofs:LongWord; out len:LongWord); deprecated;
  28  private
  29  dh:tHandle; {handle to the data file}
  30  filename:string[80];
  31  segi:pointer{to seg info obj};
  32  procedure SegSeek(ofs:longword); deprecated;
  33 end;
  34 tObjectInfo=tStoreObjectInfo;
  35
  36 operator :=(a:string) r:tFID;
  37 operator :=(a:tFID) r:string;
  38 {Should consult Download on non-final files}
  39
  40 IMPLEMENTATION
  41 uses SHA1;
  42
  43 type
  44 tSegStatic=packed object
  45  first,after:LongWord;
  46  end;
  47 tSeg_ptr=^tSeg;
  48 tSeg=object(tSegStatic)
  49  next:tSeg_ptr;
  50  end;
  51 tSegInfo_ptr=^tSegInfo;
  52 pSegInfo=tSegInfo_ptr;
  53 tSegInfo=object
  54  cache:^tSeg;
  55  name:tFID;
  56  refc:byte;
  57  next:tSegInfo_ptr;
  58  finalized:boolean;
  59  procedure SetSeg(ofs,len:LongWord; state:boolean);
  60  function GetSegLen(ofs:LongWord):LongWord;
  61  procedure Free;
  62  end;
  63 var SegInfoChain:^tSegInfo;
  64
  65 type tFileNameVar=(fvFinal,fvPart,fvInfo);
  66 procedure mkfilen(var d:string; flag:tFileNameVar; const fid:tfid);
  67  function hc(b:byte):char;
  68   begin
  69   if b<10 then hc:=char(ord('0')+b)
  70           else hc:=char(ord('a')-10+b);
  71   end;
  72  var b,i:byte;
  73  begin
  74  d:='obj/';
  75  b:=system.length(d);
  76  SetLength(d,b+40);
  77  inc(b);
  78  for i:=0 to 19 do begin
  79   d[b+(i*2)]:=hc(fid[i] shr 4);
  80   d[b+(i*2)+1]:=hc(fid[i] and $F);
  81  end;
  82  case flag of
  83   fvPart: d:=d+'.prt';
  84   fvInfo: d:=d+'.seg';
  85   fvFinal:;
  86  end;
  87 end;
  88
  89 function GetSegInfo(const fid:tFID):tSegInfo_ptr;
  90  var fn:string;
  91  var fh:file of tSegStatic;
  92  var cp:^tSeg;
  93  label nocr;
  94  begin
  95  result:=SegInfoChain;
  96  while assigned(result) do begin
  97   if CompareWord(result^.name,fid,10)=0 then goto nocr;
  98   result:=result^.next;
  99  end;
 100  mkfilen(fn,fvInfo,fid);
 101  new(result);
 102  with result^ do begin
 103   cache:=nil;
 104   name:=fid;
 105   refc:=0;
 106   next:=nil;
 107   SegInfoChain:=result;
 108   Assign(fh,fn);
 109   {$I-}ReSet(fh);{$I+}if ioresult=0 then begin
 110    while not eof(fh) do begin
 111     new(cp);
 112     read(fh,cp^);
 113     cp^.next:=cache;
 114     cache:=cp;
 115    end;
 116    close(fh);
 117   end;
 118  end;
 119  nocr:
 120  Inc(result^.refc);
 121 end;
 122
 123 procedure tStoreObjectInfo.Open(const fid:tfid);
 124  begin
 125  mkfilen(filename,fvFinal,fid);
 126  segi:=nil;
 127  Offset:=0;
 128  name:=fid;
 129  dh:=FileOpen(filename,fmOpenRead or fmShareDenyWrite);
 130  if dh<>-1 then begin
 131   rc:=0;
 132   final:=true;
 133   length:=FileSeek(dh,0,fsFromEnd);
 134   FileSeek(dh,0,fsFromBeginning);
 135  end else begin
 136   mkfilen(filename,fvPart,fid);
 137   final:=false;
 138   dh:=FileOpen(filename,fmOpenRead or fmShareDenyWrite);
 139   if dh<>-1 then begin
 140    rc:=0;
 141    final:=false;
 142    length:=FileSeek(dh,0,fsFromEnd);
 143    FileSeek(dh,0,fsFromBeginning);
 144    segi:=GetSegInfo(fid);
 145    if tSegInfo(segi^).finalized then begin
 146     assert(length>0);
 147     final:=true;
 148    end;
 149   end else begin
 150    Writeln('Store1: open failed for file ',filename,', ioresult=',IOResult);
 151    rc:=2;
 152   end;
 153  end;
 154 end;
 155
 156 procedure tStoreObjectInfo.EnableWrite(const fid:tFID);
 157  begin
 158  writeln('Store1: enaling write');
 159  assert((dh=-1)or(not final));
 160  if dh=-1 then begin
 161   {file was close, create}
 162   dh:=FileCreate(filename);
 163   if dh=-1 then begin
 164    Writeln('Store1: create failed for file ',filename,', ioresult=',IOResult);
 165    rc:=3; exit end;
 166   {init length and segments}
 167   length:=0;
 168   segi:=GetSegInfo(fid);
 169  end;
 170  if dh<>-1 then begin
 171   {file was open, close and reopen rw}
 172   FileClose(dh);
 173   dh:=FileOpen(filename,fmOpenReadWrite or fmShareDenyWrite);
 174  end;
 175  if dh=-1 then rc:=2 else rc:=0;
 176 end;
 177 procedure tStoreObjectInfo.SetFLength(len:LongWord);
 178  begin
 179  assert(not final);
 180  //writeln('Store1: SetFLength ',len);
 181  length:=len;
 182  {todo: errors!!!}
 183  FileSeek(dh,len,fsFromBeginning);
 184  FileSeek(dh,0,fsFromBeginning);
 185 end;
 186 procedure tSegInfo.SetSeg(ofs,len:LongWord; state:boolean);
 187  var cp:^tSeg;
 188  var pcp:^pointer;
 189  var after:LongWord;
 190  var op:boolean;
 191  procedure Dump(c:char);
 192   begin
 193   cp:=cache;
 194   writeln('Store1: dumpCache ',c,' ',LongWord(@self));
 195   while assigned(cp) do begin
 196    writeln(cp^.first,'-',cp^.after);
 197    cp:=cp^.next;
 198   end;
 199  end;
 200  begin
 201  assert(state);
 202  after:=ofs+len;
 203  //Dump('a');
 204  pcp:=@cache;
 205  cp:=cache;
 206  //writeln('Store1: Add: ',ofs,'-',after);
 207  while assigned(cp) do begin
 208   op:=false;
 209   if (ofs<=cp^.first)and(after>=cp^.after) then begin
 210    {merge complete-encase}
 211    pcp^:=cp^.next;
 212    dispose(cp);
 213    cp:=pcp^;
 214    continue;
 215   end;
 216   if cp^.after=ofs then begin
 217    {merge left-matching}
 218    pcp^:=cp^.next;
 219    ofs:=cp^.first;
 220    dispose(cp);
 221    cp:=pcp^;
 222    continue;
 223   end;
 224   if cp^.first=after then begin
 225    {merge right-matching}
 226    pcp^:=cp^.next;
 227    after:=cp^.after;
 228    dispose(cp);
 229    cp:=pcp^;
 230    continue;
 231   end;
 232   if (after>cp^.first)and(ofs<=cp^.first)and(after<=cp^.after) then begin writeln('k'); after:=cp^.first; end;
 233   if (ofs<cp^.after)and(after>=cp^.after)and(ofs>=cp^.first) then begin writeln('l');  ofs:=cp^.after;end;
 234   if not op then pcp:=@cp^.next;
 235   cp:=pcp^;
 236  end;
 237  //Dump('b');
 238  {add the merged seg}
 239  if ofs<>after then begin
 240  new(cp);
 241  cp^.first:=ofs;
 242  cp^.after:=after;
 243  cp^.next:=cache;
 244  cache:=cp;
 245  end;
 246  //Dump('c');
 247 end;
 248 procedure tStoreObjectInfo.WriteSeg(ofs:LongWord;len:word;data:pointer);
 249  begin
 250  {todo: errors!!!}
 251  FileSeek(dh,ofs,fsFromBeginning);
 252  FileWrite(dh,data^,len);
 253  tSegInfo(segi^).SetSeg(ofs,len,true);
 254 end;
 255 procedure tStoreObjectInfo.GetMiss(out ofs:LongWord; out len:LongWord; var state:pointer);
 256  var cp,cp1,cp2:^tSeg;
 257  begin with tSegInfo(segi^) do begin
 258  {find seg with lowest base, return 0..base-1}
 259  cp1:=nil; cp2:=nil;
 260  len:=0;
 261  ofs:=LongWord(state);
 262  cp:=cache; while assigned(cp) do begin
 263   if ((cp1=nil)or(cp^.first<cp1^.first))and(cp^.first>=ofs) then cp1:=cp;
 264  cp:=cp^.next; end;
 265  if assigned(cp1) then begin
 266   cp:=cache; while assigned(cp) do begin
 267    if ((cp2=nil)or(cp^.first<cp2^.first))and(cp^.first>cp1^.first)and(cp^.first>=ofs) then cp2:=cp;
 268   cp:=cp^.next; end;
 269   if assigned(cp2) then begin
 270    ofs:=cp1^.after;
 271    len:=cp2^.first-ofs;
 272   end else begin
 273    ofs:=cp1^.after;
 274    len:=self.length-ofs;
 275   end;
 276  end else len:=self.length-ofs;
 277  state:=pointer(ofs+len);
 278 end;end;
 279 procedure tStoreObjectInfo.GetMiss(out ofs:LongWord; out len:LongWord);
 280  var state:pointer;
 281  begin
 282  state:=nil;
 283  GetMiss(ofs,len,state);
 284 end;
 285
 286
 287 procedure tStoreObjectInfo.ReadSeg(into:pointer; ofs:LongWord; len:word);
 288  var red:LongWord;
 289  begin
 290  SegSeek(ofs);
 291  assert(seglen>=len);
 292  red:=FileRead(dh,into^,len);
 293  seglen:=seglen-red;
 294  offset:=offset+red;
 295  if red=len then rc:=0 else begin
 296   //todo
 297   writeln('Store1: read ',red,' out of ',len,' requested bytes');
 298   rc:=2;
 299  end;
 300 end;
 301 procedure tSegInfo.Free;
 302  var fh:file of tSegStatic;
 303  var cp:^tSeg;
 304  var on,nn:string;
 305  begin
 306  Dec(refc); if refc>0 then begin writeln('Not saving, ',refc); exit;end;
 307  {save segs, free segs, free}
 308  mkfilen(on,fvInfo,name);
 309  Assign(fh,on);
 310  writeln('Store1: Saving segment info');
 311  ReWrite(fh);
 312  while assigned(cache) do begin
 313   cp:=cache;
 314   if not finalized then write(fh,cp^);
 315   cache:=cp^.next;
 316   dispose(cp);
 317  end;
 318  Close(fh);
 319  if finalized then begin
 320   writeln('Store1: segi finalized, renaming datafile, erasing infofile');
 321   mkfilen(on,fvPart,name);
 322   mkfilen(nn,fvFinal,name);
 323   RenameFile(on,nn);
 324   Erase(fh);
 325  end;
 326  FreeMem(@self,sizeof(self));
 327 end;
 328 procedure tStoreObjectInfo.Close;
 329  begin
 330  if assigned(segi) then tSegInfo(segi^).Free;
 331  segi:=nil;
 332  FileClose(dh);
 333  dh:=-1;
 334 end;
 335 procedure tStoreObjectInfo.VerifyAndReset;
 336  var ctx:tSHA1Context;
 337  var digest:tSHA1Digest;
 338  var buf: array [1..2048] of byte;
 339  var red:Integer;
 340  begin
 341  SegSeek(0);
 342  if seglen<length then begin writeln('Not complete! ',length-seglen); exit;end;
 343  {if check segi... then exit};
 344  SHA1Init( ctx );
 345  while seglen>0 do begin
 346   red:=sizeof(buf);
 347   if red>seglen then red:=seglen;
 348   red:=FileRead(dh,buf,red);
 349   seglen:=seglen-red;
 350   if red<0 then exit; {todo}
 351   SHA1Update( ctx, buf, red );
 352  end;
 353  SHA1Final( ctx, digest );
 354  assert(sizeof(digest)=sizeof(tfid));
 355  if CompareWord(name,digest,10)=0 then begin
 356   writeln('Store1: hash match');
 357   {todo: mark final-verified in segi, rename on segi done}
 358   final:=true;
 359   assert(assigned(segi));
 360   with tSegInfo(segi^) do begin
 361    assert( (cache^.first=0) and (cache^.after=length) and (cache^.next=nil) );
 362    finalized:=true;
 363   end;
 364   Close;
 365   {set some invalid values to prevent doing anything}
 366   length:=0; {the object MUST be closed now} seglen:=0;
 367  end else writeln('Hash not matching ',sha1print(digest),' ',sha1print(name));
 368 end;
 369
 370 function tSegInfo.GetSegLen(ofs:LongWord):LongWord;
 371  var cp:^tSeg;
 372  begin
 373  cp:=cache;
 374  while assigned(cp) do begin
 375   if (cp^.first<=ofs)and(cp^.after>ofs) then begin
 376    GetSegLen:=cp^.after-ofs;
 377   exit end;
 378   cp:=cp^.next;
 379  end;
 380  GetSegLen:=0;
 381 end;
 382 procedure tStoreObjectInfo.GetSegAfter(ofs:LongWord; out base:LongWord; out limit:LongWord);
 383  var cp:^tSeg;
 384  begin
 385  Assert(not final);
 386  cp:=tSegInfo(segi^).cache; {FIXME}
 387  while assigned(cp) do begin
 388   if (cp^.first>ofs) then begin
 389    base:=cp^.first;
 390    limit:=cp^.after-base-1;
 391   exit end;
 392   cp:=cp^.next;
 393  end;
 394 end;
 395 procedure tStoreObjectInfo.SegSeek(ofs:longword);
 396  begin
 397  if final then begin
 398   if ofs<=length then begin
 399    seglen:=length-ofs;
 400    if FileSeek(dh,ofs,fsFromBeginning)=ofs then begin
 401     offset:=ofs;
 402     rc:=0;
 403    end else rc:=3;
 404   end else rc:=5;
 405  end else if assigned(segi) then begin
 406   seglen:=tSegInfo(segi^).GetSegLen(ofs);
 407   if seglen=0 then rc:=4 else if FileSeek(dh,ofs,fsFromBeginning)<>ofs then rc:=3 else rc:=0;
 408   offset:=ofs;
 409  end else rc:=7;
 410 end;
 411 function tStoreObjectInfo.SegmentLength(ofs:LongWord): LongWord;
 412  begin
 413  if ofs>self.length then begin result:=0;exit end;
 414  if Final then result:=self.Length-ofs else begin
 415   result:=tSegInfo(segi^).GetSegLen(ofs);
 416  end;
 417 end;
 418
 419 operator :=(a:string) r:tFID;
 420  var i:byte;
 421  function unhex(c:char):byte;
 422   begin
 423   c:=upcase(c);
 424   if (c<='F')and(c>='A') then unhex:=(ord(c)-ord('A'))+10
 425   else unhex:=ord(c)-ord('0');
 426  end;
 427  begin
 428  for i:=0 to 19 do r[i]:=(unhex(a[i*2+1])shl 4)or(unhex(a[i*2+2]));
 429 end;
 430 operator :=(a:tFID) r:string;
 431  begin
 432  r:=sha1print(a);
 433 end;
 434 BEGIN
 435  CreateDir('obj');
 436  SegInfoChain:=nil;
 437 END.