OpenXP 5 Code

{   $Id: resource.pas 7176 2005-11-15 08:34:51Z mkaemmerer $

    Copyright (C) 1991-2001 Peter Mandrella
    Copyright (C) 2000-2002 OpenXP team (www.openxp.de)

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
}

{$I xpdefine.inc }

unit  resource;


interface

uses
  xpglobal,
  sysutils,
  typeform,fileio;

procedure OpenResource(const fn:string; preloadmem:longint);
procedure CloseResource;
function  ResIsOpen:boolean;

function  GetRes(nr:word):string;
function  GetRepS(nr:word; const txt:String):string;
function  GetRes2(nr1,nr2:word):string;
function  GetReps2(nr1,nr2:word; const txt:string):string;
function  Res2Anz(nr:word):word;
function  IsRes(nr:word):boolean;
procedure FreeRes;                        { Cluster freigeben }
function  reps(const s1,s2:string):string;

procedure InitResourceUnit;

implementation  { --------------------------------------------------- }

uses debug;

const maxblocks = 4;
      maxindex  = 4096;   { max. Strings pro Block }

type
      barr   = packed array[0..65300] of byte;
      barrp  = ^barr;
      rblock = packed record
                      anzahl   : smallword; { Anzahl Strings in diesem Block  }
                      fileadr  : longint;   { Startadresse in RES-Datei       }
                      contsize : smallword; { GrӇe des Inhalts (Texte)       }
                      lastnr   : smallword; { letzte Res.-Nr. in diesem Block }
                      flags    : smallword; { 1 = preload                     }
                      dummy    : longint;   
               end;
      tindex = packed array[0..maxindex-1,0..1] of smallword;

const
      clnr   : word  = $ffff;    { geladener Cluster }
      ResourceOpen : Boolean = false;

var   block  : packed array[1..maxblocks] of rblock;
      blockptr: packed array[1..maxblocks] of barrp;
      blocks : word;
      index  : packed array[1..maxblocks] of ^tindex;
      FH: Integer;

      clsize : word;         { Cluster-GrӇe }
      clindex: ^tindex;      { Cluster-Index  }
      clcont : barrp;        { Cluster-Inhalt }
      clcsize: word;         { GrӇe des Inhalts }
      clbnr  : integer;


procedure error(txt:string);
begin
  writeln('<RES> Error: ',txt);
  halt(1);
end;

{ preloadmem: soviel Bytes Heap soll mindestens freibleiben }

procedure OpenResource(const fn:string; preloadmem:longint);
var
  i  : integer;
begin
  if ResourceOpen then
    error('Resource file already open');
  FH := FileOpen(fn, fmOpenRead + fmShareDenyNone);
  if FH < 0 then
    error(ioerror(ioresult,'can''t open '+UpperCase(fn)));
  ResourceOpen := true;
  FileSeek(FH, 128, 0);
  FileRead(FH, Blocks, 2);
  FileSeek(FH, 128+16, 0);
  FileRead(FH,block,sizeof(block));
  for i:=1 to blocks do
  begin          { Indextabellen laden }
    getmem(index[i],block[i].anzahl*4);
    FileSeek(FH, block[i].fileadr, 0);
    FileRead(FH, index[i]^,block[i].anzahl*4);
    getmem(blockptr[i],block[i].contsize);
    FileRead(FH,blockptr[i]^,block[i].contsize)   { preload }
  end;
end;


procedure CloseResource;
var i : integer;
begin
  if not ResourceOpen then
     error('no resource file open');
  FileClose(FH);
  ResourceOpen := false;
  for i:=1 to blocks do
  with block[i] do
  begin
    freemem(blockptr[i],contsize);
    freemem(index[i],anzahl*4);
  end;
  freeres;
end;

function ResIsOpen:boolean;
begin
  ResIsOpen := ResourceOpen;
end;


function getnr(nr:word; var bnr,inr:word):boolean;
var l,r,m : word;
begin
  getnr:=false;
  bnr:=1;
  while (bnr<=blocks) and (nr>block[bnr].lastnr) do
    inc(bnr);
  if (bnr<=blocks) and (block[bnr].anzahl>0) then
  begin
    getnr:=true;
    l:=0;
    r:=block[bnr].anzahl-1;
    while (r-l>1) and (index[bnr]^[l,0] and $7fff<>nr) do begin
      m:=(l+r)div 2;
      if index[bnr]^[m,0] and $7fff<=nr then l:=m
      else r:=m;
      end;
    if index[bnr]^[l,0] and $7fff=nr then
      inr:=l
    else if index[bnr]^[r,0] and $7fff=nr then
      inr:=r
    else
      getnr:=false;
  end;
