paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 18:09:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r40191 into '.':

Browse Source 
U    packages/fcl-js/src/jsbase.pp
U    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r40191 into '.':
 U   .
--- Merging r40195 into '.':
U    packages/fcl-web/examples/simpleserver/simpleserver.pas
--- Recording mergeinfo for merge of r40195 into '.':
 G   .
--- Merging r40203 into '.':
U    packages/fcl-js/src/jsscanner.pp
--- Recording mergeinfo for merge of r40203 into '.':
 G   .
--- Merging r40364 into '.':
U    packages/fcl-web/src/base/fphttpstatus.pas
U    packages/fcl-web/fpmake.pp
--- Recording mergeinfo for merge of r40364 into '.':
 G   .
--- Merging r40366 into '.':
G    packages/fcl-web/examples/simpleserver/simpleserver.pas
U    packages/fcl-web/examples/simpleserver/simpleserver.lpi
--- Recording mergeinfo for merge of r40366 into '.':
 G   .
--- Merging r40393 into '.':
U    packages/fcl-web/src/base/httproute.pp
--- Recording mergeinfo for merge of r40393 into '.':
 G   .
--- Merging r40395 into '.':
U    packages/fcl-web/src/base/fphttpclient.pp
--- Recording mergeinfo for merge of r40395 into '.':
 G   .
--- Merging r40592 into '.':
G    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r40592 into '.':
 G   .
--- Merging r40707 into '.':
U    packages/fcl-js/tests/tcwriter.pp
G    packages/fcl-js/src/jswriter.pp
--- Recording mergeinfo for merge of r40707 into '.':
 G   .

# revisions: 40191,40195,40203,40364,40366,40393,40395,40592,40707

git-svn-id: branches/fixes_3_2@40719 -
This commit is contained in:
marco 2018-12-31 16:46:05 +00:00
parent e16529a374
commit e680d94fe1
10 changed files with 145 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
packages/fcl-js/src/jsbase.pp
View File

@ -176,6 +176,7 @@ begin
else
exit;
end;
Result:=true;
end;
{$else}
var

15
packages/fcl-js/src/jsscanner.pp
View File

@ -504,22 +504,15 @@ begin
SetLength(FCurTokenString,Len);
if Len > 0 then
Move(TokenStart^,FCurTokenString[1],Len);
// Check if this is a keyword or identifier
// !!!: Optimize this!
I:=FirstKeyword;
While (Result=tjsIdentifier) and (I<=Lastkeyword) do
begin
if (CurTokenString=TokenInfos[i]) then
// Check if this is a keyword or identifier
// !!!: Optimize this!
for i:=FirstKeyword to Lastkeyword do
if CurTokenString=TokenInfos[i] then
begin
Result := i;
FCurToken := Result;
exit;
end;
{$Push}
{$R-}
I:=Succ(I);
{$Pop}
end
end;
Function TJSScanner.FetchToken: TJSToken;

58
packages/fcl-js/src/jswriter.pp
View File

