paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-12-03 09:57:31 +01:00
Code Issues Packages Projects Releases Wiki Activity

pas2js: logger adapted for pas2js

Browse Source 
git-svn-id: trunk@40041 -
This commit is contained in:
Mattias Gaertner 2018-10-25 19:43:08 +00:00
parent bcbc578287
commit a089496183
9 changed files with 404 additions and 472 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -6995,6 +6995,7 @@ packages/pastojs/src/pas2jscompiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfilecache.pp svneol=native#text/plain packages/pastojs/src/pas2jsfilecache.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfiler.pp svneol=native#text/plain packages/pastojs/src/pas2jsfiler.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfileutils.pp svneol=native#text/plain packages/pastojs/src/pas2jsfileutils.pp svneol=native#text/plain
packages/pastojs/src/pas2jsfileutilsnodejs.inc svneol=native#text/plain
packages/pastojs/src/pas2jsfileutilsunix.inc svneol=native#text/plain packages/pastojs/src/pas2jsfileutilsunix.inc svneol=native#text/plain
packages/pastojs/src/pas2jsfileutilswin.inc svneol=native#text/plain packages/pastojs/src/pas2jsfileutilswin.inc svneol=native#text/plain
packages/pastojs/src/pas2jslibcompiler.pp svneol=native#text/plain packages/pastojs/src/pas2jslibcompiler.pp svneol=native#text/plain

8
packages/pastojs/src/pas2js_defines.inc
View File

@ -1,5 +1,6 @@
{$inline on} {$inline on}
{$IFDEF Windows} {$IFDEF Windows}
{$define CaseInsensitiveFilenames} {$define CaseInsensitiveFilenames}
{$define HasUNCPaths} {$define HasUNCPaths}
@ -11,6 +12,11 @@
{$DEFINE NotLiteralFilenames} // e.g. HFS+ normalizes file names {$DEFINE NotLiteralFilenames} // e.g. HFS+ normalizes file names
{$ENDIF} {$ENDIF}
{$DEFINE UTF8_RTL} {$IFDEF FPC}
{$DEFINE UsePChar}
{$DEFINE HasInt64}
{$DEFINE UTF8_RTL}
{$DEFINE HasStdErr}
{$ENDIF}

8
packages/pastojs/src/pas2jscompiler.pp
View File

@ -2975,7 +2975,7 @@ var
aFilename: String; aFilename: String;
begin begin
// first try HOME directory // first try HOME directory
aFilename:=ChompPathDelim(GetEnvironmentVariableUTF8('HOME')); aFilename:=ChompPathDelim(GetEnvironmentVariablePJ('HOME'));
if aFilename<>'' then if aFilename<>'' then
begin begin
aFilename:=aFilename+PathDelim{$IFDEF UNIX}+'.'{$ENDIF}+DefaultConfigFile; aFilename:=aFilename+PathDelim{$IFDEF UNIX}+'.'{$ENDIF}+DefaultConfigFile;
@ -3716,7 +3716,7 @@ begin
RegisterMessages; RegisterMessages;
FFileCache:=TPas2jsFilesCache.Create(Log); FFileCache:=TPas2jsFilesCache.Create(Log);
FFileCache.BaseDirectory:=GetCurrentDirUTF8; FFileCache.BaseDirectory:=GetCurrentDirPJ;
FFileCacheAutoFree:=true; FFileCacheAutoFree:=true;
FDirectoryCache:=FFileCache.DirectoryCache; FDirectoryCache:=FFileCache.DirectoryCache;
FLog.OnFormatPath:=@FileCache.FormatPath; FLog.OnFormatPath:=@FileCache.FormatPath;
@ -3793,7 +3793,7 @@ function TPas2jsCompiler.OnMacroEnv(Sender: TObject; var Params: string;
Lvl: integer): boolean; Lvl: integer): boolean;
begin begin
if Lvl=0 then ; if Lvl=0 then ;
Params:=GetEnvironmentVariableUTF8(Params); Params:=GetEnvironmentVariablePJ(Params);
Result:=true; Result:=true;
end; end;
@ -4428,7 +4428,7 @@ end;
function TPas2jsCompiler.ExpandFileName(const Filename: string): string; function TPas2jsCompiler.ExpandFileName(const Filename: string): string;
begin begin
Result:=ExpandFileNameUTF8(Filename,FileCache.BaseDirectory); Result:=ExpandFileNamePJ(Filename,FileCache.BaseDirectory);
end; end;
end. end.

8
packages/pastojs/src/pas2jsfilecache.pp
View File

