1 {
2 /***************************************************************************
3 projectuserresources.pas - Lazarus IDE unit
4 ---------------------------------------
5 TProjectUserResources is responsible for the inclusion of the
6 custom resources in executables as res file
7
8
9 ***************************************************************************/
10
11 ***************************************************************************
12 * *
13 * This source is free software; you can redistribute it and/or modify *
14 * it under the terms of the GNU General Public License as published by *
15 * the Free Software Foundation; either version 2 of the License, or *
16 * (at your option) any later version. *
17 * *
18 * This code is distributed in the hope that it will be useful, but *
19 * WITHOUT ANY WARRANTY; without even the implied warranty of *
20 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
21 * General Public License for more details. *
22 * *
23 * A copy of the GNU General Public License is available on the World *
24 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
25 * obtain it by writing to the Free Software Foundation, *
26 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
27 * *
28 ***************************************************************************
29 }
30 unit ProjectUserResources;
31
32 {$mode objfpc}{$H+}
33 {$modeswitch advancedrecords}
34
35 interface
36
37 uses
38 // RTL + LCL
39 Classes, SysUtils,
40 resource, bitmapresource, groupresource, groupiconresource, groupcursorresource,
41 // LCL
42 LCLProc,
43 // LazUtils
44 FileProcs, LazFileUtils, LazUTF8, Laz2_XMLCfg,
45 // IdeIntf
46 ProjectResourcesIntf, IDEMsgIntf, MacroIntf, IDEExternToolIntf,
47 // IDE
48 LazarusIDEStrConsts;
49
50 type
51 TUserResourceType = (
52 rtIcon, // maps to RT_GROUP_ICON
53 rtCursor, // maps to RT_GROUP_CURSOR
54 rtBitmap, // maps to RT_BITMAP
55 rtHTML, // maps to RT_HTML
56 rtRCData // maps to RT_RCDATA
57 );
58 PResourceItem = ^TResourceItem;
59
60 { TResourceItem }
61
62 TResourceItem = record
63 public
64 FileName: String;
65 ResType: TUserResourceType;
66 ResName: String;
67 procedure ReadFromProjectFile(AConfig: TXMLConfig; const Path: String);
68 procedure WriteToProjectFile(AConfig: TXMLConfig; const Path: String);
CreateResourcenull69 function CreateResource(const ProjectDirectory: String): TAbstractResource;
GetRealFileNamenull70 function GetRealFileName(const ProjectDirectory: String): String;
71 end;
72
73 { TResourceList }
74
75 TResourceList = class(TList)
76 private
GetItemnull77 function GetItem(AIndex: Integer): PResourceItem;
78 protected
79 procedure Notify(Ptr: Pointer; Action: TListNotification); override;
80 public
AddItemnull81 function AddItem: PResourceItem;
82 procedure AddResource(const FileName: String; ResType: TUserResourceType; const ResName: String);
83 property Items[AIndex: Integer]: PResourceItem read GetItem; default;
84 end;
85
86 { TProjectUserResources }
87
88 TProjectUserResources = class(TAbstractProjectResource)
89 private
90 FList: TResourceList;
91 public
92 constructor Create; override;
93 destructor Destroy; override;
94
UpdateResourcesnull95 function UpdateResources(AResources: TAbstractProjectResources;
96 const MainFilename: string): Boolean; override;
97 procedure WriteToProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
98 procedure ReadFromProjectFile(AConfig: {TXMLConfig}TObject; const Path: String); override;
99 property List: TResourceList read FList;
100 end;
101
102 const
103 ResourceTypeToStr: array[TUserResourceType] of String = (
104 { rtIcon } 'ICON',
105 { rtCursor } 'CURSOR',
106 { rtBitmap } 'BITMAP',
107 { rtHTML } 'HTML',
108 { rtRCData } 'RCDATA'
109 );
110
StrToResourceTypenull111 function StrToResourceType(const AStr: String): TUserResourceType;
112
113 implementation
114
StrToResourceTypenull115 function StrToResourceType(const AStr: String): TUserResourceType;
116 begin
117 case AStr of
118 'ICON': Result := rtIcon;
119 'CURSOR': Result := rtCursor;
120 'BITMAP': Result := rtBitmap;
121 'HTML': Result := rtHTML;
122 else
123 Result := rtRCData;
124 end;
125 end;
126
127 { TResourceItem }
128
129 procedure TResourceItem.ReadFromProjectFile(AConfig: TXMLConfig; const Path: String);
130 begin
131 FileName := AConfig.GetValue(Path + 'FileName', '');
132 ResType := StrToResourceType(AConfig.GetValue(Path + 'Type', ''));
133 ResName := AConfig.GetValue(Path + 'ResourceName', '');
134 end;
135
136 procedure TResourceItem.WriteToProjectFile(AConfig: TXMLConfig; const Path: String);
137 begin
138 AConfig.SetValue(Path + 'FileName', FileName);
139 AConfig.SetValue(Path + 'Type', ResourceTypeToStr[ResType]);
140 AConfig.SetValue(Path + 'ResourceName', ResName);
141 end;
142
TResourceItem.CreateResourcenull143 function TResourceItem.CreateResource(const ProjectDirectory: String): TAbstractResource;
144 var
145 Stream: TFileStream;
146 TypeDesc, NameDesc: TResourceDesc;
147 RealFileName: String;
148 begin
149 Result := nil;
150
151 RealFileName := GetRealFileName(ProjectDirectory);
152
153 if FileExistsUTF8(RealFileName) then
154 begin
155 Stream := TFileStream.Create(UTF8ToSys(RealFileName), fmOpenRead or fmShareDenyWrite);
156 try
157 NameDesc := TResourceDesc.Create(ResName);
158 case ResType of
159 rtIcon:
160 begin
161 Result := TGroupIconResource.Create(nil, NameDesc);
162 TGroupResource(Result).ItemData.CopyFrom(Stream, Stream.Size)
163 end;
164 rtCursor:
165 begin
166 Result := TGroupCursorResource.Create(nil, NameDesc);
167 TGroupResource(Result).ItemData.CopyFrom(Stream, Stream.Size)
168 end;
169 rtBitmap:
170 begin
171 Result := TBitmapResource.Create(nil, NameDesc);
172 TBitmapResource(Result).BitmapData.CopyFrom(Stream, Stream.Size);
173 end;
174 rtHTML:
175 begin
176 TypeDesc := TResourceDesc.Create(RT_HTML);
177 Result := TGenericResource.Create(TypeDesc, NameDesc);
178 TypeDesc.Free;
179 TGenericResource(Result).RawData.CopyFrom(Stream, Stream.Size)
180 end;
181 rtRCData:
182 begin
183 TypeDesc := TResourceDesc.Create(RT_RCDATA);
184 Result := TGenericResource.Create(TypeDesc, NameDesc);
185 TypeDesc.Free;
186 TGenericResource(Result).RawData.CopyFrom(Stream, Stream.Size)
187 end;
188 end;
189 NameDesc.Free;
190 finally
191 Stream.Free;
192 end;
193 end
194 else
195 AddIDEMessage(mluError,Format(lisFileNotFound2, [Filename]));
196 end;
197
GetRealFileNamenull198 function TResourceItem.GetRealFileName(const ProjectDirectory: String): String;
199 begin
200 Result := FileName;
201 if not IDEMacros.SubstituteMacros(Result) then
202 debugln(['TResourceItem.GetRealFileName failed FileName="', FileName, '"']);
203 Result := TrimFilename(Result);
204 ForcePathDelims(Result);
205 if not FilenameIsAbsolute(Result) then
206 Result := TrimFilename(AppendPathDelim(ProjectDirectory) + Result);
207 end;
208
209 { TResourceList }
210
GetItemnull211 function TResourceList.GetItem(AIndex: Integer): PResourceItem;
212 begin
213 Result := PResourceItem(inherited Get(AIndex));
214 end;
215
216 procedure TResourceList.Notify(Ptr: Pointer; Action: TListNotification);
217 begin
218 if Action = lnDeleted then
219 Dispose(PResourceItem(Ptr))
220 else
221 inherited Notify(Ptr, Action);
222 end;
223
TResourceList.AddItemnull224 function TResourceList.AddItem: PResourceItem;
225 begin
226 New(Result);
227 Add(Result);
228 end;
229
230 procedure TResourceList.AddResource(const FileName: String;
231 ResType: TUserResourceType; const ResName: String);
232 var
233 Data: PResourceItem;
234 begin
235 Data := AddItem;
236 Data^.FileName := FileName;
237 Data^.ResType := ResType;
238 Data^.ResName := ResName;
239 end;
240
TProjectUserResources.UpdateResourcesnull241 function TProjectUserResources.UpdateResources(AResources: TAbstractProjectResources; const MainFilename: string): Boolean;
242 var
243 I: Integer;
244 ARes: TAbstractResource;
245 ProjectDirectory: String;
246 begin
247 Result := True;
248 ProjectDirectory := ExtractFilePath(MainFileName);
249 for I := 0 to List.Count - 1 do
250 begin
251 ARes := List[I]^.CreateResource(ProjectDirectory);
252 if Assigned(ARes) then
253 AResources.AddSystemResource(ARes);
254 end;
255 end;
256
257 procedure TProjectUserResources.WriteToProjectFile(AConfig: TObject; const Path: String);
258 var
259 I: Integer;
260 begin
261 TXMLConfig(AConfig).SetDeleteValue(Path+'General/Resources/Count', List.Count, 0);
262 for I := 0 to List.Count - 1 do
263 List[I]^.WriteToProjectFile(TXMLConfig(AConfig), Path + 'General/Resources/Resource_' + IntToStr(I) + '/')
264 end;
265
266 procedure TProjectUserResources.ReadFromProjectFile(AConfig: TObject; const Path: String);
267 var
268 I, Count: Integer;
269 begin
270 List.Clear;
271 Count := TXMLConfig(AConfig).GetValue(Path+'General/Resources/Count', 0);
272 for I := 0 to Count - 1 do
273 List.AddItem^.ReadFromProjectFile(TXMLConfig(AConfig), Path + 'General/Resources/Resource_' + IntToStr(I) + '/')
274 end;
275
276 constructor TProjectUserResources.Create;
277 begin
278 inherited Create;
279 FList := TResourceList.Create;
280 end;
281
282 destructor TProjectUserResources.Destroy;
283 begin
284 FList.Free;
285 inherited Destroy;
286 end;
287
288 initialization
289 RegisterProjectResource(TProjectUserResources);
290
291 end.
292
293