end;


function rsize(bnr,inr:word):word;
begin
  with block[bnr] do
    if inr<anzahl-1 then
      rsize:=index[bnr]^[inr+1,1]-index[bnr]^[inr,1]
    else
      rsize:=contsize-index[bnr]^[inr,1];
end;


function GetRes(nr:word):string;
var bnr,inr : word;
    s       : shortstring;
begin
  if not getnr(nr,bnr,inr) then
  begin
    GetRes:='fehlt: ['+strs(nr)+'] ';
    Debug.DebugLog('resource','resource missing: '+strs(nr),dlWarning);
    end
  else
    with block[bnr] do
    begin
      SetLength(s, rsize(bnr,inr)); {s[0]:=chr(rsize(bnr,inr));}
      Move(blockptr[bnr]^[index[bnr]^[inr,1]],s[1],length(s));
      GetRes:=s;
    end;
end;


procedure FreeRes;                        { Gruppe freigeben }
begin
  if clnr<>$ffff then begin
    freemem(clindex,clsize*4);
    clnr:=$ffff;
    end;
end;


function GetRes2(nr1,nr2:word):string;
var bnr,inr  : word;
    size,ofs : word;
    l,r,m,i  : word;
    s        : shortstring;
label ende;

  function fehlt:string;
  begin
    fehlt:='fehlt: ['+strs(Nr1)+'.'+strs(nr2)+'] ';
    Debug.DebugLog('resource','resource missing: '+strs(nr1)+'.'+strs(nr2),dlWarning);
  end;

  begin
  if not getnr(nr1,bnr,inr) then
    GetRes2:=fehlt
  else
    if index[bnr]^[inr,0] and $8000=0 then
      error('['+strs(nr1)+']: no split page')
    else
      with block[bnr] do begin
        if (inr<>clnr) or (bnr <> clbnr) then
        begin
          FreeRes;
          size:=rsize(bnr,inr);
          ofs:=index[bnr]^[inr,1];
            Move(blockptr[bnr]^[ofs],clsize,2);
            clcsize:=size-2-clsize*4;
            getmem(clindex,clsize*4);
            Move(blockptr[bnr]^[ofs+2],clindex^,clsize*4);
            clcont:=@blockptr[bnr]^[ofs+2+clsize*4];
          end;
        l:=0; r:=clsize-1;
        while (r-l>1) and (clindex^[l,0]<>nr2) do begin
          m:=(l+r)div 2;
          if clindex^[m,0]<=nr2 then l:=m
          else r:=m;
          end;
        if clindex^[l,0]=nr2 then i:=l
        else if clindex^[r,0]=nr2 then i:=r
        else begin
          s:=fehlt; goto ende;
          end;
        if i<clsize-1 then
          size:=clindex^[i+1,1]-clindex^[i,1]
        else
          size:=clcsize-clindex^[i,1];
        SetLength(s, size); { s[0]:=chr(size); }
        Move(clcont^[clindex^[i,1]],s[1],size);
      ende:
        GetRes2:=s;
        clbnr:=bnr; clnr:=inr;
        end;
end;


function Res2Anz(nr:word):word;
var bnr,inr : word;
begin
  if getnr(nr,bnr,inr) then
    with block[bnr] do
    begin
       Move(blockptr[bnr]^[index[bnr]^[inr,1]],nr,2);
       Res2Anz:=nr;
    end
  else
    Res2Anz:=0;
end;

function IsRes(nr:word):boolean;
var bnr,inr : word;
begin
  IsRes:=getnr(nr,bnr,inr);
end;


function reps(const s1,s2:string):string;
var p : Integer;
begin
  p:=pos('%s',s1);
  if p>0 then reps:=LeftStr(s1,p-1)+s2+mid(s1,p+2)
  else reps:=s1;
end;

function GetRepS(nr:word; const txt:String):string;
begin
  GetReps:=reps(getres(nr),txt);
end;

function GetReps2(nr1,nr2:word; const txt:string):string;
begin
  GetReps2:=reps(getres2(nr1,nr2),txt);
end;

var
  SavedExitProc: pointer;

procedure ExitResourceUnit;
begin
  ExitProc:= SavedExitProc;
  if ResourceOpen then
    Closeresource;
end;

procedure InitResourceUnit;
begin
  SavedExitProc:= ExitProc;
  ExitProc:= @ExitResourceUnit;
end;

end.