1 {
2 /***************************************************************************
3 projectresources.pas - Lazarus IDE unit
4 -----------------------------------------
5
6 ***************************************************************************/
7
8 ***************************************************************************
9 * *
10 * This source is free software; you can redistribute it and/or modify *
11 * it under the terms of the GNU General Public License as published by *
12 * the Free Software Foundation; either version 2 of the License, or *
13 * (at your option) any later version. *
14 * *
15 * This code is distributed in the hope that it will be useful, but *
16 * WITHOUT ANY WARRANTY; without even the implied warranty of *
17 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
18 * General Public License for more details. *
19 * *
20 * A copy of the GNU General Public License is available on the World *
21 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
22 * obtain it by writing to the Free Software Foundation, *
23 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
24 * *
25 ***************************************************************************
26
27 Abstract: Project Resources - is a list of System and Lazarus resources.
28 Currently it contains:
29 - Version information
30 - XP manifest
31 - Project icon
32 }
33 unit ProjectResources;
34
35 {$mode objfpc}{$H+}
36
37 interface
38
39 uses
40 // RTL + LCL
41 Classes, SysUtils, resource, reswriter, fgl, Laz_AVL_Tree,
42 // LCL
43 Controls, LCLProc, LResources,
44 // LazUtils
45 LazFileUtils, Laz2_XMLCfg,
46 // Codetools
47 KeywordFuncLists, BasicCodeTools, CodeToolManager, CodeCache,
48 // IdeIntf
49 ProjectIntf, ProjectResourcesIntf, CompOptsIntf,
50 // IDE
51 LazarusIDEStrConsts, DialogProcs,
52 W32Manifest, W32VersionInfo, ProjectIcon, ProjectUserResources;
53
54 type
55 TResourceList = specialize TFPGObjectList<TAbstractProjectResource>;
56
57 { TProjectResources }
58
59 TProjectResources = class(TAbstractProjectResources)
60 private
61 FModified: Boolean;
62 FOnModified: TNotifyEvent;
63 FInModified: Boolean;
64 FLrsIncludeAllowed: Boolean;
65
66 FResources: TResourceList;
67 FSystemResources: TResources;
68 FLazarusResources: TStringList;
69
70 resFileName: String;
71 lrsFileName: String;
72 LastResFileName: String;
73 LastLrsFileName: String;
74
GetProjectIconnull75 function GetProjectIcon: TProjectIcon;
GetProjectUserResourcesnull76 function GetProjectUserResources: TProjectUserResources;
GetVersionInfonull77 function GetVersionInfo: TProjectVersionInfo;
GetXPManifestnull78 function GetXPManifest: TProjectXPManifest;
79 procedure SetFileNames(const MainFileName, TestDir: String);
80 procedure SetModified(const AValue: Boolean);
Updatenull81 function Update: Boolean;
UpdateMainSourceFilenull82 function UpdateMainSourceFile(const AFileName: string): Boolean;
83 procedure UpdateFlagLrsIncludeAllowed(const AFileName: string);
Savenull84 function Save(SaveToTestDir: string): Boolean;
85 procedure UpdateCodeBuffers;
86 procedure DeleteLastCodeBuffers;
87
88 procedure OnResourceModified(Sender: TObject);
89 protected
90 procedure SetResourceType(const AValue: TResourceType); override;
GetProjectResourcenull91 function GetProjectResource(AIndex: TAbstractProjectResourceClass): TAbstractProjectResource; override;
92 public
93 constructor Create(AProject: TLazProject); override;
94 destructor Destroy; override;
95
96 procedure AddSystemResource(AResource: TAbstractResource); override;
97 procedure AddLazarusResource(AResource: TStream; const AResourceName, AResourceType: String); override;
98
99 procedure DoAfterBuild(AReason: TCompileReason; SaveToTestDir: boolean);
100 procedure DoBeforeBuild(AReason: TCompileReason; SaveToTestDir: boolean);
101 procedure Clear;
Regeneratenull102 function Regenerate(const MainFileName: String;
103 UpdateSource, PerformSave: boolean;
104 const SaveToTestDir: string): Boolean;
RenameDirectivesnull105 function RenameDirectives(const CurFileName, NewFileName: String): Boolean;
106 procedure DeleteResourceBuffers;
107
HasSystemResourcesnull108 function HasSystemResources: Boolean;
HasLazarusResourcesnull109 function HasLazarusResources: Boolean;
110
111 procedure WriteToProjectFile(AConfig: TXMLConfig; const Path: String);
112 procedure ReadFromProjectFile(AConfig: TXMLConfig; const Path: String; ReadAll: Boolean);
113
114 property Modified: Boolean read FModified write SetModified;
115 property OnModified: TNotifyEvent read FOnModified write FOnModified;
116
117 property XPManifest: TProjectXPManifest read GetXPManifest;
118 property VersionInfo: TProjectVersionInfo read GetVersionInfo;
119 property ProjectIcon: TProjectIcon read GetProjectIcon;
120 property UserResources: TProjectUserResources read GetProjectUserResources;
121 end;
122
GuessResourceTypenull123 function GuessResourceType(Code: TCodeBuffer; out Typ: TResourceType): boolean;
124
125 const
126 ResourceTypeNames: array[TResourceType] of string = (
127 'lrs',
128 'res'
129 );
130
StrToResourceTypenull131 function StrToResourceType(const s: string): TResourceType;
132
133 implementation
134
135 const
136 LazResourcesUnit = 'LResources';
137
StrToResourceTypenull138 function StrToResourceType(const s: string): TResourceType;
139 var
140 t: TResourceType;
141 begin
142 for t := Low(TResourceType) to High(TResourceType) do
143 if SysUtils.CompareText(ResourceTypeNames[t], s) = 0 then exit(t);
144 Result := rtLRS;
145 end;
146
147 procedure ParseResourceType(Code: TCodeBuffer; NestedComments: boolean;
148 out HasLRSIncludeDirective, HasRDirective: boolean);
149
ExtractDirectiveFileNamenull150 function ExtractDirectiveFileName(ds: PChar): string;
151 var i: Integer;
152 begin
153 while IsIdentChar[ds^] do Inc(ds);
154 while ds^ in [' ',#9] do Inc(ds);
155 if ds^ = '''' then
156 begin
157 Inc(ds);
158 i := IndexChar(ds^, -1, '''');
159 SetLength(Result, i);
160 if i>0 then
161 Move(ds^, Result[1], i);
162 end else begin
163 i := IndexChar(ds^, -1, '}');
164 SetLength(Result, i);
165 if i>0 then
166 Move(ds^, Result[1], i);
167 Result := TrimRight(Result);
168 end;
169 end;
170
171 var
172 p: Integer;
173 d: PChar;
174 Src, dFileName: string;
175 begin
176 Src := Code.Source;
177 HasLRSIncludeDirective := False;
178 HasRDirective := False;
179 p:=1;
180 while p < length(Src) do
181 begin
182 p := FindNextCompilerDirective(Src, p, NestedComments);
183 if p > length(Src) then break;
184 d := @Src[p];
185 if (d[0]='{') and (d[1]='$') then
186 begin
187 inc(d, 2);
188 if (d[0] in ['r','R']) and not (HasRDirective or IsIdentChar[d[1]]) then
189 begin
190 // using resources
191 dFileName := ExtractDirectiveFileName(d);
192 HasRDirective := SameText(dFileName, '*.lfm') or
193 SameText(dFileName, ExtractFileNameOnly(Code.Filename) + '.lfm');
194 end
195 else
196 if (d[0] in ['i','I']) and not HasLRSIncludeDirective
197 and ((d[1] in [' ',#9]) or (CompareIdentifiers(@d[0],'include')=0)) then
198 begin
199 // using include directive with lrs file
200 dFileName := ExtractDirectiveFileName(d);
201 HasLRSIncludeDirective :=
202 SameText(dFileName, ExtractFileNameOnly(Code.Filename) + '.lrs') or
203 SameText(dFileName, '*.lrs');
204 end;
205 end;
206 p := FindCommentEnd(Src, p, NestedComments);
207 end;
208 end;
209
210 type
211 TResourceTypesCacheItem = class
212 public
213 Code: TCodeBuffer;
214 CodeStamp: integer;
215 HasLRSIncludeDirective: boolean;
216 HasRDirective: boolean;
217 end;
218
CompareResTypCacheItemsnull219 function CompareResTypCacheItems(Data1, Data2: Pointer): integer;
220 var
221 Item1: TResourceTypesCacheItem absolute Data1;
222 Item2: TResourceTypesCacheItem absolute Data2;
223 begin
224 Result:=CompareFilenames(Item1.Code.Filename,Item2.Code.Filename);
225 end;
226
CompareCodeWithResTypCacheItemnull227 function CompareCodeWithResTypCacheItem(CodeBuf, CacheItem: Pointer): integer;
228 var
229 Code: TCodeBuffer absolute CodeBuf;
230 Item: TResourceTypesCacheItem absolute CacheItem;
231 begin
232 Result:=CompareFilenames(Code.Filename,Item.Code.Filename);
233 end;
234
235 type
236
237 { TResourceTypesCache }
238
239 TResourceTypesCache = class
240 public
241 Tree: TAvlTree; //
242 constructor Create;
243 destructor Destroy; override;
244 procedure Parse(Code: TCodeBuffer;
245 out HasLRSIncludeDirective, HasRDirective: boolean);
246 end;
247
248 { TResourceTypesCache }
249
250 constructor TResourceTypesCache.Create;
251 begin
252 Tree:=TAvlTree.Create(@CompareResTypCacheItems);
253 end;
254
255 destructor TResourceTypesCache.Destroy;
256 begin
257 Tree.FreeAndClear;
258 FreeAndNil(Tree);
259 inherited Destroy;
260 end;
261
262 procedure TResourceTypesCache.Parse(Code: TCodeBuffer; out
263 HasLRSIncludeDirective, HasRDirective: boolean);
264 var
265 Node: TAvlTreeNode;
266 Item: TResourceTypesCacheItem;
267 begin
268 Node := Tree.FindKey(Code, @CompareCodeWithResTypCacheItem);
269 if (Node <> nil) then
270 begin
271 Item := TResourceTypesCacheItem(Node.Data);
272 if (Item.CodeStamp = Item.Code.ChangeStep) then
273 begin
274 // cache valid
275 HasLRSIncludeDirective := Item.HasLRSIncludeDirective;
276 HasRDirective := Item.HasRDirective;
277 exit;
278 end;
279 end
280 else
281 Item := nil;
282 // update
283 if Item = nil then
284 begin
285 Item := TResourceTypesCacheItem.Create;
286 Item.Code := Code;
287 Tree.Add(Item);
288 end;
289 Item.CodeStamp := Code.ChangeStep;
290 ParseResourceType(Code,
291 CodeToolBoss.GetNestedCommentsFlagForFile(Code.Filename),
292 Item.HasLRSIncludeDirective, Item.HasRDirective);
293 HasLRSIncludeDirective := Item.HasLRSIncludeDirective;
294 HasRDirective := Item.HasRDirective;
295 end;
296
297 var
298 ResourceTypesCache: TResourceTypesCache = nil;
299
GuessResourceTypenull300 function GuessResourceType(Code: TCodeBuffer; out Typ: TResourceType): boolean;
301 var
302 HasLRSIncludeDirective, HasRDirective: Boolean;
303 begin
304 if ResourceTypesCache = nil then
305 ResourceTypesCache := TResourceTypesCache.Create;
306 ResourceTypesCache.Parse(Code, HasLRSIncludeDirective, HasRDirective);
307 //DebugLn(['GuessResourceType ',Code.Filename,' HasLRS=',HasLRSIncludeDirective,' HasR=',HasRDirective]);
308 if HasLRSIncludeDirective then
309 begin
310 Typ := rtLRS;
311 Result := True;
312 end
313 else
314 if HasRDirective then
315 begin
316 Typ := rtRes;
317 Result := True;
318 end
319 else
320 begin
321 Typ := rtLRS;
322 Result := False;
323 end;
324 end;
325
326 { TProjectResources }
327
328 procedure TProjectResources.SetFileNames(const MainFileName, TestDir: String);
329 begin
330 // rc is in the executable dir
331 //resFileName := TestDir + ExtractFileNameOnly(MainFileName) + '.rc';
332
333 // res is in the project dir for now because {$R project1.res} searches only in unit dir
334 // lrs is in the project dir also
335 if FileNameIsAbsolute(MainFileName) then
336 begin
337 resFileName := ChangeFileExt(MainFileName, '.res');
338 lrsFileName := ChangeFileExt(MainFileName, '.lrs');
339 end
340 else
341 begin
342 resFileName := TestDir + ExtractFileNameOnly(MainFileName) + '.res';
343 lrsFileName := TestDir + ExtractFileNameOnly(MainFileName) + '.lrs';
344 end;
345 end;
346
GetProjectIconnull347 function TProjectResources.GetProjectIcon: TProjectIcon;
348 begin
349 Result := TProjectIcon(GetProjectResource(TProjectIcon));
350 end;
351
TProjectResources.GetProjectUserResourcesnull352 function TProjectResources.GetProjectUserResources: TProjectUserResources;
353 begin
354 Result := TProjectUserResources(GetProjectResource(TProjectUserResources));
355 end;
356
TProjectResources.GetVersionInfonull357 function TProjectResources.GetVersionInfo: TProjectVersionInfo;
358 begin
359 Result := TProjectVersionInfo(GetProjectResource(TProjectVersionInfo));
360 end;
361
TProjectResources.GetXPManifestnull362 function TProjectResources.GetXPManifest: TProjectXPManifest;
363 begin
364 Result := TProjectXPManifest(GetProjectResource(TProjectXPManifest));
365 end;
366
367 procedure TProjectResources.SetResourceType(const AValue: TResourceType);
368 begin
369 if ResourceType <> AValue then
370 begin
371 inherited SetResourceType(AValue);
372 Modified := True;
373 end;
374 end;
375
376 procedure TProjectResources.SetModified(const AValue: Boolean);
377 var
378 i: integer;
379 begin
380 if FInModified then
381 Exit;
382 FInModified := True;
383 if FModified <> AValue then
384 begin
385 FModified := AValue;
386 if not FModified then
387 for i := 0 to FResources.Count - 1 do
388 FResources[i].Modified := False;
389 if Assigned(FOnModified) then
390 OnModified(Self);
391 end;
392 FInModified := False;
393 end;
394
TProjectResources.Updatenull395 function TProjectResources.Update: Boolean;
396 var
397 i: integer;
398 begin
399 Result:=true;
400 Clear;
401 for i := 0 to FResources.Count - 1 do
402 begin
403 Result := FResources[i].UpdateResources(Self, resFileName);
404 if not Result then begin
405 debugln(['TProjectResources.Update UpdateResources of ',DbgSName(FResources[i]),' failed']);
406 Exit;
407 end;
408 end;
409 end;
410
411 procedure TProjectResources.OnResourceModified(Sender: TObject);
412 begin
413 Modified := Modified or TAbstractProjectResource(Sender).Modified;
414 end;
415
416 constructor TProjectResources.Create(AProject: TLazProject);
417 var
418 i: integer;
419 L: TList;
420 R: TAbstractProjectResource;
421 begin
422 inherited Create(AProject);
423 inherited SetResourceType(rtRes); // set fpc resources by default
424
425 FInModified := False;
426 FLrsIncludeAllowed := False;
427
428 FSystemResources := TResources.Create;
429 FLazarusResources := TStringList.Create;
430
431 FResources := TResourceList.Create;
432 L := GetRegisteredResources;
433 for i := 0 to L.Count - 1 do
434 begin
435 R := TAbstractProjectResourceClass(L[i]).Create;
436 R.Modified := False;
437 R.OnModified := @OnResourceModified;
438 FResources.Add(R);
439 end;
440 end;
441
442 destructor TProjectResources.Destroy;
443 begin
444 DeleteResourceBuffers;
445
446 FreeAndNil(FResources);
447 FreeAndNil(FSystemResources);
448 FreeAndNil(FLazarusResources);
449
450 inherited Destroy;
451 end;
452
453 procedure TProjectResources.AddSystemResource(AResource: TAbstractResource);
454 begin
455 FSystemResources.Add(AResource);
456 end;
457
458 procedure TProjectResources.AddLazarusResource(AResource: TStream;
459 const AResourceName, AResourceType: String);
460 var
461 OutStream: TStringStream;
462 begin
463 OutStream := TStringStream.Create('');
464 try
465 BinaryToLazarusResourceCode(AResource, OutStream, AResourceName, AResourceType);
466 FLazarusResources.Add(OutStream.DataString);
467 finally
468 OutStream.Free;
469 end;
470 end;
471
TProjectResources.GetProjectResourcenull472 function TProjectResources.GetProjectResource(AIndex: TAbstractProjectResourceClass): TAbstractProjectResource;
473 var
474 i: integer;
475 begin
476 for i := 0 to FResources.Count - 1 do
477 begin
478 Result := FResources[i];
479 if Result.InheritsFrom(AIndex) then
480 Exit;
481 end;
482 Result := nil;
483 end;
484
485 procedure TProjectResources.DoAfterBuild(AReason: TCompileReason; SaveToTestDir: boolean);
486 var
487 i: integer;
488 begin
489 for i := 0 to FResources.Count - 1 do
490 FResources[i].DoAfterBuild(Self, AReason, SaveToTestDir);
491 end;
492
493 procedure TProjectResources.DoBeforeBuild(AReason: TCompileReason; SaveToTestDir: boolean);
494 var
495 i: integer;
496 begin
497 for i := 0 to FResources.Count - 1 do
498 FResources[i].DoBeforeBuild(Self, AReason, SaveToTestDir);
499 end;
500
501 procedure TProjectResources.Clear;
502 begin
503 FSystemResources.Clear;
504 FLazarusResources.Clear;
505 FMessages.Clear;
506 end;
507
Regeneratenull508 function TProjectResources.Regenerate(const MainFileName: String; UpdateSource,
509 PerformSave: boolean; const SaveToTestDir: string): Boolean;
510 begin
511 //DebugLn(['TProjectResources.Regenerate MainFilename=',MainFilename,
512 // ' UpdateSource=',UpdateSource,' PerformSave=',PerformSave]);
513 //DumpStack;
514 Result := False;
515
516 if (MainFileName = '') then
517 Exit(true);
518
519 // remember old codebuffer filenames
520 LastResFileName := resFileName;
521 LastLrsFileName := lrsFileName;
522 SetFileNames(MainFileName, SaveToTestDir);
523
524 UpdateFlagLrsIncludeAllowed(MainFileName);
525
526 try
527 // update resources (FLazarusResources, FSystemResources, ...)
528 if not Update then begin
529 debugln(['TProjectResources.Regenerate Update failed']);
530 Exit;
531 end;
532 // create codebuffers of new .lrs and .rc files
533 UpdateCodeBuffers;
534 // update .lpr file (old and new include files exist, so parsing should work without errors)
535 if UpdateSource and not UpdateMainSourceFile(MainFileName) then begin
536 debugln(['TProjectResources.Regenerate UpdateMainSourceFile failed']);
537 exit;
538 end;
539
540 if PerformSave and not Save(SaveToTestDir) then begin
541 debugln(['TProjectResources.Regenerate Save failed']);
542 Exit;
543 end;
544 finally
545 DeleteLastCodeBuffers;
546 end;
547
548 Result := True;
549 end;
550
HasSystemResourcesnull551 function TProjectResources.HasSystemResources: Boolean;
552 begin
553 Result := FSystemResources.Count > 0;
554 end;
555
TProjectResources.HasLazarusResourcesnull556 function TProjectResources.HasLazarusResources: Boolean;
557 begin
558 Result := FLazarusResources.Count > 0;
559 end;
560
561 procedure TProjectResources.WriteToProjectFile(AConfig: TXMLConfig;
562 const Path: String);
563 var
564 i: integer;
565 begin
566 AConfig.SetDeleteValue(Path+'General/ResourceType/Value', ResourceTypeNames[ResourceType], ResourceTypeNames[rtLRS]);
567 for i := 0 to FResources.Count - 1 do
568 FResources[i].WriteToProjectFile(AConfig, Path);
569 end;
570
571 procedure TProjectResources.ReadFromProjectFile(AConfig: TXMLConfig;
572 const Path: String; ReadAll: Boolean);
573 var
574 i: integer;
575 begin
576 ResourceType := StrToResourceType(AConfig.GetValue(Path+'General/ResourceType/Value', ResourceTypeNames[rtLRS]));
577 for i := 0 to FResources.Count - 1 do
578 if ReadAll or FResources[i].IsDefaultOption then
579 FResources[i].ReadFromProjectFile(AConfig, Path);
580 end;
581
UpdateMainSourceFilenull582 function TProjectResources.UpdateMainSourceFile(const AFileName: string): Boolean;
583 var
584 NewX, NewY, NewTopLine: integer;
585 CodeBuf, NewCode: TCodeBuffer;
586 Filename, Directive: String;
587 NamePos, InPos: integer;
588 begin
589 Result := True;
590
591 CodeBuf := CodeToolBoss.LoadFile(AFilename, False, False);
592 if CodeBuf <> nil then
593 begin
594 SetFileNames(AFileName, '');
595 Filename := ExtractFileName(resFileName);
596 //debugln(['TProjectResources.UpdateMainSourceFile HasSystemResources=',HasSystemResources,' Filename=',Filename,' HasLazarusResources=',HasLazarusResources]);
597
598 // update LResources uses
599 if CodeToolBoss.FindUnitInAllUsesSections(CodeBuf, LazResourcesUnit, NamePos, InPos) then
600 begin
601 if not (FLrsIncludeAllowed and HasLazarusResources) then
602 begin
603 if not CodeToolBoss.RemoveUnitFromAllUsesSections(CodeBuf, LazResourcesUnit) then
604 begin
605 Result := False;
606 Messages.Add(Format(lisCouldNotRemoveFromMainSource, [LazResourcesUnit]));
607 debugln(['TProjectResources.UpdateMainSourceFile removing LResources from all uses sections failed']);
608 end;
609 end;
610 end
611 else
612 if FLrsIncludeAllowed and HasLazarusResources then
613 begin
614 if not CodeToolBoss.AddUnitToMainUsesSection(CodeBuf, LazResourcesUnit,'') then
615 begin
616 Result := False;
617 Messages.Add(Format(lisCouldNotAddToMainSource, [LazResourcesUnit]));
618 debugln(['TProjectResources.UpdateMainSourceFile adding LResources to main source failed']);
619 end;
620 end;
621
622 // update {$R filename} directive
623 if CodeToolBoss.FindResourceDirective(CodeBuf, 1, 1,
624 NewCode, NewX, NewY,
625 NewTopLine, '*.res', false) then
626 begin
627 // there is a resource directive in the source
628 if not HasSystemResources then
629 begin
630 if not CodeToolBoss.RemoveDirective(NewCode, NewX, NewY, true) then
631 begin
632 Result := False;
633 Messages.Add(Format(lisCouldNotRemoveRFromMainSource, [Filename]));
634 debugln(['TProjectResources.UpdateMainSourceFile failed: removing resource directive']);
635 end;
636 end;
637 end
638 else
639 if HasSystemResources then
640 begin
641 Directive := '{$R *.res}';
642 if not CodeToolBoss.AddResourceDirective(CodeBuf, Filename, false, Directive) then
643 begin
644 Result := False;
645 Messages.Add(Format(lisCouldNotAddRToMainSource, [Filename]));
646 debugln(['TProjectResources.UpdateMainSourceFile failed: adding resource directive']);
647 end;
648 end;
649
650 // update {$I filename} directive
651 Filename := ExtractFileName(lrsFileName);
652 if CodeToolBoss.FindIncludeDirective(CodeBuf, 1, 1,
653 NewCode, NewX, NewY,
654 NewTopLine, Filename, false) then
655 begin
656 // there is a resource directive in the source
657 //debugln(['TProjectResources.UpdateMainSourceFile include directive found: FCanHaveLrsInclude=',FLrsIncludeAllowed,' HasLazarusResources=',HasLazarusResources]);
658 if not (FLrsIncludeAllowed and HasLazarusResources) then
659 begin
660 if not CodeToolBoss.RemoveDirective(NewCode, NewX, NewY, true) then
661 begin
662 Result := False;
663 Messages.Add(Format(lisCouldNotRemoveIFromMainSource, [Filename]));
664 debugln(['TProjectResources.UpdateMainSourceFile removing include directive from main source failed']);
665 Exit;
666 end;
667 end;
668 end
669 else
670 if FLrsIncludeAllowed and HasLazarusResources then
671 begin
672 //debugln(['TProjectResources.UpdateMainSourceFile include directive not found: FCanHaveLrsInclude=',FLrsIncludeAllowed,' HasLazarusResources=',HasLazarusResources]);
673 if not CodeToolBoss.AddIncludeDirectiveForInit(CodeBuf,Filename,'') then
674 begin
675 Result := False;
676 Messages.Add(Format(lisCouldNotAddIToMainSource, [Filename]));
677 debugln(['TProjectResources.UpdateMainSourceFile adding include directive to main source failed']);
678 Exit;
679 end;
680 end;
681 end;
682 end;
683
684 procedure TProjectResources.UpdateFlagLrsIncludeAllowed(const AFileName: string);
685 var
686 CodeBuf: TCodeBuffer;
687 NamePos, InPos: Integer;
688 begin
689 FLrsIncludeAllowed := False;
690
691 CodeBuf := CodeToolBoss.LoadFile(AFileName, False, False);
692 if CodeBuf = nil then
693 Exit;
694
695 // Check that .lpr contains Forms and Interfaces in the uses section. If it does not
696 // we cannot add LResources (it is not a lazarus application)
697 CodeToolBoss.ActivateWriteLock;
698 try
699 FLrsIncludeAllowed :=
700 CodeToolBoss.FindUnitInAllUsesSections(CodeBuf, 'Forms', NamePos, InPos, True) and
701 CodeToolBoss.FindUnitInAllUsesSections(CodeBuf, 'Interfaces', NamePos, InPos, True);
702 finally
703 CodeToolBoss.DeactivateWriteLock;
704 end;
705 end;
706
TProjectResources.RenameDirectivesnull707 function TProjectResources.RenameDirectives(const CurFileName, NewFileName: String): Boolean;
708 var
709 NewX, NewY, NewTopLine: integer;
710 CodeBuf, NewCode: TCodeBuffer;
711
712 oldLrsFileName, newLrsFileName: String;
713 begin
714 //DebugLn(['TProjectResources.RenameDirectives CurFileName="',CurFileName,'" NewFileName="',NewFileName,'"']);
715 Result := True;
716
717 CodeBuf := CodeToolBoss.LoadFile(CurFileName, False, False);
718 if CodeBuf = nil then
719 Exit;
720
721 LastResFileName := resFileName;
722 LastLrsFileName := lrsFileName;
723 try
724 SetFileNames(CurFileName, '');
725 oldLrsFileName := ExtractFileName(lrsFileName);
726 SetFileNames(NewFileName, '');
727 newLrsFileName := ExtractFileName(lrsFileName);
728
729 // update resources (FLazarusResources, FSystemResources, ...)
730 UpdateFlagLrsIncludeAllowed(CurFileName);
731 if not Update then
732 Exit;
733 // update codebuffers of new .lrs and .res files
734 UpdateCodeBuffers;
735
736 // update {$I filename} directive
737 if CodeToolBoss.FindIncludeDirective(CodeBuf, 1, 1,
738 NewCode, NewX, NewY,
739 NewTopLine, oldLrsFileName, false) then
740 begin
741 // there is a resource directive in the source
742 if not CodeToolBoss.RemoveDirective(NewCode, NewX, NewY, true) then
743 begin
744 Result := False;
745 debugln(['TProjectResources.RenameDirectives removing include directive from main source failed']);
746 Messages.Add('Could not remove "{$I '+ oldLrsFileName +'"} from main source!');
747 Exit;
748 end;
749 if not CodeToolBoss.AddIncludeDirectiveForInit(CodeBuf, newLrsFileName, '') then
750 begin
751 Result := False;
752 debugln(['TProjectResources.RenameDirectives adding include directive to main source failed']);
753 Messages.Add('Could not add "{$I '+ newLrsFileName +'"} to main source!');
754 Exit;
755 end;
756 end;
757 finally
758 DeleteLastCodeBuffers;
759 end;
760 end;
761
762 procedure TProjectResources.DeleteResourceBuffers;
763
764 procedure DeleteBuffer(Filename: string);
765 var
766 CodeBuf: TCodeBuffer;
767 begin
768 if Filename = '' then
769 Exit;
770 CodeBuf := CodeToolBoss.FindFile(Filename);
771 if CodeBuf <> nil then
772 CodeBuf.IsDeleted := true;
773 end;
774
775 begin
776 DeleteLastCodeBuffers;
777 DeleteBuffer(resFileName);
778 DeleteBuffer(lrsFileName);
779 end;
780
Savenull781 function TProjectResources.Save(SaveToTestDir: string): Boolean;
782
SaveCodeBufnull783 function SaveCodeBuf(Filename: string): boolean;
784 var
785 CodeBuf: TCodeBuffer;
786 TestFilename: String;
787 begin
788 Result := True;
789 CodeBuf := CodeToolBoss.FindFile(Filename);
790 if (CodeBuf = nil) or CodeBuf.IsDeleted then Exit;
791 if not CodeBuf.IsVirtual then
792 Result := SaveCodeBuffer(CodeBuf) in [mrOk,mrIgnore]
793 else if SaveToTestDir<>'' then
794 begin
795 TestFilename := AppendPathDelim(SaveToTestDir) + CodeBuf.Filename;
796 Result := SaveCodeBufferToFile(CodeBuf, TestFilename) in [mrOk, mrIgnore];
797 end;
798 end;
799
800 begin
801 Result := False;
802 if not SaveCodeBuf(resFileName) then Exit;
803 if not SaveCodeBuf(lrsFileName) then Exit;
804 Result := True;
805 end;
806
807 procedure TProjectResources.UpdateCodeBuffers;
808 var
809 CodeBuf: TCodeBuffer;
810 S: TStream;
811 Writer: TAbstractResourceWriter;
812 begin
813 if HasSystemResources then
814 begin
815 CodeBuf := CodeToolBoss.CreateFile(resFileName);
816 S := TMemoryStream.Create;
817 Writer := TResResourceWriter.Create;
818 try
819 FSystemResources.WriteToStream(S, Writer);
820 S.Position := 0;
821 CodeBuf.LoadFromStream(S);
822 finally
823 Writer.Free;
824 S.Free;
825 end;
826 end;
827 if FLrsIncludeAllowed and HasLazarusResources then
828 begin
829 CodeBuf := CodeToolBoss.CreateFile(lrsFileName);
830 CodeBuf.Source := FLazarusResources.Text;
831 end;
832 end;
833
834 procedure TProjectResources.DeleteLastCodeBuffers;
835
836 procedure CleanCodeBuffer(var OldFilename: string; const NewFilename: string);
837 var
838 CodeBuf: TCodeBuffer;
839 begin
840 if (OldFileName <> '') and (OldFilename <> NewFilename) then
841 begin
842 // file was renamed => mark old file as deleted
843 CodeBuf := CodeToolBoss.FindFile(OldFileName);
844 if (CodeBuf <> nil) then
845 CodeBuf.IsDeleted := true;
846 OldFileName := '';
847 end;
848 end;
849
850 begin
851 CleanCodeBuffer(LastResFileName, resFileName);
852 CleanCodeBuffer(LastLrsFileName, lrsFileName);
853 end;
854
855 finalization
856 ResourceTypesCache.Free;
857
858 end.
859
860