1 {
2 Copyright (c) 1998-2008 by Florian Klaempfl
3
4 Handles the resource files handling
5
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19
20 ****************************************************************************
21 }
22 unit comprsrc;
23
24 {$i fpcdefs.inc}
25
26 interface
27
28 uses
29 Systems, cstreams, cscript;
30
31 type
32 tresoutput = (roRES, roOBJ);
33
34 tresourcefile = class(TAbstractResourceFile)
35 private
36 fname : ansistring;
37 protected
SetupCompilerArgumentsnull38 function SetupCompilerArguments(output: tresoutput; const OutName :
39 ansistring; respath: ansistring; out ObjUsed : boolean) : ansistring; virtual;
40 public
41 constructor Create(const fn : ansistring);override;
Compilenull42 function Compile(output: tresoutput; const OutName: ansistring) : boolean; virtual;
43 procedure PostProcessResourcefile(const s : ansistring);virtual;
IsCompilednull44 function IsCompiled(const fn : ansistring) : boolean;virtual;
45 procedure Collect(const fn : ansistring);virtual;
46 procedure EndCollect; virtual;
47 end;
48
49 TWinLikeResourceFile = class(tresourcefile)
50 private
51 fResScript : TScript;
52 fScriptName : ansistring;
53 fCollectCount : integer;
54 protected
SetupCompilerArgumentsnull55 function SetupCompilerArguments(output: tresoutput; const OutName :
56 ansistring; respath: ansistring; out ObjUsed : boolean) : ansistring; override;
57 public
58 constructor Create(const fn : ansistring);override;
59 destructor Destroy; override;
Compilenull60 function Compile(output: tresoutput; const OutName: ansistring) : boolean; override;
IsCompilednull61 function IsCompiled(const fn : ansistring) : boolean;override;
62 procedure Collect(const fn : ansistring);override;
63 procedure EndCollect; override;
64 end;
65
66 TJVMRawResourceFile = class(TWinLikeResourceFile)
67 private
68 protected
69 public
Compilenull70 function Compile(output: tresoutput; const OutName: ansistring) : boolean; override;
IsCompilednull71 function IsCompiled(const fn : ansistring) : boolean;override;
72 end;
73
74
75 procedure CompileResourceFiles;
76 procedure CollectResourceFiles;
77
78 Var
79 ResCompiler : String;
80 RCCompiler : String;
81
82 implementation
83
84 uses
85 SysUtils,
86 cutils,cfileutl,cclasses,
87 Globtype,Globals,Verbose,Fmodule, comphook,cpuinfo;
88
89 {****************************************************************************
90 TRESOURCEFILE
91 ****************************************************************************}
92
93 constructor tresourcefile.create(const fn : ansistring);
94 begin
95 fname:=fn;
96 end;
97
98
99 procedure tresourcefile.PostProcessResourcefile(const s : ansistring);
100 begin
101 end;
102
103
tresourcefile.IsCompilednull104 function tresourcefile.IsCompiled(const fn: ansistring): boolean;
105 begin
106 Result:=CompareText(ExtractFileExt(fn), target_info.resobjext) = 0;
107 end;
108
109 procedure tresourcefile.Collect(const fn: ansistring);
110 begin
111 if fn='' then
112 exit;
113 fname:=fn;
114 Compile(roOBJ, ChangeFileExt(fn, target_info.resobjext));
115 end;
116
117 procedure tresourcefile.EndCollect;
118 begin
119
120 end;
121
tresourcefile.SetupCompilerArgumentsnull122 function tresourcefile.SetupCompilerArguments(output: tresoutput; const OutName
123 : ansistring; respath: ansistring; out ObjUsed : boolean) : ansistring;
124 var
125 s : TCmdStr;
126 begin
127 if output=roRES then
128 begin
129 s:=target_res.rccmd;
130 Replace(s,'$RES',maybequoted(OutName));
131 Replace(s,'$RC',maybequoted(fname));
132 ObjUsed:=False;
133 end
134 else
135 begin
136 s:=target_res.rescmd;
137 ObjUsed:=(pos('$OBJ',s)>0);
138 Replace(s,'$OBJ',maybequoted(OutName));
139 Replace(s,'$RES',maybequoted(fname));
140 end;
141 Result:=s;
142 end;
143
tresourcefile.compilenull144 function tresourcefile.compile(output: tresoutput; const OutName: ansistring)
145 : boolean;
146
SelectBinnull147 Function SelectBin(Const Bin1,Bin2 : String) : String;
148 begin
149 If (Bin1<>'') then
150 SelectBin:=Bin1
151 else
152 SelectBin:=Bin2;
153 end;
154
155 var
156 respath,
157 s,
158 bin,
159 resbin : TCmdStr;
160 resfound,
161 objused : boolean;
162 begin
163 Result:=true;
164 if output=roRES then
165 Bin:=SelectBin(RCCompiler,target_res.rcbin)
166 else
167 Bin:=SelectBin(ResCompiler,target_res.resbin);
168 if bin='' then
169 begin
170 Result:=false;
171 exit;
172 end;
173 resfound:=false;
174 if utilsdirectory<>'' then
175 resfound:=FindFile(utilsprefix+bin+source_info.exeext,utilsdirectory,false,resbin);
176 if not resfound then
177 begin
178 resfound:=FindExe(utilsprefix+bin,false,resbin);
179 if not resfound and (utilsprefix<>'') and ( (output=roRES) or (Pos('$ARCH', target_res.rescmd)<>0) ) then
180 { Search for resource compiler without utilsprefix, if RC->RES compiler is called }
181 { or RES->OBJ compiler supports different architectures. }
182 resfound:=FindExe(bin,false,resbin);
183 end;
184 { get also the path to be searched for the windres.h }
185 respath:=ExtractFilePath(resbin);
186 if (not resfound) and not(cs_link_nolink in current_settings.globalswitches) then
187 begin
188 Message1(exec_e_res_not_found, utilsprefix+bin+source_info.exeext);
189 current_settings.globalswitches:=current_settings.globalswitches+[cs_link_nolink];
190 Result:=false;
191 end;
192 s:=SetupCompilerArguments(output,OutName,respath,objused);
193 { Execute the command }
194 { Always try to compile resources. but don't complain if cs_link_nolink }
195 if resfound then
196 begin
197 Message1(exec_i_compilingresource,fname);
198 Message2(exec_d_resbin_params,resbin,s);
199 FlushOutput;
200 try
201 if RequotedExecuteProcess(resbin,s) <> 0 then
202 begin
203 if not (cs_link_nolink in current_settings.globalswitches) then
204 Message(exec_e_error_while_compiling_resources);
205 current_settings.globalswitches:=current_settings.globalswitches+[cs_link_nolink];
206 Result:=false;
207 end;
208 except
209 on E:EOSError do
210 begin
211 if not (cs_link_nolink in current_settings.globalswitches) then
212 Message1(exec_e_cant_call_resource_compiler, resbin);
213 current_settings.globalswitches:=current_settings.globalswitches+[cs_link_nolink];
214 Result:=false;
215 end
216 end;
217 end;
218 { Update asmres when externmode is set and resource compiling failed }
219 if (not Result) and (cs_link_nolink in current_settings.globalswitches) then
220 AsmRes.AddLinkCommand(resbin,s,OutName);
221 if Result and (output=roOBJ) and ObjUsed then
222 current_module.linkunitofiles.add(OutName,link_always);
223 end;
224
225 constructor TWinLikeResourceFile.Create(const fn : ansistring);
226 begin
227 inherited Create(fn);
228 fResScript:=nil;
229 fCollectCount:=0;
230 if (tf_use_8_3 in target_info.flags) then
231 fScriptName:=ChangeFileExt(fn,'.rls')
232 else
233 fScriptName:=ChangeFileExt(fn,'.reslst');
234 end;
235
236 destructor TWinLikeResourceFile.Destroy;
237 begin
238 if fResScript<>nil then
239 fResScript.Free;
240 inherited;
241 end;
242
SetupCompilerArgumentsnull243 function TWinLikeResourceFile.SetupCompilerArguments(output: tresoutput; const
244 OutName : ansistring; respath : ansistring; out ObjUsed : boolean) : ansistring;
245 var
246 srcfilepath,
247 preprocessorbin,
248 s : TCmdStr;
249 arch,
250 subarch: ansistring;
251
WindresFileNamenull252 function WindresFileName(filename: TCmdStr): TCmdStr;
253 // to be on the safe side, for files that are passed to the preprocessor,
254 // only give short file names with forward slashes to windres
255 var
256 i: longint;
257 begin
258 Result := GetShortName(filename);
259 for I:=1 to Length(Result) do
260 if Result[I] in AllowDirectorySeparators then
261 Result[i]:='/';
262 end;
263
264 begin
265 srcfilepath:=ExtractFilePath(current_module.mainsource);
266 if output=roRES then
267 begin
268 s:=target_res.rccmd;
269 if target_res.rcbin = 'windres' then
270 Replace(s,'$RC',WindresFileName(fname))
271 else
272 Replace(s,'$RC',maybequoted(fname));
273 Replace(s,'$RES',maybequoted(OutName));
274 ObjUsed:=False;
275 end
276 else
277 begin
278 s:=target_res.rescmd;
279 if (res_external_file in target_res.resflags) then
280 ObjUsed:=false
281 else
282 ObjUsed:=(pos('$OBJ',s)>0);
283 Replace(s,'$OBJ',maybequoted(OutName));
284 subarch:='all';
285 arch:=cpu2str[target_cpu];
286 if (target_info.cpu=systems.cpu_arm) then
287 begin
288 //Differentiate between arm and armeb
289 if (target_info.endian=endian_big) then
290 arch:=arch+'eb';
291 end;
292 if target_info.cpu=systems.cpu_powerpc64 then
293 begin
294 { differentiate between ppc64 and ppc64le }
295 if target_info.endian=endian_little then
296 arch:=arch+'le';
297 end;
298 Replace(s,'$ARCH',arch);
299 if target_info.system=system_arm_ios then
300 subarch:=lower(cputypestr[current_settings.cputype]);
301 Replace(s,'$SUBARCH',subarch);
302 case target_info.endian of
303 endian_little : Replace(s,'$ENDIAN','littleendian');
304 endian_big : Replace(s,'$ENDIAN','bigendian');
305 end;
306 //call resource compiler with debug switch
307 if (status.verbosity and V_Debug)<>0 then
308 Replace(s,'$DBG','-v')
309 else
310 Replace(s,'$DBG','');
311 if fCollectCount=0 then
312 s:=s+' '+maybequoted(fname)
313 else
314 s:=s+' '+maybequoted('@'+fScriptName);
315 end;
316 { windres doesn't like empty include paths }
317 if respath='' then
318 respath:='.';
319 Replace(s,'$INC',maybequoted(respath));
320 if (output=roRes) and (target_res.rcbin='windres') then
321 begin
322 { try to find a preprocessor }
323 preprocessorbin := respath+'cpp'+source_info.exeext;
324 if FileExists(preprocessorbin,true) then
325 s:='--preprocessor='+preprocessorbin+' '+s;
326 if (srcfilepath<>'') then
327 s:='--include '+WindresFileName(srcfilepath)+' '+s;
328 end;
329 Result:=s;
330 end;
331
compilenull332 function TWinLikeResourceFile.compile(output: tresoutput;
333 const OutName: ansistring) : boolean;
334 begin
335 Result:=inherited compile(output,OutName);
336 //delete fpc-res.lst file if things went well
337 if Result and (output=roOBJ) then
338 DeleteFile(fScriptName);
339 end;
340
IsCompilednull341 function TWinLikeResourceFile.IsCompiled(const fn: ansistring): boolean;
342 const
343 ResSignature : array [1..32] of byte =
344 ($00,$00,$00,$00,$20,$00,$00,$00,$FF,$FF,$00,$00,$FF,$FF,$00,$00,
345 $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00);
346 knownexts : array[1..4] of string[4] = ('.lfm', '.dfm', '.xfm', '.tlb');
347 var
348 f : file;
349 oldfmode : byte;
350 buf: array[1..32] of byte;
351 i: longint;
352 ext : shortstring;
353 begin
354 ext:=lower(ExtractFileExt(fn));
355 Result:=CompareText(ext, target_info.resext) = 0;
356 if not Result then
357 for i:=1 to high(knownexts) do
358 begin
359 Result:=CompareText(ext, knownexts[i]) = 0;
360 if Result then break;
361 end;
362
363 if Result or not FileExists(fn, False) then exit;
364 oldfmode:=Filemode;
365 Filemode:=0;
366 assign(f,fn);
367 reset(f,1);
368 BlockRead(f, buf, SizeOf(buf), i);
369 close(f);
370 Filemode:=oldfmode;
371
372 if i<>SizeOf(buf) then
373 exit;
374
375 for i:=1 to 32 do
376 if buf[i]<>ResSignature[i] then
377 exit;
378
379 Result:=True;
380 end;
381
382 procedure TWinLikeResourceFile.Collect(const fn: ansistring);
383 begin
384 if fResScript=nil then
385 fResScript:=TScript.Create(fScriptName);
386 fResScript.Add(maybequoted_for_script(fn,script_fpcres));
387 inc(fCollectCount);
388 end;
389
390 procedure TWinLikeResourceFile.EndCollect;
391 begin
392 if fResScript<>nil then
393 begin
394 fResScript.WriteToDisk;
395 FreeAndNil(fResScript);
396 Compile(roOBJ,ChangeFileExt(fname,target_info.resobjext));
397 end;
398 end;
399
400
401 {****************************************************************************
402 TJVMRawResourceFile
403 ****************************************************************************}
404
TJVMRawResourceFile.Compilenull405 function TJVMRawResourceFile.Compile(output: tresoutput; const OutName: ansistring): boolean;
406 begin
407 if output<>roOBJ then
408 internalerror(2011081703);
409 result:=inherited;
410 end;
411
412
IsCompilednull413 function TJVMRawResourceFile.IsCompiled(const fn: ansistring): boolean;
414 begin
415 internalerror(2011081704);
416 result:=true;
417 end;
418
419
CopyResFilenull420 function CopyResFile(inf,outf : TCmdStr) : boolean;
421 var
422 src,dst : TCCustomFileStream;
423 begin
424 { Copy .res file to units output dir. }
425 Result:=false;
426 src:=CFileStreamClass.Create(inf,fmOpenRead or fmShareDenyNone);
427 if CStreamError<>0 then
428 begin
429 Message1(exec_e_cant_open_resource_file, src.FileName);
430 Include(current_settings.globalswitches, cs_link_nolink);
431 exit;
432 end;
433 dst:=CFileStreamClass.Create(current_module.outputpath+outf,fmCreate);
434 if CStreamError<>0 then
435 begin
436 Message1(exec_e_cant_write_resource_file, dst.FileName);
437 Include(current_settings.globalswitches, cs_link_nolink);
438 exit;
439 end;
440 dst.CopyFrom(src,src.Size);
441 dst.Free;
442 src.Free;
443 Result:=true;
444 end;
445
446 procedure CompileResourceFiles;
447 var
448 resourcefile : tresourcefile;
449 res: TCmdStrListItem;
450 p,s : TCmdStr;
451 outfmt : tresoutput;
452 begin
453 { Don't do anything for systems supporting resources without using resource
454 file classes (e.g. Mac OS). They process resources elsewhere. }
455 if ((target_info.res<>res_none) and (target_res.resourcefileclass=nil)) or
456 (res_no_compile in target_res.resflags) then
457 exit;
458
459 p:=ExtractFilePath(ExpandFileName(current_module.mainsource));
460 res:=TCmdStrListItem(current_module.ResourceFiles.First);
461 while res<>nil do
462 begin
463 if target_info.res=res_none then
464 Message(scan_e_resourcefiles_not_supported);
465 s:=res.FPStr;
466 if not path_absolute(s) then
467 s:=p+s;
468 if not FileExists(s, True) then
469 begin
470 Message1(exec_e_cant_open_resource_file, s);
471 Include(current_settings.globalswitches, cs_link_nolink);
472 exit;
473 end;
474 resourcefile:=TResourceFile(resinfos[target_info.res]^.resourcefileclass.create(s));
475 if resourcefile.IsCompiled(s) then
476 begin
477 resourcefile.free;
478 if AnsiCompareFileName(IncludeTrailingPathDelimiter(ExpandFileName(current_module.outputpath)), p) <> 0 then
479 begin
480 { Copy .res file to units output dir. Otherwise .res file will not be found
481 when only compiled units path is available }
482 res.FPStr:=ExtractFileName(res.FPStr); //store file name only in PPU.
483 if not CopyResFile(s,res.FPStr) then exit;
484 end;
485 end
486 else
487 begin
488 res.FPStr:=ExtractFileName(res.FPStr);
489 if (target_res.rcbin='') and (RCCompiler='') then
490 begin
491 { if target does not have .rc to .res compiler, create obj }
492 outfmt:=roOBJ;
493 res.FPStr:=ChangeFileExt(res.FPStr,target_info.resobjext);
494 end
495 else
496 begin
497 outfmt:=roRES;
498 res.FPStr:=ChangeFileExt(res.FPStr,target_info.resext);
499 end;
500 resourcefile.compile(outfmt, current_module.outputpath+res.FPStr);
501 resourcefile.free;
502 end;
503 res:=TCmdStrListItem(res.Next);
504 end;
505 end;
506
507
508 procedure CollectResourceFiles;
509 var
510 resourcefile : tresourcefile;
511
512 procedure ProcessModule(u : tmodule);
513 var
514 res : TCmdStrListItem;
515 s : TCmdStr;
516 begin
517 res:=TCmdStrListItem(u.ResourceFiles.First);
518 while assigned(res) do
519 begin
520 if path_absolute(res.FPStr) then
521 s:=res.FPStr
522 else
523 begin
524 s:=u.path+res.FPStr;
525 if not FileExists(s,True) then
526 s:=u.outputpath+res.FPStr;
527 end;
528 resourcefile.Collect(s);
529 res:=TCmdStrListItem(res.Next);
530 end;
531 end;
532
533 var
534 hp : tused_unit;
535 s : TCmdStr;
536 begin
537 if (target_info.res=res_none) or ((target_res.resbin='')
538 and (ResCompiler='')) then
539 exit;
540 // if cs_link_nolink in current_settings.globalswitches then
541 // exit;
542 s:=ChangeFileExt(current_module.ppufilename,target_info.resobjext);
543 if (res_arch_in_file_name in target_res.resflags) then
544 s:=ChangeFileExt(s,'.'+cpu2str[target_cpu]+target_info.resobjext);
545 resourcefile:=TResourceFile(resinfos[target_info.res]^.resourcefileclass.create(s));
546 hp:=tused_unit(usedunits.first);
547 while assigned(hp) do
548 begin
549 ProcessModule(hp.u);
550 hp:=tused_unit(hp.next);
551 end;
552 ProcessModule(current_module);
553 { Finish collection }
554 resourcefile.EndCollect;
555 resourcefile.free;
556 end;
557
558 end.
559