paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-04 05:22:59 +01:00
Code Issues Packages Projects Releases Wiki Activity
14b3c11c0d
fpc/rtl/inc/extres.inc
Michael VAN CANNEYT d2d3fe6bc3 * Char -> AnsiChar
2023-07-14 17:26:10 +02:00

661 lines
18 KiB
PHP
Raw Blame History

{
This file is part of the Free Pascal run time library.
Copyright (c) 2008 by Giulio Bernardi
Resource support as external files
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
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.
**********************************************************************}
{
This file implements two kinds of external resource support:
- one for systems that support the mmap call (usually unix-like oses)
- one fallback implementation based on pascal files and GetMem/FreeMem
Be sure to define EXTRES_MMAP or EXTRES_GENERIC before including this file!
}
{$IF defined(EXTRES_MMAP) and defined(EXTRES_GENERIC)}
{$FATAL EXTRES_MMAP and EXTRES_GENERIC can't be defined together}
{$ENDIF}
{$IF (not defined(EXTRES_MMAP)) and (not defined(EXTRES_GENERIC))}
{$FATAL EXTRES_MMAP or EXTRES_GENERIC must be defined}
{$ENDIF}
const
FPCRES_MAGIC = 'FPCRES';
FPCRES_VERSION = 1;
{$IFDEF ENDIAN_BIG}
FPCRES_ENDIAN = 1;
{$ENDIF}
{$IFDEF ENDIAN_LITTLE}
FPCRES_ENDIAN = 2;
{$ENDIF}
FPCRES_EXT = '.fpcres';
type
TExtHeader = packed record
magic : array[0..5] of AnsiChar;//'FPCRES'
version : byte; //EXT_CURRENT_VERSION
endianess : byte; //EXT_ENDIAN_BIG or EXT_ENDIAN_LITTLE
count : longword; //resource count
nodesize : longword; //size of header (up to string table, excluded)
hdrsize : longword; //size of header (up to string table, included)
reserved1 : longword;
reserved2 : longword;
reserved3 : longword;
end;
PExtHeader = ^TExtHeader;
TResInfoNode = packed record
nameid : longword; //name offset / integer ID / languageID
ncounthandle : longword; //named sub-entries count/resource handle
idcountsize : longword; //id sub-entries count / resource size
subptr : longword; //first sub-entry offset
end;
PResInfoNode = ^TResInfoNode;
{$IFDEF EXTRES_GENERIC}
TResHandle = record
info : PResInfoNode;
ptr : Pointer;
end;
PResHandle = ^TResHandle;
{$ENDIF}
var ResHeader : PExtHeader = nil;
usedhandles : longword = 0;
{$IFDEF EXTRES_MMAP}
fd : integer;
fd_size : longword;
reshandles : PPointer = nil;
{$ENDIF}
{$IFDEF EXTRES_GENERIC}
fd : file;
reshandles : PResHandle = nil;
{$ENDIF}
(*****************************************************************************
Private Helper Functions
*****************************************************************************)
//resource functions are case insensitive... copied from genstr.inc
function ResStrIComp(Str1, Str2 : PAnsiChar): SizeInt;
var
counter: SizeInt;
c1, c2: AnsiChar;
begin
counter := 0;
c1 := upcase(str1[counter]);
c2 := upcase(str2[counter]);
while c1 = c2 do
begin
if (c1 = #0) or (c2 = #0) then break;
inc(counter);
c1 := upcase(str1[counter]);
c2 := upcase(str2[counter]);
end;
ResStrIComp := ord(c1) - ord(c2);
end;
{!fixme!}
//function InternalIsIntResource(aStr : PAnsiChar; out aInt : PtrUint) : boolean;
function InternalIsIntResource(aStr : PAnsiChar; var aInt : PtrUint) : boolean;
var i : integer;
s : shortstring;
code : word;
begin
InternalIsIntResource:=((PtrUInt(aStr) shr 16)=0);
if InternalIsIntResource then aInt:=PtrUInt(aStr)
else
begin
//a string like #number specifies an integer id
if aStr[0]='#' then
begin
i:=1;
while aStr[i]<>#0 do
inc(i);
if i>256 then i:=256;
s[0]:=chr(i-1);
Move(aStr[1],s[1],i-1);
Val(s,aInt,code);
InternalIsIntResource:=code=0;
end;
end;
end;
function GetResInfoPtr(const offset : longword) : PResInfoNode; inline;
begin
GetResInfoPtr:=PResInfoNode(PtrUInt(ResHeader)+offset);
end;
function GetPchar(const offset : longword) : PAnsiChar; inline;
begin
GetPchar:=PAnsiChar(PtrUInt(ResHeader)+offset);
end;
function GetPtr(const offset : longword) : Pointer; inline;
begin
GetPtr:=Pointer(PtrUInt(ResHeader)+offset);
end;
procedure FixResEndian;
var ptr : plongword;
blockend : plongword;
begin
//all info nodes reside in a contiguos block of memory.
//they are all 16 bytes long and made by longwords
//so, simply swap each longword in the block
ptr:=GetPtr(sizeof(TExtHeader));
blockend:=GetPtr(ResHeader^.nodesize);
while ptr<blockend do
begin
ptr^:=SwapEndian(ptr^);
inc(ptr);
end;
end;
function GetExtResPath : PAnsiChar;
var len, i : integer;
pathstr : shortstring;
begin
pathstr:=paramstr(0);
len:=byte(pathstr[0]);
i:=len;
//writeln('exe name is ',pathstr);
//find position of extension
while (i>0) and (not (pathstr[i] in ['.',DirectorySeparator])) do
dec(i);
if (i>0) and (pathstr[i]='.') then dec(i)
else i:=len;
pathstr[0]:=Chr(i);
pathstr:=pathstr+FPCRES_EXT;
len:=byte(pathstr[0]);
GetExtResPath:=GetMem(len+1);
Move(pathstr[1],GetExtResPath[0],len);
GetExtResPath[len]:=#0;
//writeln('Resource file is ',GetExtResPath);
end;
function BinSearchStr(arr : PResInfoNode; query : PAnsiChar; left, right : integer)
: PResInfoNode;
var pivot, res : integer;
resstr : PAnsiChar;
begin
BinSearchStr:=nil;
while left<=right do
begin
pivot:=(left+right) div 2;
resstr:=GetPchar(arr[pivot].nameid);
res:=ResStrIComp(resstr,query);
if res<0 then left:=pivot+1
else if res>0 then right:=pivot-1
else
begin
BinSearchStr:=@arr[pivot];
exit;
end;
end;
end;
function BinSearchInt(arr : PResInfoNode; query : PAnsiChar; left, right : integer)
: PResInfoNode;
var pivot : integer;
begin
BinSearchInt:=nil;
while left<=right do
begin
pivot:=(left+right) div 2;
if arr[pivot].nameid<PtrUInt(query) then left:=pivot+1
else if arr[pivot].nameid>PtrUInt(query) then right:=pivot-1
else
begin
BinSearchInt:=@arr[pivot];
exit;
end;
end;
end;
function BinSearchRes(root : PResInfoNode; aDesc : PAnsiChar) : PResInfoNode;
var aID : PtrUint;
begin
if InternalIsIntResource(aDesc,aID) then
BinSearchRes:=BinSearchInt(GetResInfoPtr(root^.subptr),PAnsiChar(aID),
root^.ncounthandle,root^.ncounthandle+root^.idcountsize-1)
else
BinSearchRes:=BinSearchStr(GetResInfoPtr(root^.subptr),aDesc,0,
root^.ncounthandle-1);
end;
//Returns a pointer to a name node.
function InternalFindResource(ResourceName, ResourceType: PAnsiChar):
PResInfoNode;
begin
InternalFindResource:=nil;
if ResHeader=nil then exit;
InternalFindResource:=GetResInfoPtr(sizeof(TExtHeader));
InternalFindResource:=BinSearchRes(InternalFindResource,ResourceType);
if InternalFindResource<>nil then
InternalFindResource:=BinSearchRes(InternalFindResource,ResourceName);
end;
function FindSubLanguage(aPtr : PResInfoNode; aLangID : word; aMask: word) : PResInfoNode;
var arr : PResInfoNode;
i : longword;
begin
FindSubLanguage:=nil;
arr:=GetResInfoPtr(aPtr^.subptr);
i:=0;
while i<aPtr^.idcountsize do
begin
if (PtrUInt(arr[i].nameid) and aMask)=(aLangID and aMask) then
begin
FindSubLanguage:=@arr[i];
exit;
end;
inc(i);
end;
end;
{$IFDEF EXTRES_MMAP}
procedure InitResources;
const
PROT_READ = 1;
PROT_WRITE = 2;
var respath : PAnsiChar;
fdstat : stat;
begin
respath:=GetExtResPath;
// writeln('respath ',respath);
fd:=FpOpen(respath,O_RDONLY,0);
// writeln('fpopen returned ',fd);
FreeMem(respath);
if fd=-1 then exit;
if FpFStat(fd,fdstat)<>0 then
begin
// writeln('fpfstat failed');
FpClose(fd);
exit;
end;
// writeln('fpfstat suceeded');
fd_size:=fdstat.st_size;
ResHeader:=PExtHeader(Fpmmap(nil,fd_size,PROT_READ or PROT_WRITE,
MAP_PRIVATE,fd,0));
// writeln('fpmmap returned ',PtrInt(ResHeader));
if PtrInt(ResHeader)=-1 then
begin
FpClose(fd);
exit;
end;
if (ResHeader^.magic<>FPCRES_MAGIC) or
(ResHeader^.version<>fpcres_version) then
begin
FpClose(fd);
exit;
end;
// writeln('magic ok');
if ResHeader^.endianess<>FPCRES_ENDIAN then
begin
ResHeader^.count:=SwapEndian(ResHeader^.count);
ResHeader^.nodesize:=SwapEndian(ResHeader^.nodesize);
ResHeader^.hdrsize:=SwapEndian(ResHeader^.hdrsize);
FixResEndian;
end;
reshandles:=GetMem(sizeof(Pointer)*ResHeader^.count);
FillByte(reshandles^,sizeof(Pointer)*ResHeader^.count,0);
end;
procedure FinalizeResources;
begin
if ResHeader=nil then exit;
FreeMem(reshandles);
Fpmunmap(ResHeader,fd_size);
FpClose(fd);
end;
{$ENDIF}
{$IFDEF EXTRES_GENERIC}
procedure InitResources;
var respath : PAnsiChar;
tmp : longword;
tmpptr : pbyte;
label ExitErrMem, ExitErrFile, ExitNoErr;
begin
respath:=GetExtResPath;
// writeln('respath ',respath);
Assign(fd,respath);
FreeMem(respath);
{$I-}
Reset(fd,1);
{$I+}
if IOResult<>0 then exit;
// writeln('file opened');
ResHeader:=GetMem(sizeof(TExtHeader));
if ResHeader=nil then goto ExitErrFile;
{$I-}
BlockRead(fd,ResHeader^,sizeof(TExtHeader),tmp);
{$I+}
if (IOResult<>0) or (tmp<>sizeof(TExtHeader)) then goto ExitErrMem;
if (ResHeader^.magic<>FPCRES_MAGIC) or (ResHeader^.version<>fpcres_version)
then goto ExitErrMem;
// writeln('magic ok');
if ResHeader^.endianess<>FPCRES_ENDIAN then
begin
ResHeader^.count:=SwapEndian(ResHeader^.count);
ResHeader^.nodesize:=SwapEndian(ResHeader^.nodesize);
ResHeader^.hdrsize:=SwapEndian(ResHeader^.hdrsize);
end;
SysReallocMem(ResHeader,ResHeader^.hdrsize);
if ResHeader=nil then goto ExitErrFile;
tmpptr:=pbyte(ResHeader);
inc(tmpptr,sizeof(TExtHeader));
{$I-}
BlockRead(fd,tmpptr^,ResHeader^.hdrsize-sizeof(TExtHeader),tmp);
{$I+}
if (IOResult<>0) or (tmp<>ResHeader^.hdrsize-sizeof(TExtHeader)) then goto ExitErrMem;
if ResHeader^.endianess<>FPCRES_ENDIAN then
FixResEndian;
reshandles:=GetMem(sizeof(TResHandle)*ResHeader^.count);
FillByte(reshandles^,sizeof(TResHandle)*ResHeader^.count,0);
goto ExitNoErr;
ExitErrMem:
FreeMem(ResHeader);
ResHeader:=nil;
ExitErrFile:
{$I-}
Close(fd);
{$I+}
ExitNoErr:
end;
procedure FinalizeResources;
begin
if ResHeader=nil then exit;
FreeMem(reshandles);
FreeMem(ResHeader);
Close(fd);
end;
{$ENDIF}
(*****************************************************************************
Public Resource Functions
*****************************************************************************)
Function ExtHINSTANCE : TFPResourceHMODULE;
begin
ExtHINSTANCE:=0;
end;
function ExtEnumResourceTypes(ModuleHandle : TFPResourceHMODULE; EnumFunc : EnumResTypeProc; lParam : PtrInt) : LongBool;
var ptr : PResInfoNode;
totn, totid, i : longword;
pc : PAnsiChar;
begin
ExtEnumResourceTypes:=False;
if ResHeader=nil then exit;
ptr:=GetResInfoPtr(sizeof(TExtHeader));
totn:=ptr^.ncounthandle;
totid:=totn+ptr^.idcountsize;
ptr:=GetResInfoPtr(ptr^.subptr);
ExtEnumResourceTypes:=true;
i:=0;
while i<totn do //named entries
begin
pc:=GetPChar(ptr[i].nameid);
if not EnumFunc(ModuleHandle,pc,lParam) then exit;
inc(i);
end;
while i<totid do
begin
if not EnumFunc(ModuleHandle,PAnsiChar(ptr[i].nameid),lParam) then exit;
inc(i);
end;
end;
function ExtEnumResourceNames(ModuleHandle : TFPResourceHMODULE; ResourceType : PAnsiChar; EnumFunc : EnumResNameProc; lParam : PtrInt) : LongBool;
var ptr : PResInfoNode;
totn, totid, i : longword;
pc : PAnsiChar;
begin
ExtEnumResourceNames:=False;
if ResHeader=nil then exit;
ptr:=GetResInfoPtr(sizeof(TExtHeader));
ptr:=BinSearchRes(ptr,ResourceType);
if ptr=nil then exit;
totn:=ptr^.ncounthandle;
totid:=totn+ptr^.idcountsize;
ptr:=GetResInfoPtr(ptr^.subptr);
ExtEnumResourceNames:=true;
i:=0;
while i<totn do //named entries
begin
pc:=GetPChar(ptr[i].nameid);
if not EnumFunc(ModuleHandle,ResourceType,pc,lParam) then exit;
inc(i);
end;
while i<totid do
begin
if not EnumFunc(ModuleHandle,ResourceType,PAnsiChar(ptr[i].nameid),lParam) then exit;
inc(i);
end;
end;
function ExtEnumResourceLanguages(ModuleHandle : TFPResourceHMODULE; ResourceType, ResourceName : PAnsiChar; EnumFunc : EnumResLangProc; lParam : PtrInt) : LongBool;
var ptr : PResInfoNode;
tot, i : integer;
begin
ExtEnumResourceLanguages:=False;
ptr:=InternalFindResource(ResourceName,ResourceType);
if ptr=nil then exit;
tot:=ptr^.idcountsize;
ptr:=GetResInfoPtr(ptr^.subptr);
ExtEnumResourceLanguages:=true;
i:=0;
while i<tot do
begin
if not EnumFunc(ModuleHandle,ResourceType,ResourceName,PtrUInt(ptr[i].nameid),lParam) then exit;
inc(i);
end;
end;
Function ExtFindResource(ModuleHandle: TFPResourceHMODULE; ResourceName, ResourceType: PAnsiChar)
: TFPResourceHandle;
var ptr : PResInfoNode;
begin
ExtFindResource:=0;
ptr:=InternalFindResource(ResourceName,ResourceType);
if ptr=nil then exit;
//first language id
ptr:=GetResInfoPtr(ptr^.subptr);
if ptr^.ncounthandle=0 then
begin
{$IFDEF EXTRES_MMAP}
reshandles[usedhandles]:=ptr;
{$ENDIF}
{$IFDEF EXTRES_GENERIC}
reshandles[usedhandles].info:=ptr;
{$ENDIF}
inc(usedhandles);
ptr^.ncounthandle:=usedhandles;
end;
ExtFindResource:=ptr^.ncounthandle;
end;
Function ExtFindResourceEx(ModuleHandle: TFPResourceHMODULE; ResourceType,
ResourceName: PAnsiChar; Language : word): TFPResourceHandle;
const LANG_NEUTRAL = 0;
LANG_ENGLISH = 9;
var nameptr,ptr : PResInfoNode;
begin
ExtFindResourceEx:=0;
nameptr:=InternalFindResource(ResourceName,ResourceType);
if nameptr=nil then exit;
//try exact match
ptr:=FindSubLanguage(nameptr,Language,$FFFF);
//try primary language
if ptr=nil then
ptr:=FindSubLanguage(nameptr,Language,$3FF);
//try language neutral
if ptr=nil then
ptr:=FindSubLanguage(nameptr,LANG_NEUTRAL,$3FF);
//try english
if ptr=nil then
ptr:=FindSubLanguage(nameptr,LANG_ENGLISH,$3FF);
//nothing found, return the first one
if ptr=nil then
ptr:=GetResInfoPtr(nameptr^.subptr);
if ptr^.ncounthandle=0 then
begin
{$IFDEF EXTRES_MMAP}
reshandles[usedhandles]:=ptr;
{$ENDIF}
{$IFDEF EXTRES_GENERIC}
reshandles[usedhandles].info:=ptr;
{$ENDIF}
inc(usedhandles);
ptr^.ncounthandle:=usedhandles;
end;
ExtFindResourceEx:=ptr^.ncounthandle;
end;
{$IFDEF EXTRES_MMAP}
Function ExtLoadResource(ModuleHandle: TFPResourceHMODULE; ResHandle: TFPResourceHandle): TFPResourceHGLOBAL;
begin
ExtLoadResource:=0;
if ResHeader=nil then exit;
if (ResHandle<=0) or (ResHandle>usedhandles) then exit;
ExtLoadResource:=TFPResourceHGLOBAL(GetPtr(PResInfoNode(reshandles[ResHandle-1])^.subptr));
end;
Function ExtFreeResource(ResData: TFPResourceHGLOBAL): LongBool;
begin
ExtFreeResource:=(ResHeader<>nil);
end;
Function ExtSizeofResource(ModuleHandle: TFPResourceHMODULE; ResHandle: TFPResourceHandle): LongWord;
begin
ExtSizeofResource:=0;
if ResHeader=nil then exit;
if (ResHandle<=0) or (ResHandle>usedhandles) then exit;
ExtSizeofResource:=PResInfoNode(reshandles[ResHandle-1])^.idcountsize;
end;
{$ENDIF}
{$IFDEF EXTRES_GENERIC}
(*
Resource data memory layout:
-2*sizeof(pointer) Reference count
-sizeof(pointer) Pointer to resource info
0 Resource data
*)
Function ExtLoadResource(ModuleHandle: TFPResourceHMODULE; ResHandle: TFPResourceHandle): TFPResourceHGLOBAL;
var ptr : PPtrUInt;
tmp : longword;
begin
ExtLoadResource:=0;
if ResHeader=nil then exit;
if (ResHandle<=0) or (ResHandle>usedhandles) then exit;
if reshandles[ResHandle-1].ptr=nil then
begin
{$I-}
Seek(fd,reshandles[ResHandle-1].info^.subptr);
{$I+}
if IOResult<>0 then exit;
ptr:=GetMem(reshandles[ResHandle-1].info^.idcountsize+2*sizeof(PtrUint));
if ptr=nil then exit;
ptr^:=1; //refcount
inc(ptr);
ptr^:=PtrUInt(reshandles[ResHandle-1].info); //ptr to resource info
inc(ptr);
{$I-}
BlockRead(fd,ptr^,reshandles[ResHandle-1].info^.idcountsize,tmp);
{$I+}
if (IOResult<>0) or (tmp<>reshandles[ResHandle-1].info^.idcountsize) then
begin
FreeMem(ptr);
exit;
end;
reshandles[ResHandle-1].ptr:=ptr;
end
else
begin
ptr:=reshandles[ResHandle-1].ptr;
dec(ptr,2);
inc(ptr^,1); //increase reference count
end;
ExtLoadResource:=TFPResourceHGLOBAL(reshandles[ResHandle-1].ptr);
end;
Function ExtFreeResource(ResData: TFPResourceHGLOBAL): LongBool;
var ptrinfo : PResInfoNode;
ptr : PPtrUInt;
begin
ExtFreeResource:=(ResHeader<>nil);
if not ExtFreeResource then exit;
ptr:=PPtrUInt(ResData);
dec(ptr,2);
dec(ptr^); //decrease reference count
if ptr^=0 then
begin
inc(ptr);
ptrinfo:=PResInfoNode(ptr^);
dec(ptr);
FreeMem(ptr);
reshandles[ptrinfo^.ncounthandle-1].ptr:=nil;
end;
ExtFreeResource:=true;
end;
Function ExtSizeofResource(ModuleHandle: TFPResourceHMODULE; ResHandle: TFPResourceHandle): LongWord;
var ptrinfo : PResInfoNode;
begin
ExtSizeofResource:=0;
if ResHeader=nil then exit;
if (ResHandle<=0) or (ResHandle>usedhandles) then exit;
ptrinfo:=PResInfoNode(reshandles[ResHandle-1].info);
ExtSizeofResource:=ptrinfo^.idcountsize;
end;
{$ENDIF}
Function ExtLockResource(ResData: TFPResourceHGLOBAL): Pointer;
begin
ExtLockResource:=Nil;
if ResHeader=nil then exit;
ExtLockResource:=Pointer(ResData);
end;
Function ExtUnlockResource(ResData: TFPResourceHGLOBAL): LongBool;
begin
ExtUnlockResource:=(ResHeader<>nil);
end;
const
ExternalResourceManager : TResourceManager =
(
HINSTANCEFunc : @ExtHINSTANCE;
EnumResourceTypesFunc : @ExtEnumResourceTypes;
EnumResourceNamesFunc : @ExtEnumResourceNames;
EnumResourceLanguagesFunc : @ExtEnumResourceLanguages;
FindResourceFunc : @ExtFindResource;
FindResourceExFunc : @ExtFindResourceEx;
LoadResourceFunc : @ExtLoadResource;
SizeofResourceFunc : @ExtSizeofResource;
LockResourceFunc : @ExtLockResource;
UnlockResourceFunc : @ExtUnlockResource;
FreeResourceFunc : @ExtFreeResource;
);
Reference in New Issue View Git Blame Copy Permalink