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