paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-17 20:59:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

- added TLResources.Find by Name and ValueType (it was by Name only before)

Browse Source 
- new class TLazarusResourceStream similar to TResourceStream
- some code needed resource stream has been switched to use TLazarusResourceStream

git-svn-id: trunk@11429 -
This commit is contained in:
paul 2007-07-06 02:32:22 +00:00
parent 4d69b762e7
commit ce2a7a71a6
3 changed files with 188 additions and 102 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
ideintf/ideimagesintf.pas
View File

@ -108,8 +108,7 @@ var
Names: TStringList; Names: TStringList;
Graphic: TGraphic; Graphic: TGraphic;
GraphicClass: TGraphicClass; GraphicClass: TGraphicClass;
Res: TLResource; Stream: TLazarusResourceStream;
Stream: TStream;
begin begin
Result := GetImageIndex(ImageSize, ImageName); Result := GetImageIndex(ImageSize, ImageName);
if Result = -1 then if Result = -1 then
@ -131,29 +130,26 @@ begin
if List <> nil then if List <> nil then
begin begin
Res := LazarusResources.Find(ImageName); try
if (Res <> nil) and (Res.Value <> '') then Stream := TLazarusResourceStream.Create(ImageName, nil);
begin if (Stream.Res <> nil) then
GraphicClass := GetGraphicClassForFileExtension(Res.ValueType);
if GraphicClass <> nil then
begin begin
Graphic := GraphicClass.Create; GraphicClass := GetGraphicClassForFileExtension(Stream.Res.ValueType);
if Graphic is TBitmap then if GraphicClass <> nil then
try begin
Stream := TMemoryStream.Create; Graphic := GraphicClass.Create;
if Graphic is TBitmap then
try try
Stream.Write(Res.Value[1], length(Res.Value));
Stream.Position := 0;
Graphic.LoadFromStream(Stream); Graphic.LoadFromStream(Stream);
Result := List.Add(TBitmap(Graphic), nil); Result := List.Add(TBitmap(Graphic), nil);
Names.AddObject(ImageName, TObject(PtrInt(Result))); Names.AddObject(ImageName, TObject(PtrInt(Result)));
finally finally
Stream.Free; Graphic.Free;
end; end;
finally
Graphic.Free;
end; end;
end; end;
Stream.Free;
except
end; end;
end; end;
end; end;

25
lcl/graphics.pp
View File

@ -1474,27 +1474,24 @@ end;
function LoadBitmapFromLazarusResource(ResourceName: String): TBitmap; function LoadBitmapFromLazarusResource(ResourceName: String): TBitmap;
var var
Res: TLResource; Stream: TLazarusResourceStream;
Stream: TStream;
GraphicClass: TGraphicClass; GraphicClass: TGraphicClass;
begin begin
Result := nil; Result := nil;
Res := LazarusResources.Find(ResourceName); Stream := nil;
if (Res <> nil) and (Res.Value <> '') then try
begin Stream := TLazarusResourceStream.Create(ResourceName, nil);
GraphicClass := GetGraphicClassForFileExtension(Res.ValueType); if (Stream.Res <> nil) then
if (GraphicClass <> nil) and (GraphicClass.InheritsFrom(TBitmap)) then
begin begin
Result := TBitmap(GraphicClass.Create); GraphicClass := GetGraphicClassForFileExtension(Stream.Res.ValueType);
Stream := TMemoryStream.Create; if (GraphicClass <> nil) and (GraphicClass.InheritsFrom(TBitmap)) then
try begin
Stream.Write(Res.Value[1], length(Res.Value)); Result := TBitmap(GraphicClass.Create);
Stream.Position := 0;
Result.LoadFromStream(Stream); Result.LoadFromStream(Stream);
finally
Stream.Free;
end; end;
end; end;
finally
Stream.Free;
end; end;
end; end;

237
lcl/lresources.pp
View File

