1 {
2 pas2jni - JNI bridge generator for Pascal.
3
4 Copyright (c) 2013 by Yury Sidorov.
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 ppuparser;
23
24 {$mode objfpc}{$H+}
25
26 interface
27
28 uses
29 Classes, SysUtils, def;
30
31 type
32 TCheckItemResult = (crDefault, crInclude, crExclude);
33 TOnCheckItem = function (const ItemName: string): TCheckItemResult of object;
34
35 { TPPUParser }
36 TPPUParser = class
37 private
38 FOnCheckItem: TOnCheckItem;
39 FDefaultSearchPathAdded: boolean;
FindUnitnull40 function FindUnit(const AName: string): string;
ReadUnitnull41 function ReadUnit(const AName: string): string;
InternalParsenull42 function InternalParse(const AUnitName: string): TUnitDef;
43 procedure AddSearchPath(const ASearchPath: string);
ReadProcessOutputnull44 function ReadProcessOutput(const AExeName, AParams: string; var AOutput, AError: string): integer;
45 procedure AddDefaultSearchPath(const ACPU, AOS: string);
46 public
47 SearchPath: TStringList;
48 Units: TDef;
49 OnExceptionProc: TProcDef;
50
51 constructor Create(const ASearchPath: string);
52 destructor Destroy; override;
53 procedure Parse(const AUnitName: string);
54 property OnCheckItem: TOnCheckItem read FOnCheckItem write FOnCheckItem;
55 end;
56
57 var
58 ppudumpprog: string;
59
60 implementation
61
62 uses process, pipes, fpjson, jsonparser, jsonscanner;
63
64 const
65 OnExceptionProcName = 'JNI_OnException';
66
67 type
68 TCharSet = set of char;
69
WordPositionnull70 function WordPosition(const N: Integer; const S: string;
71 const WordDelims: TCharSet): Integer;
72 var
73 Count, I: Integer;
74 begin
75 Count := 0;
76 I := 1;
77 Result := 0;
78 while (I <= Length(S)) and (Count <> N) do
79 begin
80 { skip over delimiters }
81 while (I <= Length(S)) and (S[I] in WordDelims) do
82 Inc(I);
83 { if we're not beyond end of S, we're at the start of a word }
84 if I <= Length(S) then
85 Inc(Count);
86 { if not finished, find the end of the current word }
87 if Count <> N then
88 while (I <= Length(S)) and not (S[I] in WordDelims) do
89 Inc(I)
90 else
91 Result := I;
92 end;
93 end;
94
ExtractWordnull95 function ExtractWord(N: Integer; const S: string;
96 const WordDelims: TCharSet): string;
97 var
98 I: Integer;
99 Len: Integer;
100 begin
101 Len := 0;
102 I := WordPosition(N, S, WordDelims);
103 if I <> 0 then
104 { find the end of the current word }
105 while (I <= Length(S)) and not (S[I] in WordDelims) do
106 begin
107 { add the I'th character to result }
108 Inc(Len);
109 SetLength(Result, Len);
110 Result[Len] := S[I];
111 Inc(I);
112 end;
113 SetLength(Result, Len);
114 end;
115
116 { TPPUParser }
117
118 constructor TPPUParser.Create(const ASearchPath: string);
119 begin
120 SearchPath:=TStringList.Create;
121 AddSearchPath(ASearchPath);
122 Units:=TDef.Create;
123 end;
124
125 destructor TPPUParser.Destroy;
126 begin
127 Units.Free;
128 SearchPath.Free;
129 inherited Destroy;
130 end;
131
132 procedure TPPUParser.Parse(const AUnitName: string);
133 begin
134 InternalParse(AUnitName);
135 end;
136
FindUnitnull137 function TPPUParser.FindUnit(const AName: string): string;
138 var
139 i: integer;
140 fn: string;
141 begin
142 fn:=ChangeFileExt(LowerCase(AName), '.ppu');
143 if FileExists(fn) then begin
144 Result:=fn;
145 exit;
146 end;
147 for i:=0 to SearchPath.Count - 1 do begin
148 Result:=IncludeTrailingPathDelimiter(SearchPath[i]) + fn;
149 if FileExists(Result) then
150 exit;
151 end;
152 raise Exception.CreateFmt('Unable to find PPU file for unit "%s".', [AName]);
153 end;
154
TPPUParser.ReadUnitnull155 function TPPUParser.ReadUnit(const AName: string): string;
156 var
157 s, un, err: ansistring;
158 ec: integer;
159 begin
160 un:=FindUnit(AName);
161 if ppudumpprog = '' then begin
162 ppudumpprog:='ppudump';
163 // Check for ppudump in the same folder as pas2jni
164 s:=ExtractFilePath(ParamStr(0));
165 if s <> '' then begin
166 s:=s + ppudumpprog + ExtractFileExt(ParamStr(0));
167 if FileExists(s) then
168 ppudumpprog:=s;
169 end;
170 end;
171 ec:=ReadProcessOutput(ppudumpprog, '-Fj' + LineEnding + un, s, err);
172 err:=Trim(err);
173 if (Copy(s, 1, 1) <> '[') and ((ec = 0) or (err = '')) then begin
174 ec:=-1;
175 err:='Output of ppudump is not in JSON format.' + LineEnding + 'Probably old version of ppudump has been used.';
176 end;
177 if ec <> 0 then begin
178 if err = '' then
179 if Length(s) < 300 then
180 err:=s;
181 raise Exception.CreateFmt('Error reading contents of unit "%s" using "%s".'+LineEnding+'Error code: %d'+LineEnding+'%s', [un, ppudumpprog, ec, err]);
182 end;
183 Result:=s;
184 {$ifopt D+}
185 // Lines.SaveToFile(AName + '-dump.txt');
186 {$endif}
187 end;
188
InternalParsenull189 function TPPUParser.InternalParse(const AUnitName: string): TUnitDef;
190 var
191 junit: TJSONObject;
192 deref: array of TUnitDef;
193 CurUnit: TUnitDef;
194 IsSystemUnit: boolean;
195 AMainUnit: boolean;
196 CurObjName: string;
197
_GetRefnull198 function _GetRef(Ref: TJSONObject; ExpectedClass: TDefClass = nil): TDef;
199 var
200 j: integer;
201 u: TUnitDef;
202 begin
203 Result:=nil;
204 if Ref = nil then
205 exit;
206 u:=CurUnit;
207 j:=Ref.Get('Unit', -1);
208 if j >= 0 then begin
209 u:=deref[j];
210 if u.DefType = dtNone then begin
211 // Reading unit
212 u:=InternalParse(LowerCase(u.Name));
213 if u = nil then
214 exit;
215 if u.CPU <> CurUnit.CPU then
216 raise Exception.CreateFmt('Invalid target CPU of unit "%s": %s', [u.Name, u.CPU]);
217 if u.OS <> CurUnit.OS then
218 raise Exception.CreateFmt('Invalid target OS of unit "%s": %s', [u.Name, u.OS]);
219 if u.PPUVer <> CurUnit.PPUVer then
220 raise Exception.CreateFmt('Invalid PPU version of unit "%s": %s', [u.Name, u.PPUVer]);
221 deref[j].Free;
222 deref[j]:=u;
223 end;
224 end;
225
226 j:=Ref.Integers['Id'];
227 Result:=u.FindDef(j);
228 if Result = nil then begin
229 if ExpectedClass <> nil then
230 Result:=ExpectedClass.Create(u, dtNone)
231 else
232 Result:=TDef.Create(u, dtNone);
233 Result.DefId:=j;
234 end;
235
236 if (ExpectedClass <> nil) and (Result <> nil) then
237 if (Result.DefType <> dtNone) and not (Result is ExpectedClass) then
238 raise Exception.CreateFmt('Unexpected class. Expected: %s, got: %s', [ExpectedClass.ClassName, Result.ClassName]);
239 end;
240
241 procedure _ReadDefs(CurDef: TDef; jobj: TJSONObject; const ItemsName: string);
242 var
243 i, j: integer;
244 jt, s: string;
245 d: TDef;
246 it: TJSONObject;
247 jarr, arr: TJSONArray;
248 ct: TClassType;
249 begin
250 jarr:=jobj.Get(ItemsName, TJSONArray(nil));
251 if jarr = nil then
252 exit;
253 with jarr do
254 for i:=0 to Count - 1 do begin
255 it:=Objects[i];
256 CurObjName:=it.Get('Name', '');
257 jt:=it.Strings['Type'];
258 if jt = 'obj' then begin
259 s:=it.Strings['ObjType'];
260 if s = 'class' then
261 ct:=ctClass
262 else
263 if s = 'interface' then
264 ct:=ctInterface
265 else
266 if s = 'object' then
267 ct:=ctObject
268 else
269 continue;
270 d:=TClassDef.Create(CurDef, dtClass);
271 TClassDef(d).CType:=ct;
272 if ct = ctInterface then
273 TClassDef(d).IID:=it.Get('IID', '');
274 end
275 else
276 if jt = 'rec' then begin
277 if IsSystemUnit and (CompareText(CurObjName, 'tguid') = 0) then begin
278 d:=TTypeDef.Create(CurDef, dtType);
279 TTypeDef(d).BasicType:=btGuid;
280 end
281 else begin
282 d:=TClassDef.Create(CurDef, dtClass);
283 TClassDef(d).CType:=ctRecord;
284 end;
285 end
286 else
287 if jt = 'proc' then
288 d:=TProcDef.Create(CurDef, dtProc)
289 else
290 if jt = 'proctype' then begin
291 d:=TProcDef.Create(CurDef, dtProcType);
292 TProcDef(d).ProcType:=ptProcedure;
293 end
294 else
295 if jt = 'param' then begin
296 d:=TVarDef.Create(CurDef, dtParam);
297 TVarDef(d).VarOpt:=[voRead];
298 end
299 else
300 if jt = 'prop' then begin
301 d:=TVarDef.Create(CurDef, dtProp);
302 TVarDef(d).VarOpt:=[];
303 end
304 else
305 if jt = 'field' then
306 d:=TVarDef.Create(CurDef, dtField)
307 else
308 if jt = 'var' then
309 d:=TVarDef.Create(CurDef, dtVar)
310 else
311 if jt = 'ord' then begin
312 d:=TTypeDef.Create(CurDef, dtType);
313 with TTypeDef(d) do begin
314 s:=it.Strings['OrdType'];
315 j:=it.Get('Size', 0);
316 if s = 'void' then
317 BasicType:=btVoid
318 else
319 if s = 'uint' then begin
320 case j of
321 1: BasicType:=btByte;
322 2: BasicType:=btWord;
323 4: BasicType:=btLongWord;
324 else BasicType:=btInt64;
325 end;
326 end
327 else
328 if s = 'sint' then begin
329 case j of
330 1: BasicType:=btShortInt;
331 2: BasicType:=btSmallInt;
332 4: BasicType:=btLongInt;
333 else BasicType:=btInt64;
334 end;
335 end
336 else
337 if (s = 'pasbool') or (s = 'bool') then
338 BasicType:=btBoolean
339 else
340 if s = 'char' then begin
341 if j = 1 then
342 BasicType:=btChar
343 else
344 BasicType:=btWideChar;
345 end
346 else
347 if s = 'currency' then
348 BasicType:=btDouble;
349 end;
350 end
351 else
352 if jt = 'float' then begin
353 d:=TTypeDef.Create(CurDef, dtType);
354 with TTypeDef(d) do
355 if it.Strings['FloatType'] = 'single' then
356 BasicType:=btSingle
357 else
358 BasicType:=btDouble;
359 end
360 else
361 if jt = 'string' then begin
362 d:=TTypeDef.Create(CurDef, dtType);
363 s:=it.Strings['StrType'];
364 with TTypeDef(d) do
365 if (s = 'wide') or (s = 'unicode') or (s = 'long') then
366 BasicType:=btWideString
367 else
368 BasicType:=btString;
369 if not (IsSystemUnit and (CompareText(CurObjName, 'rawbytestring') = 0)) then
370 CurObjName:=s + 'string';
371 end
372 else
373 if jt = 'enum' then begin
374 d:=TTypeDef.Create(CurDef, dtEnum);
375 TTypeDef(d).BasicType:=btEnum;
376 end
377 else
378 if jt = 'set' then
379 d:=TSetDef.Create(CurDef, dtSet)
380 else
381 if jt = 'ptr' then begin
382 d:=TPointerDef.Create(CurDef, dtPointer);
383 end
384 else
385 if jt = 'const' then
386 d:=TConstDef.Create(CurDef, dtConst)
387 else
388 if jt = 'array' then
389 d:=TArrayDef.Create(CurDef, dtArray)
390 else
391 if jt = 'classref' then
392 d:=TClassRefDef.Create(CurDef, dtClassRef)
393 else
394 continue;
395
396 if (CurObjName = '') and not (d.DefType in [dtEnum, dtArray]) then begin
397 d.Free;
398 continue;
399 end;
400
401 // Common def attributes
402 d.Name:=CurObjName;
403 d.DefId:=it.Get('Id', -1);
404 d.SymId:=it.Get('SymId', -1);
405 s:=it.Get('Visibility', '');
406 d.IsPrivate:=(s <> '') and (s <> 'public') and (s <> 'published');
407 if Copy(d.Name, 1, 1) = '$' then
408 d.IsPrivate:=True;
409
410 // Specific def attributes
411 case d.DefType of
412 dtClass:
413 with TClassDef(d) do begin
414 if CType <> ctRecord then
415 AncestorClass:=TClassDef(_GetRef(it.Get('Ancestor', TJSONObject(nil)), TClassDef));
416 if CType in [ctObject, ctRecord] then
417 Size:=it.Integers['Size'];
418 arr:=it.Get('Options', TJSONArray(nil));
419 if arr <> nil then
420 for j:=0 to arr.Count - 1 do begin
421 s:=arr.Strings[j];
422 if s = 'abstract_methods' then
423 HasAbstractMethods:=True;
424 end;
425 _ReadDefs(d, it, 'Fields');
426 end;
427 dtProc, dtProcType:
428 with TProcDef(d) do begin
429 arr:=it.Get('Options', TJSONArray(nil));
430 if arr <> nil then
431 for j:=0 to arr.Count - 1 do begin
432 s:=arr.Strings[j];
433 if s = 'procedure' then
434 ProcType:=ptProcedure
435 else
436 if s = 'function' then
437 ProcType:=ptFunction
438 else
439 if s = 'constructor' then begin
440 ProcType:=ptConstructor;
441 if CompareText(Name, 'create') = 0 then
442 Name:='Create'; // fix char case for standard constructors
443 end
444 else
445 if s = 'destructor' then
446 ProcType:=ptDestructor
447 else
448 if s = 'overriding' then begin
449 ProcType:=ptDestructor;
450 ProcOpt:=ProcOpt + [poOverride];
451 if ProcType <> ptConstructor then
452 IsPrivate:=True;
453 end
454 else
455 if s = 'overload' then
456 ProcOpt:=ProcOpt + [poOverload]
457 else
458 if s = 'abstract' then
459 TClassDef(Parent).HasAbstractMethods:=True
460 else
461 if s = 'classmethod' then
462 ProcOpt:=ProcOpt + [poClassMethod];
463 end;
464
465 ReturnType:=_GetRef(it.Get('RetType', TJSONObject(nil)));
466 if (DefType = dtProcType) and not ( (ReturnType is TTypeDef) and (TTypeDef(ReturnType).BasicType = btVoid) ) then
467 ProcType:=ptFunction;
ifnull468 if it.Get('MethodPtr', False) then
469 ProcOpt:=ProcOpt + [poMethodPtr];
470
andnull471 if IsSystemUnit and (ProcType = ptFunction) and (Name = 'int') then
472 Name:='Int';
473
474 _ReadDefs(d, it, 'Params');
475
476 for j:=0 to d.Count - 1 do
477 with d[j] do begin
478 if DefType <> dtParam then
479 continue;
480 s:=Name;
481 Name:=Format('p%d', [j + 1]);
482 AliasName:=s;
483 end;
484 // Check for user exception handler proc
485 if AMainUnit and (Parent = CurUnit) and (OnExceptionProc = nil) and (AnsiCompareText(Name, OnExceptionProcName) = 0) then
486 OnExceptionProc:=TProcDef(d);
487 end;
488 dtVar, dtField, dtParam:
489 with TVarDef(d) do begin
490 VarType:=_GetRef(it.Objects['VarType']);
491 s:=it.Get('Spez', '');
492 if s = 'out' then
493 VarOpt:=[voWrite, voOut]
494 else
495 if s = 'var' then
496 VarOpt:=[voRead, voWrite, voVar]
497 else
498 if s = 'const' then
499 VarOpt:=[voRead, voConst];
500 end;
501 dtProp:
502 with TVarDef(d) do begin
503 VarType:=_GetRef(it.Objects['PropType']);
504 if it.Get('Getter', TJSONObject(nil)) <> nil then
505 VarOpt:=VarOpt + [voRead];
506 if it.Get('Setter', TJSONObject(nil)) <> nil then
507 VarOpt:=VarOpt + [voWrite];
508
509 _ReadDefs(d, it, 'Params');
510 end;
511 dtEnum:
512 _ReadDefs(d, it, 'Elements');
513 dtSet:
514 with TSetDef(d) do begin
515 Size:=it.Integers['Size'];
516 Base:=it.Integers['Base'];
517 ElMax:=it.Integers['Max'];
518 ElType:=TTypeDef(_GetRef(it.Objects['ElType'], TTypeDef));
519 if (ElType <> nil) and (ElType.Name = '') then
520 ElType.Name:=CurObjName + 'El';
521 end;
522 dtConst:
523 with TConstDef(d) do begin
524 VarType:=_GetRef(it.Get('TypeRef', TJSONObject(nil)));
525 s:=it.Strings['ValType'];
526 if s = 'int' then
527 Value:=IntToStr(it.Int64s['Value'])
528 else
529 if s = 'float' then begin
530 Str(it.Floats['Value'], s);
531 Value:=s;
532 end
533 else
534 if s = 'string' then begin
535 s:=it.Strings['Value'];
536 s:=StringReplace(s, '\', '\\', [rfReplaceAll]);
537 s:=StringReplace(s, '"', '\"', [rfReplaceAll]);
538 s:=StringReplace(s, #9, '\t', [rfReplaceAll]);
539 s:=StringReplace(s, #10, '\n', [rfReplaceAll]);
540 s:=StringReplace(s, #13, '\r', [rfReplaceAll]);
541 Value:='"' + s + '"';
542 end
543 else
544 FreeAndNil(d);
545 end;
546 dtPointer:
547 with TPointerDef(d) do begin
548 PtrType:=_GetRef(it.Get('Ptr', TJSONObject(nil)));;
549 if AMainUnit and (Parent = CurUnit) and (CompareText(Name, 'TJavaObject') = 0) then
550 DefType:=dtJniObject;
551 end;
552 dtArray:
553 with TArrayDef(d) do begin
554 _ReadDefs(d, it, 'Types');
555 RangeLow:=it.Get('Low', -1);
556 RangeHigh:=it.Get('High', -1);
557 RangeType:=_GetRef(it.Get('RangeType', TJSONObject(nil)));
558 ElType:=_GetRef(it.Get('ElType', TJSONObject(nil)));
559 end;
560 dtClassRef:
561 with TClassRefDef(d) do begin
562 ClassRef:=_GetRef(it.Get('Ref', TJSONObject(nil)));;
563 end;
564 dtNone, dtUnit, dtType, dtJniObject, dtJniEnv:
565 ; // no action
566 end;
567 end;
568 end;
569
570 var
571 i, j: integer;
572 s: string;
573 chkres: TCheckItemResult;
574 jp: TJSONParser;
575 jdata: TJSONData;
576 begin
577 Result:=nil;
578 for i:=0 to Units.Count - 1 do
579 if CompareText(Units[i].Name, AUnitName) = 0 then begin
580 Result:=TUnitDef(Units[i]);
581 exit;
582 end;
583
584 chkres:=FOnCheckItem(AUnitName);
585 if chkres = crExclude then
586 exit;
587
588 AMainUnit:=chkres = crInclude;
589
590 if not AMainUnit and ( (CompareText(AUnitName, 'windows') = 0) or (CompareText(AUnitName, 'unix') = 0) ) then
591 exit;
592
593 s:=ReadUnit(AUnitName);
594 try
595 jdata:=nil;
596 try
597 jp:=TJSONParser.Create(s, [joUTF8]);
598 try
599 s:='';
600 jdata:=jp.Parse;
601 junit:=TJSONObject(jdata.Items[0]);
602 finally
603 jp.Free;
604 end;
605
606 IsSystemUnit:=CompareText(AUnitName, 'system') = 0;
607
608 Result:=TUnitDef.Create(nil, dtUnit);
609 Units.Add(Result);
610 Result.Name:=junit.Strings['Name'];
611 Result.PPUVer:=junit.Integers['Version'];
612 Result.CPU:=junit.Strings['TargetCPU'];
613 Result.OS:=junit.Strings['TargetOS'];
614 j:=Length(Result.CPU);
615 if AnsiLowerCase(Copy(Result.OS, Length(Result.OS) - j, j + 1)) = AnsiLowerCase('-' + Result.CPU) then
616 Result.OS:=Copy(Result.OS, 1, Length(Result.OS) - j - 1);
617 Result.IntfCRC:=junit.Strings['InterfaceCRC'];
618
619 if IsSystemUnit then
620 Result.IsUsed:=True;
621
622 if not FDefaultSearchPathAdded then begin
623 FDefaultSearchPathAdded:=True;
624 AddDefaultSearchPath(AnsiLowerCase(Result.CPU), AnsiLowerCase(Result.OS));
625 end;
626
627 if junit.Find('Units') <> nil then
628 with junit.Arrays['Units'] do begin
629 SetLength(deref, Count);
630 for i:=0 to Count - 1 do begin
631 deref[i]:=TUnitDef.Create(nil, dtNone);
632 deref[i].Name:=Strings[i];
633 end;
634 end;
635
636 CurUnit:=Result;
637 _ReadDefs(CurUnit, junit, 'Interface');
638
639 Result.ResolveDefs;
640
641 if CompareText(AUnitName, 'jni') = 0 then begin
642 for i:=0 to Result.Count - 1 do
643 with Result[i] do
644 if CompareText(Name, 'PJNIEnv') = 0 then
645 DefType:=dtJniEnv;
646 end;
647
648 if AMainUnit then
649 Result.IsUsed:=True;
650
651 SetLength(Result.UsedUnits, Length(deref));
652 j:=0;
653 for i:=0 to High(deref) do
654 if deref[i].DefType = dtNone then
655 deref[i].Free
656 else begin
657 Result.UsedUnits[j]:=deref[i];
658 Inc(j);
659 end;
660 SetLength(Result.UsedUnits, j);
661 finally
662 jdata.Free;
663 end;
664 except
665 if CurObjName <> '' then
666 CurObjName:=Format('; Object: "%s"', [CurObjName]);
667 raise Exception.CreateFmt('%s' + LineEnding + 'Unit: "%s"%s', [Exception(ExceptObject).Message, AUnitName, CurObjName]);
668 end;
669 end;
670
671 procedure TPPUParser.AddSearchPath(const ASearchPath: string);
672 var
673 i, j: integer;
674 s, d: string;
675 sr: TSearchRec;
676 sl: TStringList;
677 begin
678 sl:=TStringList.Create;
679 try
680 sl.Delimiter:=';';
681 sl.DelimitedText:=ASearchPath;
682 i:=0;
683 while i < sl.Count do begin
684 s:=sl[i];
685 if (Pos('*', s) > 0) or (Pos('?', s) > 0) then begin
686 d:=ExtractFilePath(s);
687 j:=FindFirst(s, faDirectory, sr);
688 while j = 0 do begin
689 if (sr.Name <> '.') and (sr.Name <> '..') then
690 sl.Add(d + sr.Name);
691 j:=FindNext(sr);
692 end;
693 FindClose(sr);
694 sl.Delete(i);
695 end
696 else
697 Inc(i);
698 end;
699 SearchPath.AddStrings(sl);
700 finally
701 sl.Free;
702 end;
703 end;
704
TPPUParser.ReadProcessOutputnull705 function TPPUParser.ReadProcessOutput(const AExeName, AParams: string; var AOutput, AError: string): integer;
706
707 procedure _ReadOutput(o: TInputPipeStream; var s: string; var idx: integer);
708 var
709 i: integer;
710 begin
711 with o do
712 while NumBytesAvailable > 0 do begin
713 i:=NumBytesAvailable;
714 if idx + i > Length(s) then
715 SetLength(s, idx + i*10 + idx div 10);
716 ReadBuffer(s[idx + 1], i);
717 Inc(idx, i);
718 end;
719 end;
720
721 var
722 p: TProcess;
723 oidx, eidx: integer;
724 begin
725 AOutput:='';
726 AError:='';
727 oidx:=0;
728 eidx:=0;
729 p:=TProcess.Create(nil);
730 try
731 p.Executable:=AExeName;
732 p.Parameters.Text:=AParams;
733 p.Options:=[poUsePipes, poNoConsole];
734 p.ShowWindow:=swoHIDE;
735 p.StartupOptions:=[suoUseShowWindow];
736 try
737 p.Execute;
738 except
739 raise Exception.CreateFmt('Unable to run "%s".'+LineEnding+'%s', [p.Executable, Exception(ExceptObject).Message]);
740 end;
741 repeat
742 if p.Output.NumBytesAvailable = 0 then
743 TThread.Yield;
744 _ReadOutput(p.Output, AOutput, oidx);
745 _ReadOutput(p.Stderr, AError, eidx);
746 until not p.Running and (p.Output.NumBytesAvailable = 0) and (p.Stderr.NumBytesAvailable = 0);
747 SetLength(AOutput, oidx);
748 SetLength(AError, eidx);
749 Result:=p.ExitStatus;
750 finally
751 p.Free;
752 end;
753 end;
754
755 procedure TPPUParser.AddDefaultSearchPath(const ACPU, AOS: string);
756 var
757 fpc, s, e: string;
758 sl: TStringList;
759 i, j: integer;
760 begin
761 try
762 fpc:=ExtractFilePath(ppudumpprog) + 'fpc' + ExtractFileExt(ParamStr(0));
763 if not FileExists(fpc) then
764 exit;
765 // Find the compiler binary
766 if ReadProcessOutput(fpc, '-P' + ACPU + LineEnding + '-T' + AOS + LineEnding + '-PB', s, e) <> 0 then
767 exit;
768 fpc:=Trim(s);
769 // Get units path from the compiler output
770 ReadProcessOutput(fpc, '-P' + ACPU + LineEnding + '-T' + AOS + LineEnding + '-vt' + LineEnding + '.', s, e);
771 sl:=TStringList.Create;
772 try
773 sl.Text:=s;
774 s:='';
775 for i:=0 to sl.Count - 1 do begin
776 s:=sl[i];
777 j:=Pos(':', s);
778 if j > 0 then begin
779 s:=Trim(Copy(s, j + 1, MaxInt));
780 s:=ExcludeTrailingPathDelimiter(s);
781 if (Copy(s, Length(s) - 3, 4) = DirectorySeparator + 'rtl') and DirectoryExists(s) then begin
782 AddSearchPath(ExtractFilePath(s) + '*');
783 exit;
784 end;
785 end;
786 end;
787 finally
788 sl.Free;
789 end;
790 except
791 // Ignore exceptions
792 end;
793 end;
794
795 end.
796
797