@ -1425,7 +1425,7 @@ begin
if ExtractFilePath(aFilename)<>'' then if ExtractFilePath(aFilename)<>'' then
begin begin
Result:=ExpandFileNameUTF8(aFilename,BaseDirectory); Result:=ExpandFileNamePJ(aFilename,BaseDirectory);
if not FileExistsLogged(Result) then if not FileExistsLogged(Result) then
Result:=''; Result:='';
exit; exit;
@ -1993,7 +1993,7 @@ begin
if ExtractFilename(Result)='' then if ExtractFilename(Result)='' then
if RaiseOnError then if RaiseOnError then
raise EFileNotFoundError.Create('invalid file name "'+Filename+'"'); raise EFileNotFoundError.Create('invalid file name "'+Filename+'"');
Result:=ExpandFileNameUTF8(Result,BaseDirectory); Result:=ExpandFileNamePJ(Result,BaseDirectory);
if (ExtractFilename(Result)='') or not FilenameIsAbsolute(Result) then if (ExtractFilename(Result)='') or not FilenameIsAbsolute(Result) then
if RaiseOnError then if RaiseOnError then
raise EFileNotFoundError.Create('invalid file name "'+Filename+'"'); raise EFileNotFoundError.Create('invalid file name "'+Filename+'"');
@ -2128,9 +2128,9 @@ function TPas2jsFilesCache.ExpandDirectory(const Filename, BaseDir: string
begin begin
if Filename='' then exit(''); if Filename='' then exit('');
if BaseDir<>'' then if BaseDir<>'' then
Result:=ExpandFileNameUTF8(Filename,BaseDir) Result:=ExpandFileNamePJ(Filename,BaseDir)
else else
Result:=ExpandFileNameUTF8(Filename,BaseDirectory); Result:=ExpandFileNamePJ(Filename,BaseDirectory);
if Result='' then exit; if Result='' then exit;
Result:=IncludeTrailingPathDelimiter(Result); Result:=IncludeTrailingPathDelimiter(Result);
end; end;

415
packages/pastojs/src/pas2jsfileutils.pp
View File

@ -28,6 +28,9 @@ uses
{$IFDEF Unix} {$IFDEF Unix}
BaseUnix, BaseUnix,
{$ENDIF} {$ENDIF}
{$IFDEF Pas2JS}
NodeJSFS,
{$ENDIF}
SysUtils, Classes; SysUtils, Classes;
function FilenameIsAbsolute(const aFilename: string):boolean; function FilenameIsAbsolute(const aFilename: string):boolean;
@ -35,7 +38,7 @@ function FilenameIsWinAbsolute(const aFilename: string):boolean;
function FilenameIsUnixAbsolute(const aFilename: string):boolean; function FilenameIsUnixAbsolute(const aFilename: string):boolean;
function FileIsInPath(const Filename, Path: string): boolean; function FileIsInPath(const Filename, Path: string): boolean;
function ChompPathDelim(const Path: string): string; function ChompPathDelim(const Path: string): string;
function ExpandFileNameUTF8(const FileName: string; {const} BaseDir: string = ''): string; function ExpandFileNamePJ(const FileName: string; {const} BaseDir: string = ''): string;
function ExpandDirectory(const aDirectory: string): string; function ExpandDirectory(const aDirectory: string): string;
function TryCreateRelativePath(const Filename, BaseDirectory: String; function TryCreateRelativePath(const Filename, BaseDirectory: String;
UsePointDirectory: boolean; out RelPath: String): Boolean; UsePointDirectory: boolean; out RelPath: String): Boolean;
@ -43,7 +46,7 @@ function ResolveDots(const AFilename: string): string;
procedure ForcePathDelims(Var FileName: string); procedure ForcePathDelims(Var FileName: string);
function GetForcedPathDelims(Const FileName: string): String; function GetForcedPathDelims(Const FileName: string): String;
function ExtractFilenameOnly(const aFilename: string): string; function ExtractFilenameOnly(const aFilename: string): string;
function GetCurrentDirUTF8: String; function GetCurrentDirPJ: String;
function CompareFilenames(const File1, File2: string): integer; function CompareFilenames(const File1, File2: string): integer;
function GetPhysicalFilename(const Filename: string; function GetPhysicalFilename(const Filename: string;
@ -53,9 +56,9 @@ function ResolveSymLinks(const Filename: string;
function MatchGlobbing(Mask, Name: string): boolean; function MatchGlobbing(Mask, Name: string): boolean;
function FileIsWritable(const AFilename: string): boolean; function FileIsWritable(const AFilename: string): boolean;
function GetEnvironmentVariableCountUTF8: Integer; function GetEnvironmentVariableCountPJ: Integer;
function GetEnvironmentStringUTF8(Index: Integer): string; function GetEnvironmentStringPJ(Index: Integer): string;
function GetEnvironmentVariableUTF8(const EnvVar: string): String; function GetEnvironmentVariablePJ(const EnvVar: string): String;
function GetNextDelimitedItem(const List: string; Delimiter: char; function GetNextDelimitedItem(const List: string; Delimiter: char;
var Position: integer): string; var Position: integer): string;
@ -64,6 +67,7 @@ type TChangeStamp = SizeInt;
const InvalidChangeStamp = low(TChangeStamp); const InvalidChangeStamp = low(TChangeStamp);
procedure IncreaseChangeStamp(var Stamp: TChangeStamp); procedure IncreaseChangeStamp(var Stamp: TChangeStamp);
{$IFDEF FPC_HAS_CPSTRING}
const const
UTF8BOM = #$EF#$BB#$BF; UTF8BOM = #$EF#$BB#$BF;
EncodingUTF8 = 'UTF-8'; EncodingUTF8 = 'UTF-8';
@ -92,6 +96,7 @@ function SystemCPToUTF8(const s: string): string;
function ConsoleToUTF8(const s: string): string; function ConsoleToUTF8(const s: string): string;
// converts UTF8 string to console encoding (used by Write, WriteLn) // converts UTF8 string to console encoding (used by Write, WriteLn)
function UTF8ToConsole(const s: string): string; function UTF8ToConsole(const s: string): string;
{$ENDIF FPC_HAS_CPSTRING}
implementation implementation
@ -99,6 +104,7 @@ implementation
uses Windows; uses Windows;
{$ENDIF} {$ENDIF}
{$IFDEF FPC_HAS_CPSTRING}
var var
EncodingValid: boolean = false; EncodingValid: boolean = false;
DefaultTextEncoding: string = EncodingSystem; DefaultTextEncoding: string = EncodingSystem;
@ -108,11 +114,12 @@ var
{$ENDIF} {$ENDIF}
{$ENDIF} {$ENDIF}
NonUTF8System: boolean = false; NonUTF8System: boolean = false;
{$ENDIF}
function FilenameIsWinAbsolute(const aFilename: string): boolean; function FilenameIsWinAbsolute(const aFilename: string): boolean;
begin begin
Result:=((length(aFilename)>=3) and Result:=((length(aFilename)>=3) and
(aFilename[1] in ['A'..'Z','a'..'z']) and (aFilename[2]=':') and (aFilename[3]in AllowDirectorySeparators)) (aFilename[1] in ['A'..'Z','a'..'z']) and (aFilename[2]=':') and (aFilename[3]in AllowDirectorySeparators))
or ((length(aFilename)>=2) and (aFilename[1] in AllowDirectorySeparators) and (aFilename[2] in AllowDirectorySeparators)); or ((length(aFilename)>=2) and (aFilename[1] in AllowDirectorySeparators) and (aFilename[2] in AllowDirectorySeparators));
end; end;
@ -136,7 +143,7 @@ begin
ExpPath:=IncludeTrailingPathDelimiter(Path); ExpPath:=IncludeTrailingPathDelimiter(Path);
l:=length(ExpPath); l:=length(ExpPath);
Result:=(l>0) and (length(ExpFile)>l) and (ExpFile[l]=PathDelim) Result:=(l>0) and (length(ExpFile)>l) and (ExpFile[l]=PathDelim)
and (AnsiCompareFileName(ExpPath,LeftStr(ExpFile,l))=0); and (CompareFileNames(ExpPath,LeftStr(ExpFile,l))=0);
end; end;
function ChompPathDelim(const Path: string): string; function ChompPathDelim(const Path: string): string;
@ -174,7 +181,7 @@ function ExpandDirectory(const aDirectory: string): string;
begin begin
Result:=aDirectory; Result:=aDirectory;
if Result='' then exit; if Result='' then exit;
Result:=ExpandFileNameUTF8(Result); Result:=ExpandFileNamePJ(Result);
if Result='' then exit; if Result='' then exit;
Result:=IncludeTrailingPathDelimiter(Result); Result:=IncludeTrailingPathDelimiter(Result);
end; end;
@ -207,329 +214,44 @@ function TryCreateRelativePath(const Filename, BaseDirectory: String;
- Filename = foo/bar BaseDirectory = bar/foo Result = False (no shared base directory) - Filename = foo/bar BaseDirectory = bar/foo Result = False (no shared base directory)
- Filename = /foo BaseDirectory = bar Result = False (mixed absolute and relative) - Filename = /foo BaseDirectory = bar Result = False (mixed absolute and relative)
} }
function IsNameChar(c: char): boolean; inline;
begin
Result:=(c<>#0) and not (c in AllowDirectorySeparators);
end;
var
UpDirCount: Integer;
ResultPos: Integer;
i: Integer;
FileNameRestLen, SharedDirs: Integer;
FileP, BaseP, FileEndP, BaseEndP: PChar;
begin begin
Result:=false; Result:=false;
RelPath:=Filename; RelPath:=Filename;
if (BaseDirectory='') or (Filename='') then exit; if (BaseDirectory='') or (Filename='') then exit;
// check for different windows file drives writeln('TryCreateRelativePath ToDo: ',Filename,' Base=',BaseDirectory,' UsePointDirectory=',UsePointDirectory);
if (CompareText(ExtractFileDrive(Filename),
ExtractFileDrive(BaseDirectory))<>0)
then
exit;
FileP:=PChar(Filename);
BaseP:=PChar(BaseDirectory);
//writeln('TryCreateRelativePath START File="',FileP,'" Base="',BaseP,'"');
// skip matching directories
SharedDirs:=0;
if FileP^ in AllowDirectorySeparators then
begin
if not (BaseP^ in AllowDirectorySeparators) then exit;
repeat
while FileP^ in AllowDirectorySeparators do inc(FileP);
while BaseP^ in AllowDirectorySeparators do inc(BaseP);
if (FileP^=#0) or (BaseP^=#0) then break;
//writeln('TryCreateRelativePath check match .. File="',FileP,'" Base="',BaseP,'"');
FileEndP:=FileP;
BaseEndP:=BaseP;
while IsNameChar(FileEndP^) do inc(FileEndP);
while IsNameChar(BaseEndP^) do inc(BaseEndP);
if CompareFilenames(copy(Filename,FileP-PChar(Filename)+1,FileEndP-FileP),
copy(BaseDirectory,BaseP-PChar(BaseDirectory)+1,BaseEndP-BaseP))<>0
then
break;
FileP:=FileEndP;
BaseP:=BaseEndP;
inc(SharedDirs);
until false;
end else if (BaseP^ in AllowDirectorySeparators) then
exit;
//writeln('TryCreateRelativePath skipped matches File="',FileP,'" Base="',BaseP,'"');
if SharedDirs=0 then exit;
// calculate needed '../'
UpDirCount:=0;
BaseEndP:=BaseP;
while IsNameChar(BaseEndP^) do begin
inc(UpDirCount);
while IsNameChar(BaseEndP^) do inc(BaseEndP);
while BaseEndP^ in AllowDirectorySeparators do inc(BaseEndP);
end;
//writeln('TryCreateRelativePath UpDirCount=',UpDirCount,' File="',FileP,'" Base="',BaseP,'"');
// create relative filename
if (FileP^=#0) and (UpDirCount=0) then
begin
// Filename is the BaseDirectory
if UsePointDirectory then
RelPath:='.'
else
RelPath:='';
exit(true);
end;
FileNameRestLen:=length(Filename)-(FileP-PChar(Filename));
SetLength(RelPath,3*UpDirCount+FileNameRestLen);
ResultPos:=1;
for i:=1 to UpDirCount do begin
RelPath[ResultPos]:='.';
RelPath[ResultPos+1]:='.';
RelPath[ResultPos+2]:=PathDelim;
inc(ResultPos,3);
end;
if FileNameRestLen>0 then
Move(FileP^,RelPath[ResultPos],FileNameRestLen);
Result:=true;
end; end;
function ResolveDots(const AFilename: string): string; function ResolveDots(const AFilename: string): string;
//trim double path delims and expand special dirs like .. and . //trim double path delims and expand special dirs like .. and .
//on Windows change also '/' to '\' except for filenames starting with '\\?\' //on Windows change also '/' to '\' except for filenames starting with '\\?\'
var
{$ifdef windows} Len: Integer;
function IsDriveDelim(const Path: string; p: integer): boolean; inline;
begin
Result:=(p=2) and (Path[2]=DriveDelim) and (Path[1] in ['a'..'z','A'..'Z']);
end;
{$endif}
function IsPathDelim(const Path: string; p: integer): boolean;
begin
if (p<=0) or (Path[p]=PathDelim) then exit(true);
{$ifdef windows}
if IsDriveDelim(Path,p) then
exit(true);
{$endif}
Result:=false;
end;
var SrcPos, DestPos, Len, DirStart: integer;
c: char;
MacroPos: LongInt;
begin begin
Len:=length(AFilename); Len:=length(AFilename);
if Len=0 then exit(''); if Len=0 then exit('');
Result:=AFilename; Result:=AFilename;
writeln('ResolveDots ToDo ',AFilename);
{$ifdef windows}
//Special case: everything is literal after this, even dots (this does not apply to '//?/')
if (length(AFilename)>=4) and (AFilename[1]='\') and (AFilename[2]='\')
and (AFilename[3]='?') and (AFilename[4]='\') then
exit;
{$endif}
SrcPos:=1;
DestPos:=1;
// trim double path delimiters and special dirs . and ..
while (SrcPos<=Len) do begin
c:=AFilename[SrcPos];
{$ifdef windows}
//change / to \. The WinApi accepts both, but it leads to strange effects in other places
if (c in AllowDirectorySeparators) then c := PathDelim;
{$endif}
// check for duplicate path delims
if (c=PathDelim) then
begin
inc(SrcPos);
{$IFDEF Windows}
if (DestPos>2)
{$ELSE}
if (DestPos>1)
{$ENDIF}
and (Result[DestPos-1]=PathDelim) then
begin
// skip duplicate PathDelim
continue;
end;
Result[DestPos]:=c;
inc(DestPos);
continue;
end;
// check for special dirs . and ..
if (c='.') then
begin
if (SrcPos<Len) then
begin
if (AFilename[SrcPos+1] in AllowDirectorySeparators)
and IsPathDelim(Result,DestPos-1) then
begin
// special dir ./ or */./
// -> skip
inc(SrcPos,2);
while (SrcPos<=Len) and (AFilename[SrcPos] in AllowDirectorySeparators) do
inc(SrcPos);
continue;
end else if (AFilename[SrcPos+1]='.')
and ((SrcPos+1=Len) or (AFilename[SrcPos+2] in AllowDirectorySeparators)) then
begin
// special dir ..
// 1. .. -> copy
// 2. /.. -> skip .., keep /
// 3. C:.. -> copy
// 4. C:\.. -> skip .., keep C:\
// 5. \\.. -> skip .., keep \\
// 6. ../.. -> copy because if the first '..' was not resolved, the next can't neither
// 7. dir/.. -> trim dir and ..
// 8. dir$macro/.. -> copy
if DestPos=1 then
begin
// 1. .. or ../ -> copy
end else if (DestPos=2) and (Result[1]=PathDelim) then
begin
// 2. /.. -> skip .., keep /
inc(SrcPos,2);
continue;
{$IFDEF Windows}
end else if (DestPos=3) and IsDriveDelim(Result,2) then
begin
// 3. C:.. -> copy
end else if (DestPos=4) and (Result[3]=PathDelim)
and IsDriveDelim(Result,2) then
begin
// 4. C:\.. -> skip .., keep C:\
inc(SrcPos,2);
continue;
end else if (DestPos=3) and (Result[1]=PathDelim)
and (Result[2]=PathDelim) then
begin
// 5. \\.. -> skip .., keep \\
inc(SrcPos,2);
continue;
{$ENDIF}
end else if (DestPos>1) and (Result[DestPos-1]=PathDelim) then
begin
// */.
if (DestPos>3)
and (Result[DestPos-2]='.') and (Result[DestPos-3]='.')
and IsPathDelim(Result,DestPos-4) then
begin
// 6. ../.. -> copy because if the first '..' was not resolved, the next can't neither
end else begin
// 7. xxxdir/.. -> trim dir and skip ..
DirStart:=DestPos-2;
while (DirStart>1) and (Result[DirStart-1]<>PathDelim) do
dec(DirStart);
{$ifdef windows}
if (DirStart=1) and IsDriveDelim(Result,2) then
inc(DirStart,2);
{$endif}
MacroPos:=DirStart;
while MacroPos<DestPos do begin
if (Result[MacroPos]='$')
and (Result[MacroPos+1] in ['(','a'..'z','A'..'Z']) then
begin
// 8. directory contains a macro -> keep
break;
end;
inc(MacroPos);
end;
if MacroPos=DestPos then
begin
// previous directory does not contain a macro -> remove dir/..
DestPos:=DirStart;
inc(SrcPos,2);
//writeln('ResolveDots ',DestPos,' SrcPos=',SrcPos,' File="',AFilename,'" Result="',copy(Result,1,DestPos-1),'"');
if SrcPos>Len then
begin
// '..' at end of filename
if (DestPos>1) and (Result[DestPos-1]=PathDelim) then
begin
// foo/dir/.. -> foo
dec(DestPos);
end else if (DestPos=1) then
begin
// foo/.. -> .
Result[1]:='.';
DestPos:=2;
end;
end else if DestPos=1 then
begin
// e.g. 'foo/../'
while (SrcPos<=Len) and (AFilename[SrcPos] in AllowDirectorySeparators) do
inc(SrcPos);
end;
continue;
end;
end;
end;
end;
end else begin
// special dir . at end of filename
if DestPos=1 then
begin
Result:='.';
exit;
end;
if (DestPos>2) and (Result[DestPos-1]=PathDelim)
{$ifdef windows}
and not IsDriveDelim(Result,DestPos-2)
{$endif}
then begin
// foo/. -> foo
// C:foo\. -> C:foo
// C:\. -> C:\
dec(DestPos);
end;
break;
end;
end;
// copy directory
repeat
Result[DestPos]:=c;
inc(DestPos);
inc(SrcPos);
if (SrcPos>Len) then break;
c:=AFilename[SrcPos];
{$ifdef windows}
//change / to \. The WinApi accepts both, but it leads to strange effects in other places
if (c in AllowDirectorySeparators) then c := PathDelim;
{$endif}
if c=PathDelim then break;
until false;
end;
// trim result
if DestPos<=length(AFilename) then
if (DestPos=1) then
Result:='.'
else
SetLength(Result,DestPos-1);
end; end;
procedure ForcePathDelims(Var FileName: string); procedure ForcePathDelims(Var FileName: string);
var
i: Integer;
begin begin
for i:=1 to length(FileName) do Filename:=GetForcedPathDelims(Filename);
{$IFDEF Windows}
if Filename[i]='/' then
Filename[i]:='\';
{$ELSE}
if Filename[i]='\' then
Filename[i]:='/';
{$ENDIF}
end; end;
function GetForcedPathDelims(const FileName: string): String; function GetForcedPathDelims(const FileName: string): String;
var
i: Integer;
c: Char;
begin begin
Result:=FileName; Result:=Filename;
ForcePathDelims(Result); if PathDelim='/' then
c:='\'
else
c:='/';
for i:=1 to length(Result) do
if Result[i]=c then
Result[i]:=PathDelim;
end; end;
function ExtractFilenameOnly(const aFilename: string): string; function ExtractFilenameOnly(const aFilename: string): string;
@ -552,73 +274,16 @@ end;
function CompareFilenames(const File1, File2: string): integer; function CompareFilenames(const File1, File2: string): integer;
begin begin
Result:=AnsiCompareFileName(File1,File2); writeln('CompareFilenames ToDo ',File1,' ',File2);
Result:=0;
end; end;
function MatchGlobbing(Mask, Name: string): boolean; function MatchGlobbing(Mask, Name: string): boolean;
// match * and ? // match * and ?
function IsNameEnd(NameP: PChar): boolean; inline;
begin
Result:=(NameP^=#0) and (NameP-PChar(Name)=length(Name));
end;
function Check(MaskP, NameP: PChar): boolean;
var
c: Integer;
begin
repeat
case MaskP^ of
#0:
exit(IsNameEnd(NameP));
'?':
if not IsNameEnd(NameP) then
begin
inc(MaskP);
c:=UTF8CharacterStrictLength(NameP);
if c<1 then c:=1;
inc(NameP,c);
end else
exit(false);
'*':
begin
repeat
inc(MaskP);
until MaskP^<>'*';
if MaskP=#0 then exit(true);
while not IsNameEnd(NameP) do begin
inc(NameP);
if Check(MaskP,NameP) then exit(true);
end;
exit(false);
end;
else
if NameP^<>MaskP^ then exit(false);
c:=UTF8CharacterStrictLength(MaskP);
if c<1 then c:=1;
inc(MaskP);
c:=UTF8CharacterStrictLength(NameP);
if c<1 then c:=1;
inc(NameP,c);
end;
until false;
end;
var
MaskP: PChar;
begin begin
if Mask='' then exit(Name=''); if Mask='' then exit(Name='');
{$IFDEF CaseInsensitiveFilenames} writeln('MatchGlobbing ToDo ',Mask,' Name=',Name);
Mask:=AnsiLowerCase(Mask); Result:=false;
Name:=AnsiLowerCase(Name);
{$ENDIF}
MaskP:=PChar(Mask);
while (MaskP^='*') and (MaskP[1]='*') do inc(MaskP);
if (MaskP^='*') and (MaskP[1]=#0) then
exit(true); // the * mask fits all, even the empty string
if Name='' then
exit(false);
Result:=Check(MaskP,PChar(Name));
end; end;
function GetNextDelimitedItem(const List: string; Delimiter: char; function GetNextDelimitedItem(const List: string; Delimiter: char;
@ -641,6 +306,7 @@ begin
Stamp:=InvalidChangeStamp+1; Stamp:=InvalidChangeStamp+1;
end; end;
{$IFDEF FPC_HAS_CPSTRING}
function IsNonUTF8System: boolean; function IsNonUTF8System: boolean;
begin begin
Result:=NonUTF8System; Result:=NonUTF8System;
@ -756,6 +422,7 @@ begin
// conversion magic // conversion magic
SetCodePage(RawByteString(Result), CP_ACP, False); SetCodePage(RawByteString(Result), CP_ACP, False);
end; end;
{$ENDIF}
{$IFDEF Unix} {$IFDEF Unix}
{$I pas2jsfileutilsunix.inc} {$I pas2jsfileutilsunix.inc}
@ -763,9 +430,13 @@ end;
{$IFDEF Windows} {$IFDEF Windows}
{$I pas2jsfileutilswin.inc} {$I pas2jsfileutilswin.inc}
{$ENDIF} {$ENDIF}
{$IFDEF NodeJS}
{$I pas2jsfileutilsnodejs.inc}
{$ENDIF}
procedure InternalInit; procedure InternalInit;
begin begin
{$IFDEF FPC_HAS_CPSTRING}
SetMultiByteConversionCodePage(CP_UTF8); SetMultiByteConversionCodePage(CP_UTF8);
// SetMultiByteFileSystemCodePage(CP_UTF8); not needed, this is the default under Windows // SetMultiByteFileSystemCodePage(CP_UTF8); not needed, this is the default under Windows
SetMultiByteRTLFileSystemCodePage(CP_UTF8); SetMultiByteRTLFileSystemCodePage(CP_UTF8);
@ -776,12 +447,16 @@ begin
{$ELSE} {$ELSE}
NonUTF8System:=SysUtils.CompareText(DefaultTextEncoding,'UTF8')<>0; NonUTF8System:=SysUtils.CompareText(DefaultTextEncoding,'UTF8')<>0;
{$ENDIF} {$ENDIF}
{$ENDIF}
InitPlatform; InitPlatform;
end; end;
initialization initialization
InternalInit; InternalInit;
{$IFDEF FPC}
finalization finalization
FinalizePlatform; FinalizePlatform;
{$ENDIF}
end. end.

130
packages/pastojs/src/pas2jsfileutilsnodejs.inc Normal file
View File

@ -0,0 +1,130 @@
{%MainUnit pas2jsfileutils.pas}
{
This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Mattias Gaertner mattias@freepascal.org
NodeJS backend of pas2jsfileutils
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************
}
function FilenameIsAbsolute(const aFilename: string): boolean;
begin
writeln('FilenameIsAbsolute ToDo ',aFilename);
Result:=FilenameIsUnixAbsolute(aFilename);
end;
function ExpandFileNamePJ(const FileName: string; BaseDir: string): string;
var
IsAbs: Boolean;
HomeDir, Fn: String;
begin
Fn := FileName;
ForcePathDelims(Fn);
IsAbs := FileNameIsUnixAbsolute(Fn);
if (not IsAbs) then
begin
if ((Length(Fn) > 1) and (Fn[1] = '~') and (Fn[2] = '/')) or (Fn = '~') then
begin
HomeDir := GetEnvironmentVariablePJ('HOME');
if not FileNameIsUnixAbsolute(HomeDir) then
HomeDir := ExpandFileNamePJ(HomeDir,'');
Fn := HomeDir + Copy(Fn,2,length(Fn));
IsAbs := True;
end;
end;
if IsAbs then
begin
Result := ResolveDots(Fn);
end
else
begin
if (BaseDir = '') then
Fn := IncludeTrailingPathDelimiter(GetCurrentDirPJ) + Fn
else
Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn;
Fn := ResolveDots(Fn);
//if BaseDir is not absolute then this needs to be expanded as well
if not FileNameIsUnixAbsolute(Fn) then
Fn := ExpandFileNamePJ(Fn, '');
Result := Fn;
end;
end;
function GetCurrentDirPJ: String;
begin
writeln('GetCurrentDirPJ ToDo');
Result:='';
end;
function GetPhysicalFilename(const Filename: string; ExceptionOnError: boolean
): string;
var
OldPath, NewPath: String;
p, l: integer;
begin
Result:=Filename;
p:=1;
l:=length(Result);
while p<=l do
begin
while (p<=l) and (Result[p]='/') do
inc(p);
if p>l then exit;
if Result[p]<>'/' then
begin
repeat
inc(p);
until (p>l) or (Result[p]='/');
OldPath:=LeftStr(Result,p-1);
NewPath:=ResolveSymLinks(OldPath,ExceptionOnError);
if NewPath='' then exit('');
if OldPath<>NewPath then
begin
Result:=NewPath+copy(Result,length(OldPath)+1,length(Result));
p:=length(NewPath)+1;
end;
end;
end;
end;
function ResolveSymLinks(const Filename: string; ExceptionOnError: boolean
): string;
begin
writeln('ResolveSymLinks ToDo ',Filename,' ',ExceptionOnError);
Result:=Filename;
end;
function FileIsWritable(const AFilename: string): boolean;
begin
writeln('FileIsWritable ToDo ',AFilename);
Result := false;
end;
function GetEnvironmentVariableCountPJ: Integer;
begin
Result:=GetEnvironmentVariableCount;
end;
function GetEnvironmentStringPJ(Index: Integer): string;
begin
Result:=GetEnvironmentString(Index);
end;
function GetEnvironmentVariablePJ(const EnvVar: string): String;
begin
Result:=GetEnvironmentVariable(EnvVar);
end;
procedure InitPlatform;
begin
end;

21
packages/pastojs/src/pas2jsfileutilsunix.inc
View File

@ -3,7 +3,7 @@
This file is part of the Free Component Library (FCL) This file is part of the Free Component Library (FCL)
Copyright (c) 2018 Mattias Gaertner mattias@freepascal.org Copyright (c) 2018 Mattias Gaertner mattias@freepascal.org
Pascal to Javascript converter class. Unix backend of pas2jsfileutils
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -20,7 +20,7 @@ begin
Result:=FilenameIsUnixAbsolute(aFilename); Result:=FilenameIsUnixAbsolute(aFilename);
end; end;
function ExpandFileNameUTF8(const FileName: string; BaseDir: string): string; function ExpandFileNamePJ(const FileName: string; BaseDir: string): string;
var var
IsAbs: Boolean; IsAbs: Boolean;
HomeDir, Fn: String; HomeDir, Fn: String;
@ -32,9 +32,9 @@ begin
begin begin
if ((Length(Fn) > 1) and (Fn[1] = '~') and (Fn[2] = '/')) or (Fn = '~') then if ((Length(Fn) > 1) and (Fn[1] = '~') and (Fn[2] = '/')) or (Fn = '~') then
begin begin
HomeDir := GetEnvironmentVariableUTF8('HOME'); HomeDir := GetEnvironmentVariablePJ('HOME');
if not FileNameIsUnixAbsolute(HomeDir) then if not FileNameIsUnixAbsolute(HomeDir) then
HomeDir := ExpandFileNameUtf8(HomeDir,''); HomeDir := ExpandFileNamePJ(HomeDir,'');
Fn := HomeDir + Copy(Fn,2,length(Fn)); Fn := HomeDir + Copy(Fn,2,length(Fn));
IsAbs := True; IsAbs := True;
end; end;
@ -46,18 +46,18 @@ begin
else else
begin begin
if (BaseDir = '') then if (BaseDir = '') then
Fn := IncludeTrailingPathDelimiter(GetCurrentDirUtf8) + Fn Fn := IncludeTrailingPathDelimiter(GetCurrentDirPJ) + Fn
else else
Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn; Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn;
Fn := ResolveDots(Fn); Fn := ResolveDots(Fn);
//if BaseDir is not absolute then this needs to be expanded as well //if BaseDir is not absolute then this needs to be expanded as well
if not FileNameIsUnixAbsolute(Fn) then if not FileNameIsUnixAbsolute(Fn) then
Fn := ExpandFileNameUtf8(Fn, ''); Fn := ExpandFileNamePJ(Fn, '');
Result := Fn; Result := Fn;
end; end;
end; end;
function GetCurrentDirUTF8: String; function GetCurrentDirPJ: String;
begin begin
Result:=GetCurrentDir; Result:=GetCurrentDir;
end; end;
@ -148,17 +148,17 @@ begin
Result := BaseUnix.FpAccess(AFilename, BaseUnix.W_OK) = 0; Result := BaseUnix.FpAccess(AFilename, BaseUnix.W_OK) = 0;
end; end;
function GetEnvironmentVariableCountUTF8: Integer; function GetEnvironmentVariableCountPJ: Integer;
begin begin
Result:=GetEnvironmentVariableCount; Result:=GetEnvironmentVariableCount;
end; end;
function GetEnvironmentStringUTF8(Index: Integer): string; function GetEnvironmentStringPJ(Index: Integer): string;
begin begin
Result:=ConsoleToUTF8(GetEnvironmentString(Index)); Result:=ConsoleToUTF8(GetEnvironmentString(Index));
end; end;
function GetEnvironmentVariableUTF8(const EnvVar: string): String; function GetEnvironmentVariablePJ(const EnvVar: string): String;
begin begin
Result:=ConsoleToUTF8(GetEnvironmentVariable(EnvVar)); Result:=ConsoleToUTF8(GetEnvironmentVariable(EnvVar));
end; end;
@ -225,3 +225,4 @@ procedure FinalizePlatform;
begin begin
end; end;

14
packages/pastojs/src/pas2jsfileutilswin.inc
View File

@ -268,7 +268,7 @@ begin
{$endif} {$endif}
end; end;
function ExpandFileNameUtf8(const FileName: string; {const} BaseDir: String = ''): String; function ExpandFileNamePJ(const FileName: string; {const} BaseDir: String = ''): String;
var var
IsAbs, StartsWithRoot, CanUseBaseDir : Boolean; IsAbs, StartsWithRoot, CanUseBaseDir : Boolean;
{$ifndef WinCE} {$ifndef WinCE}
@ -305,11 +305,11 @@ begin
begin begin
FnDrive := UpCase(Fn[1]); FnDrive := UpCase(Fn[1]);
GetDirUtf8(Byte(FnDrive)-64, CurDir{%H-}); GetDirUtf8(Byte(FnDrive)-64, CurDir{%H-});
CurDrive := UpCase(GetCurrentDirUtf8[1]); CurDrive := UpCase(GetCurrentDirPJ[1]);
end end
else else
begin begin
CurDir := GetCurrentDirUtf8; CurDir := GetCurrentDirPJ;
FnDrive := UpCase(CurDir[1]); FnDrive := UpCase(CurDir[1]);
CurDrive := FnDrive; CurDrive := FnDrive;
end; end;
@ -377,7 +377,7 @@ begin
end; end;
end; end;
function GetCurrentDirUtf8: String; function GetCurrentDirPJ: String;
{$ifndef WinCE} {$ifndef WinCE}
var var
w : UnicodeString; w : UnicodeString;
@ -421,7 +421,7 @@ begin
Result:=((FileGetAttrUTF8(AFilename) and faReadOnly) = 0); Result:=((FileGetAttrUTF8(AFilename) and faReadOnly) = 0);
end; end;
function GetEnvironmentVariableCountUTF8: Integer; function GetEnvironmentVariableCountPJ: Integer;
var var
hp,p : PWideChar; hp,p : PWideChar;
begin begin
@ -437,7 +437,7 @@ begin
FreeEnvironmentStringsW(p); FreeEnvironmentStringsW(p);
end; end;
function GetEnvironmentStringUTF8(Index: Integer): string; function GetEnvironmentStringPJ(Index: Integer): string;
var var
hp,p : PWideChar; hp,p : PWideChar;
begin begin
@ -455,7 +455,7 @@ begin
FreeEnvironmentStringsW(p); FreeEnvironmentStringsW(p);
end; end;
function GetEnvironmentVariableUTF8(const EnvVar: string): String; function GetEnvironmentVariablePJ(const EnvVar: string): String;
begin begin
Result:=UTF16ToUTF8(SysUtils.GetEnvironmentVariable(UTF8ToUTF16(EnvVar))); Result:=UTF16ToUTF8(SysUtils.GetEnvironmentVariable(UTF8ToUTF16(EnvVar)));
end; end;

271
packages/pastojs/src/pas2jslogger.pp
View File

@ -23,9 +23,14 @@ unit Pas2jsLogger;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$inline on} {$inline on}
{$i pas2js_defines.inc}
interface interface
uses uses
{$IFDEF Pas2JS}
JS, NodeJSFS,
{$ENDIF}
Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson, Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, fpjson,
Pas2jsFileUtils; Pas2jsFileUtils;
@ -42,6 +47,41 @@ const
const const
DefaultLogMsgTypes = [mtFatal..mtDebug]; // by default show everything DefaultLogMsgTypes = [mtFatal..mtDebug]; // by default show everything
type
{$IFDEF Pas2JS}
{ TPas2jsStream }
TPas2jsStream = class
public
procedure Write(const s: string); virtual; abstract;
end;
{ TPas2jsFileStream }
TPas2jsFileStream = class(TPas2JSStream)
public
constructor Create(Filename: string; Mode: cardinal);
destructor Destroy; override;
procedure Write(const s: string); override;
end;
const
fmCreate = $FF00;
fmOpenRead = 0;
//fmOpenWrite = 1;
//fmOpenReadWrite = 2;
{ Share modes}
//fmShareCompat = $0000;
//fmShareExclusive = $0010;
//fmShareDenyWrite = $0020;
//fmShareDenyRead = $0030;
fmShareDenyNone = $0040;
{$ELSE}
TPas2jsStream = TStream;
TPas2jsFileStream = TFileStream;
{$ENDIF}
type type
{ TPas2jsMessage } { TPas2jsMessage }
@ -59,7 +99,7 @@ type
TPas2jsLogger = class TPas2jsLogger = class
private private
FDebugLog: TStream; FDebugLog: TPas2JSStream;
FEncoding: string; FEncoding: string;
FLastMsgCol: integer; FLastMsgCol: integer;
FLastMsgFile: string; FLastMsgFile: string;
@ -67,8 +107,7 @@ type
FLastMsgNumber: integer; FLastMsgNumber: integer;
FLastMsgTxt: string; FLastMsgTxt: string;
FLastMsgType: TMessageType; FLastMsgType: TMessageType;
FMsgNumberDisabled: PInteger;// sorted ascending FMsgNumberDisabled: array of Integer;// sorted ascending
FMsgNumberDisabledCount: integer;
FMsg: TFPList; // list of TPas2jsMessage FMsg: TFPList; // list of TPas2jsMessage
FOnFormatPath: TPScannerFormatPathEvent; FOnFormatPath: TPScannerFormatPathEvent;
FOnLog: TPas2jsLogEvent; FOnLog: TPas2jsLogEvent;
@ -77,7 +116,9 @@ type
FShowMsgNumbers: boolean; FShowMsgNumbers: boolean;
FShowMsgTypes: TMessageTypes; FShowMsgTypes: TMessageTypes;
FSorted: boolean; FSorted: boolean;
{$IFDEF HasStdErr}
FWriteMsgToStdErr: boolean; FWriteMsgToStdErr: boolean;
{$ENDIF}
function GetMsgCount: integer; function GetMsgCount: integer;
function GetMsgNumberDisabled(MsgNumber: integer): boolean; function GetMsgNumberDisabled(MsgNumber: integer): boolean;
function GetMsgs(Index: integer): TPas2jsMessage; inline; function GetMsgs(Index: integer): TPas2jsMessage; inline;
@ -87,7 +128,7 @@ type
procedure SetOutputFilename(AValue: string); procedure SetOutputFilename(AValue: string);
procedure SetSorted(AValue: boolean); procedure SetSorted(AValue: boolean);
procedure DoLogRaw(const Msg: string; SkipEncoding : Boolean); procedure DoLogRaw(const Msg: string; SkipEncoding : Boolean);
function Concatenate(Args: array of const): string; function Concatenate(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
public public
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
@ -95,20 +136,25 @@ type
function FindMsg(MsgNumber: integer; ExceptionOnNotFound: boolean): TPas2jsMessage; function FindMsg(MsgNumber: integer; ExceptionOnNotFound: boolean): TPas2jsMessage;
procedure Sort; procedure Sort;
procedure LogRaw(const Msg: string); overload; procedure LogRaw(const Msg: string); overload;
procedure LogRaw(Args: array of const); overload; procedure LogRaw(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}); overload;
procedure LogLn; procedure LogLn;
procedure LogPlain(const Msg: string); overload; procedure LogPlain(const Msg: string); overload;
procedure LogPlain(Args: array of const); overload; procedure LogPlain(Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}); overload;
procedure LogMsg(MsgNumber: integer; Args: array of const; procedure LogMsg(MsgNumber: integer;
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF};
const Filename: string = ''; Line: integer = 0; Col: integer = 0; const Filename: string = ''; Line: integer = 0; Col: integer = 0;
UseFilter: boolean = true); UseFilter: boolean = true);
procedure Log(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0; procedure Log(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0;
const Filename: string = ''; Line: integer = 0; Col: integer = 0; const Filename: string = ''; Line: integer = 0; Col: integer = 0;
UseFilter: boolean = true); UseFilter: boolean = true);
procedure LogMsgIgnoreFilter(MsgNumber: integer; Args: array of const); procedure LogMsgIgnoreFilter(MsgNumber: integer;
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF});
{$IFDEF FPC}
procedure LogExceptionBackTrace; procedure LogExceptionBackTrace;
{$ENDIF}
function MsgTypeToStr(MsgType: TMessageType): string; function MsgTypeToStr(MsgType: TMessageType): string;
function GetMsgText(MsgNumber: integer; Args: array of const): string; function GetMsgText(MsgNumber: integer;
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
function FormatMsg(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0; function FormatMsg(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0;
const Filename: string = ''; Line: integer = 0; Col: integer = 0): string; const Filename: string = ''; Line: integer = 0; Col: integer = 0): string;
function FormatJSONMsg(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0; function FormatJSONMsg(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0;
@ -131,7 +177,9 @@ type
property OutputFilename: string read FOutputFilename write SetOutputFilename; property OutputFilename: string read FOutputFilename write SetOutputFilename;
property ShowMsgNumbers: boolean read FShowMsgNumbers write FShowMsgNumbers; property ShowMsgNumbers: boolean read FShowMsgNumbers write FShowMsgNumbers;
property ShowMsgTypes: TMessageTypes read FShowMsgTypes write FShowMsgTypes; property ShowMsgTypes: TMessageTypes read FShowMsgTypes write FShowMsgTypes;
{$IFDEF HasStdErr}
property WriteMsgToStdErr: boolean read FWriteMsgToStdErr write FWriteMsgToStdErr; property WriteMsgToStdErr: boolean read FWriteMsgToStdErr write FWriteMsgToStdErr;
{$ENDIF}
property Sorted: boolean read FSorted write SetSorted; property Sorted: boolean read FSorted write SetSorted;
property OnLog: TPas2jsLogEvent read FOnLog write FOnLog; property OnLog: TPas2jsLogEvent read FOnLog write FOnLog;
property LastMsgType: TMessageType read FLastMsgType write FLastMsgType; property LastMsgType: TMessageType read FLastMsgType write FLastMsgType;
@ -140,13 +188,13 @@ type
property LastMsgCol: integer read FLastMsgCol write FLastMsgCol; property LastMsgCol: integer read FLastMsgCol write FLastMsgCol;
property LastMsgTxt: string read FLastMsgTxt write FLastMsgTxt; property LastMsgTxt: string read FLastMsgTxt write FLastMsgTxt;
property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber; property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber;
property DebugLog: TStream read FDebugLog write FDebugLog; property DebugLog: TPas2jsStream read FDebugLog write FDebugLog;
end; end;
function CompareP2JMessage(Item1, Item2: Pointer): Integer; function CompareP2JMessage(Item1, Item2: {$IFDEF Pas2JS}JSValue{$ELSE}Pointer{$ENDIF}): Integer;
function QuoteStr(const s: string): string; function QuoteStr(const s: string; Quote: char = '"'): string;
function DeQuoteStr(const s: string): string; function DeQuoteStr(const s: string; Quote: char = '"'): string;
function AsString(Element: TPasElement; Full: boolean = true): string; overload; function AsString(Element: TPasElement; Full: boolean = true): string; overload;
function AsString(Element: TJSElement): string; overload; function AsString(Element: TJSElement): string; overload;
function DbgString(Element: TJSElement; Indent: integer): string; overload; function DbgString(Element: TJSElement; Indent: integer): string; overload;
@ -154,12 +202,14 @@ function DbgAsString(Element: TJSValue; Indent: integer): string; overload;
function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string; overload; function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string; overload;
function DbgAsString(Element: TJSObjectLiteralElements; Indent: integer): string; overload; function DbgAsString(Element: TJSObjectLiteralElements; Indent: integer): string; overload;
function DbgAsString(Element: TJSObjectLiteralElement; Indent: integer): string; overload; function DbgAsString(Element: TJSObjectLiteralElement; Indent: integer): string; overload;
{$IFDEF UsePChar}
function DbgHexMem(p: Pointer; Count: integer): string; function DbgHexMem(p: Pointer; Count: integer): string;
{$ENDIF}
function DbgStr(const s: string): string; function DbgStr(const s: string): string;
implementation implementation
function CompareP2JMessage(Item1, Item2: Pointer): Integer; function CompareP2JMessage(Item1, Item2: {$IFDEF Pas2JS}JSValue{$ELSE}Pointer{$ENDIF}): Integer;
var var
Msg1: TPas2jsMessage absolute Item1; Msg1: TPas2jsMessage absolute Item1;
Msg2: TPas2jsMessage absolute Item2; Msg2: TPas2jsMessage absolute Item2;
@ -167,14 +217,14 @@ begin
Result:=Msg1.Number-Msg2.Number; Result:=Msg1.Number-Msg2.Number;
end; end;
function QuoteStr(const s: string): string; function QuoteStr(const s: string; Quote: char): string;
begin begin
Result:=AnsiQuotedStr(S,'"'); Result:={$IFDEF Pas2JS}SysUtils.QuotedStr{$ELSE}AnsiQuotedStr{$ENDIF}(S,Quote);
end; end;
function DeQuoteStr(const s: string): string; function DeQuoteStr(const s: string; Quote: char): string;
begin begin
Result:=AnsiDequotedStr(S,'"'); Result:={$IFDEF Pas2JS}SysUtils.DeQuoteString{$ELSE}AnsiDequotedStr{$ENDIF}(S,Quote);
end; end;
function AsString(Element: TPasElement; Full: boolean): string; function AsString(Element: TPasElement; Full: boolean): string;
@ -252,16 +302,16 @@ begin
if Element is TJSStatementList then if Element is TJSStatementList then
begin begin
Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding
+Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent); +StringOfChar(' ',Indent)+DbgString(TJSBinaryExpression(Element).B,Indent);
end else if Element is TJSVariableDeclarationList then end else if Element is TJSVariableDeclarationList then
begin begin
Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding
+Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent); +StringOfChar(' ',Indent)+DbgString(TJSBinaryExpression(Element).B,Indent);
end else if Element is TJSWithStatement then end else if Element is TJSWithStatement then
begin begin
Result:='with ('+DbgString(TJSBinaryExpression(Element).A,Indent+2)+'){'+LineEnding Result:='with ('+DbgString(TJSBinaryExpression(Element).A,Indent+2)+'){'+LineEnding
+Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent+2)+LineEnding +StringOfChar(' ',Indent)+DbgString(TJSBinaryExpression(Element).B,Indent+2)+LineEnding
+Space(Indent)+'}'; +StringOfChar(' ',Indent)+'}';
end else if Element is TJSBinaryExpression then end else if Element is TJSBinaryExpression then
begin begin
Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2); Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2);
@ -299,12 +349,12 @@ begin
end else if Element is TJSIfStatement then end else if Element is TJSIfStatement then
begin begin
Result:='if('+DbgString(TJSIfStatement(Element).Cond,Indent+2)+'){'+LineEnding Result:='if('+DbgString(TJSIfStatement(Element).Cond,Indent+2)+'){'+LineEnding
+Space(Indent+2)+DbgString(TJSIfStatement(Element).BTrue,Indent+2)+LineEnding +StringOfChar(' ',Indent+2)+DbgString(TJSIfStatement(Element).BTrue,Indent+2)+LineEnding
+Space(Indent); +StringOfChar(' ',Indent);
if TJSIfStatement(Element).BFalse<>nil then if TJSIfStatement(Element).BFalse<>nil then
Result+=' else {'+LineEnding Result+=' else {'+LineEnding
+Space(Indent+2)+DbgString(TJSIfStatement(Element).BFalse,Indent+2)+LineEnding +StringOfChar(' ',Indent+2)+DbgString(TJSIfStatement(Element).BFalse,Indent+2)+LineEnding
+Space(Indent)+'}'; +StringOfChar(' ',Indent)+'}';
// body // body
end else if Element is TJSBodyStatement then end else if Element is TJSBodyStatement then
@ -351,8 +401,8 @@ begin
end else begin end else begin
if TJSBodyStatement(Element).Body<>nil then if TJSBodyStatement(Element).Body<>nil then
Result+='{'+LineEnding Result+='{'+LineEnding
+Space(Indent+2)+DbgString(TJSBodyStatement(Element).Body,Indent+2)+LineEnding +StringOfChar(' ',Indent+2)+DbgString(TJSBodyStatement(Element).Body,Indent+2)+LineEnding
+Space(Indent)+'}' +StringOfChar(' ',Indent)+'}'
else else
Result+='{}'; Result+='{}';
end; end;
@ -372,14 +422,14 @@ begin
jstNull: Result:='null'; jstNull: Result:='null';
jstBoolean: Result:=BoolToStr(Element.AsBoolean,'true','false'); jstBoolean: Result:=BoolToStr(Element.AsBoolean,'true','false');
jstNumber: str(Element.AsNumber,Result); jstNumber: str(Element.AsNumber,Result);
jstString: Result:=AnsiQuotedStr(Element.AsString{%H-},''''); jstString: Result:=QuoteStr(Element.AsString{%H-},'''');
jstObject: Result:='{:OBJECT:}'; jstObject: Result:='{:OBJECT:}';
jstReference: Result:='{:REFERENCE:}'; jstReference: Result:='{:REFERENCE:}';
JSTCompletion: Result:='{:COMPLETION:}'; JSTCompletion: Result:='{:COMPLETION:}';
else Result:='{:Unknown ValueType '+IntToStr(ord(Element.ValueType))+':}'; else Result:='{:Unknown ValueType '+IntToStr(ord(Element.ValueType))+':}';
end; end;
end; end;
Result:=Space(Indent)+Result; Result:=StringOfChar(' ',Indent)+Result;
end; end;
function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string; function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string;
@ -410,6 +460,7 @@ begin
+':'+DbgString(TJSObjectLiteralElement(Element).Expr,Indent+2); +':'+DbgString(TJSObjectLiteralElement(Element).Expr,Indent+2);
end; end;
{$IFDEF UsePChar}
function DbgHexMem(p: Pointer; Count: integer): string; function DbgHexMem(p: Pointer; Count: integer): string;
var var
i: Integer; i: Integer;
@ -418,6 +469,7 @@ begin
for i:=0 to Count-1 do for i:=0 to Count-1 do
Result:=Result+HexStr(ord(PChar(p)[i]),2); Result:=Result+HexStr(ord(PChar(p)[i]),2);
end; end;
{$ENDIF}
function DbgStr(const s: string): string; function DbgStr(const s: string): string;
var var
@ -434,6 +486,26 @@ begin
end; end;
end; end;
{$IFDEF Pas2JS}
{ TPas2jsFileStream }
constructor TPas2jsFileStream.Create(Filename: string; Mode: cardinal);
begin
writeln('TPas2JSFileStream.Create TODO ',Filename,' Mode=',Mode);
end;
destructor TPas2jsFileStream.Destroy;
begin
writeln('TPas2JSFileStream.Destroy TODO');
inherited Destroy;
end;
procedure TPas2jsFileStream.Write(const s: string);
begin
writeln('TPas2JSFileStream.Write TODO s="',s,'"');
end;
{$ENDIF}
{ TPas2jsLogger } { TPas2jsLogger }
function TPas2jsLogger.GetMsgs(Index: integer): TPas2jsMessage; function TPas2jsLogger.GetMsgs(Index: integer): TPas2jsMessage;
@ -447,7 +519,7 @@ var
l, r, m, CurMsgNumber: Integer; l, r, m, CurMsgNumber: Integer;
begin begin
l:=0; l:=0;
r:=FMsgNumberDisabledCount-1; r:=length(FMsgNumberDisabled)-1;
m:=0; m:=0;
while l<=r do begin while l<=r do begin
m:=(l+r) div 2; m:=(l+r) div 2;
@ -472,7 +544,11 @@ procedure TPas2jsLogger.SetEncoding(const AValue: string);
var var
NewValue: String; NewValue: String;
begin begin
{$IFDEF Pas2JS}
NewValue:=Trim(lowercase(AValue));
{$ELSE}
NewValue:=NormalizeEncoding(AValue); NewValue:=NormalizeEncoding(AValue);
{$ENDIF}
if FEncoding=NewValue then Exit; if FEncoding=NewValue then Exit;
//LogPlain(ClassName+': Encoding changed from "'+FEncoding+'" to "'+NewValue+'"'); //LogPlain(ClassName+': Encoding changed from "'+FEncoding+'" to "'+NewValue+'"');
FEncoding:=NewValue; FEncoding:=NewValue;
@ -488,28 +564,33 @@ procedure TPas2jsLogger.SetMsgNumberDisabled(MsgNumber: integer; AValue: boolean
var var
InsertPos, OldCount: Integer; InsertPos, OldCount: Integer;
begin begin
OldCount:=FMsgNumberDisabledCount; OldCount:=length(FMsgNumberDisabled);
if AValue then if AValue then
begin begin
// enable // enable
InsertPos:=FindMsgNumberDisabled(MsgNumber,true); InsertPos:=FindMsgNumberDisabled(MsgNumber,true);
if (InsertPos<OldCount) and (FMsgNumberDisabled[InsertPos]=MsgNumber) then if (InsertPos<OldCount) and (FMsgNumberDisabled[InsertPos]=MsgNumber) then
exit; // already disabled exit; // already disabled
inc(FMsgNumberDisabledCount); // insert into array
ReAllocMem(FMsgNumberDisabled,SizeOf(Integer)*FMsgNumberDisabledCount); {$IF defined(FPC) and (FPC_FULLVERSION<30101)}
if InsertPos<OldCount then SetLength(FMsgNumberDisabled,OldCount+1);
Move(FMsgNumberDisabled[InsertPos],FMsgNumberDisabled[InsertPos+1],
SizeOf(Integer)*(OldCount-InsertPos));
FMsgNumberDisabled[InsertPos]:=MsgNumber; FMsgNumberDisabled[InsertPos]:=MsgNumber;
{$ELSE}
Insert(MsgNumber,FMsgNumberDisabled,InsertPos);
{$ENDIF}
end else begin end else begin
// disable // disable
InsertPos:=FindMsgNumberDisabled(MsgNumber,false); InsertPos:=FindMsgNumberDisabled(MsgNumber,false);
if InsertPos<0 then exit; if InsertPos<0 then exit;
// delete from array
{$IF defined(FPC) and (FPC_FULLVERSION<30101)}
if InsertPos+1<OldCount then if InsertPos+1<OldCount then
Move(FMsgNumberDisabled[InsertPos+1],FMsgNumberDisabled[InsertPos], Move(FMsgNumberDisabled[InsertPos+1],FMsgNumberDisabled[InsertPos],
SizeOf(Integer)*(OldCount-InsertPos-1)); SizeOf(Integer)*(OldCount-InsertPos-1));
dec(FMsgNumberDisabledCount); SetLength(FMsgNumberDisabled,OldCount-1);
ReAllocMem(FMsgNumberDisabled,SizeOf(Integer)*FMsgNumberDisabledCount); {$ELSE}
Delete(FMsgNumberDisabled,InsertPos,1);
{$ENDIF}
end; end;
end; end;
@ -536,6 +617,7 @@ begin
if SkipEncoding then if SkipEncoding then
S:=Msg S:=Msg
else begin else begin
{$IFDEF FPC_HAS_CPSTRING}
if (Encoding='utf8') or (Encoding='json') then if (Encoding='utf8') or (Encoding='json') then
S:=Msg S:=Msg
else if Encoding='console' then else if Encoding='console' then
@ -547,6 +629,9 @@ begin
if FOutputFile=nil then if FOutputFile=nil then
S:=UTF8ToConsole(Msg); S:=UTF8ToConsole(Msg);
end; end;
{$ELSE}
S:=Msg;
{$ENDIF}
end; end;
//writeln('TPas2jsLogger.LogPlain "',Encoding,'" "',DbgStr(S),'"'); //writeln('TPas2jsLogger.LogPlain "',Encoding,'" "',DbgStr(S),'"');
if DebugLog<>nil then if DebugLog<>nil then
@ -556,48 +641,74 @@ begin
else if FOutputFile<>nil then else if FOutputFile<>nil then
FOutputFile.Write(S+LineEnding) FOutputFile.Write(S+LineEnding)
else begin else begin
{$IFDEF FPC_HAS_CPSTRING}
// prevent codepage conversion magic // prevent codepage conversion magic
SetCodePage(RawByteString(S), CP_OEMCP, False); SetCodePage(RawByteString(S), CP_OEMCP, False);
{$ENDIF}
{AllowWriteln} {AllowWriteln}
{$IFDEF HasStdErr}
if WriteMsgToStdErr then if WriteMsgToStdErr then
writeln(StdErr,S) writeln(StdErr,S)
else else
{$ENDIF}
writeln(S); writeln(S);
{AllowWriteln-} {AllowWriteln-}
end; end;
end; end;
function TPas2jsLogger.Concatenate(Args: array of const): string; function TPas2jsLogger.Concatenate(
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
var var
s: String; s: String;
i: Integer; i: Integer;
{$IFDEF Pas2JS}
V: JSValue;
{$ELSE}
V: TVarRec;
{$ENDIF}
begin begin
s:=''; s:='';
for i:=Low(Args) to High(Args) do for i:=Low(Args) to High(Args) do
begin begin
case Args[i].VType of V:=Args[i];
vtInteger: s += IntToStr(Args[i].VInteger); {$IFDEF Pas2JS}
vtBoolean: s += BoolToStr(Args[i].VBoolean); case jsTypeOf(V) of
vtChar: s += Args[i].VChar; 'boolean':
{$ifndef FPUNONE} if V then s+='true' else s+='false';
vtExtended: ; // Args[i].VExtended^; 'number':
{$ENDIF} if isInteger(V) then
vtString: s += Args[i].VString^; s+=str(NativeInt(V))
vtPointer: ; // Args[i].VPointer; else
vtPChar: s += Args[i].VPChar; s+=str(Double(V));
vtObject: ; // Args[i].VObject; 'string':
vtClass: ; // Args[i].VClass; s+=String(V);
vtWideChar: s += AnsiString(Args[i].VWideChar); else continue;
vtPWideChar: s += AnsiString(Args[i].VPWideChar);
vtAnsiString: s += AnsiString(Args[i].VAnsiString);
vtCurrency: ; // Args[i].VCurrency^);
vtVariant: ; // Args[i].VVariant^);
vtInterface: ; // Args[i].VInterface^);
vtWidestring: s += AnsiString(WideString(Args[i].VWideString));
vtInt64: s += IntToStr(Args[i].VInt64^);
vtQWord: s += IntToStr(Args[i].VQWord^);
vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString));
end; end;
{$ELSE}
case V.VType of
vtInteger: s += IntToStr(V.VInteger);
vtBoolean: s += BoolToStr(V.VBoolean);
vtChar: s += V.VChar;
{$ifndef FPUNONE}
vtExtended: ; // V.VExtended^;
{$ENDIF}
vtString: s += V.VString^;
vtPointer: ; // V.VPointer;
vtPChar: s += V.VPChar;
vtObject: ; // V.VObject;
vtClass: ; // V.VClass;
vtWideChar: s += AnsiString(V.VWideChar);
vtPWideChar: s += AnsiString(V.VPWideChar);
vtAnsiString: s += AnsiString(V.VAnsiString);
vtCurrency: ; // V.VCurrency^);
vtVariant: ; // V.VVariant^);
vtInterface: ; // V.VInterface^);
vtWidestring: s += AnsiString(WideString(V.VWideString));
vtInt64: s += IntToStr(V.VInt64^);
vtQWord: s += IntToStr(V.VQWord^);
vtUnicodeString:s += AnsiString(UnicodeString(V.VUnicodeString));
end;
{$ENDIF}
end; end;
Result:=s; Result:=s;
end; end;
@ -615,10 +726,9 @@ begin
CloseOutputFile; CloseOutputFile;
CloseDebugLog; CloseDebugLog;
for i:=0 to FMsg.Count-1 do for i:=0 to FMsg.Count-1 do
TObject(FMsg[i]).Free; TObject(FMsg[i]).{$IFDEF Pas2JS}Destroy{$ELSE}Free{$ENDIF};
FreeAndNil(FMsg); FreeAndNil(FMsg);
ReAllocMem(FMsgNumberDisabled,0); FMsgNumberDisabled:=nil;
FMsgNumberDisabledCount:=0;
inherited Destroy; inherited Destroy;
end; end;
@ -688,7 +798,7 @@ begin
end; end;
function TPas2jsLogger.GetMsgText(MsgNumber: integer; function TPas2jsLogger.GetMsgText(MsgNumber: integer;
Args: array of const): string; Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF}): string;
var var
Msg: TPas2jsMessage; Msg: TPas2jsMessage;
begin begin
@ -702,7 +812,8 @@ begin
DoLogRaw(Msg,False); DoLogRaw(Msg,False);
end; end;
procedure TPas2jsLogger.LogRaw(Args: array of const); procedure TPas2jsLogger.LogRaw(
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF});
begin begin
LogRaw(Concatenate(Args)); LogRaw(Concatenate(Args));
end; end;
@ -716,7 +827,11 @@ procedure TPas2jsLogger.DebugLogWriteLn(Msg: string);
begin begin
if FDebugLog=nil then exit; if FDebugLog=nil then exit;
Msg:=Msg+LineEnding; Msg:=Msg+LineEnding;
{$IFDEF Pas2JS}
FDebugLog.Write(Msg);
{$ELSE}
FDebugLog.Write(Msg[1],length(Msg)); FDebugLog.Write(Msg[1],length(Msg));
{$ENDIF}
end; end;
function TPas2jsLogger.GetEncodingCaption: string; function TPas2jsLogger.GetEncodingCaption: string;
@ -724,9 +839,11 @@ begin
Result:=Encoding; Result:=Encoding;
if Result='' then if Result='' then
begin begin
{$IFDEF FPC_HAS_CPSTRING}
if FOutputFile=nil then if FOutputFile=nil then
Result:='console' Result:='console'
else else
{$ENDIF}
Result:='utf-8'; Result:='utf-8';
end; end;
if Result='console' then if Result='console' then
@ -753,12 +870,14 @@ begin
DoLogRaw(Msg,False); DoLogRaw(Msg,False);
end; end;
procedure TPas2jsLogger.LogPlain(Args: array of const); procedure TPas2jsLogger.LogPlain(
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF});
begin begin
LogPlain(Concatenate(Args)); LogPlain(Concatenate(Args));
end; end;
procedure TPas2jsLogger.LogMsg(MsgNumber: integer; Args: array of const; procedure TPas2jsLogger.LogMsg(MsgNumber: integer;
Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF};
const Filename: string; Line: integer; Col: integer; UseFilter: boolean); const Filename: string; Line: integer; Col: integer; UseFilter: boolean);
var var
Msg: TPas2jsMessage; Msg: TPas2jsMessage;
@ -789,11 +908,12 @@ begin
end; end;
procedure TPas2jsLogger.LogMsgIgnoreFilter(MsgNumber: integer; procedure TPas2jsLogger.LogMsgIgnoreFilter(MsgNumber: integer;
Args: array of const); Args: array of {$IFDEF Pas2JS}jsvalue{$ELSE}const{$ENDIF});
begin begin
LogMsg(MsgNumber,Args,'',0,0,false); LogMsg(MsgNumber,Args,'',0,0,false);
end; end;
{$IFDEF FPC}
procedure TPas2jsLogger.LogExceptionBackTrace; procedure TPas2jsLogger.LogExceptionBackTrace;
var var
lErrorAddr: CodePointer; lErrorAddr: CodePointer;
@ -808,6 +928,7 @@ begin
for FrameNumber := 0 to FrameCount-1 do for FrameNumber := 0 to FrameCount-1 do
Log(mtDebug,BackTraceStrFunc(Frames[FrameNumber])); Log(mtDebug,BackTraceStrFunc(Frames[FrameNumber]));
end; end;
{$ENDIF}
function TPas2jsLogger.MsgTypeToStr(MsgType: TMessageType): string; function TPas2jsLogger.MsgTypeToStr(MsgType: TMessageType): string;
begin begin
@ -887,8 +1008,10 @@ begin
if DirectoryExists(OutputFilename) then if DirectoryExists(OutputFilename) then
raise Exception.Create('Log is directory: "'+OutputFilename+'"'); raise Exception.Create('Log is directory: "'+OutputFilename+'"');
FOutputFile:=TFileWriter.Create(OutputFilename); FOutputFile:=TFileWriter.Create(OutputFilename);
{$IFDEF FPC_HAS_CPSTRING}
if (Encoding='') or (Encoding='utf8') then if (Encoding='') or (Encoding='utf8') then
FOutputFile.Write(UTF8BOM); FOutputFile.Write(UTF8BOM);
{$ENDIF}
end; end;
procedure TPas2jsLogger.Flush; procedure TPas2jsLogger.Flush;
@ -907,11 +1030,7 @@ end;
procedure TPas2jsLogger.Reset; procedure TPas2jsLogger.Reset;
begin begin
OutputFilename:=''; OutputFilename:='';
if FMsgNumberDisabled<>nil then FMsgNumberDisabled:=nil;
begin
ReAllocMem(FMsgNumberDisabled,0);
FMsgNumberDisabledCount:=0;
end;
ShowMsgNumbers:=false; ShowMsgNumbers:=false;
FShowMsgTypes:=DefaultLogMsgTypes; FShowMsgTypes:=DefaultLogMsgTypes;
end; end;
@ -930,7 +1049,7 @@ procedure TPas2jsLogger.OpenDebugLog;
const const
DbgLogFilename = 'pas2jsdebug.log'; DbgLogFilename = 'pas2jsdebug.log';
begin begin
FDebugLog:=TFileStream.Create(DbgLogFilename,fmCreate or fmShareDenyNone); FDebugLog:=TPas2jsFileStream.Create(DbgLogFilename,fmCreate or fmShareDenyNone);
end; end;
procedure TPas2jsLogger.CloseDebugLog; procedure TPas2jsLogger.CloseDebugLog;