@ -37,7 +37,7 @@ interface
uses uses
Classes, SysUtils, Types, FPCAdds, TypInfo, DynQueue, LCLProc, LCLStrConsts, Classes, SysUtils, Types, FPCAdds, TypInfo, DynQueue, LCLProc, LCLStrConsts,
LazConfigStorage; LazConfigStorage, RtlConsts;
type type
{ TLResourceList } { TLResourceList }
@ -64,11 +64,25 @@ type
destructor Destroy; override; destructor Destroy; override;
procedure Add(const Name, ValueType, Value: AnsiString); procedure Add(const Name, ValueType, Value: AnsiString);
procedure Add(const Name, ValueType: AnsiString; const Values: array of string); procedure Add(const Name, ValueType: AnsiString; const Values: array of string);
function Find(const Name: AnsiString):TLResource; function Find(const Name: AnsiString): TLResource; overload;
function Find(const Name, ValueType: AnsiString): TLResource; overload;
function Count: integer; function Count: integer;
property Items[Index: integer]: TLResource read GetItems; property Items[Index: integer]: TLResource read GetItems;
end; end;
{ TLazarusResourceStream }
TLazarusResourceStream = class(TCustomMemoryStream)
private
FRes: TLResource;
procedure Initialize(Name, ResType: PChar);
public
constructor Create(const ResName: string; ResType: PChar);
constructor CreateFromID(ResID: Integer; ResType: PChar);
function Write(const Buffer; Count: Longint): Longint; override;
property Res: TLResource read FRes;
end;
{$IFDEF TRANSLATESTRING} {$IFDEF TRANSLATESTRING}
{ TAbstractTranslator} { TAbstractTranslator}
TAbstractTranslator = class(TObject)//Should it be somewhat more than TObject? TAbstractTranslator = class(TObject)//Should it be somewhat more than TObject?
@ -1111,15 +1125,16 @@ end;
constructor TLResourceList.Create; constructor TLResourceList.Create;
begin begin
FList:=TList.Create; FList := TList.Create;
FMergeList:=TList.Create; FMergeList := TList.Create;
FSortedCount:=0; FSortedCount := 0;
end; end;
destructor TLResourceList.Destroy; destructor TLResourceList.Destroy;
var a:integer; var
a: integer;
begin begin
for a:=0 to FList.Count-1 do for a := 0 to FList.Count - 1 do
TLResource(FList[a]).Free; TLResource(FList[a]).Free;
FList.Free; FList.Free;
FMergeList.Free; FMergeList.Free;
@ -1133,36 +1148,37 @@ begin
Result:=0; Result:=0;
end; end;
procedure TLResourceList.Add(const Name,ValueType: AnsiString; procedure TLResourceList.Add(const Name, ValueType: AnsiString;
const Values: array of string); const Values: array of string);
var var
NewLResource: TLResource; NewLResource: TLResource;
i, TotalLen, ValueCount, p: integer; i, TotalLen, ValueCount, p: integer;
begin begin
NewLResource:=TLResource.Create; NewLResource := TLResource.Create;
NewLResource.Name:=Name; NewLResource.Name := Name;
NewLResource.ValueType:=uppercase(ValueType); NewLResource.ValueType := uppercase(ValueType);
ValueCount:=High(Values)-Low(Values)+1; ValueCount := High(Values) - Low(Values) + 1;
case ValueCount of case ValueCount of
0: 0:
begin begin
NewLResource.Free; NewLResource.Free;
exit; exit;
end; end;
1:
1: NewLResource.Value:=Values[0]; NewLResource.Value:=Values[0];
else else
TotalLen:=0; TotalLen := 0;
for i:=Low(Values) to High(Values) do begin for i := Low(Values) to High(Values) do
inc(TotalLen,length(Values[i])); inc(TotalLen, length(Values[i]));
end; SetLength(NewLResource.Value, TotalLen);
SetLength(NewLResource.Value,TotalLen); p := 1;
p:=1; for i := Low(Values) to High(Values) do
for i:=Low(Values) to High(Values) do begin begin
if length(Values[i])>0 then begin if length(Values[i]) > 0 then
Move(Values[i][1],NewLResource.Value[p],length(Values[i])); begin
inc(p,length(Values[i])); Move(Values[i][1], NewLResource.Value[p], length(Values[i]));
inc(p, length(Values[i]));
end; end;
end; end;
end; end;
@ -1170,27 +1186,60 @@ begin
FList.Add(NewLResource); FList.Add(NewLResource);
end; end;
function TLResourceList.Find(const Name:AnsiString):TLResource; function TLResourceList.Find(const Name: AnsiString):TLResource;
var var
P: Integer; P: Integer;
begin begin
P := FindPosition(Name); P := FindPosition(Name);
if P >= 0 then if P >= 0 then
Result:=TLResource(FList[P]) Result := TLResource(FList[P])
else else
Result:=nil; Result := nil;
end;
function TLResourceList.Find(const Name, ValueType: AnsiString): TLResource;
var
P, I: Integer;
begin
P := FindPosition(Name);
if P >= 0 then
begin
// Since we can have many resources that have the same name but different type
// we should look before and after found position (dont forget that we are searching
// them by dividing intervals)
// look before position
for I := P - 1 downto 0 do
begin
Result := TLResource(FList[I]);
if (Result.Name = Name) and (Result.ValueType = ValueType) then
Exit;
end;
// look from position
for I := P to FList.Count - 1 do
begin
Result := TLResource(FList[I]);
if (Result.Name = Name) and (Result.ValueType = ValueType) then
Exit;
end;
Result := nil;
end
else
Result := nil;
end; end;
function TLResourceList.FindPosition(const Name: AnsiString): Integer; function TLResourceList.FindPosition(const Name: AnsiString): Integer;
var L,R,C: Integer; var
L, R, C: Integer;
begin begin
if FSortedCount < FList.Count then if FSortedCount < FList.Count then
Sort; Sort;
L := 0; L := 0;
R := FList.Count-1; R := FList.Count-1;
while (L <= R) do begin while (L <= R) do
Result:=(L + R) shr 1; begin
C := AnsiCompareText(Name,TLResource(FList[Result]).Name); Result := (L + R) shr 1;
C := AnsiCompareText(Name, TLResource(FList[Result]).Name);
if C < 0 then if C < 0 then
R := Result - 1 R := Result - 1
else else
@ -1204,75 +1253,87 @@ end;
function TLResourceList.GetItems(Index: integer): TLResource; function TLResourceList.GetItems(Index: integer): TLResource;
begin begin
Result:=TLResource(FList[Index]); Result := TLResource(FList[Index]);
end; end;
procedure TLResourceList.Sort; procedure TLResourceList.Sort;
begin begin
if FSortedCount=FList.Count then exit; if FSortedCount = FList.Count then
exit;
// sort the unsorted elements // sort the unsorted elements
FMergeList.Count:=FList.Count; FMergeList.Count := FList.Count;
MergeSort(FList,FMergeList,FSortedCount,FList.Count-1); MergeSort(FList, FMergeList, FSortedCount, FList.Count - 1);
// merge both // merge both
Merge(FList,FMergeList,0,FSortedCount,FList.Count-1); Merge(FList, FMergeList, 0, FSortedCount, FList.Count - 1);
FSortedCount:=FList.Count; FSortedCount := FList.Count;
end; end;
procedure TLResourceList.MergeSort(List,MergeList:TList; Pos1,Pos2:integer); procedure TLResourceList.MergeSort(List, MergeList: TList; Pos1, Pos2: integer);
var cmp,mid:integer; var
cmp, mid: integer;
begin begin
if Pos1=Pos2 then begin if Pos1 = Pos2 then
end else if Pos1+1=Pos2 then begin begin
cmp:=AnsiCompareText( end else
TLResource(List[Pos1]).Name,TLResource(List[Pos2]).Name); if Pos1 + 1 = Pos2 then
if cmp>0 then begin begin
MergeList[Pos1]:=List[Pos1]; cmp := AnsiCompareText(TLResource(List[Pos1]).Name, TLResource(List[Pos2]).Name);
List[Pos1]:=List[Pos2]; if cmp > 0 then
List[Pos2]:=MergeList[Pos1]; begin
MergeList[Pos1] := List[Pos1];
List[Pos1] := List[Pos2];
List[Pos2] := MergeList[Pos1];
end; end;
end else begin end else
if Pos2>Pos1 then begin begin
mid:=(Pos1+Pos2) shr 1; if Pos2 > Pos1 then
MergeSort(List,MergeList,Pos1,mid); begin
MergeSort(List,MergeList,mid+1,Pos2); mid := (Pos1 + Pos2) shr 1;
Merge(List,MergeList,Pos1,mid+1,Pos2); MergeSort(List, MergeList, Pos1, mid);
MergeSort(List, MergeList, mid + 1, Pos2);
Merge(List, MergeList, Pos1, mid + 1, Pos2);
end; end;
end; end;
end; end;
procedure TLResourceList.Merge(List,MergeList:TList;Pos1,Pos2,Pos3:integer); procedure TLResourceList.Merge(List, MergeList: TList; Pos1, Pos2, Pos3: integer);
// merge two sorted arrays // merge two sorted arrays
// the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3 // the first array ranges Pos1..Pos2-1, the second ranges Pos2..Pos3
var Src1Pos,Src2Pos,DestPos,cmp,a:integer; var
Src1Pos, Src2Pos, DestPos, cmp, a: integer;
begin begin
if (Pos1>=Pos2) or (Pos2>Pos3) then exit; if (Pos1 >= Pos2) or (Pos2 > Pos3) then
Src1Pos:=Pos2-1; exit;
Src2Pos:=Pos3; Src1Pos := Pos2 - 1;
DestPos:=Pos3; Src2Pos := Pos3;
while (Src2Pos>=Pos2) and (Src1Pos>=Pos1) do begin DestPos := Pos3;
cmp:=AnsiCompareText( while (Src2Pos >= Pos2) and (Src1Pos >= Pos1) do
TLResource(List[Src1Pos]).Name,TLResource(List[Src2Pos]).Name); begin
if cmp>0 then begin cmp:=AnsiCompareText(TLResource(List[Src1Pos]).Name, TLResource(List[Src2Pos]).Name);
MergeList[DestPos]:=List[Src1Pos]; if cmp > 0 then
begin
MergeList[DestPos] := List[Src1Pos];
dec(Src1Pos); dec(Src1Pos);
end else begin end else
MergeList[DestPos]:=List[Src2Pos]; begin
MergeList[DestPos] := List[Src2Pos];
dec(Src2Pos); dec(Src2Pos);
end; end;
dec(DestPos); dec(DestPos);
end; end;
while Src2Pos>=Pos2 do begin while Src2Pos >= Pos2 do
MergeList[DestPos]:=List[Src2Pos]; begin
MergeList[DestPos] := List[Src2Pos];
dec(Src2Pos); dec(Src2Pos);
dec(DestPos); dec(DestPos);
end; end;
for a:=DestPos+1 to Pos3 do for a := DestPos + 1 to Pos3 do
List[a]:=MergeList[a]; List[a] := MergeList[a];
end; end;
procedure TLResourceList.Add(const Name, ValueType, Value: AnsiString); procedure TLResourceList.Add(const Name, ValueType, Value: AnsiString);
begin begin
Add(Name,ValueType,[Value]); Add(Name, ValueType, [Value]);
end; end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
@ -4381,6 +4442,38 @@ begin
end; end;
end; end;
{ TLazarusResourceStream }
procedure TLazarusResourceStream.Initialize(Name, ResType: PChar);
begin
if ResType <> nil then
FRes := LazarusResources.Find(Name, ResType)
else
FRes := LazarusResources.Find(Name);
if FRes = nil then
raise EResNotFound.CreateFmt(SResNotFound, [Name]);
SetPointer(PChar(FRes.Value), Length(FRes.Value));
end;
constructor TLazarusResourceStream.Create(const ResName: string; ResType: PChar);
begin
inherited Create;
Initialize(PChar(ResName), ResType);
end;
constructor TLazarusResourceStream.CreateFromID(ResID: Integer; ResType: PChar);
begin
inherited Create;
Initialize(PChar(PtrInt(ResID)), ResType);
end;
function TLazarusResourceStream.Write(const Buffer; Count: Longint): Longint;
begin
Result := 0;
raise EStreamError.Create(SCantWriteResourceStreamError);
end;
//------------------------------------------------------------------------------ //------------------------------------------------------------------------------
procedure InternalInit; procedure InternalInit;
begin begin