1program pas2fpm; 2 3{$mode objfpc}{$H+} 4 5uses 6 {$IFDEF UNIX}{$IFDEF UseCThreads} 7 cthreads, 8 {$ENDIF}{$ENDIF} 9 Classes, SysUtils, CustApp, passrcutil; 10 11type 12 13 { TUnitEntry } 14 15 TUnitEntry = Class(TCollectionItem) 16 private 17 FIntfDeps: TStrings; 18 FImplDeps: TStrings; 19 FDone: Boolean; 20 FErr: String; 21 FFileName : String; 22 FName: String; 23 FProcessing: Boolean; 24 Fres: Boolean; 25 function GetName: String; 26 Public 27 constructor Create(ACollection: TCollection); override; 28 destructor Destroy; override; 29 Procedure CleanIntfDependencies(Verbose : Boolean); 30 Procedure CleanImplDependencies(Verbose : Boolean); 31 Procedure OrderDependencies(Order : TStrings); 32 Function Nodependencies : Boolean; 33 Property FileName : String Read FFileName Write FFileName; 34 Property Name : String Read GetName; 35 Property IntfDependencies : TStrings Read FIntfDeps; 36 Property ImplDependencies : TStrings Read FImplDeps; 37 Property Resources : Boolean Read Fres Write Fres; 38 Property Err : String Read FErr Write Ferr; 39 Property Done : Boolean Read FDone Write FDone; 40 Property Processing : Boolean Read FProcessing Write FProcessing; 41 end; 42 43 { TUnitEntries } 44 45 TUnitEntries = Class(TCollection) 46 private 47 function GetE(AIndex : Integer): TUnitEntry; 48 public 49 Function IndexOfEntry(Const AName : String) : Integer; 50 Function FindEntry(Const AName : string) : TUnitEntry; 51 Function AddEntry(Const AFileName : String) : TUnitEntry; 52 Property Units[AIndex : Integer] : TUnitEntry Read GetE; default; 53 end; 54 55 56 { TPas2FPMakeApp } 57 58 TPas2FPMakeApp = class(TCustomApplication) 59 private 60 procedure AddLine(const ALine: String); 61 function CheckParams : boolean; 62 procedure CreateSources; 63 Procedure ProcessUnits; 64 function GetUnitProps(const FN: String; out Res: Boolean; UIn,UIm: TStrings; Out Err : string): Boolean; 65 Function SimulateCompile(E,EFrom: TUnitEntry) : Boolean; 66 procedure WriteProgEnd; 67 procedure WriteProgStart; 68 procedure WriteSources; 69 protected 70 FVerbose : Boolean; 71 FFiles : TUnitEntries; 72 FSrc, 73 FUnits: TStrings; 74 InterfaceUnitsOnly : Boolean; 75 FPackageName : string; 76 FOutputFile : string; 77 procedure DoRun; override; 78 public 79 constructor Create(TheOwner: TComponent); override; 80 destructor Destroy; override; 81 procedure WriteHelp; virtual; 82 end; 83 84{ TUnitEntries } 85 86function TUnitEntries.GetE(AIndex : Integer): TUnitEntry; 87begin 88 Result:=Items[AIndex] as TUnitEntry; 89end; 90 91function TUnitEntries.IndexOfEntry(const AName: String): Integer; 92begin 93 Result:=Count-1; 94 While (Result>=0) and (CompareText(GetE(Result).Name,AName)<>0) do 95 Dec(Result); 96end; 97 98function TUnitEntries.FindEntry(const AName: string): TUnitEntry; 99 100Var 101 I:Integer; 102begin 103 I:=IndexofEntry(Aname); 104 If (I<>-1) then 105 Result:=GetE(I) 106 else 107 Result:=Nil; 108end; 109 110function TUnitEntries.AddEntry(Const AFileName: String): TUnitEntry; 111begin 112 Result:=Add as TunitEntry; 113 Result.FileName:=AFileName; 114end; 115 116{ TUnitEntry } 117 118function TUnitEntry.GetName: String; 119begin 120 Result:=ChangeFileExt(ExtractFileName(FileName),''); 121end; 122 123constructor TUnitEntry.Create(ACollection: TCollection); 124begin 125 inherited Create(ACollection); 126 FIntfDeps:=TStringList.Create; 127 FImplDeps:=TStringList.Create; 128end; 129 130destructor TUnitEntry.Destroy; 131begin 132 FreeAndNil(FIntfDeps); 133 FreeAndNil(FImplDeps); 134 inherited Destroy; 135end; 136 137procedure TUnitEntry.CleanIntfDependencies(Verbose : Boolean); 138 139Var 140 I,J : Integer; 141 U : TUnitEntry; 142 143begin 144 For I:=FintfDeps.Count-1 downto 0 do 145 begin 146 U:=FIntfDeps.Objects[i] as TUnitEntry; 147 J:=U.ImplDependencies.IndexOf(Name); 148 if J<>-1 then 149 begin 150 U.ImplDependencies.Delete(J); 151 If Verbose then 152 Writeln(StdErr,'Removing interdependency of ',Name,' from ',U.Name); 153 end; 154 end; 155 156end; 157 158procedure TUnitEntry.CleanImplDependencies(Verbose : Boolean); 159 160Var 161 I,J : Integer; 162 U : TUnitEntry; 163 164begin 165 For I:=FImplDeps.Count-1 downto 0 do 166 begin 167 U:=FImplDeps.Objects[i] as TUnitEntry; 168 J:=U.ImplDependencies.IndexOf(Name); 169 if J<>-1 then 170 begin 171 U.ImplDependencies.Delete(J); 172 If Verbose then 173 Writeln(StdErr,'Removing interdependency of ',Name,' from ',U.Name); 174 end; 175 end; 176end; 177 178procedure TUnitEntry.OrderDependencies(Order: TStrings); 179 180Var 181 L : TStringList; 182 I,CC : integer; 183 184begin 185 L:=TstringList.Create; 186 try 187 L.Assign(FintfDeps); 188 L.Sorted:=True; 189 CC:=L.Count; 190 FintfDeps.Clear; 191 For I:=0 to Order.Count-1 do 192 if L.Indexof(Order[i])<>-1 then 193 FIntfDeps.Add(Order[i]); 194 If FintfDeps.Count<>CC then 195 Writeln('Internal error 1'); 196 L.Sorted:=False; 197 L.Assign(FimplDeps); 198 CC:=L.Count; 199 L.Sorted:=True; 200 FImplDeps.Clear; 201 For I:=0 to Order.Count-1 do 202 if L.Indexof(Order[i])<>-1 then 203 FImplDeps.Add(Order[i]); 204 If FImplDeps.Count<>CC then 205 Writeln('Internal error 2'); 206 finally 207 L.free; 208 end; 209end; 210 211function TUnitEntry.Nodependencies: Boolean; 212begin 213 Result:=(FIntfDeps.Count=0) and (FImplDeps.Count=0); 214end; 215 216{ TPas2FPMakeApp } 217 218Function TPas2FPMakeApp.CheckParams : Boolean; 219 220 Procedure AddFileMask(S : String); 221 222 Var 223 Info : TSearchRec; 224 D : String; 225 226 begin 227 D:=ExtractFilePath(S); 228 If FindFirst(S,0,Info)=0 then 229 try 230 Repeat 231 FFiles.AddEntry(D+Info.Name); 232 FUnits.Add(ChangeFileExt(ExtractFileName(info.name),'')); 233 until (FindNext(Info)<>0); 234 finally 235 FindClose(Info); 236 end; 237 end; 238 239Var 240 I : Integer; 241 S : String; 242 243begin 244 Result:=True; 245 I:=1; 246 While I<=ParamCount do 247 begin 248 S:=Paramstr(i); 249 if (S<>'') then 250 begin 251 if S[1]<>'-' then 252 begin 253 If (Pos('?',S)<>0) or (Pos('*',S)<>0) then 254 AddFileMask(S) 255 else if comparetext(ChangeFileExt(extractfilename(s),''),'fpmake')<>0 then 256 begin 257 FFiles.AddEntry(S); 258 FUnits.Add(ChangeFileExt(ExtractFileName(S),'')); 259 end; 260 end 261 else 262 begin 263 If (s='o') then 264 begin 265 inc(I); 266 FoutputFile:=ParamStr(i); 267 end 268 else If (s='-i') then 269 InterfaceUnitsOnly:=True 270 else If (s='-v') then 271 FVerbose:=True 272 else if (s='-p') then 273 begin 274 Inc(i); 275 FPackageName:=ParamStr(i); 276 end 277 else 278 begin 279 Result:=False; 280 exit; 281 end; 282 end; 283 end; 284 Inc(i); 285 end; 286 Result:=(FFiles.Count>0); 287end; 288 289procedure TPas2FPMakeApp.AddLine(Const ALine : String); 290 291begin 292 FSrc.Add(ALine); 293end; 294 295Function TPas2FPMakeApp.GetUnitProps(Const FN : String; Out Res : Boolean; UIn,UIm : TStrings; Out Err : string) : Boolean; 296 297Var 298 I,J : Integer; 299 A : TPasSrcAnalysis; 300 301begin 302 Result:=False; 303 try 304 If FVerbose then 305 Writeln(StdErr,'Analysing unit ',FN); 306 A:=TPasSrcAnalysis.Create(Self); 307 try 308 A.FileName:=FN; 309 Res:=A.HasResourcestrings; 310 A.GetInterfaceUnits(Uin); 311 if Not InterfaceUnitsOnly then 312 A.GetImplementationUnits(Uim); 313 For I:=Uin.Count-1 downto 0 do 314 begin 315 J:=FUnits.IndexOf(UIN[i]); 316 if (j=-1) then 317 Uin.Delete(i) 318 else 319 Uin.Objects[i]:=FUnits.Objects[J]; 320 end; 321 For I:=Uim.Count-1 downto 0 do 322 begin 323 J:=FUnits.IndexOf(UIm[i]); 324 if (j=-1) then 325 Uim.Delete(i) 326 else 327 Uim.Objects[i]:=FUnits.Objects[J]; 328 end; 329 finally 330 A.Free; 331 end; 332 Result:=True; 333 except 334 On E : Exception do 335 Err:=E.Message; 336 // Ignore 337 end; 338 339end; 340 341procedure TPas2FPMakeApp.WriteProgStart; 342 343begin 344 AddLine('program fpmake;'); 345 AddLine(''); 346 AddLine('uses fpmkunit;'); 347 AddLine(''); 348 AddLine('Var'); 349 AddLine(' T : TTarget;'); 350 AddLine(' P : TPackage;'); 351 AddLine('begin'); 352 AddLine(' With Installer do'); 353 AddLine(' begin'); 354 AddLine(' P:=AddPackage('''+FPackageName+''');'); 355 AddLine(' P.Version:=''0.0'';'); 356// AddLine(' P.Dependencies.Add('fcl-base'); 357 AddLine(' P.Author := ''Your name'';'); 358 AddLine(' P.License := ''LGPL with modification'';'); 359 AddLine(' P.HomepageURL := ''www.yourcompany.com'';'); 360 AddLine(' P.Email := ''yourmail@yourcompany.com'';'); 361 AddLine(' P.Description := ''Your very nice program'';'); 362 AddLine(' // P.NeedLibC:= false;'); 363end; 364 365procedure TPas2FPMakeApp.WriteProgEnd; 366 367begin 368 AddLine(' Run;'); 369 AddLine(' end;'); 370 AddLine('end.'); 371end; 372 373procedure TPas2FPMakeApp.CreateSources; 374 375 376Var 377 I,j : Integer; 378 U : TStrings; 379 F : TUnitEntry; 380 FN : String; 381 382begin 383 WriteProgStart; 384 For I:=0 to FUnits.Count-1 do 385 begin 386 F:=FFiles.FindEntry(FUnits[i]); 387 FN:=F.FileName; 388 AddLine(' T:=P.Targets.AddUnit('''+FN+''');'); 389 if F.Err<>'' then 390 AddLine(' // Failed to analyse unit "'+Fn+'". Error: "'+F.Err+'"') 391 else 392 begin 393 if F.Resources then 394 AddLine(' T.ResourceStrings := True;'); 395 U:=TStringList.Create; 396 try 397 U.AddStrings(F.IntfDependencies); 398 U.AddStrings(F.ImplDependencies); 399 if (U.Count>0) then 400 begin 401 AddLine(' with T.Dependencies do'); 402 AddLine(' begin'); 403 For J:=0 to U.Count-1 do 404 AddLine(' AddUnit('''+U[j]+''');'); 405 AddLine(' end;'); 406 end; 407 finally 408 U.Free; 409 end; 410 end; 411 end; 412 WriteProgEnd; 413end; 414 415function TPas2FPMakeApp.SimulateCompile(E,EFrom: TUnitEntry): Boolean; 416 417Var 418 I : Integer; 419 420begin 421 Result:=True; 422 if E.Done then 423 begin 424 Result:=Not E.Processing; 425 if FVerbose then 426 if Not Result then 427 Writeln(StdErr,'Detected circular reference ',E.Name,' coming from ',EFrom.Name) 428 else if Assigned(EFrom) then 429 Writeln(StdErr,'Attempt to recompile ',E.Name,' coming from ',EFrom.Name) 430 else 431 Writeln(StdErr,'Attempt to recompile ',E.Name); 432 exit; 433 end; 434 E.Done:=True; 435 E.Processing:=True; 436 For I:=0 to E.IntfDependencies.Count-1 do 437 SimulateCompile(E.IntfDependencies.Objects[I] as TUnitEntry,E); 438 For I:=0 to E.ImplDependencies.Count-1 do 439 SimulateCompile(E.ImplDependencies.Objects[I] as TUnitEntry,E); 440 E.Processing:=False; 441 FUnits.Add(E.Name); 442end; 443 444procedure TPas2FPMakeApp.ProcessUnits; 445 446Var 447 I,J,k : integer; 448 Err : String; 449 F : TUnitEntry; 450 R : Boolean; 451 452begin 453 For I:=0 to Funits.Count-1 do 454 begin 455 J:=FFiles.IndexOfEntry(FUnits[i]); 456 Funits.Objects[i]:=FFiles[J]; 457 end; 458 TStringList(FUnits).Sorted:=True; 459 For I:=0 to FFiles.Count-1 do 460 begin 461 F:=FFiles[i]; 462 if not GetUnitProps(F.FileName,R,F.IntfDependencies,F.ImplDependencies,Err) then 463 F.Err:=Err 464 else 465 F.Resources:=R; 466 end; 467 For I:=0 to FFiles.Count-1 do 468 FFiles[i].CleanIntfDependencies(FVerbose); 469 For I:=0 to FFiles.Count-1 do 470 FFiles[i].CleanImplDependencies(FVerbose); 471 TStringList(FUnits).Sorted:=False; 472 FUnits.Clear; 473 For I:=0 to FFiles.Count-1 do 474 if FFiles[i].NoDependencies then 475 begin 476 FUnits.Add(FFiles[i].Name); 477 FFiles[i].Done:=True; 478 end; 479 For I:=0 to FFiles.Count-1 do 480 SimulateCompile(FFiles[i],Nil); 481 // At this point, FUnits is in the order that the compiler should compile them. 482 // Now we order the dependencies. 483 For I:=0 to FFiles.Count-1 do 484 FFiles[i].OrderDependencies(FUnits); 485end; 486 487procedure TPas2FPMakeApp.WriteSources; 488 489Var 490 F : Text; 491 492begin 493 AssignFile(F,FOutputFile); 494 Rewrite(F); 495 try 496 Write(F,FSrc.Text); 497 finally 498 CloseFile(F); 499 end; 500end; 501 502procedure TPas2FPMakeApp.DoRun; 503 504var 505 ErrorMsg: String; 506 507begin 508 // parse parameters 509 if HasOption('h','help') or Not CheckParams then 510 begin 511 WriteHelp; 512 Terminate; 513 exit; 514 end; 515 ProcessUnits; 516 CreateSources; 517 WriteSources; 518 // stop program loop 519 Terminate; 520end; 521 522constructor TPas2FPMakeApp.Create(TheOwner: TComponent); 523begin 524 inherited Create(TheOwner); 525 StopOnException:=True; 526 FFiles:=TUnitEntries.Create(TUnitEntry); 527 FSrc:=TStringList.Create; 528 FUnits:=TStringList.Create; 529 FPackageName:='Your package name here'; 530end; 531 532destructor TPas2FPMakeApp.Destroy; 533begin 534 FreeAndNil(FFiles); 535 FreeAndNil(FSrc); 536 FreeAndNil(FUnits); 537 inherited Destroy; 538end; 539 540procedure TPas2FPMakeApp.WriteHelp; 541begin 542 { add your help code here } 543 writeln('Usage: ',ExeName,' [options] file1 .. filen'); 544 Writeln('Where [options] is one or more of'); 545 Writeln(' -h This help'); 546 Writeln(' -p packagename Set package name'); 547 Writeln(' -i Use interface units only for checking dependencies'); 548 Writeln(' -o outputfile Set output filename (default is standard output)'); 549 Writeln(' -v Write diagnostic output to stderr'); 550end; 551 552var 553 Application: TPas2FPMakeApp; 554begin 555 Application:=TPas2FPMakeApp.Create(nil); 556 Application.Title:='Pascal to FPMake application'; 557 Application.Run; 558 Application.Free; 559end. 560 561