@ -355,8 +355,8 @@ Var
begin
Result:=Length(S)*SizeOf(TJSWriterChar);
if Result=0 then exit;
MinLen:=Result+FBufPos;
If (MinLen>Capacity) then
MinLen:=Result+integer(FBufPos);
If (MinLen>integer(Capacity)) then
begin
DesLen:=(FCapacity*3) div 2;
if DesLen>MinLen then
@ -364,7 +364,7 @@ begin
Capacity:=MinLen;
end;
Move(S[1],FBuffer[FBufPos],Result);
FBufPos:=FBufPos+Result;
FBufPos:=integer(FBufPos)+Result;
end;
{$endif}
@ -377,8 +377,8 @@ Var
begin
Result:=Length(S)*SizeOf(UnicodeChar);
if Result=0 then exit;
MinLen:=Result+FBufPos;
If (MinLen>Capacity) then
MinLen:=Result+integer(FBufPos);
If (MinLen>integer(Capacity)) then
begin
DesLen:=(FCapacity*3) div 2;
if DesLen>MinLen then
@ -386,7 +386,7 @@ begin
Capacity:=MinLen;
end;
Move(S[1],FBuffer[FBufPos],Result);
FBufPos:=FBufPos+Result;
FBufPos:=integer(FBufPos)+Result;
end;
{$endif}
@ -545,8 +545,8 @@ Var
I,J,L : Integer;
R: TJSString;
c: WideChar;
begin
//system.writeln('TJSWriter.EscapeString "',S,'"');
I:=1;
J:=1;
R:='';
@ -554,7 +554,8 @@ begin
While I<=L do
begin
c:=S[I];
if (c in [#0..#31,'"','''','/','\']) or (c>=#$ff00) then
if (c in [#0..#31,'"','''','/','\'])
or (c>=#$ff00) or ((c>=#$D800) and (c<=#$DFFF)) then
begin
R:=R+Copy(S,J,I-J);
Case c of
@ -568,7 +569,25 @@ begin
#10 : R:=R+'\n';
#12 : R:=R+'\f';
#13 : R:=R+'\r';
#$ff00..#$ffff: R:=R+'\u'+TJSString(HexStr(ord(c),4));
#$D800..#$DFFF:
begin
if (I<L) then
begin
c:=S[I+1];
if (c>=#$D000) and (c<=#$DFFF) then
begin
inc(I,2); // surrogate, two char codepoint
continue;
end
else
// invalid UTF-16, cannot be encoded as UTF-8 -> encode as hex
R:=R+'\u'+TJSString(HexStr(ord(c),4));
end
else
// invalid UTF-16 at end of string, cannot be encoded as UTF-8 -> encode as hex
R:=R+'\u'+TJSString(HexStr(ord(c),4));
end;
#$FF00..#$FFFF: R:=R+'\u'+TJSString(HexStr(ord(c),4));
end;
J:=I+1;
end;
@ -576,6 +595,7 @@ begin
end;
R:=R+Copy(S,J,I-1);
Result:=R;
//system.writeln('TJSWriter.EscapeString Result="',Result,'"');
end;
procedure TJSWriter.WriteValue(V: TJSValue);
@ -1235,6 +1255,7 @@ procedure TJSWriter.WriteBinary(El: TJSBinary);
Var
S : String;
AllowCompact, WithBrackets: Boolean;
ElC: TClass;
begin
{$IFDEF VerboseJSWriter}
System.writeln('TJSWriter.WriteBinary SkipRoundBrackets=',FSkipRoundBrackets);
@ -1243,6 +1264,18 @@ begin
if WithBrackets then
Write('(');
FSkipRoundBrackets:=false;
ElC:=El.ClassType;
if El.A is TJSBinaryExpression then
if (El.A.ClassType=ElC)
and ((ElC=TJSLogicalOrExpression)
or (ElC=TJSLogicalAndExpression)
or (ElC=TJSBitwiseAndExpression)
or (ElC=TJSBitwiseOrExpression)
or (ElC=TJSBitwiseXOrExpression)
or (ElC=TJSAdditiveExpressionPlus)
or (ElC=TJSAdditiveExpressionMinus)
or (ElC=TJSMultiplicativeExpressionMul)) then
FSkipRoundBrackets:=true;
WriteJS(El.A);
Writer.CurElement:=El;
AllowCompact:=False;
@ -1259,6 +1292,13 @@ begin
S:=' '+S+' ';
end;
FSkipRoundBrackets:=false;
ElC:=El.ClassType;
if El.B is TJSBinaryExpression then
if (El.B.ClassType=ElC)
and ((ElC=TJSLogicalOrExpression)
or (ElC=TJSLogicalAndExpression)) then
FSkipRoundBrackets:=true;
// Note: a+(b+c) <> a+b+c e.g. floats, 0+string
Write(S);
WriteJS(El.B);
Writer.CurElement:=El;

54
packages/fcl-js/tests/tcwriter.pp
View File

@ -180,10 +180,11 @@ type
{ TTestExpressionWriter }
TTestExpressionWriter= class(TTestJSWriter)
TTestExpressionWriter = class(TTestJSWriter)
Protected
Procedure TestUnary(Const Msg : String; AClass : TJSUnaryClass; Result : String);
Procedure TestBinary(Const Msg : String; AClass : TJSBinaryClass; Result : String;ACompact : Boolean);
Procedure TestBinary(Const Msg : String; AClass : TJSBinaryClass; Result : String; ACompact : Boolean);
Procedure TestBinaryNested(Const Msg : String; AClass : TJSBinaryClass; Result : String; ACompact : Boolean);
Published
Procedure TestIdent;
Procedure TestThis;
@ -201,8 +202,10 @@ type
Procedure TestPostMinusMinus;
Procedure TestBinaryLogicalOr;
Procedure TestBinaryLogicalOrCompact;
Procedure TestBinaryLogicalOrNested;
Procedure TestBinaryLogicalAnd;
Procedure TestBinaryLogicalAndCompact;
Procedure TestBinaryLogicalAndNested;
Procedure TestBinaryBitwiseOr;
Procedure TestBinaryBitwiseOrCompact;
Procedure TestBinaryBitwiseAnd;
@ -237,10 +240,13 @@ type
Procedure TestBinaryURShiftOfCompact;
Procedure TestBinaryPlus;
Procedure TestBinaryPlusCompact;
Procedure TestBinaryPlusNested;
Procedure TestBinaryMinus;
Procedure TestBinaryMinusCompact;
Procedure TestBinaryMinusNested;
Procedure TestBinaryMultiply;
Procedure TestBinaryMultiplyCompact;
Procedure TestBinaryMultiplyNested;
Procedure TestBinaryDivide;
Procedure TestBinaryDivideCompact;
Procedure TestBinaryMod;
@ -291,6 +297,23 @@ begin
AssertWrite(Msg,Result,U);
end;
procedure TTestExpressionWriter.TestBinaryNested(const Msg: String;
AClass: TJSBinaryClass; Result: String; ACompact: Boolean);
var
U: TJSBinary;
begin
if ACompact then
Writer.Options:=Writer.Options+[woCompact];
U:=AClass.Create(0,0);
U.A:=AClass.Create(0,0);
TJSBinary(U.A).A:=CreateIdent('a');
TJSBinary(U.A).B:=CreateIdent('b');
U.B:=AClass.Create(0,0);
TJSBinary(U.B).A:=CreateIdent('c');
TJSBinary(U.B).B:=CreateIdent('d');
AssertWrite(Msg,Result,U);
end;
procedure TTestExpressionWriter.TestIdent;
begin
@ -373,6 +396,11 @@ begin
TestBinary('logical or',TJSLogicalOrExpression,'(a||b)',True);
end;
procedure TTestExpressionWriter.TestBinaryLogicalOrNested;
begin
TestBinaryNested('logical or',TJSLogicalOrExpression,'(a||b||c||d)',True);
end;
procedure TTestExpressionWriter.TestBinaryLogicalAnd;
begin
TestBinary('logical or',TJSLogicalAndExpression,'(a && b)',False);
@ -383,6 +411,11 @@ begin
TestBinary('logical or',TJSLogicalAndExpression,'(a&&b)',True);
end;
procedure TTestExpressionWriter.TestBinaryLogicalAndNested;
begin
TestBinaryNested('logical and',TJSLogicalAndExpression,'(a&&b&&c&&d)',True);
end;
procedure TTestExpressionWriter.TestBinaryBitwiseOr;
begin
TestBinary('Bitwise or',TJSBitwiseOrExpression,'(a | b)',False);
@ -553,6 +586,11 @@ begin
TestBinary('A plus B',TJSAdditiveExpressionPlus,'(a+b)',True);
end;
procedure TTestExpressionWriter.TestBinaryPlusNested;
begin
TestBinaryNested('(A+B)+(C+D)',TJSAdditiveExpressionPlus,'(a+b+(c+d))',True);
end;
procedure TTestExpressionWriter.TestBinaryMinus;
begin
TestBinary('A minus B',TJSAdditiveExpressionMinus,'(a - b)',False);
@ -563,6 +601,11 @@ begin
TestBinary('A minus B',TJSAdditiveExpressionMinus,'(a-b)',True);
end;
procedure TTestExpressionWriter.TestBinaryMinusNested;
begin
TestBinaryNested('(A-B)-(C-D)',TJSAdditiveExpressionMinus,'(a-b-(c-d))',True);
end;
procedure TTestExpressionWriter.TestBinaryMultiply;
begin
TestBinary('A multiply B',TJSMultiplicativeExpressionMul,'(a * b)',False);
@ -573,6 +616,11 @@ begin
TestBinary('A multiply B',TJSMultiplicativeExpressionMul,'(a*b)',True);
end;
procedure TTestExpressionWriter.TestBinaryMultiplyNested;
begin
TestBinaryNested('(A*B)*(C*D)',TJSMultiplicativeExpressionMul,'(a*b*(c*d))',True);
end;
procedure TTestExpressionWriter.TestBinaryDivide;
begin
TestBinary('A divide B',TJSMultiplicativeExpressionDiv,'(a / b)',False);
@ -2594,7 +2642,7 @@ Var
S : AnsiString;
p: Integer;
begin
S:=FTextWriter.AsAnsistring;
S:=FTextWriter.AsString;
if S=Result then exit;
p:=1;
while (p<=length(S)) and (p<=length(Result)) and (S[p]=Result[p]) do inc(p);

1
packages/fcl-web/examples/simpleserver/simpleserver.lpi
View File

@ -39,6 +39,7 @@
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../../src/base"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>

19
packages/fcl-web/examples/simpleserver/simpleserver.pas
View File

@ -46,6 +46,7 @@ begin
Writeln('-i --indexpage=name Directory index page to use (default: index.html)');
Writeln('-n --noindexpage Do not allow index page.');
Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)');
Writeln('-m --mimetypes=file path of mime.types, default under unix: /etc/mime.types');
Writeln('-q --quiet Do not write diagnostic messages');
Halt(Ord(Msg<>''));
end;
@ -65,8 +66,24 @@ begin
if D='' then
D:=GetCurrentDir;
Log(etInfo,'Listening on port %d, serving files from directory: %s',[Port,D]);
if HasOption('m','mimetypes') then
MimeTypesFile:=GetOptionValue('m','mimetypes');
{$ifdef unix}
MimeTypesFile:='/etc/mime.types';
if MimeTypesFile='' then
begin
MimeTypesFile:='/etc/mime.types';
if not FileExists(MimeTypesFile) then
begin
{$ifdef darwin}
MimeTypesFile:='/private/etc/apache2/mime.types';
if not FileExists(MimeTypesFile) then
{$endif}
MimeTypesFile:='';
end;
end;
if (MimeTypesFile<>'') and not FileExists(MimeTypesFile) then
Log(etWarning,'mimetypes file not found: '+MimeTypesFile);
{$endif}
TSimpleFileModule.BaseDir:=IncludeTrailingPathDelimiter(D);
TSimpleFileModule.OnLog:=@Log;

5
packages/fcl-web/fpmake.pp
View File

@ -182,6 +182,11 @@ begin
OSes:=[Win32,Win64];
Dependencies.AddUnit('custhttpsys');
end;
with P.Targets.AddUnit('fphttpstatus.pas') do
begin
Dependencies.AddUnit('fphttpserver');
Dependencies.AddUnit('HTTPDefs');
end;
T:=P.Targets.AddUnit('fcgigate.pp');
T.ResourceStrings:=true;
With T.Dependencies do

21
packages/fcl-web/src/base/fphttpclient.pp
View File

@ -1376,7 +1376,7 @@ procedure TFPCustomHTTPClient.HTTPMethod(const AMethod, AURL: String;
Stream: TStream; const AllowedResponseCodes: array of Integer);
Var
M,L,NL : String;
M,L,NL,RNL : String;
RC : Integer;
RR : Boolean; // Repeat request ?
@ -1399,17 +1399,22 @@ begin
if (RC>MaxRedirects) then
Raise EHTTPClient.CreateFmt(SErrMaxRedirectsReached,[RC]);
NL:=GetHeader(FResponseHeaders,'Location');
if Not Assigned(FOnRedirect) then
L:=NL
else
if Assigned(FOnRedirect) then
FOnRedirect(Self,L,NL);
if (not IsAbsoluteURI(NL)) and ResolveRelativeURI(L,NL,RNL) then
NL:=RNL;
if (RedirectForcesGET(FResponseStatusCode)) then
M:='GET';
L:=NL;
// Request has saved cookies in sentcookies.
FreeAndNil(FCookies);
FCookies:=FSentCookies;
FSentCookies:=Nil;
if ParseURI(L).Host=ParseURI(NL).Host then
FreeAndNil(FSentCookies)
else
begin
FreeAndNil(FCookies);
FCookies:=FSentCookies;
FSentCookies:=Nil;
end;
L:=NL;
end;
end;
if (FResponseStatusCode=401) then

4
packages/fcl-web/src/base/fphttpstatus.pas
View File

@ -171,13 +171,13 @@ begin
HTTPEncode(ARequest.Connection.Server.AdminMail) +
'">' +
HTTPEncode(name) +
'</a> Port ' + ARequest.ServerPort +
'</a> Port ' + IntToStr(ARequest.ServerPort) +
'</address>'
else
Result := prefix + '<address>' + ARequest.Connection.Server.ServerBanner +
' Server at ' +
ARequest.Connection.Server.AdminMail +
' Port ' + ARequest.ServerPort +
' Port ' + IntToStr(ARequest.ServerPort) +
'</address>';
end;

2
packages/fcl-web/src/base/httproute.pp
View File

@ -422,7 +422,7 @@ Var
begin
Result:=High(TRouteMethod);
MN:=Uppercase(S);
While (Result>=Low(TRouteMethod)) and (RouteMethodNames[Result]<>MN) do
While (Result>Low(TRouteMethod)) and (RouteMethodNames[Result]<>MN) do
Result:=Pred(Result);
if Result=rmAll then Result:=rmUnknown;
end;