From 049585441b42960001208c23941c707465ad081f Mon Sep 17 00:00:00 2001 From: "ronierys2@hotmail.com" Date: Mon, 13 May 2024 08:46:00 -0300 Subject: [PATCH 1/3] =?UTF-8?q?corre=C3=A7=C3=B5es?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../Basic/Mechanics/uRESTDWMessageCoder.pas | 15 +- .../Mechanics/uRESTDWMessageCoderMIME.pas | 289 +++-- CORE/Source/Basic/uRESTDWBasic.pas | 1095 ++++++++--------- CORE/Source/Basic/uRESTDWParams.pas | 4 +- CORE/Source/Basic/uRESTDWStorageBin.pas | 46 +- CORE/Source/Consts/uRESTDWConsts.pas | 4 +- .../Memdataset/uRESTDWMemoryDataset.pas | 65 +- CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas | 2 +- CORE/Source/Wizards/RDWCGIWizard.pas | 4 +- CORE/Source/Wizards/STLWizard.pas | 3 + CORE/Source/Wizards/templates/URDWDm.dfm | 28 +- CORE/Source/Wizards/templates/URDWDm.pas | 12 +- 12 files changed, 797 insertions(+), 770 deletions(-) diff --git a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas index 471f7ddfd..d5dc584c3 100644 --- a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas +++ b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas @@ -54,6 +54,7 @@ Const ADelim : String = '.') : String; Overload; Function ReadLnRFCB(Var VMsgEnd : Boolean; Const ALineTerminator : String; + Const BoundaryEnd : String = ''; Const ADelim : String = '.') : TRESTDWBytes; Property Filename : String Read FFilename; Property FreeSourceStream : Boolean Read FFreeSourceStream Write FFreeSourceStream; @@ -393,10 +394,22 @@ Function TRESTDWMessageDecoder.ReadLnRFCB(Var VMsgEnd : Boolean; Const ALineTerminator : String; + Const BoundaryEnd : String = ''; Const ADelim : String = '.') : TRESTDWBytes; +Var + vline : String; + vBytes : TRESTDWBytes; Begin Result := ReadLnB(ALineTerminator); - If Length(Result) = 0 Then {do not localize} + vLine := BytesToString(Result); + If Pos(BoundaryEnd, vLine) > 0 Then + Begin + vBytes := StringToBytes(Copy(vLine, 1, Pos(BoundaryEnd, vLine) -1)); + Result := vBytes; + SetLength(vBytes, 0); + VMsgEnd := True; + End + Else If Length(Result) = 0 Then {do not localize} Begin VMsgEnd := True; Exit; diff --git a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas index 4b252634a..ccc87476c 100644 --- a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas +++ b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas @@ -284,158 +284,151 @@ destructor TRESTDWMessageDecoderMIME.Destroy; Function TRESTDWMessageDecoderMIME.ReadBody(ADestStream : TStream; Var VMsgEnd : Boolean) : TRESTDWMessageDecoder; -var - LContentType, LContentTransferEncoding: string; - LDecoder: TRESTDWDecoder; - LBytes : TRESTDWBytes; - LLine: string; - LBuffer: string; //Needed for binhex4 because cannot decode line-by-line. - LIsThisTheFirstLine: Boolean; //Needed for binary encoding - BoundaryStart, BoundaryEnd: string; - IsBinaryContentTransferEncoding: Boolean; -begin - LIsThisTheFirstLine := True; - VMsgEnd := False; - Result := nil; - if FBodyEncoded then begin - LContentType := TRESTDWMessage(Owner).ContentType; - LContentTransferEncoding := TRESTDWMessage(Owner).ContentTransferEncoding; - end else begin - LContentType := FHeaders.Values['Content-Type']; {Do not Localize} - LContentTransferEncoding := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize} - end; - if LContentTransferEncoding = '' then begin - if IsHeaderMediaType(LContentType, 'application/mac-binhex40') then begin {Do not Localize} - LContentTransferEncoding := 'binhex40'; {do not localize} - end; - end; - - // RLebeau 08/17/09 - According to RFC 2045 Section 6.4: - // "If an entity is of type "multipart" the Content-Transfer-Encoding is not - // permitted to have any value other than "7bit", "8bit" or "binary"." - // - // However, came across one message where the "Content-Type" was set to - // "multipart/related" and the "Content-Transfer-Encoding" was set to - // "quoted-printable". Outlook and Thunderbird were apparently able to parse - // the message correctly, but Indy was not. So let's check for that scenario - // and ignore illegal "Content-Transfer-Encoding" values if present... - - if IsHeaderMediaType(LContentType, 'multipart') and (LContentTransferEncoding <> '') then {do not localize} - begin - if PosInStrArray(LContentTransferEncoding, ['7bit', '8bit', 'binary'], False) = -1 then begin {do not localize} - LContentTransferEncoding := ''; - end; - end; - - if TextIsSame(LContentTransferEncoding, 'base64') then begin {Do not Localize} - LDecoder := TRESTDWDecoderMIMELineByLine.Create(nil); - end else if TextIsSame(LContentTransferEncoding, 'quoted-printable') then begin {Do not Localize} - LDecoder := TRESTDWDecoderQuotedPrintable.Create(nil); - end else if TextIsSame(LContentTransferEncoding, 'binhex40') then begin {Do not Localize} - LDecoder := TRESTDWDecoderBinHex4.Create(nil); - end else begin - LDecoder := nil; - end; - Try - if LDecoder <> nil then begin - LDecoder.DecodeBegin(ADestStream); - end; - - if MIMEBoundary <> '' then begin - BoundaryStart := '--' + MIMEBoundary; {Do not Localize} - BoundaryEnd := BoundaryStart + '--'; {Do not Localize} - end; - - case PosInStrArray(LContentTransferEncoding, ['7bit', 'quoted-printable', 'base64', '8bit', 'binary'], False) of {do not localize} - 0..2: IsBinaryContentTransferEncoding := False; - 3..4: IsBinaryContentTransferEncoding := True; - else - // According to RFC 2045 Section 6.4: - // "Any entity with an unrecognized Content-Transfer-Encoding must be - // treated as if it has a Content-Type of "application/octet-stream", - // regardless of what the Content-Type header field actually says." - IsBinaryContentTransferEncoding := True; - end; - Repeat - if not FProcessFirstLine then begin - if IsBinaryContentTransferEncoding then - LBytes := ReadLnRFCB(VMsgEnd, EOL, '.') {do not localize} - Else - LLine := ReadLnRFC(VMsgEnd); - end else begin - LLine := FFirstLine; - FFirstLine := ''; {Do not Localize} - FProcessFirstLine := False; - // Do not use ADELIM since always ends with . (standard) - if LLine = '.' then begin {Do not Localize} - VMsgEnd := True; - Break; - end; - if TextStartsWith(LLine, '..') then begin - Delete(LLine, 1, 1); - end; - end; - If (IsBinaryContentTransferEncoding) Then - Begin - If Length(LBytes) > 0 Then - ADestStream.WriteBuffer(LBytes[0], Length(LBytes)); - SetLength(LBytes, 0); - If (VMsgEnd) Then - Break; - End; - // New boundary - end self and create new coder - if MIMEBoundary <> '' then begin - if TextIsSame(LLine, BoundaryStart) then begin - Result := TRESTDWMessageDecoderMIME.Create(Owner); - Break; - // End of all coders (not quite ALL coders) - end; - if TextIsSame(LLine, BoundaryEnd) then begin - // POP the boundary - if Owner is TRESTDWMessage then begin - TRESTDWMessage(Owner).MIMEBoundary.Pop; - end; - Break; - end; - end; - if Not Assigned(LDecoder) then - Begin - // Data to save, but not decode - If Not IsBinaryContentTransferEncoding then - If Assigned(ADestStream) then - WriteStringToStream(ADestStream, LLine + EOL); - end - else - begin - // Data to decode - // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are - // intact - if LDecoder is TRESTDWDecoderQuotedPrintable then begin - // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are intact -// LLine := LLine + EOF; - LDecoder.Decode(LLine); - end else if LDecoder is TRESTDWDecoderBinHex4 then begin - //We cannot decode line-by-line because lines don't have a whole - //number of 4-byte blocks due to the : inserted at the start of - //the first line, so buffer the file... - LBuffer := LBuffer + LLine; - end else if LLine <> '' then begin - LDecoder.Decode(LLine); - end; - end; - Until False; - If LDecoder <> Nil Then +Var + LContentType, + LContentTransferEncoding, + LLine, + LBinaryLineBreak, + LBuffer, //Needed for binhex4 because cannot decode line-by-line. + LBoundaryStart, + LBoundaryEnd : String; + LIsThisTheFirstLine, //Needed for binary encoding + LIsBinaryContentTransferEncoding : Boolean; + LDecoder : TRESTDWDecoder; +Begin + LIsThisTheFirstLine := True; + VMsgEnd := False; + Result := Nil; + If FBodyEncoded Then + Begin + LContentType := TRESTDWMessage(Owner).ContentType; + LContentTransferEncoding := TRESTDWMessage(Owner).ContentTransferEncoding; + End + Else + Begin + LContentType := FHeaders.Values['Content-Type']; {Do not Localize} + LContentTransferEncoding := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize} + End; + If LContentTransferEncoding = '' Then + Begin + If IsHeaderMediaType(LContentType, 'application/mac-binhex40') Then {Do not Localize} + LContentTransferEncoding := 'binhex40' {do not localize} + Else If Not IsHeaderMediaType(LContentType, 'application/octet-stream') Then {Do not Localize} + LContentTransferEncoding := '7bit'; {do not localize} + End + Else If IsHeaderMediaType(LContentType, 'multipart') Then {do not localize} + Begin + If PosInStrArray(LContentTransferEncoding, ['7bit', '8bit', 'binary'], False) = -1 Then {do not localize} + LContentTransferEncoding := ''; + End; + If TextIsSame(LContentTransferEncoding, 'base64') Then {Do not Localize} + LDecoder := TRESTDWDecoderMIMELineByLine.Create(Nil) + Else If TextIsSame(LContentTransferEncoding, 'quoted-printable') Then {Do not Localize} + LDecoder := TRESTDWDecoderQuotedPrintable.Create(Nil) + Else If TextIsSame(LContentTransferEncoding, 'binhex40') Then {Do not Localize} + LDecoder := TRESTDWDecoderBinHex4.Create (Nil) + Else + LDecoder := nil; + Try + If LDecoder <> Nil Then + LDecoder.DecodeBegin(ADestStream); + If MIMEBoundary <> '' Then + Begin + LBoundaryStart := '--' + MIMEBoundary; {Do not Localize} + LBoundaryEnd := LBoundaryStart + '--'; {Do not Localize} + End; + If LContentTransferEncoding <> '' Then + Begin + Case PosInStrArray(LContentTransferEncoding, ['7bit', 'quoted-printable', 'base64', '8bit', 'binary'], False) Of {do not localize} + 0..2: LIsBinaryContentTransferEncoding := False; + 3..4: LIsBinaryContentTransferEncoding := True; + Else + LIsBinaryContentTransferEncoding := True; + LContentTransferEncoding := ''; + End; + End + Else + LIsBinaryContentTransferEncoding := True; + Repeat + If Not FProcessFirstLine Then Begin - If LDecoder Is TRESTDWDecoderBinHex4 Then + If LIsBinaryContentTransferEncoding Then Begin - //Now decode the complete block... - LDecoder.Decode(LBuffer); + LLine := ReadLnRFC(VMsgEnd, EOL, '.'); {do not localize} + LBinaryLineBreak := EOL; + End + Else + LLine := ReadLnRFC(VMsgEnd, LF, '.'); {do not localize} + End + Else + Begin + LLine := FFirstLine; + FFirstLine := ''; {Do not Localize} + FProcessFirstLine := False; + // Do not use ADELIM since always ends with . (standard) + If LLine = '.' Then + Begin {Do not Localize} + VMsgEnd := True; + Break; End; - LDecoder.DecodeEnd; + If TextStartsWith(LLine, '..') Then + Delete(LLine, 1, 1); End; - Finally - FreeAndNil(LDecoder); - End; + If VMsgEnd Then + Break; + If MIMEBoundary <> '' Then + Begin + If TextIsSame(LLine, LBoundaryStart) Then + Begin + Result := TRESTDWMessageDecoderMIME.Create(Owner); + Break; + End; + If TextIsSame(LLine, LBoundaryEnd) Then + Begin + If Owner is TRESTDWMessage Then + TRESTDWMessage(Owner).MIMEBoundary.Pop; + Break; + End; + End; + If LDecoder = Nil Then + Begin + If LIsBinaryContentTransferEncoding Then + Begin {do not localize} + If LIsThisTheFirstLine Then + LIsThisTheFirstLine := False + Else + Begin + If Assigned(ADestStream) Then + WriteStringToStream(ADestStream, LBinaryLineBreak, -1, 1); + End; + If Assigned(ADestStream) Then + WriteStringToStream(ADestStream, LLine, -1, 1); + End + Else + Begin + If Assigned(ADestStream) Then + WriteStringToStream(ADestStream, LLine + EOL, -1, 1); + End; + End + Else + Begin + If LDecoder Is TRESTDWDecoderQuotedPrintable Then + LDecoder.Decode(LLine + EOL) + Else If LDecoder Is TRESTDWDecoderBinHex4 Then + LBuffer := LBuffer + LLine + Else If LLine <> '' Then + LDecoder.Decode(LLine); + End; + Until False; + If LDecoder <> Nil Then + Begin + If LDecoder Is TRESTDWDecoderBinHex4 Then + LDecoder.Decode(LBuffer); + LDecoder.DecodeEnd; + End; + Finally + FreeAndNil(LDecoder); + End; End; Function TRESTDWMessageDecoderMIME.GetAttachmentFilename(Const AContentType, diff --git a/CORE/Source/Basic/uRESTDWBasic.pas b/CORE/Source/Basic/uRESTDWBasic.pas index f730b7dbc..2b299bbac 100644 --- a/CORE/Source/Basic/uRESTDWBasic.pas +++ b/CORE/Source/Basic/uRESTDWBasic.pas @@ -484,20 +484,20 @@ TRESTDWServerIpVersionConfig = class(TPersistent) Url, RawHTTPCommand : String; Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - RequestHeaders : TStringList; - ClientPort : Integer; - RawHeaders, - Params : TStrings; - QueryParams : String; - ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + Const RequestHeaders : TStringList; + Const ClientPort : Integer; + Const RawHeaders, + Params : TStrings; + QueryParams : String; + Const ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; Var StatusCode : Integer; Var ResponseHeaders : TStringList; Var ResponseString : String; @@ -696,60 +696,60 @@ TRESTDWServerIpVersionConfig = class(TPersistent) Var Pooler, MyIP : String; AccessTag : String; Var InvalidTag : Boolean);Virtual;Abstract; - Function CommandExec (Const AContext : TComponent; + Function CommandExec (Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - RequestHeaders : TStringList; - ClientPort : Integer; - RawHeaders, - Params : TStrings; - QueryParams : String; - ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean;Override; + RawHTTPCommand : String; + Var ContentType : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + Const RequestHeaders : TStringList; + Const ClientPort : Integer; + Const RawHeaders, + Params : TStrings; + QueryParams : String; + Const ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean;Override; End; TRESTDWProxyBase = Class(TRESTDWBasicReceptor) Private Protected Public - Function CommandExec (Const AContext : TComponent; + Function CommandExec (Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - RequestHeaders : TStringList; - ClientPort : Integer; - RawHeaders, - Params : TStrings; - QueryParams : String; - ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean;Override; + RawHTTPCommand : String; + Var ContentType : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + Const RequestHeaders : TStringList; + Const ClientPort : Integer; + Const RawHeaders, + Params : TStrings; + QueryParams : String; + Const ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean;Override; End; //Heranças para Servidores Standalone TRESTServicePoolerBase = Class(TRESTServiceBase) @@ -1552,30 +1552,30 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); Inherited; End; -Function TRESTDWProxyBase.CommandExec(Const AContext : TComponent; +Function TRESTDWProxyBase.CommandExec(Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - RequestHeaders : TStringList; - ClientPort : Integer; - RawHeaders, - Params : TStrings; - QueryParams : String; - ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean; + RawHTTPCommand : String; + Var ContentType : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + Const RequestHeaders : TStringList; + Const ClientPort : Integer; + Const RawHeaders, + Params : TStrings; + QueryParams : String; + Const ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean; Var I, vErrorCode : Integer; DataMode : TDataMode; @@ -3001,30 +3001,30 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End; End; -Function TRESTServiceBase.CommandExec(Const AContext : TComponent; +Function TRESTServiceBase.CommandExec(Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; + RawHTTPCommand : String; + Var ContentType : String; ClientIP, UserAgent, AuthUsername, AuthPassword, - Token : String; - RequestHeaders : TStringList; - ClientPort : Integer; - RawHeaders, - Params : TStrings; - QueryParams : String; - ContentStringStream : TStream; + Token : String; + Const RequestHeaders : TStringList; + Const ClientPort : Integer; + Const RawHeaders, + Params : TStrings; + QueryParams : String; + Const ContentStringStream : TStream; Var AuthRealm, sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean; + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean; Var I, vErrorCode : Integer; DataMode : TDataMode; @@ -3088,6 +3088,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); PCustomHeaders : ^TStrings; vTempContext : TRESTDWContext; vTempEvent : TRESTDWEvent; + vRESTDWBytes : TRESTDWBytes; Function ExcludeTag(Value : String) : String; Begin Result := Value; @@ -3137,8 +3138,10 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End; procedure ReadRawHeaders; var - I: Integer; + I, A : Integer; JSONParam : TRESTDWJSONParam; + aName, + aValue : String; begin If Not Assigned(RawHeaders) Then Exit; @@ -3149,25 +3152,36 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vRequestHeader.Add(RawHeaders.Text); For I := 0 To RawHeaders.Count -1 Do Begin - tmp := RawHeaders.Names[I]; - vTempText := RawHeaders.Values[tmp]; + tmp := RawHeaders[I]; + A := Pos(':', tmp); + If A > 0 Then + Begin + aName := Copy(tmp, 1, Pos(':', tmp) -1); + Delete(tmp, 1, Pos(':', tmp)); + vTempText := Trim(tmp); + End + Else + Begin + aName := Copy(tmp, 1, Length(tmp)); + vTempText := ''; + End; If (vTempText <> '') And (vTempText[InitStrPos] = ' ') then Delete(vTempText,1,1); - If pos('dwwelcomemessage', lowercase(tmp)) > 0 Then + If pos('dwwelcomemessage', lowercase(aName)) > 0 Then vWelcomeMessage := DecodeStrings(vTempText{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}) - Else If pos('dwaccesstag', lowercase(tmp)) > 0 Then + Else If pos('dwaccesstag', lowercase(aName)) > 0 Then vAccessTag := DecodeStrings(vTempText{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}) - Else If pos('datacompression', lowercase(tmp)) > 0 Then + Else If pos('datacompression', lowercase(aName)) > 0 Then compresseddata := StringToBoolean(vTempText) - Else If pos('dwencodestrings', lowercase(tmp)) > 0 Then + Else If pos('dwencodestrings', lowercase(aName)) > 0 Then encodestrings := StringToBoolean(vTempText) - Else If pos('dwusecript', lowercase(tmp)) > 0 Then + Else If pos('dwusecript', lowercase(aName)) > 0 Then vdwCriptKey := StringToBoolean(vTempText) - Else If (pos('dwassyncexec', lowercase(tmp)) > 0) And (Not (dwassyncexec)) Then + Else If (pos('dwassyncexec', lowercase(aName)) > 0) And (Not (dwassyncexec)) Then dwassyncexec := StringToBoolean(vTempText) - Else if pos('binaryrequest', lowercase(tmp)) > 0 Then + Else if pos('binaryrequest', lowercase(aName)) > 0 Then vBinaryEvent := StringToBoolean(vTempText) - Else If pos('dwconnectiondefs', lowercase(tmp)) > 0 Then + Else If pos('dwconnectiondefs', lowercase(aName)) > 0 Then Begin vdwConnectionDefs := TConnectionDefs.Create; JSONValue := TRESTDWJSONValue.Create; @@ -3180,7 +3194,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); FreeAndNil(JSONValue); End; End - Else If pos('dwservereventname', lowercase(tmp)) > 0 Then + Else If pos('dwservereventname', lowercase(aName)) > 0 Then Begin JSONValue := TRESTDWJSONValue.Create; Try @@ -3202,14 +3216,14 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); QueryParams, vmark, vEncoding{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}, DWParams, RequestType); Try - If Trim(lowercase(tmp)) <> '' Then + If Trim(lowercase(aName)) <> '' Then Begin - JSONParam := DWParams.ItemsString[lowercase(tmp)]; + JSONParam := DWParams.ItemsString[lowercase(aName)]; If JSONParam = Nil Then Begin JSONParam := TRESTDWJSONParam.Create(DWParams.Encoding); JSONParam.ObjectDirection := odIN; - JSONParam.ParamName := lowercase(tmp); + JSONParam.ParamName := lowercase(aName); {$IFDEF RESTDWLAZARUS} JSONParam.DatabaseCharSet := vDatabaseCharSet; {$ENDIF} @@ -3504,7 +3518,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); Exit; End; Cmd := RemoveBackslashCommands(Trim(RawHTTPCommand)); - vRequestHeader.Add(Cmd); +// vRequestHeader.Add(Cmd); Cmd := StringReplace(Cmd, ' HTTP/1.0', '', [rfReplaceAll]); Cmd := StringReplace(Cmd, ' HTTP/1.1', '', [rfReplaceAll]); Cmd := StringReplace(Cmd, ' HTTP/2.0', '', [rfReplaceAll]); @@ -3580,30 +3594,32 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); If (RequestType In [rtGet, rtDelete]) Then Begin aurlContext := vUrlToExec; - If Not Assigned(DWParams) Then - TRESTDWDataUtils.ParseRESTURL (Url, vEncoding, vmark{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}, DWParams); vOldMethod := vUrlToExec; - If DWParams <> Nil Then + If Not Assigned(DWParams) Then Begin - If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then - vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then - vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - If (DWParams.ItemsString['datacompression'] <> Nil) Then - compresseddata := StringToBoolean(DWParams.ItemsString['datacompression'].AsString); - If (DWParams.ItemsString['dwencodestrings'] <> Nil) Then - encodestrings := StringToBoolean(DWParams.ItemsString['dwencodestrings'].AsString); - If (DWParams.ItemsString['dwservereventname'] <> Nil) Then + TRESTDWDataUtils.ParseRESTURL (Url, vEncoding, vmark{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}, DWParams); + If DWParams <> Nil Then Begin - If vdwservereventname <> GetEventName(Lowercase(DWParams.ItemsString['dwservereventname'].AsString)) Then - vdwservereventname := DecodeStrings(DWParams.ItemsString['dwservereventname'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then + vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then + vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + If (DWParams.ItemsString['datacompression'] <> Nil) Then + compresseddata := StringToBoolean(DWParams.ItemsString['datacompression'].AsString); + If (DWParams.ItemsString['dwencodestrings'] <> Nil) Then + encodestrings := StringToBoolean(DWParams.ItemsString['dwencodestrings'].AsString); + If (DWParams.ItemsString['dwservereventname'] <> Nil) Then + Begin + If vdwservereventname <> GetEventName(Lowercase(DWParams.ItemsString['dwservereventname'].AsString)) Then + vdwservereventname := DecodeStrings(DWParams.ItemsString['dwservereventname'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + End; + If (DWParams.ItemsString['dwusecript'] <> Nil) Then + vdwCriptKey := StringToBoolean(DWParams.ItemsString['dwusecript'].AsString); + If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then + dwassyncexec := StringToBoolean(DWParams.ItemsString['dwassyncexec'].AsString); + If (DWParams.ItemsString['BinaryCompatibleMode'] <> Nil) Then + vBinaryCompatibleMode := DWParams.ItemsString['BinaryCompatibleMode'].Value; End; - If (DWParams.ItemsString['dwusecript'] <> Nil) Then - vdwCriptKey := StringToBoolean(DWParams.ItemsString['dwusecript'].AsString); - If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then - dwassyncexec := StringToBoolean(DWParams.ItemsString['dwassyncexec'].AsString); - If (DWParams.ItemsString['BinaryCompatibleMode'] <> Nil) Then - vBinaryCompatibleMode := DWParams.ItemsString['BinaryCompatibleMode'].Value; End; If (vUrlToExec = '') And (aurlContext <> '') Then vUrlToExec := aurlContext; @@ -3680,56 +3696,16 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vServerMethod := aServerMethod; If Assigned(vServerMethod) Then Begin - If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then - vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then - vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - Try // identificando o evento a ser chamado no datamodule - vTempServerMethods := vServerMethod.Create(Nil); - If Not vCORS Then - FreeAndNil(CORSCustomHeaders); - {$IFNDEF RESTDWLAZARUS} - {$IFNDEF FPC} - If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End - Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End; - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End; - {$ENDIF} - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or +// If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then +// vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); +// If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then +// vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + vTempServerMethods := vServerMethod.Create(Nil); + If Not vCORS Then + FreeAndNil(CORSCustomHeaders); + {$IFNDEF RESTDWLAZARUS} + {$IFNDEF FPC} + If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or (vTempServerMethods Is TServerMethodDatamodule) Then Begin If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then @@ -3738,7 +3714,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vErrorCode := 200; End; End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or (vTempServerMethods Is TServerBaseMethodClass) Then Begin If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then @@ -3747,10 +3723,47 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vErrorCode := 200; End; End; - {$ENDIF} - vUrlToExec := vOldRequest; - Finally - End; + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End; + {$ENDIF} + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End; + {$ENDIF} + vUrlToExec := vOldRequest; If (Assigned(vTempServerMethods)) Then Begin {$IFNDEF RESTDWLAZARUS} @@ -3941,32 +3954,29 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); {$ENDIF} If vNeedAuthorization Then Begin - // Aqui que Valida a Autenticação - vAuthenticator.AuthValidate(vTempServerMethods, - vUrlToExec, - vWelcomeMessage, - vAccessTag, - AuthUsername, - AuthPassword, - RawHeaders, - RequestType, - DWParams, - vGettoken, - vTokenValidate, - vToken, - vErrorCode, vErrorMessage, vAcceptAuth); - If Not vAcceptAuth and not ((vCORS) And (RequestType = rtOption)) Then //Roniery - Begin - //Eloy - if vAuthenticator is TRESTDWAuthBasic then - AuthRealm := cAuthRealm; - StatusCode := vErrorCode; - ErrorMessage := vErrorMessage; - // - WriteError; - DestroyComponents; - Exit; - End; + vAuthenticator.AuthValidate(vTempServerMethods, + vUrlToExec, + vWelcomeMessage, + vAccessTag, + AuthUsername, + AuthPassword, + RawHeaders, + RequestType, + DWParams, + vGettoken, + vTokenValidate, + vToken, + vErrorCode, vErrorMessage, vAcceptAuth); + If Not vAcceptAuth and not ((vCORS) And (RequestType = rtOption)) Then //Roniery + Begin + If vAuthenticator is TRESTDWAuthBasic Then + AuthRealm := cAuthRealm; + StatusCode := vErrorCode; + ErrorMessage := vErrorMessage; + WriteError; + DestroyComponents; + Exit; + End; End; vErrorCode := 200; vErrorMessage := ''; @@ -3978,48 +3988,60 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End Else Begin - {$IFNDEF RESTDWLAZARUS} - {$IFNDEF FPC} - If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then - TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End - Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then - TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End; - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + Try + {$IFNDEF RESTDWLAZARUS} + {$IFNDEF FPC} + If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or (vTempServerMethods Is TServerMethodDatamodule) Then Begin If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or (vTempServerMethods Is TServerBaseMethodClass) Then Begin If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); End; - {$ENDIF} - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then - TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then + TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then + TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End; + {$ENDIF} + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then + TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then + TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End; + {$ENDIF} + Except + On E : Exception do Begin - If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then - TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + If Assigned(ResultStream) Then + FreeAndNil(ResultStream); + StatusCode := 500; + ResultStream := TStringStream.Create('OnWelcomeMessage raise error: ' + E.Message); + Result := False; + Exit; End; - {$ENDIF} + End; End; End; End @@ -4034,12 +4056,8 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); Try If Assigned(vLastRequest) Then Begin - Try - If Assigned(vLastRequest) Then - vLastRequest(UserAgent + sLineBreak + - RawHTTPCommand); - Finally - End; + If Assigned(vLastRequest) Then + vLastRequest(UserAgent + sLineBreak + RawHTTPCommand); End; If (vUrlToExec = '') And (Cmd <> '/') Then vUrlToExec := vOldMethod; @@ -4063,33 +4081,34 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); sCharSet := 'utf-8' Else sCharSet := 'ansi'; - If DWParams <> Nil Then - Begin - If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then - dwassyncexec := DWParams.ItemsString['dwassyncexec'].AsBoolean; - If DWParams.ItemsString['dwusecript'] <> Nil Then - vdwCriptKey := DWParams.ItemsString['dwusecript'].AsBoolean; - End; +// If DWParams <> Nil Then +// Begin +// If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then +// dwassyncexec := DWParams.ItemsString['dwassyncexec'].AsBoolean; +// If DWParams.ItemsString['dwusecript'] <> Nil Then +// vdwCriptKey := DWParams.ItemsString['dwusecript'].AsBoolean; +// End; If dwassyncexec Then Begin - StatusCode := 200; - vReplyString := AssyncCommandMSG; + StatusCode := 200; + vReplyString := AssyncCommandMSG; If compresseddata Then mb := TStringStream(ZCompressStreamNew(vReplyString)) Else mb := TStringStream.Create(vReplyString{$IFDEF DELPHIXEUP}, TEncoding.UTF8{$ENDIF}); - mb.Position := 0; + mb.Position := 0; If Not (Assigned(ResultStream)) Then ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); FreeAndNil(mb); End; - If DWParams.itemsstring['binaryRequest'] <> Nil Then - vBinaryEvent := DWParams.itemsstring['binaryRequest'].Value; - If DWParams.itemsstring['BinaryCompatibleMode'] <> Nil Then - vBinaryCompatibleMode := DWParams.itemsstring['BinaryCompatibleMode'].Value; - If DWParams.itemsstring['MetadataRequest'] <> Nil Then - vMetadata := DWParams.itemsstring['MetadataRequest'].value; + //Remoção de Códigos duplicados XyberX +// If DWParams.itemsstring['binaryRequest'] <> Nil Then +// vBinaryEvent := DWParams.itemsstring['binaryRequest'].Value; +// If DWParams.itemsstring['BinaryCompatibleMode'] <> Nil Then +// vBinaryCompatibleMode := DWParams.itemsstring['BinaryCompatibleMode'].Value; +// If DWParams.itemsstring['MetadataRequest'] <> Nil Then +// vMetadata := DWParams.itemsstring['MetadataRequest'].value; If (Assigned(DWParams)) And (Assigned(vCripto)) Then DWParams.SetCriptOptions(vdwCriptKey, vCripto.Key); If Assigned(vTempServerMethods) Then @@ -4152,8 +4171,6 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); If Not vFileExists Then Begin tmp := ''; -// If Referer <> '' Then -// tmp := GetLastMethod(Referer); If Url <> '' Then sFile := GetFileOSDir(ExcludeTag(tmp + Url)) Else @@ -4189,315 +4206,296 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End; End; End; - Try - If Assigned(vRequestHeader) Then - Begin - vRequestHeader.Clear; - FreeAndNil(vRequestHeader); - End; - If Assigned(vServerMethod) Then - If Assigned(vTempServerMethods) Then - Begin - {$IFNDEF RESTDWLAZARUS} - {$IFNDEF FPC} - If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then + If Assigned(vRequestHeader) Then + Begin + vRequestHeader.Clear; + FreeAndNil(vRequestHeader); + End; + If Assigned(vServerMethod) Then + If Assigned(vTempServerMethods) Then + Begin + {$IFNDEF RESTDWLAZARUS} + {$IFNDEF FPC} + If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then Begin - If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then + If Assigned(vCriticalSection) Then Begin - If Assigned(vCriticalSection) Then - Begin - vCriticalSection.Release; - FreeAndNil(vCriticalSection); - End; + vCriticalSection.Release; + FreeAndNil(vCriticalSection); End; - End - Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then + End; + End + Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then + Begin + If Assigned(vCriticalSection) Then Begin - If Assigned(vCriticalSection) Then - Begin - vCriticalSection.Release; - FreeAndNil(vCriticalSection); - End; + vCriticalSection.Release; + FreeAndNil(vCriticalSection); End; End; - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End; - {$ENDIF} + End; {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then + Begin + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then + Begin + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End; + {$ENDIF} + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then Begin - If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); End; - {$ENDIF} - Try - vTempServerMethods.free; - vTempServerMethods := Nil; - Except - End; - End; - If Not dwassyncexec Then - Begin - If (Not (vTagReply)) Then + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then Begin - If vEncoding = esUtf8 Then - sCharSet := 'utf-8' - Else - sCharSet := 'ansi'; - If vContentType <> '' Then - ContentType := vContentType; - If Not vServerContextCall Then + If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then Begin - If (vUrlToExec <> '') Then - Begin - If DataMode in [dmDataware] Then - Begin - If Trim(JSONStr) <> '' Then - Begin - If Not(((Pos('{', JSONStr) > 0) And - (Pos('}', JSONStr) > 0)) Or - ((Pos('[', JSONStr) > 0) And - (Pos(']', JSONStr) > 0))) Then - Begin - If Not (WelcomeAccept) And (vErrorMessage <> '') Then - JSONStr := escape_chars(vErrorMessage) - Else If Not((JSONStr[InitStrPos] = '"') And - (JSONStr[Length(JSONStr)] = '"')) Then - JSONStr := '"' + JSONStr + '"'; - End; - End; -// vErrorCode := 200; - If (RequestType <> rtOption) Then - Begin - If vBinaryEvent Then - vReplyString := JSONStr - Else - Begin - If Not(((vUrlToExec = '') Or (vUrlToExec = '/')) And (RequestType = rtGet)) Then - Begin - If Not (WelcomeAccept) And (vErrorMessage <> '') Then - Begin - If vEncode_Errors then - vReplyString := escape_chars(vErrorMessage) - Else - vReplyString := vErrorMessage; - End - Else - vReplyString := Format(TValueDisp, [GetParamsReturn(DWParams), JSONStr]); - End; - End; - End; - End - Else If DataMode = dmRAW Then - Begin - If (Trim(JSONStr) = '') And (WelcomeAccept) Then - vReplyString := '{}' - Else If Not (WelcomeAccept) And (vErrorMessage <> '') Then - vReplyString := escape_chars(vErrorMessage) - Else - vReplyString := JSONStr; - End; - End; - If Assigned(DWParams) Then - Begin - If DWParams.RequestHeaders.Output.Count > 0 Then - Begin - For I := 0 To DWParams.RequestHeaders.Output.Count -1 Do - RequestHeaders.Add(DWParams.RequestHeaders.Output[I]); - End; - End; - StatusCode := vErrorCode; - If Assigned(DWParams) And - (Pos(DWParams.Url_Redirect, Cmd) = 0) And - (DWParams.Url_Redirect <> '') Then - Begin - vUrlRedirect := DWParams.Url_Redirect; - If Assigned(Redirect) Then - Redirect(vUrlRedirect, AContext); - End; - If compresseddata Then - Begin - If vBinaryEvent Then - Begin - ms := TMemoryStream.Create; - If vGettoken Then - Begin - DWParams.Clear; - DWParams.CreateParam('token', vReplyString); - End; - Try - If DWParams.ItemsString['MessageError'] = Nil Then - Begin - DWParams.CreateParam('MessageError'); - DWParams.ItemsString['MessageError'].ObjectDirection := odOut; - End; - If ((JSONStr <> TReplyOK) and (JSONStr <> Trim(''))) then + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End; + {$ENDIF} + Try + vTempServerMethods.free; + vTempServerMethods := Nil; + Except + End; + End; + If Not dwassyncexec Then + Begin + If (Not (vTagReply)) Then + Begin + If vEncoding = esUtf8 Then + sCharSet := 'utf-8' + Else + sCharSet := 'ansi'; + If vContentType <> '' Then + ContentType := vContentType; + If Not vServerContextCall Then + Begin + If (vUrlToExec <> '') Then + Begin + If DataMode in [dmDataware] Then + Begin + If Trim(JSONStr) <> '' Then + Begin + If Not(((Pos('{', JSONStr) > 0) And + (Pos('}', JSONStr) > 0)) Or + ((Pos('[', JSONStr) > 0) And + (Pos(']', JSONStr) > 0))) Then Begin - If DWParams.ItemsString['MessageError'].AsString = '' Then - DWParams.ItemsString['MessageError'].AsString := JSONStr; - End + If Not (WelcomeAccept) And + (vErrorMessage <> '') Then + JSONStr := escape_chars(vErrorMessage) + Else If Not((JSONStr[InitStrPos] = '"') And + (JSONStr[Length(JSONStr)] = '"')) Then + JSONStr := '"' + JSONStr + '"'; + End; + End; + If (RequestType <> rtOption) Then + Begin + If vBinaryEvent Then + vReplyString := JSONStr Else - DWParams.ItemsString['MessageError'].AsString := ''; - DWParams.SaveToStream(TStream(ms), tdwpxt_OUT); - ZCompressStreamD(ms, ResultStream); - Finally - FreeAndNil(ms); + Begin + If Not(((vUrlToExec = '') Or (vUrlToExec = '/')) And (RequestType = rtGet)) Then + Begin + If Not (WelcomeAccept) And (vErrorMessage <> '') Then + Begin + If vEncode_Errors then + vReplyString := escape_chars(vErrorMessage) + Else + vReplyString := vErrorMessage; + End + Else + vReplyString := Format(TValueDisp, [GetParamsReturn(DWParams), JSONStr]); + End; + End; End; - End - Else - Begin - If Assigned(ResultStream) Then - FreeAndNil(ResultStream); - ResultStream := TStringStream(ZCompressStreamNew(vReplyString)); - End; - If not (vErrorCode in [200,201]) Then - ResponseString := escape_chars(vReplyString) - End - Else - Begin - {$IFNDEF FPC} - {$IFDEF DELPHIXEUP} - If vBinaryEvent Then + End + Else If DataMode = dmRAW Then + Begin + If (Trim(JSONStr) = '') And (WelcomeAccept) Then + vReplyString := '{}' + Else If Not (WelcomeAccept) And (vErrorMessage <> '') Then + vReplyString := escape_chars(vErrorMessage) + Else + vReplyString := JSONStr; + End; + End; + If Assigned(DWParams) Then + Begin + If DWParams.RequestHeaders.Output.Count > 0 Then + Begin + For I := 0 To DWParams.RequestHeaders.Output.Count -1 Do + RequestHeaders.Add(DWParams.RequestHeaders.Output[I]); + End; + End; + StatusCode := vErrorCode; + If Assigned(DWParams) And + (Pos(DWParams.Url_Redirect, Cmd) = 0) And + (DWParams.Url_Redirect <> '') Then + Begin + vUrlRedirect := DWParams.Url_Redirect; + If Assigned(Redirect) Then + Redirect(vUrlRedirect, AContext); + End; + If compresseddata Then + Begin + If vBinaryEvent Then + Begin + ms := TMemoryStream.Create; + If vGettoken Then + Begin + DWParams.Clear; + DWParams.CreateParam('token', vReplyString); + End; + Try + If DWParams.ItemsString['MessageError'] = Nil Then Begin - mb := TStringStream.Create(''); - Try - DWParams.SaveToStream(mb, tdwpxt_OUT); - Finally - End; - End - Else - mb := TStringStream.Create(vReplyString{$IFDEF DELPHIXEUP}, TEncoding.UTF8{$ENDIF}); - mb.Position := 0; - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(mb, ResultStream); - FreeAndNil(mb); - {$ELSE} - If vBinaryEvent Then + DWParams.CreateParam('MessageError'); + DWParams.ItemsString['MessageError'].ObjectDirection := odOut; + End; + If ((JSONStr <> TReplyOK) and (JSONStr <> Trim(''))) then Begin - mb := TStringStream.Create(''); - Try - DWParams.SaveToStream(mb, tdwpxt_OUT); - Finally - End; - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(mb, ResultStream); - FreeAndNil(mb); + If DWParams.ItemsString['MessageError'].AsString = '' Then + DWParams.ItemsString['MessageError'].AsString := JSONStr; End Else - ResponseString := vReplyString; - {$ENDIF} - {$ELSE} + DWParams.ItemsString['MessageError'].AsString := ''; + DWParams.SaveToStream(TStream(ms), tdwpxt_OUT); + ZCompressStreamD(ms, ResultStream); + Finally + FreeAndNil(ms); + End; + End + Else + Begin + If Assigned(ResultStream) Then + FreeAndNil(ResultStream); + ResultStream := TStringStream(ZCompressStreamNew(vReplyString)); + End; + If not (vErrorCode in [200,201]) Then + ResponseString := escape_chars(vReplyString) + End + Else + Begin + {$IFNDEF FPC} + {$IFDEF DELPHIXEUP} If vBinaryEvent Then Begin - mb := TStringStream.Create(''); - Try - DWParams.SaveToStream(mb, tdwpxt_OUT); - Finally - End; - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(mb, ResultStream); - FreeAndNil(mb); + ResultStream := TMemoryStream.Create; + DWParams.SaveToStream(ResultStream, tdwpxt_OUT); +// WriteStream(mb, ResultStream); End Else Begin - If vEncoding = esUtf8 Then - mb := TStringStream.Create(Utf8Encode(vReplyString)) - Else - mb := TStringStream.Create(vReplyString); - mb.Position := 0; - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(mb, ResultStream); - FreeAndNil(mb); +// If Not (vErrorCode in [200, 201]) Then + ResultStream := TStringStream.Create(Utf8Encode(vReplyString)); +// Else +// ResultStream := TStringStream.Create(vReplyString); End; + ResultStream.Position := 0; + {$ELSE} + If vBinaryEvent Then + Begin + ResultStream := TMemoryStream.Create; + DWParams.SaveToStream(ResultStream, tdwpxt_OUT); + End + Else + ResponseString := vReplyString; {$ENDIF} - End; - End - Else - Begin - LocalDoc := ''; - If TEncodeSelect(vEncoding) = esUtf8 Then - sCharset := 'utf-8' - Else If TEncodeSelect(vEncoding) in [esANSI, esASCII] Then - sCharset := 'ansi'; - If Not vSpecialServer Then - Begin - StatusCode := vErrorCode; - If ServerContextStream <> Nil Then + {$ELSE} + If vBinaryEvent Then Begin - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(ServerContextStream, ResultStream); - FreeAndNil(ServerContextStream); + ResultStream := TMemoryStream.Create; + DWParams.SaveToStream(ResultStream, tdwpxt_OUT); End Else Begin - {$IFDEF FPC} - If vEncoding = esUtf8 Then - mb := TStringStream.Create(Utf8Encode(JSONStr)) - Else - mb := TStringStream.Create(JSONStr); - mb.Position := 0; + If vEncoding = esUtf8 Then + mb := TStringStream.Create(Utf8Encode(vReplyString)) + Else + mb := TStringStream.Create(vReplyString); + mb.Position := 0; + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); + WriteStream(mb, ResultStream); + FreeAndNil(mb); + End; + {$ENDIF} + End; + End + Else + Begin + LocalDoc := ''; + If TEncodeSelect(vEncoding) = esUtf8 Then + sCharset := 'utf-8' + Else If TEncodeSelect(vEncoding) in [esANSI, esASCII] Then + sCharset := 'ansi'; + If Not vSpecialServer Then + Begin + StatusCode := vErrorCode; + If ServerContextStream <> Nil Then + Begin + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); + WriteStream(ServerContextStream, ResultStream); + FreeAndNil(ServerContextStream); + End + Else + Begin + {$IFDEF FPC} + If vEncoding = esUtf8 Then + mb := TStringStream.Create(Utf8Encode(JSONStr)) + Else + mb := TStringStream.Create(JSONStr); + mb.Position := 0; + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); + FreeAndNil(mb); + {$ELSE} + {$IF CompilerVersion > 21} + mb := TStringStream.Create(JSONStr{$IFNDEF FPC}{$IF CompilerVersion > 21}, TEncoding.UTF8{$IFEND}{$ENDIF}); + mb.Position := 0; If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); + ResultStream := TStringStream.Create(''); + WriteStream(mb, ResultStream); FreeAndNil(mb); {$ELSE} - {$IF CompilerVersion > 21} - mb := TStringStream.Create(JSONStr{$IFNDEF FPC}{$IF CompilerVersion > 21}, TEncoding.UTF8{$IFEND}{$ENDIF}); - mb.Position := 0; - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(mb, ResultStream); - FreeAndNil(mb); - {$ELSE} - ResponseString := JSONStr; + ResponseString := JSONStr; {$IFEND} - {$ENDIF} - End; - End; - End; - End; - End; - Finally -// FreeAndNil(mb); - End; + {$ENDIF} + End; + End; + End; + End; + End; If Assigned(vLastResponse) Then Begin Try @@ -4868,7 +4866,6 @@ procedure TRESTDWBasicReceptor.SetAuthenticator( Begin // lazarus iniciando com sujeira de memoria vStrings vStrings := nil; - If ServerMethodsClass <> Nil Then Begin For I := 0 To ServerMethodsClass.ComponentCount -1 Do @@ -5322,7 +5319,7 @@ procedure TRESTDWBasicReceptor.SetAuthenticator( JSONParam.ObjectDirection := odOut; Params.Add(JSONParam); End; - Params.ItemsString['MessageError'].AsString :=''; +// Params.ItemsString['MessageError'].AsString :=''; If ReturnEvent(BaseObject, vUrlMethod, vBaseUrl, vResult, Params, DataMode, ErrorCode, ContentType, Accesstag, RequestType, RequestHeader) Then Begin JSONStr := vResult; diff --git a/CORE/Source/Basic/uRESTDWParams.pas b/CORE/Source/Basic/uRESTDWParams.pas index a181d84cf..f18c93a3d 100644 --- a/CORE/Source/Basic/uRESTDWParams.pas +++ b/CORE/Source/Basic/uRESTDWParams.pas @@ -6245,7 +6245,7 @@ procedure TRESTDWJSONParam.SetParamContentType(const bValue: String); Else S := TNullString; J := Length(S); - Stream.Write(J, Sizeof(DWInteger)); + Stream.Write(J, Sizeof(DWInt64)); Stream.Write(S[InitStrPos], J); End; ovWord : Begin @@ -6538,7 +6538,7 @@ procedure TRESTDWJSONParam.SetParamContentType(const bValue: String); ovFMTBcd, ovFloat, ovExtended : Begin - Stream.Read(J, Sizeof(DWInteger)); + Stream.Read(J, Sizeof(DWInt64)); SetLength(S, J); If J <> 0 Then Begin diff --git a/CORE/Source/Basic/uRESTDWStorageBin.pas b/CORE/Source/Basic/uRESTDWStorageBin.pas index 2ae57c90b..d587fb608 100644 --- a/CORE/Source/Basic/uRESTDWStorageBin.pas +++ b/CORE/Source/Basic/uRESTDWStorageBin.pas @@ -220,24 +220,40 @@ interface Index : Integer); Var vFDef : TFieldDef; + Function FindDef(aName : String) : Boolean; + Var + I : Integer; + Begin + Result := False; + For I := 0 To DataSet.FieldDefs.Count -1 Do + Begin + Result := Lowercase(DataSet.FieldDefs[I].Name) = Lowercase(aName); + If Result Then + Break; + End; + End; Begin If Trim(FFieldNames[Index]) <> '' Then Begin - VFDef := DataSet.FieldDefs.AddFieldDef; - VFDef.Name := FFieldNames[Index]; - VFDef.DataType := DWFieldTypeToFieldType(FFieldTypes[Index]); - VFDef.Size := FFieldSize[Index]; - VFDef.Required := FFieldAttrs[Index] and 1 > 0; - Case FFieldTypes[Index] of - dwftFloat, - dwftCurrency, - dwftSingle : VFDef.Precision := FFieldPrecision[Index]; - dwftBCD, - dwftFMTBcd : Begin - VFDef.Size := 0; - VFDef.Precision := 0; - End; - End; + If (Not (Assigned(DataSet.FindField(FFieldNames[Index]))) And + Not(FindDef(FFieldNames[Index]))) Then + Begin + VFDef := DataSet.FieldDefs.AddFieldDef; + VFDef.Name := FFieldNames[Index]; + VFDef.DataType := DWFieldTypeToFieldType(FFieldTypes[Index]); + VFDef.Size := FFieldSize[Index]; + VFDef.Required := FFieldAttrs[Index] and 1 > 0; + Case FFieldTypes[Index] of + dwftFloat, + dwftCurrency, + dwftSingle : VFDef.Precision := FFieldPrecision[Index]; + dwftBCD, + dwftFMTBcd : Begin + VFDef.Size := 0; + VFDef.Precision := 0; + End; + End; + End; End; End; Var diff --git a/CORE/Source/Consts/uRESTDWConsts.pas b/CORE/Source/Consts/uRESTDWConsts.pas index 3075334b5..f61e98a94 100644 --- a/CORE/Source/Consts/uRESTDWConsts.pas +++ b/CORE/Source/Consts/uRESTDWConsts.pas @@ -1,4 +1,4 @@ -Unit uRESTDWConsts; +Unit uRESTDWConsts; {$I ..\..\Source\Includes\uRESTDW.inc} @@ -62,7 +62,7 @@ // controle de versão RESTDWVersionINFO = 'v2.1.0-'; - RESTDWRelease = '792'; + RESTDWRelease = '3850'; RESTDWCodeProject = 'Galaga - SourceForge'; RESTDWVersao = RESTDWVersionINFO + RESTDWRelease + '(' + RESTDWCodeProject + ')'; RESTDWDialogoTitulo = 'REST DataWare Components ' + RESTDWVersao; diff --git a/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas b/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas index 3c38c34f8..4994e9b50 100644 --- a/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas +++ b/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas @@ -427,8 +427,10 @@ TDoubleLinkedBufIndex = class(TRESTDWIndex) TRESTDWMemTable = Class(TDataset, IRESTDWMemTable) Private FSaveLoadState : TSaveLoadState; + aFilterRecs, FMaxIndexesCount, FPacketRecords, + FRecordFilterPos, FRecordPos, FRecordSize, FBookmarkOfs, @@ -1168,6 +1170,8 @@ constructor TRESTDWMemTable.Create(AOwner: TComponent); Begin Inherited Create(AOwner); FRecordPos := -1; + FRecordFilterPos := -1; + aFilterRecs := FRecordFilterPos; FLastID := Low(Integer); FAutoInc := 1; FRecords := TRecordList.Create; @@ -1530,7 +1534,9 @@ destructor TRESTDWMemTable.Destroy; FClearing := False; End; FLastID := Low(Integer); - FRecordPos := -1; + FRecordPos := -1; + FRecordFilterPos := FRecordPos; + aFilterRecs := FRecordFilterPos; End; Function TRESTDWMemTable.AllocRecordBuffer: TRecordBuffer; @@ -1710,7 +1716,7 @@ destructor TRESTDWMemTable.Destroy; End; End; -Function TRESTDWMemTable.GetRecord(Buffer: {$IFDEF NEXTGEN}TRecBuf{$ELSE}TRecordBuffer{$ENDIF}; +Function TRESTDWMemTable.GetRecord(Buffer: {$IFDEF NEXTGEN}TRecBuf{$ELSE}TRecordBuffer{$ENDIF}; GetMode: TGetMode; DoCheck: Boolean): TGetResult; var @@ -1723,20 +1729,29 @@ destructor TRESTDWMemTable.Destroy; If FRecordPos <= 0 then Begin Result := grBOF; - FRecordPos := -1; + FRecordPos := -1; + FRecordFilterPos := FRecordPos; End Else Begin +// aFilterRecs := RecordCount; Repeat Dec(FRecordPos); If Filtered then - Accept := RecordFilter; + Begin + Accept := RecordFilter; + If Accept Then + Dec(aFilterRecs); + End + Else + FRecordFilterPos := FRecordPos; Until Accept Or (FRecordPos < 0); If Not Accept Then Begin Result := grBOF; FRecordPos := -1; End; + FRecordFilterPos := aFilterRecs; End; End; gmCurrent : Begin @@ -1756,13 +1771,18 @@ destructor TRESTDWMemTable.Destroy; Repeat Inc(FRecordPos); If Filtered Then - Accept := RecordFilter; + Begin + Accept := RecordFilter; + If Accept Then + Inc(aFilterRecs); + End; Until Accept or (FRecordPos > FRecords.Count - 1); If Not Accept Then Begin Result := grEOF; - FRecordPos := RecordCount - 1; + FRecordPos := RecordCount - 1; End; + FRecordFilterPos := aFilterRecs; End; End; End; @@ -2428,6 +2448,7 @@ destructor TRESTDWMemTable.Destroy; If Active then Begin CheckBrowseMode; + aFilterRecs := 0; If Filtered <> Value then inherited SetFiltered(Value); First; @@ -2461,8 +2482,8 @@ destructor TRESTDWMemTable.Destroy; Begin SaveState := SetTempState(dsFilter); Try - RecordToBuffer(Records[FRecordPos], PRESTDWMTMemBuffer(TempBuffer)); - {$IFDEF FPC} + RecordToBuffer(Records[FRecordPos], PRESTDWMTMemBuffer(TempBuffer)); + {$IFDEF FPC} If (FFilterParser <> nil) and FFilterParser.Eval() then Begin FFilterParser.EnableWildcardMatching := @@ -2470,11 +2491,10 @@ destructor TRESTDWMemTable.Destroy; FFilterParser.CaseInsensitive := foCaseInsensitive in FilterOptions; Result := FFilterParser.Value; End; -{$ELSE} - If FFilterExpression <> nil then - Result := FFilterExpression.Evaluate(); - -{$ENDIF} + {$ELSE} + If FFilterExpression <> nil then + Result := FFilterExpression.Evaluate(); + {$ENDIF} If Assigned(OnFilterRecord) then OnFilterRecord(Self, Result); Except @@ -2642,12 +2662,16 @@ destructor TRESTDWMemTable.Destroy; Procedure TRESTDWMemTable.InternalFirst; Begin - FRecordPos := -1; + FRecordPos := -1; + FRecordFilterPos := 0; + aFilterRecs := FRecordFilterPos; End; Procedure TRESTDWMemTable.InternalLast; Begin - FRecordPos := FRecords.Count; + FRecordPos := FRecords.Count; + FRecordFilterPos := RecordCount; + aFilterRecs := FRecordFilterPos; End; Function TRESTDWMemTable.GetDataset: TDataset; @@ -4810,7 +4834,15 @@ procedure TRESTDWMemTable.InternalCreateIndex(F : TRESTDWDataSetIndex); Begin CheckActive; UpdateCursorPos; - If (FRecordPos = -1) and (RecordCount > 0) then + If (filtered) And + (TRESTDWMemTableEx(Self).GetFilteredRecordCount > 0) Then + Begin + If (FRecordFilterPos = -1) Then + Result := 1 + Else + Result := FRecordFilterPos; + End + Else If (FRecordPos = -1) and (RecordCount > 0) then Result := 1 Else Result := FRecordPos + 1; @@ -6652,6 +6684,7 @@ constructor TRESTDWMemTableEx.Create(AOwner: TComponent); fFilteredRecordCount := i; Finally + aFilterRecs := 0; If (fFilteredRecordCount > 0) and assigned(savePlace) and BookmarkValid(savePlace) then GotoBookmark(savePlace); FreeBookmark(savePlace); diff --git a/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas b/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas index c28753d5b..a694f9a8c 100644 --- a/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas +++ b/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas @@ -40,7 +40,7 @@ interface OverbyteIcsWinSock, OverbyteIcsWSocket, OverbyteIcsWndControl, OverbyteIcsHttpAppServer, OverbyteIcsUtils, OverbyteIcsFormDataDecoder, OverbyteIcsMimeUtils, OverbyteIcsSSLEAY, OverbyteIcsHttpSrv, - OverbyteIcsWSocketS, OverbyteIcsSslX509Utils; + OverbyteIcsWSocketS, OverbyteIcsSslX509Utils, OverbyteIcsSslBase; type TPoolerHttpConnection = class(THttpAppSrvConnection) diff --git a/CORE/Source/Wizards/RDWCGIWizard.pas b/CORE/Source/Wizards/RDWCGIWizard.pas index ede162167..9d06dca90 100644 --- a/CORE/Source/Wizards/RDWCGIWizard.pas +++ b/CORE/Source/Wizards/RDWCGIWizard.pas @@ -343,7 +343,9 @@ Function GetDelphiGlobalKey : String; Begin Result := ''; - {$IF DEFINED(DELPHI11UP)} // delphi 11 Alexandria + {$IF DEFINED(DELPHI12UP)} // delphi 11 Alexandria + Result := '\Software\Embarcadero\BDS\23.0\Globals'; + {$ELSEIF DEFINED(DELPHI11UP)} // delphi 11 Alexandria Result := '\Software\Embarcadero\BDS\22.0\Globals'; {$ELSEIF DEFINED(DELPHI10_4UP)} // delphi 10.4 Sydney Result := '\Software\Embarcadero\BDS\21.0\Globals'; diff --git a/CORE/Source/Wizards/STLWizard.pas b/CORE/Source/Wizards/STLWizard.pas index d363d5a53..e186ceb5e 100644 --- a/CORE/Source/Wizards/STLWizard.pas +++ b/CORE/Source/Wizards/STLWizard.pas @@ -458,6 +458,9 @@ {$IFDEF ver350} // delphi 11 Result := '\Software\Embarcadero\BDS\22.0\Globals'; {$ENDIF} + {$IFDEF ver360} // delphi 11 + Result := '\Software\Embarcadero\BDS\23.0\Globals'; + {$ENDIF} End; Function Getideprojectpath: String; diff --git a/CORE/Source/Wizards/templates/URDWDm.dfm b/CORE/Source/Wizards/templates/URDWDm.dfm index 787c77c31..9650c884c 100644 --- a/CORE/Source/Wizards/templates/URDWDm.dfm +++ b/CORE/Source/Wizards/templates/URDWDm.dfm @@ -1,30 +1,6 @@ object %0:s: T%0:s + Encoding = esUtf8 + QueuedRequest = False Height = 480 Width = 640 - object RESTDWServerEvents1: TRESTDWServerEvents - IgnoreInvalidParams = False - Events = < - item - Routes = [crAll] - NeedAuthorization = True - Params = < - item - TypeObject = toParam - ObjectDirection = odIN - ObjectValue = ovString - ParamName = 'entrada' - Encoded = True - end> - DataMode = dmDataware - Name = 'helloworld' - EventName = 'helloworld' - BaseURL = '/' - DefaultContentType = 'application/json' - CallbackEvent = False - OnlyPreDefinedParams = False - OnReplyEvent = RESTDWServerEvents1EventshelloworldReplyEvent - end> - Left = 232 - Top = 264 - end end \ No newline at end of file diff --git a/CORE/Source/Wizards/templates/URDWDm.pas b/CORE/Source/Wizards/templates/URDWDm.pas index ab093e58f..0aa6210c5 100644 --- a/CORE/Source/Wizards/templates/URDWDm.pas +++ b/CORE/Source/Wizards/templates/URDWDm.pas @@ -3,18 +3,15 @@ interface uses - uRESTDWComponentBase, uRESTDWParams, uRESTDWServerEvents, uRESTDWDatamodule, + uRESTDWJSONObject, System.Classes, System.SysUtils; type T%1:s = class(%2:s) - RESTDWServerEvents1: TRESTDWServerEvents; - procedure RESTDWServerEvents1EventshelloworldReplyEvent( - var Params: TRESTDWParams; var Result: string); private { Private declarations } public @@ -29,8 +26,5 @@ implementation {$R *.dfm} -procedure T%1:s.RESTDWServerEvents1EventshelloworldReplyEvent( - var Params: TRESTDWParams; var Result: string); -begin - Result := ('{"Message":"'+Params.Itemsstring['entrada'].Asstring+'"}'); -end; \ No newline at end of file + +end. \ No newline at end of file From 773aee6728d7328f8cf1e7acd6115150341f37db Mon Sep 17 00:00:00 2001 From: "ronierys2@hotmail.com" Date: Mon, 13 May 2024 19:07:23 -0300 Subject: [PATCH 2/3] =?UTF-8?q?Revert=20"corre=C3=A7=C3=B5es"?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This reverts commit 049585441b42960001208c23941c707465ad081f. --- .../Basic/Mechanics/uRESTDWMessageCoder.pas | 15 +- .../Mechanics/uRESTDWMessageCoderMIME.pas | 289 ++--- CORE/Source/Basic/uRESTDWBasic.pas | 1095 +++++++++-------- CORE/Source/Basic/uRESTDWParams.pas | 4 +- CORE/Source/Basic/uRESTDWStorageBin.pas | 46 +- CORE/Source/Consts/uRESTDWConsts.pas | 4 +- .../Memdataset/uRESTDWMemoryDataset.pas | 65 +- CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas | 2 +- CORE/Source/Wizards/RDWCGIWizard.pas | 4 +- CORE/Source/Wizards/STLWizard.pas | 3 - CORE/Source/Wizards/templates/URDWDm.dfm | 28 +- CORE/Source/Wizards/templates/URDWDm.pas | 12 +- 12 files changed, 770 insertions(+), 797 deletions(-) diff --git a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas index d5dc584c3..471f7ddfd 100644 --- a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas +++ b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoder.pas @@ -54,7 +54,6 @@ Const ADelim : String = '.') : String; Overload; Function ReadLnRFCB(Var VMsgEnd : Boolean; Const ALineTerminator : String; - Const BoundaryEnd : String = ''; Const ADelim : String = '.') : TRESTDWBytes; Property Filename : String Read FFilename; Property FreeSourceStream : Boolean Read FFreeSourceStream Write FFreeSourceStream; @@ -394,22 +393,10 @@ Function TRESTDWMessageDecoder.ReadLnRFCB(Var VMsgEnd : Boolean; Const ALineTerminator : String; - Const BoundaryEnd : String = ''; Const ADelim : String = '.') : TRESTDWBytes; -Var - vline : String; - vBytes : TRESTDWBytes; Begin Result := ReadLnB(ALineTerminator); - vLine := BytesToString(Result); - If Pos(BoundaryEnd, vLine) > 0 Then - Begin - vBytes := StringToBytes(Copy(vLine, 1, Pos(BoundaryEnd, vLine) -1)); - Result := vBytes; - SetLength(vBytes, 0); - VMsgEnd := True; - End - Else If Length(Result) = 0 Then {do not localize} + If Length(Result) = 0 Then {do not localize} Begin VMsgEnd := True; Exit; diff --git a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas index ccc87476c..4b252634a 100644 --- a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas +++ b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas @@ -284,151 +284,158 @@ destructor TRESTDWMessageDecoderMIME.Destroy; Function TRESTDWMessageDecoderMIME.ReadBody(ADestStream : TStream; Var VMsgEnd : Boolean) : TRESTDWMessageDecoder; -Var - LContentType, - LContentTransferEncoding, - LLine, - LBinaryLineBreak, - LBuffer, //Needed for binhex4 because cannot decode line-by-line. - LBoundaryStart, - LBoundaryEnd : String; - LIsThisTheFirstLine, //Needed for binary encoding - LIsBinaryContentTransferEncoding : Boolean; - LDecoder : TRESTDWDecoder; -Begin - LIsThisTheFirstLine := True; - VMsgEnd := False; - Result := Nil; - If FBodyEncoded Then - Begin - LContentType := TRESTDWMessage(Owner).ContentType; - LContentTransferEncoding := TRESTDWMessage(Owner).ContentTransferEncoding; - End - Else - Begin - LContentType := FHeaders.Values['Content-Type']; {Do not Localize} - LContentTransferEncoding := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize} - End; - If LContentTransferEncoding = '' Then - Begin - If IsHeaderMediaType(LContentType, 'application/mac-binhex40') Then {Do not Localize} - LContentTransferEncoding := 'binhex40' {do not localize} - Else If Not IsHeaderMediaType(LContentType, 'application/octet-stream') Then {Do not Localize} - LContentTransferEncoding := '7bit'; {do not localize} - End - Else If IsHeaderMediaType(LContentType, 'multipart') Then {do not localize} - Begin - If PosInStrArray(LContentTransferEncoding, ['7bit', '8bit', 'binary'], False) = -1 Then {do not localize} - LContentTransferEncoding := ''; - End; - If TextIsSame(LContentTransferEncoding, 'base64') Then {Do not Localize} - LDecoder := TRESTDWDecoderMIMELineByLine.Create(Nil) - Else If TextIsSame(LContentTransferEncoding, 'quoted-printable') Then {Do not Localize} - LDecoder := TRESTDWDecoderQuotedPrintable.Create(Nil) - Else If TextIsSame(LContentTransferEncoding, 'binhex40') Then {Do not Localize} - LDecoder := TRESTDWDecoderBinHex4.Create (Nil) - Else - LDecoder := nil; - Try - If LDecoder <> Nil Then - LDecoder.DecodeBegin(ADestStream); - If MIMEBoundary <> '' Then - Begin - LBoundaryStart := '--' + MIMEBoundary; {Do not Localize} - LBoundaryEnd := LBoundaryStart + '--'; {Do not Localize} - End; - If LContentTransferEncoding <> '' Then - Begin - Case PosInStrArray(LContentTransferEncoding, ['7bit', 'quoted-printable', 'base64', '8bit', 'binary'], False) Of {do not localize} - 0..2: LIsBinaryContentTransferEncoding := False; - 3..4: LIsBinaryContentTransferEncoding := True; - Else - LIsBinaryContentTransferEncoding := True; - LContentTransferEncoding := ''; - End; - End - Else - LIsBinaryContentTransferEncoding := True; - Repeat - If Not FProcessFirstLine Then - Begin - If LIsBinaryContentTransferEncoding Then - Begin - LLine := ReadLnRFC(VMsgEnd, EOL, '.'); {do not localize} - LBinaryLineBreak := EOL; - End - Else - LLine := ReadLnRFC(VMsgEnd, LF, '.'); {do not localize} - End - Else - Begin - LLine := FFirstLine; - FFirstLine := ''; {Do not Localize} - FProcessFirstLine := False; - // Do not use ADELIM since always ends with . (standard) - If LLine = '.' Then - Begin {Do not Localize} - VMsgEnd := True; - Break; - End; - If TextStartsWith(LLine, '..') Then - Delete(LLine, 1, 1); - End; - If VMsgEnd Then - Break; - If MIMEBoundary <> '' Then - Begin - If TextIsSame(LLine, LBoundaryStart) Then - Begin - Result := TRESTDWMessageDecoderMIME.Create(Owner); - Break; - End; - If TextIsSame(LLine, LBoundaryEnd) Then - Begin - If Owner is TRESTDWMessage Then - TRESTDWMessage(Owner).MIMEBoundary.Pop; - Break; - End; - End; - If LDecoder = Nil Then +var + LContentType, LContentTransferEncoding: string; + LDecoder: TRESTDWDecoder; + LBytes : TRESTDWBytes; + LLine: string; + LBuffer: string; //Needed for binhex4 because cannot decode line-by-line. + LIsThisTheFirstLine: Boolean; //Needed for binary encoding + BoundaryStart, BoundaryEnd: string; + IsBinaryContentTransferEncoding: Boolean; +begin + LIsThisTheFirstLine := True; + VMsgEnd := False; + Result := nil; + if FBodyEncoded then begin + LContentType := TRESTDWMessage(Owner).ContentType; + LContentTransferEncoding := TRESTDWMessage(Owner).ContentTransferEncoding; + end else begin + LContentType := FHeaders.Values['Content-Type']; {Do not Localize} + LContentTransferEncoding := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize} + end; + if LContentTransferEncoding = '' then begin + if IsHeaderMediaType(LContentType, 'application/mac-binhex40') then begin {Do not Localize} + LContentTransferEncoding := 'binhex40'; {do not localize} + end; + end; + + // RLebeau 08/17/09 - According to RFC 2045 Section 6.4: + // "If an entity is of type "multipart" the Content-Transfer-Encoding is not + // permitted to have any value other than "7bit", "8bit" or "binary"." + // + // However, came across one message where the "Content-Type" was set to + // "multipart/related" and the "Content-Transfer-Encoding" was set to + // "quoted-printable". Outlook and Thunderbird were apparently able to parse + // the message correctly, but Indy was not. So let's check for that scenario + // and ignore illegal "Content-Transfer-Encoding" values if present... + + if IsHeaderMediaType(LContentType, 'multipart') and (LContentTransferEncoding <> '') then {do not localize} + begin + if PosInStrArray(LContentTransferEncoding, ['7bit', '8bit', 'binary'], False) = -1 then begin {do not localize} + LContentTransferEncoding := ''; + end; + end; + + if TextIsSame(LContentTransferEncoding, 'base64') then begin {Do not Localize} + LDecoder := TRESTDWDecoderMIMELineByLine.Create(nil); + end else if TextIsSame(LContentTransferEncoding, 'quoted-printable') then begin {Do not Localize} + LDecoder := TRESTDWDecoderQuotedPrintable.Create(nil); + end else if TextIsSame(LContentTransferEncoding, 'binhex40') then begin {Do not Localize} + LDecoder := TRESTDWDecoderBinHex4.Create(nil); + end else begin + LDecoder := nil; + end; + Try + if LDecoder <> nil then begin + LDecoder.DecodeBegin(ADestStream); + end; + + if MIMEBoundary <> '' then begin + BoundaryStart := '--' + MIMEBoundary; {Do not Localize} + BoundaryEnd := BoundaryStart + '--'; {Do not Localize} + end; + + case PosInStrArray(LContentTransferEncoding, ['7bit', 'quoted-printable', 'base64', '8bit', 'binary'], False) of {do not localize} + 0..2: IsBinaryContentTransferEncoding := False; + 3..4: IsBinaryContentTransferEncoding := True; + else + // According to RFC 2045 Section 6.4: + // "Any entity with an unrecognized Content-Transfer-Encoding must be + // treated as if it has a Content-Type of "application/octet-stream", + // regardless of what the Content-Type header field actually says." + IsBinaryContentTransferEncoding := True; + end; + Repeat + if not FProcessFirstLine then begin + if IsBinaryContentTransferEncoding then + LBytes := ReadLnRFCB(VMsgEnd, EOL, '.') {do not localize} + Else + LLine := ReadLnRFC(VMsgEnd); + end else begin + LLine := FFirstLine; + FFirstLine := ''; {Do not Localize} + FProcessFirstLine := False; + // Do not use ADELIM since always ends with . (standard) + if LLine = '.' then begin {Do not Localize} + VMsgEnd := True; + Break; + end; + if TextStartsWith(LLine, '..') then begin + Delete(LLine, 1, 1); + end; + end; + If (IsBinaryContentTransferEncoding) Then + Begin + If Length(LBytes) > 0 Then + ADestStream.WriteBuffer(LBytes[0], Length(LBytes)); + SetLength(LBytes, 0); + If (VMsgEnd) Then + Break; + End; + // New boundary - end self and create new coder + if MIMEBoundary <> '' then begin + if TextIsSame(LLine, BoundaryStart) then begin + Result := TRESTDWMessageDecoderMIME.Create(Owner); + Break; + // End of all coders (not quite ALL coders) + end; + if TextIsSame(LLine, BoundaryEnd) then begin + // POP the boundary + if Owner is TRESTDWMessage then begin + TRESTDWMessage(Owner).MIMEBoundary.Pop; + end; + Break; + end; + end; + if Not Assigned(LDecoder) then + Begin + // Data to save, but not decode + If Not IsBinaryContentTransferEncoding then + If Assigned(ADestStream) then + WriteStringToStream(ADestStream, LLine + EOL); + end + else + begin + // Data to decode + // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are + // intact + if LDecoder is TRESTDWDecoderQuotedPrintable then begin + // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are intact +// LLine := LLine + EOF; + LDecoder.Decode(LLine); + end else if LDecoder is TRESTDWDecoderBinHex4 then begin + //We cannot decode line-by-line because lines don't have a whole + //number of 4-byte blocks due to the : inserted at the start of + //the first line, so buffer the file... + LBuffer := LBuffer + LLine; + end else if LLine <> '' then begin + LDecoder.Decode(LLine); + end; + end; + Until False; + If LDecoder <> Nil Then Begin - If LIsBinaryContentTransferEncoding Then - Begin {do not localize} - If LIsThisTheFirstLine Then - LIsThisTheFirstLine := False - Else - Begin - If Assigned(ADestStream) Then - WriteStringToStream(ADestStream, LBinaryLineBreak, -1, 1); - End; - If Assigned(ADestStream) Then - WriteStringToStream(ADestStream, LLine, -1, 1); - End - Else + If LDecoder Is TRESTDWDecoderBinHex4 Then Begin - If Assigned(ADestStream) Then - WriteStringToStream(ADestStream, LLine + EOL, -1, 1); + //Now decode the complete block... + LDecoder.Decode(LBuffer); End; - End - Else - Begin - If LDecoder Is TRESTDWDecoderQuotedPrintable Then - LDecoder.Decode(LLine + EOL) - Else If LDecoder Is TRESTDWDecoderBinHex4 Then - LBuffer := LBuffer + LLine - Else If LLine <> '' Then - LDecoder.Decode(LLine); + LDecoder.DecodeEnd; End; - Until False; - If LDecoder <> Nil Then - Begin - If LDecoder Is TRESTDWDecoderBinHex4 Then - LDecoder.Decode(LBuffer); - LDecoder.DecodeEnd; - End; - Finally - FreeAndNil(LDecoder); - End; + Finally + FreeAndNil(LDecoder); + End; End; Function TRESTDWMessageDecoderMIME.GetAttachmentFilename(Const AContentType, diff --git a/CORE/Source/Basic/uRESTDWBasic.pas b/CORE/Source/Basic/uRESTDWBasic.pas index 2b299bbac..f730b7dbc 100644 --- a/CORE/Source/Basic/uRESTDWBasic.pas +++ b/CORE/Source/Basic/uRESTDWBasic.pas @@ -484,20 +484,20 @@ TRESTDWServerIpVersionConfig = class(TPersistent) Url, RawHTTPCommand : String; Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - Const RequestHeaders : TStringList; - Const ClientPort : Integer; - Const RawHeaders, - Params : TStrings; - QueryParams : String; - Const ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + RequestHeaders : TStringList; + ClientPort : Integer; + RawHeaders, + Params : TStrings; + QueryParams : String; + ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; Var StatusCode : Integer; Var ResponseHeaders : TStringList; Var ResponseString : String; @@ -696,60 +696,60 @@ TRESTDWServerIpVersionConfig = class(TPersistent) Var Pooler, MyIP : String; AccessTag : String; Var InvalidTag : Boolean);Virtual;Abstract; - Function CommandExec (Const AContext : TComponent; + Function CommandExec (Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - Const RequestHeaders : TStringList; - Const ClientPort : Integer; - Const RawHeaders, - Params : TStrings; - QueryParams : String; - Const ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean;Override; + RawHTTPCommand : String; + Var ContentType : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + RequestHeaders : TStringList; + ClientPort : Integer; + RawHeaders, + Params : TStrings; + QueryParams : String; + ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean;Override; End; TRESTDWProxyBase = Class(TRESTDWBasicReceptor) Private Protected Public - Function CommandExec (Const AContext : TComponent; + Function CommandExec (Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - Const RequestHeaders : TStringList; - Const ClientPort : Integer; - Const RawHeaders, - Params : TStrings; - QueryParams : String; - Const ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean;Override; + RawHTTPCommand : String; + Var ContentType : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + RequestHeaders : TStringList; + ClientPort : Integer; + RawHeaders, + Params : TStrings; + QueryParams : String; + ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean;Override; End; //Heranças para Servidores Standalone TRESTServicePoolerBase = Class(TRESTServiceBase) @@ -1552,30 +1552,30 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); Inherited; End; -Function TRESTDWProxyBase.CommandExec(Const AContext : TComponent; +Function TRESTDWProxyBase.CommandExec(Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; - ClientIP, - UserAgent, - AuthUsername, - AuthPassword, - Token : String; - Const RequestHeaders : TStringList; - Const ClientPort : Integer; - Const RawHeaders, - Params : TStrings; - QueryParams : String; - Const ContentStringStream : TStream; - Var AuthRealm, - sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean; + RawHTTPCommand : String; + Var ContentType : String; + ClientIP, + UserAgent, + AuthUsername, + AuthPassword, + Token : String; + RequestHeaders : TStringList; + ClientPort : Integer; + RawHeaders, + Params : TStrings; + QueryParams : String; + ContentStringStream : TStream; + Var AuthRealm, + sCharSet, + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean; Var I, vErrorCode : Integer; DataMode : TDataMode; @@ -3001,30 +3001,30 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End; End; -Function TRESTServiceBase.CommandExec(Const AContext : TComponent; +Function TRESTServiceBase.CommandExec(Const AContext : TComponent; Url, - RawHTTPCommand : String; - Var ContentType : String; + RawHTTPCommand : String; + Var ContentType : String; ClientIP, UserAgent, AuthUsername, AuthPassword, - Token : String; - Const RequestHeaders : TStringList; - Const ClientPort : Integer; - Const RawHeaders, - Params : TStrings; - QueryParams : String; - Const ContentStringStream : TStream; + Token : String; + RequestHeaders : TStringList; + ClientPort : Integer; + RawHeaders, + Params : TStrings; + QueryParams : String; + ContentStringStream : TStream; Var AuthRealm, sCharSet, - ErrorMessage : String; - Var StatusCode : Integer; - Var ResponseHeaders : TStringList; - Var ResponseString : String; - Var ResultStream : TStream; - Var CORSCustomHeaders : TStrings; - Redirect : TRedirect) : Boolean; + ErrorMessage : String; + Var StatusCode : Integer; + Var ResponseHeaders : TStringList; + Var ResponseString : String; + Var ResultStream : TStream; + Var CORSCustomHeaders : TStrings; + Redirect : TRedirect) : Boolean; Var I, vErrorCode : Integer; DataMode : TDataMode; @@ -3088,7 +3088,6 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); PCustomHeaders : ^TStrings; vTempContext : TRESTDWContext; vTempEvent : TRESTDWEvent; - vRESTDWBytes : TRESTDWBytes; Function ExcludeTag(Value : String) : String; Begin Result := Value; @@ -3138,10 +3137,8 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End; procedure ReadRawHeaders; var - I, A : Integer; + I: Integer; JSONParam : TRESTDWJSONParam; - aName, - aValue : String; begin If Not Assigned(RawHeaders) Then Exit; @@ -3152,36 +3149,25 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vRequestHeader.Add(RawHeaders.Text); For I := 0 To RawHeaders.Count -1 Do Begin - tmp := RawHeaders[I]; - A := Pos(':', tmp); - If A > 0 Then - Begin - aName := Copy(tmp, 1, Pos(':', tmp) -1); - Delete(tmp, 1, Pos(':', tmp)); - vTempText := Trim(tmp); - End - Else - Begin - aName := Copy(tmp, 1, Length(tmp)); - vTempText := ''; - End; + tmp := RawHeaders.Names[I]; + vTempText := RawHeaders.Values[tmp]; If (vTempText <> '') And (vTempText[InitStrPos] = ' ') then Delete(vTempText,1,1); - If pos('dwwelcomemessage', lowercase(aName)) > 0 Then + If pos('dwwelcomemessage', lowercase(tmp)) > 0 Then vWelcomeMessage := DecodeStrings(vTempText{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}) - Else If pos('dwaccesstag', lowercase(aName)) > 0 Then + Else If pos('dwaccesstag', lowercase(tmp)) > 0 Then vAccessTag := DecodeStrings(vTempText{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}) - Else If pos('datacompression', lowercase(aName)) > 0 Then + Else If pos('datacompression', lowercase(tmp)) > 0 Then compresseddata := StringToBoolean(vTempText) - Else If pos('dwencodestrings', lowercase(aName)) > 0 Then + Else If pos('dwencodestrings', lowercase(tmp)) > 0 Then encodestrings := StringToBoolean(vTempText) - Else If pos('dwusecript', lowercase(aName)) > 0 Then + Else If pos('dwusecript', lowercase(tmp)) > 0 Then vdwCriptKey := StringToBoolean(vTempText) - Else If (pos('dwassyncexec', lowercase(aName)) > 0) And (Not (dwassyncexec)) Then + Else If (pos('dwassyncexec', lowercase(tmp)) > 0) And (Not (dwassyncexec)) Then dwassyncexec := StringToBoolean(vTempText) - Else if pos('binaryrequest', lowercase(aName)) > 0 Then + Else if pos('binaryrequest', lowercase(tmp)) > 0 Then vBinaryEvent := StringToBoolean(vTempText) - Else If pos('dwconnectiondefs', lowercase(aName)) > 0 Then + Else If pos('dwconnectiondefs', lowercase(tmp)) > 0 Then Begin vdwConnectionDefs := TConnectionDefs.Create; JSONValue := TRESTDWJSONValue.Create; @@ -3194,7 +3180,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); FreeAndNil(JSONValue); End; End - Else If pos('dwservereventname', lowercase(aName)) > 0 Then + Else If pos('dwservereventname', lowercase(tmp)) > 0 Then Begin JSONValue := TRESTDWJSONValue.Create; Try @@ -3216,14 +3202,14 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); QueryParams, vmark, vEncoding{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}, DWParams, RequestType); Try - If Trim(lowercase(aName)) <> '' Then + If Trim(lowercase(tmp)) <> '' Then Begin - JSONParam := DWParams.ItemsString[lowercase(aName)]; + JSONParam := DWParams.ItemsString[lowercase(tmp)]; If JSONParam = Nil Then Begin JSONParam := TRESTDWJSONParam.Create(DWParams.Encoding); JSONParam.ObjectDirection := odIN; - JSONParam.ParamName := lowercase(aName); + JSONParam.ParamName := lowercase(tmp); {$IFDEF RESTDWLAZARUS} JSONParam.DatabaseCharSet := vDatabaseCharSet; {$ENDIF} @@ -3518,7 +3504,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); Exit; End; Cmd := RemoveBackslashCommands(Trim(RawHTTPCommand)); -// vRequestHeader.Add(Cmd); + vRequestHeader.Add(Cmd); Cmd := StringReplace(Cmd, ' HTTP/1.0', '', [rfReplaceAll]); Cmd := StringReplace(Cmd, ' HTTP/1.1', '', [rfReplaceAll]); Cmd := StringReplace(Cmd, ' HTTP/2.0', '', [rfReplaceAll]); @@ -3594,32 +3580,30 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); If (RequestType In [rtGet, rtDelete]) Then Begin aurlContext := vUrlToExec; - vOldMethod := vUrlToExec; If Not Assigned(DWParams) Then + TRESTDWDataUtils.ParseRESTURL (Url, vEncoding, vmark{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}, DWParams); + vOldMethod := vUrlToExec; + If DWParams <> Nil Then Begin - TRESTDWDataUtils.ParseRESTURL (Url, vEncoding, vmark{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}, DWParams); - If DWParams <> Nil Then + If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then + vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then + vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + If (DWParams.ItemsString['datacompression'] <> Nil) Then + compresseddata := StringToBoolean(DWParams.ItemsString['datacompression'].AsString); + If (DWParams.ItemsString['dwencodestrings'] <> Nil) Then + encodestrings := StringToBoolean(DWParams.ItemsString['dwencodestrings'].AsString); + If (DWParams.ItemsString['dwservereventname'] <> Nil) Then Begin - If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then - vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then - vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - If (DWParams.ItemsString['datacompression'] <> Nil) Then - compresseddata := StringToBoolean(DWParams.ItemsString['datacompression'].AsString); - If (DWParams.ItemsString['dwencodestrings'] <> Nil) Then - encodestrings := StringToBoolean(DWParams.ItemsString['dwencodestrings'].AsString); - If (DWParams.ItemsString['dwservereventname'] <> Nil) Then - Begin - If vdwservereventname <> GetEventName(Lowercase(DWParams.ItemsString['dwservereventname'].AsString)) Then - vdwservereventname := DecodeStrings(DWParams.ItemsString['dwservereventname'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - End; - If (DWParams.ItemsString['dwusecript'] <> Nil) Then - vdwCriptKey := StringToBoolean(DWParams.ItemsString['dwusecript'].AsString); - If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then - dwassyncexec := StringToBoolean(DWParams.ItemsString['dwassyncexec'].AsString); - If (DWParams.ItemsString['BinaryCompatibleMode'] <> Nil) Then - vBinaryCompatibleMode := DWParams.ItemsString['BinaryCompatibleMode'].Value; + If vdwservereventname <> GetEventName(Lowercase(DWParams.ItemsString['dwservereventname'].AsString)) Then + vdwservereventname := DecodeStrings(DWParams.ItemsString['dwservereventname'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); End; + If (DWParams.ItemsString['dwusecript'] <> Nil) Then + vdwCriptKey := StringToBoolean(DWParams.ItemsString['dwusecript'].AsString); + If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then + dwassyncexec := StringToBoolean(DWParams.ItemsString['dwassyncexec'].AsString); + If (DWParams.ItemsString['BinaryCompatibleMode'] <> Nil) Then + vBinaryCompatibleMode := DWParams.ItemsString['BinaryCompatibleMode'].Value; End; If (vUrlToExec = '') And (aurlContext <> '') Then vUrlToExec := aurlContext; @@ -3696,16 +3680,56 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vServerMethod := aServerMethod; If Assigned(vServerMethod) Then Begin -// If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then -// vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); -// If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then -// vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); - vTempServerMethods := vServerMethod.Create(Nil); - If Not vCORS Then - FreeAndNil(CORSCustomHeaders); - {$IFNDEF RESTDWLAZARUS} - {$IFNDEF FPC} - If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or + If DWParams.ItemsString['dwwelcomemessage'] <> Nil Then + vWelcomeMessage := DecodeStrings(DWParams.ItemsString['dwwelcomemessage'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + If (DWParams.ItemsString['dwaccesstag'] <> Nil) Then + vAccessTag := DecodeStrings(DWParams.ItemsString['dwaccesstag'].AsString{$IFDEF RESTDWLAZARUS}, vDatabaseCharSet{$ENDIF}); + Try // identificando o evento a ser chamado no datamodule + vTempServerMethods := vServerMethod.Create(Nil); + If Not vCORS Then + FreeAndNil(CORSCustomHeaders); + {$IFNDEF RESTDWLAZARUS} + {$IFNDEF FPC} + If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End + Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End; + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then + Begin + If ((vCORS) And (RequestType = rtOption)) Then + vErrorCode := 200; + End; + End; + {$ENDIF} + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or (vTempServerMethods Is TServerMethodDatamodule) Then Begin If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then @@ -3714,7 +3738,7 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vErrorCode := 200; End; End - Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or (vTempServerMethods Is TServerBaseMethodClass) Then Begin If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then @@ -3723,47 +3747,10 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); vErrorCode := 200; End; End; - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End; - {$ENDIF} - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).GetAction(vOldRequest, DWParams, CORSCustomHeaders) Then - Begin - If ((vCORS) And (RequestType = rtOption)) Then - vErrorCode := 200; - End; - End; - {$ENDIF} - vUrlToExec := vOldRequest; + {$ENDIF} + vUrlToExec := vOldRequest; + Finally + End; If (Assigned(vTempServerMethods)) Then Begin {$IFNDEF RESTDWLAZARUS} @@ -3954,29 +3941,32 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); {$ENDIF} If vNeedAuthorization Then Begin - vAuthenticator.AuthValidate(vTempServerMethods, - vUrlToExec, - vWelcomeMessage, - vAccessTag, - AuthUsername, - AuthPassword, - RawHeaders, - RequestType, - DWParams, - vGettoken, - vTokenValidate, - vToken, - vErrorCode, vErrorMessage, vAcceptAuth); - If Not vAcceptAuth and not ((vCORS) And (RequestType = rtOption)) Then //Roniery - Begin - If vAuthenticator is TRESTDWAuthBasic Then - AuthRealm := cAuthRealm; - StatusCode := vErrorCode; - ErrorMessage := vErrorMessage; - WriteError; - DestroyComponents; - Exit; - End; + // Aqui que Valida a Autenticação + vAuthenticator.AuthValidate(vTempServerMethods, + vUrlToExec, + vWelcomeMessage, + vAccessTag, + AuthUsername, + AuthPassword, + RawHeaders, + RequestType, + DWParams, + vGettoken, + vTokenValidate, + vToken, + vErrorCode, vErrorMessage, vAcceptAuth); + If Not vAcceptAuth and not ((vCORS) And (RequestType = rtOption)) Then //Roniery + Begin + //Eloy + if vAuthenticator is TRESTDWAuthBasic then + AuthRealm := cAuthRealm; + StatusCode := vErrorCode; + ErrorMessage := vErrorMessage; + // + WriteError; + DestroyComponents; + Exit; + End; End; vErrorCode := 200; vErrorMessage := ''; @@ -3988,60 +3978,48 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End Else Begin - Try - {$IFNDEF RESTDWLAZARUS} - {$IFNDEF FPC} - If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then - TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End - Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then - TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End; - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then - TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then - TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); - End; - {$ENDIF} - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + {$IFNDEF RESTDWLAZARUS} + {$IFNDEF FPC} + If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or (vTempServerMethods Is TServerMethodDatamodule) Then Begin If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or (vTempServerMethods Is TServerBaseMethodClass) Then Begin If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); End; - {$ENDIF} - Except - On E : Exception do + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then + TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then + TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End; + {$ENDIF} + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then Begin - If Assigned(ResultStream) Then - FreeAndNil(ResultStream); - StatusCode := 500; - ResultStream := TStringStream.Create('OnWelcomeMessage raise error: ' + E.Message); - Result := False; - Exit; + If Assigned(TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage) then + TServerMethodDatamodule(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If Assigned(TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage) then + TServerBaseMethodClass(vTempServerMethods).OnWelcomeMessage(vWelcomeMessage, vAccessTag, vdwConnectionDefs, WelcomeAccept, vContentType, vErrorMessage); End; - End; + {$ENDIF} End; End; End @@ -4056,8 +4034,12 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); Try If Assigned(vLastRequest) Then Begin - If Assigned(vLastRequest) Then - vLastRequest(UserAgent + sLineBreak + RawHTTPCommand); + Try + If Assigned(vLastRequest) Then + vLastRequest(UserAgent + sLineBreak + + RawHTTPCommand); + Finally + End; End; If (vUrlToExec = '') And (Cmd <> '/') Then vUrlToExec := vOldMethod; @@ -4081,34 +4063,33 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); sCharSet := 'utf-8' Else sCharSet := 'ansi'; -// If DWParams <> Nil Then -// Begin -// If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then -// dwassyncexec := DWParams.ItemsString['dwassyncexec'].AsBoolean; -// If DWParams.ItemsString['dwusecript'] <> Nil Then -// vdwCriptKey := DWParams.ItemsString['dwusecript'].AsBoolean; -// End; + If DWParams <> Nil Then + Begin + If (DWParams.ItemsString['dwassyncexec'] <> Nil) And (Not (dwassyncexec)) Then + dwassyncexec := DWParams.ItemsString['dwassyncexec'].AsBoolean; + If DWParams.ItemsString['dwusecript'] <> Nil Then + vdwCriptKey := DWParams.ItemsString['dwusecript'].AsBoolean; + End; If dwassyncexec Then Begin - StatusCode := 200; - vReplyString := AssyncCommandMSG; + StatusCode := 200; + vReplyString := AssyncCommandMSG; If compresseddata Then mb := TStringStream(ZCompressStreamNew(vReplyString)) Else mb := TStringStream.Create(vReplyString{$IFDEF DELPHIXEUP}, TEncoding.UTF8{$ENDIF}); - mb.Position := 0; + mb.Position := 0; If Not (Assigned(ResultStream)) Then ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); FreeAndNil(mb); End; - //Remoção de Códigos duplicados XyberX -// If DWParams.itemsstring['binaryRequest'] <> Nil Then -// vBinaryEvent := DWParams.itemsstring['binaryRequest'].Value; -// If DWParams.itemsstring['BinaryCompatibleMode'] <> Nil Then -// vBinaryCompatibleMode := DWParams.itemsstring['BinaryCompatibleMode'].Value; -// If DWParams.itemsstring['MetadataRequest'] <> Nil Then -// vMetadata := DWParams.itemsstring['MetadataRequest'].value; + If DWParams.itemsstring['binaryRequest'] <> Nil Then + vBinaryEvent := DWParams.itemsstring['binaryRequest'].Value; + If DWParams.itemsstring['BinaryCompatibleMode'] <> Nil Then + vBinaryCompatibleMode := DWParams.itemsstring['BinaryCompatibleMode'].Value; + If DWParams.itemsstring['MetadataRequest'] <> Nil Then + vMetadata := DWParams.itemsstring['MetadataRequest'].value; If (Assigned(DWParams)) And (Assigned(vCripto)) Then DWParams.SetCriptOptions(vdwCriptKey, vCripto.Key); If Assigned(vTempServerMethods) Then @@ -4171,6 +4152,8 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); If Not vFileExists Then Begin tmp := ''; +// If Referer <> '' Then +// tmp := GetLastMethod(Referer); If Url <> '' Then sFile := GetFileOSDir(ExcludeTag(tmp + Url)) Else @@ -4206,296 +4189,315 @@ procedure TRESTClientPoolerBase.SetIpVersion(IpV: TRESTDWClientIpVersions); End; End; End; - If Assigned(vRequestHeader) Then - Begin - vRequestHeader.Clear; - FreeAndNil(vRequestHeader); - End; - If Assigned(vServerMethod) Then - If Assigned(vTempServerMethods) Then - Begin - {$IFNDEF RESTDWLAZARUS} - {$IFNDEF FPC} - If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then - Begin - If Assigned(vCriticalSection) Then - Begin - vCriticalSection.Release; - FreeAndNil(vCriticalSection); - End; - End; - End - Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then - Begin - If Assigned(vCriticalSection) Then - Begin - vCriticalSection.Release; - FreeAndNil(vCriticalSection); - End; - End; - End; - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End; - {$ENDIF} - {$ELSE} - If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or - (vTempServerMethods Is TServerMethodDatamodule) Then - Begin - If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End - Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or - (vTempServerMethods Is TServerBaseMethodClass) Then - Begin - If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then - Begin - LeaveCriticalSection(vCriticalSection); - DoneCriticalSection(vCriticalSection); - End; - End; - {$ENDIF} - Try - vTempServerMethods.free; - vTempServerMethods := Nil; - Except + Try + If Assigned(vRequestHeader) Then + Begin + vRequestHeader.Clear; + FreeAndNil(vRequestHeader); End; - End; - If Not dwassyncexec Then - Begin - If (Not (vTagReply)) Then + If Assigned(vServerMethod) Then + If Assigned(vTempServerMethods) Then Begin - If vEncoding = esUtf8 Then - sCharSet := 'utf-8' - Else - sCharSet := 'ansi'; - If vContentType <> '' Then - ContentType := vContentType; - If Not vServerContextCall Then - Begin - If (vUrlToExec <> '') Then + {$IFNDEF RESTDWLAZARUS} + {$IFNDEF FPC} + If (vTempServerMethods.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then Begin - If DataMode in [dmDataware] Then + If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then Begin - If Trim(JSONStr) <> '' Then - Begin - If Not(((Pos('{', JSONStr) > 0) And - (Pos('}', JSONStr) > 0)) Or - ((Pos('[', JSONStr) > 0) And - (Pos(']', JSONStr) > 0))) Then - Begin - If Not (WelcomeAccept) And - (vErrorMessage <> '') Then - JSONStr := escape_chars(vErrorMessage) - Else If Not((JSONStr[InitStrPos] = '"') And - (JSONStr[Length(JSONStr)] = '"')) Then - JSONStr := '"' + JSONStr + '"'; - End; - End; - If (RequestType <> rtOption) Then + If Assigned(vCriticalSection) Then Begin - If vBinaryEvent Then - vReplyString := JSONStr - Else - Begin - If Not(((vUrlToExec = '') Or (vUrlToExec = '/')) And (RequestType = rtGet)) Then - Begin - If Not (WelcomeAccept) And (vErrorMessage <> '') Then - Begin - If vEncode_Errors then - vReplyString := escape_chars(vErrorMessage) - Else - vReplyString := vErrorMessage; - End - Else - vReplyString := Format(TValueDisp, [GetParamsReturn(DWParams), JSONStr]); - End; - End; + vCriticalSection.Release; + FreeAndNil(vCriticalSection); End; - End - Else If DataMode = dmRAW Then - Begin - If (Trim(JSONStr) = '') And (WelcomeAccept) Then - vReplyString := '{}' - Else If Not (WelcomeAccept) And (vErrorMessage <> '') Then - vReplyString := escape_chars(vErrorMessage) - Else - vReplyString := JSONStr; - End; - End; - If Assigned(DWParams) Then - Begin - If DWParams.RequestHeaders.Output.Count > 0 Then - Begin - For I := 0 To DWParams.RequestHeaders.Output.Count -1 Do - RequestHeaders.Add(DWParams.RequestHeaders.Output[I]); End; - End; - StatusCode := vErrorCode; - If Assigned(DWParams) And - (Pos(DWParams.Url_Redirect, Cmd) = 0) And - (DWParams.Url_Redirect <> '') Then - Begin - vUrlRedirect := DWParams.Url_Redirect; - If Assigned(Redirect) Then - Redirect(vUrlRedirect, AContext); - End; - If compresseddata Then + End + Else If (vTempServerMethods.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then Begin - If vBinaryEvent Then + If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then Begin - ms := TMemoryStream.Create; - If vGettoken Then + If Assigned(vCriticalSection) Then Begin - DWParams.Clear; - DWParams.CreateParam('token', vReplyString); + vCriticalSection.Release; + FreeAndNil(vCriticalSection); End; - Try - If DWParams.ItemsString['MessageError'] = Nil Then + End; + End; + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then + Begin + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then + Begin + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End; + {$ENDIF} + {$ELSE} + If (vTempServerMethods.ClassType.InheritsFrom(TServerMethodDatamodule)) Or + (vTempServerMethods Is TServerMethodDatamodule) Then + Begin + If TServerMethodDatamodule(vTempServerMethods).QueuedRequest Then + Begin + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End + Else If (vTempServerMethods.ClassType.InheritsFrom(TServerBaseMethodClass)) Or + (vTempServerMethods Is TServerBaseMethodClass) Then + Begin + If TServerBaseMethodClass(vTempServerMethods).QueuedRequest Then + Begin + LeaveCriticalSection(vCriticalSection); + DoneCriticalSection(vCriticalSection); + End; + End; + {$ENDIF} + Try + vTempServerMethods.free; + vTempServerMethods := Nil; + Except + End; + End; + If Not dwassyncexec Then + Begin + If (Not (vTagReply)) Then + Begin + If vEncoding = esUtf8 Then + sCharSet := 'utf-8' + Else + sCharSet := 'ansi'; + If vContentType <> '' Then + ContentType := vContentType; + If Not vServerContextCall Then + Begin + If (vUrlToExec <> '') Then + Begin + If DataMode in [dmDataware] Then + Begin + If Trim(JSONStr) <> '' Then Begin - DWParams.CreateParam('MessageError'); - DWParams.ItemsString['MessageError'].ObjectDirection := odOut; + If Not(((Pos('{', JSONStr) > 0) And + (Pos('}', JSONStr) > 0)) Or + ((Pos('[', JSONStr) > 0) And + (Pos(']', JSONStr) > 0))) Then + Begin + If Not (WelcomeAccept) And (vErrorMessage <> '') Then + JSONStr := escape_chars(vErrorMessage) + Else If Not((JSONStr[InitStrPos] = '"') And + (JSONStr[Length(JSONStr)] = '"')) Then + JSONStr := '"' + JSONStr + '"'; + End; End; - If ((JSONStr <> TReplyOK) and (JSONStr <> Trim(''))) then +// vErrorCode := 200; + If (RequestType <> rtOption) Then Begin - If DWParams.ItemsString['MessageError'].AsString = '' Then - DWParams.ItemsString['MessageError'].AsString := JSONStr; - End + If vBinaryEvent Then + vReplyString := JSONStr + Else + Begin + If Not(((vUrlToExec = '') Or (vUrlToExec = '/')) And (RequestType = rtGet)) Then + Begin + If Not (WelcomeAccept) And (vErrorMessage <> '') Then + Begin + If vEncode_Errors then + vReplyString := escape_chars(vErrorMessage) + Else + vReplyString := vErrorMessage; + End + Else + vReplyString := Format(TValueDisp, [GetParamsReturn(DWParams), JSONStr]); + End; + End; + End; + End + Else If DataMode = dmRAW Then + Begin + If (Trim(JSONStr) = '') And (WelcomeAccept) Then + vReplyString := '{}' + Else If Not (WelcomeAccept) And (vErrorMessage <> '') Then + vReplyString := escape_chars(vErrorMessage) Else - DWParams.ItemsString['MessageError'].AsString := ''; - DWParams.SaveToStream(TStream(ms), tdwpxt_OUT); - ZCompressStreamD(ms, ResultStream); - Finally - FreeAndNil(ms); + vReplyString := JSONStr; End; - End - Else - Begin - If Assigned(ResultStream) Then - FreeAndNil(ResultStream); - ResultStream := TStringStream(ZCompressStreamNew(vReplyString)); - End; - If not (vErrorCode in [200,201]) Then - ResponseString := escape_chars(vReplyString) - End - Else - Begin - {$IFNDEF FPC} - {$IFDEF DELPHIXEUP} - If vBinaryEvent Then - Begin - ResultStream := TMemoryStream.Create; - DWParams.SaveToStream(ResultStream, tdwpxt_OUT); -// WriteStream(mb, ResultStream); - End - Else - Begin -// If Not (vErrorCode in [200, 201]) Then - ResultStream := TStringStream.Create(Utf8Encode(vReplyString)); -// Else -// ResultStream := TStringStream.Create(vReplyString); - End; - ResultStream.Position := 0; - {$ELSE} - If vBinaryEvent Then - Begin - ResultStream := TMemoryStream.Create; - DWParams.SaveToStream(ResultStream, tdwpxt_OUT); - End - Else - ResponseString := vReplyString; - {$ENDIF} - {$ELSE} + End; + If Assigned(DWParams) Then + Begin + If DWParams.RequestHeaders.Output.Count > 0 Then + Begin + For I := 0 To DWParams.RequestHeaders.Output.Count -1 Do + RequestHeaders.Add(DWParams.RequestHeaders.Output[I]); + End; + End; + StatusCode := vErrorCode; + If Assigned(DWParams) And + (Pos(DWParams.Url_Redirect, Cmd) = 0) And + (DWParams.Url_Redirect <> '') Then + Begin + vUrlRedirect := DWParams.Url_Redirect; + If Assigned(Redirect) Then + Redirect(vUrlRedirect, AContext); + End; + If compresseddata Then + Begin If vBinaryEvent Then Begin - ResultStream := TMemoryStream.Create; - DWParams.SaveToStream(ResultStream, tdwpxt_OUT); + ms := TMemoryStream.Create; + If vGettoken Then + Begin + DWParams.Clear; + DWParams.CreateParam('token', vReplyString); + End; + Try + If DWParams.ItemsString['MessageError'] = Nil Then + Begin + DWParams.CreateParam('MessageError'); + DWParams.ItemsString['MessageError'].ObjectDirection := odOut; + End; + If ((JSONStr <> TReplyOK) and (JSONStr <> Trim(''))) then + Begin + If DWParams.ItemsString['MessageError'].AsString = '' Then + DWParams.ItemsString['MessageError'].AsString := JSONStr; + End + Else + DWParams.ItemsString['MessageError'].AsString := ''; + DWParams.SaveToStream(TStream(ms), tdwpxt_OUT); + ZCompressStreamD(ms, ResultStream); + Finally + FreeAndNil(ms); + End; End Else Begin - If vEncoding = esUtf8 Then - mb := TStringStream.Create(Utf8Encode(vReplyString)) + If Assigned(ResultStream) Then + FreeAndNil(ResultStream); + ResultStream := TStringStream(ZCompressStreamNew(vReplyString)); + End; + If not (vErrorCode in [200,201]) Then + ResponseString := escape_chars(vReplyString) + End + Else + Begin + {$IFNDEF FPC} + {$IFDEF DELPHIXEUP} + If vBinaryEvent Then + Begin + mb := TStringStream.Create(''); + Try + DWParams.SaveToStream(mb, tdwpxt_OUT); + Finally + End; + End Else - mb := TStringStream.Create(vReplyString); - mb.Position := 0; + mb := TStringStream.Create(vReplyString{$IFDEF DELPHIXEUP}, TEncoding.UTF8{$ENDIF}); + mb.Position := 0; If Not (Assigned(ResultStream)) Then ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); FreeAndNil(mb); - End; - {$ENDIF} - End; - End - Else - Begin - LocalDoc := ''; - If TEncodeSelect(vEncoding) = esUtf8 Then - sCharset := 'utf-8' - Else If TEncodeSelect(vEncoding) in [esANSI, esASCII] Then - sCharset := 'ansi'; - If Not vSpecialServer Then - Begin - StatusCode := vErrorCode; - If ServerContextStream <> Nil Then - Begin - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); - WriteStream(ServerContextStream, ResultStream); - FreeAndNil(ServerContextStream); - End - Else - Begin - {$IFDEF FPC} - If vEncoding = esUtf8 Then - mb := TStringStream.Create(Utf8Encode(JSONStr)) - Else - mb := TStringStream.Create(JSONStr); - mb.Position := 0; - If Not (Assigned(ResultStream)) Then - ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); - FreeAndNil(mb); {$ELSE} - {$IF CompilerVersion > 21} - mb := TStringStream.Create(JSONStr{$IFNDEF FPC}{$IF CompilerVersion > 21}, TEncoding.UTF8{$IFEND}{$ENDIF}); - mb.Position := 0; + If vBinaryEvent Then + Begin + mb := TStringStream.Create(''); + Try + DWParams.SaveToStream(mb, tdwpxt_OUT); + Finally + End; + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); + WriteStream(mb, ResultStream); + FreeAndNil(mb); + End + Else + ResponseString := vReplyString; + {$ENDIF} + {$ELSE} + If vBinaryEvent Then + Begin + mb := TStringStream.Create(''); + Try + DWParams.SaveToStream(mb, tdwpxt_OUT); + Finally + End; + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); + WriteStream(mb, ResultStream); + FreeAndNil(mb); + End + Else + Begin + If vEncoding = esUtf8 Then + mb := TStringStream.Create(Utf8Encode(vReplyString)) + Else + mb := TStringStream.Create(vReplyString); + mb.Position := 0; If Not (Assigned(ResultStream)) Then ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); FreeAndNil(mb); + End; + {$ENDIF} + End; + End + Else + Begin + LocalDoc := ''; + If TEncodeSelect(vEncoding) = esUtf8 Then + sCharset := 'utf-8' + Else If TEncodeSelect(vEncoding) in [esANSI, esASCII] Then + sCharset := 'ansi'; + If Not vSpecialServer Then + Begin + StatusCode := vErrorCode; + If ServerContextStream <> Nil Then + Begin + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); + WriteStream(ServerContextStream, ResultStream); + FreeAndNil(ServerContextStream); + End + Else + Begin + {$IFDEF FPC} + If vEncoding = esUtf8 Then + mb := TStringStream.Create(Utf8Encode(JSONStr)) + Else + mb := TStringStream.Create(JSONStr); + mb.Position := 0; + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); WriteStream(mb, ResultStream); + FreeAndNil(mb); {$ELSE} - ResponseString := JSONStr; + {$IF CompilerVersion > 21} + mb := TStringStream.Create(JSONStr{$IFNDEF FPC}{$IF CompilerVersion > 21}, TEncoding.UTF8{$IFEND}{$ENDIF}); + mb.Position := 0; + If Not (Assigned(ResultStream)) Then + ResultStream := TStringStream.Create(''); + WriteStream(mb, ResultStream); + FreeAndNil(mb); + {$ELSE} + ResponseString := JSONStr; {$IFEND} - {$ENDIF} - End; - End; - End; - End; - End; + {$ENDIF} + End; + End; + End; + End; + End; + Finally +// FreeAndNil(mb); + End; If Assigned(vLastResponse) Then Begin Try @@ -4866,6 +4868,7 @@ procedure TRESTDWBasicReceptor.SetAuthenticator( Begin // lazarus iniciando com sujeira de memoria vStrings vStrings := nil; + If ServerMethodsClass <> Nil Then Begin For I := 0 To ServerMethodsClass.ComponentCount -1 Do @@ -5319,7 +5322,7 @@ procedure TRESTDWBasicReceptor.SetAuthenticator( JSONParam.ObjectDirection := odOut; Params.Add(JSONParam); End; -// Params.ItemsString['MessageError'].AsString :=''; + Params.ItemsString['MessageError'].AsString :=''; If ReturnEvent(BaseObject, vUrlMethod, vBaseUrl, vResult, Params, DataMode, ErrorCode, ContentType, Accesstag, RequestType, RequestHeader) Then Begin JSONStr := vResult; diff --git a/CORE/Source/Basic/uRESTDWParams.pas b/CORE/Source/Basic/uRESTDWParams.pas index f18c93a3d..a181d84cf 100644 --- a/CORE/Source/Basic/uRESTDWParams.pas +++ b/CORE/Source/Basic/uRESTDWParams.pas @@ -6245,7 +6245,7 @@ procedure TRESTDWJSONParam.SetParamContentType(const bValue: String); Else S := TNullString; J := Length(S); - Stream.Write(J, Sizeof(DWInt64)); + Stream.Write(J, Sizeof(DWInteger)); Stream.Write(S[InitStrPos], J); End; ovWord : Begin @@ -6538,7 +6538,7 @@ procedure TRESTDWJSONParam.SetParamContentType(const bValue: String); ovFMTBcd, ovFloat, ovExtended : Begin - Stream.Read(J, Sizeof(DWInt64)); + Stream.Read(J, Sizeof(DWInteger)); SetLength(S, J); If J <> 0 Then Begin diff --git a/CORE/Source/Basic/uRESTDWStorageBin.pas b/CORE/Source/Basic/uRESTDWStorageBin.pas index d587fb608..2ae57c90b 100644 --- a/CORE/Source/Basic/uRESTDWStorageBin.pas +++ b/CORE/Source/Basic/uRESTDWStorageBin.pas @@ -220,40 +220,24 @@ interface Index : Integer); Var vFDef : TFieldDef; - Function FindDef(aName : String) : Boolean; - Var - I : Integer; - Begin - Result := False; - For I := 0 To DataSet.FieldDefs.Count -1 Do - Begin - Result := Lowercase(DataSet.FieldDefs[I].Name) = Lowercase(aName); - If Result Then - Break; - End; - End; Begin If Trim(FFieldNames[Index]) <> '' Then Begin - If (Not (Assigned(DataSet.FindField(FFieldNames[Index]))) And - Not(FindDef(FFieldNames[Index]))) Then - Begin - VFDef := DataSet.FieldDefs.AddFieldDef; - VFDef.Name := FFieldNames[Index]; - VFDef.DataType := DWFieldTypeToFieldType(FFieldTypes[Index]); - VFDef.Size := FFieldSize[Index]; - VFDef.Required := FFieldAttrs[Index] and 1 > 0; - Case FFieldTypes[Index] of - dwftFloat, - dwftCurrency, - dwftSingle : VFDef.Precision := FFieldPrecision[Index]; - dwftBCD, - dwftFMTBcd : Begin - VFDef.Size := 0; - VFDef.Precision := 0; - End; - End; - End; + VFDef := DataSet.FieldDefs.AddFieldDef; + VFDef.Name := FFieldNames[Index]; + VFDef.DataType := DWFieldTypeToFieldType(FFieldTypes[Index]); + VFDef.Size := FFieldSize[Index]; + VFDef.Required := FFieldAttrs[Index] and 1 > 0; + Case FFieldTypes[Index] of + dwftFloat, + dwftCurrency, + dwftSingle : VFDef.Precision := FFieldPrecision[Index]; + dwftBCD, + dwftFMTBcd : Begin + VFDef.Size := 0; + VFDef.Precision := 0; + End; + End; End; End; Var diff --git a/CORE/Source/Consts/uRESTDWConsts.pas b/CORE/Source/Consts/uRESTDWConsts.pas index f61e98a94..3075334b5 100644 --- a/CORE/Source/Consts/uRESTDWConsts.pas +++ b/CORE/Source/Consts/uRESTDWConsts.pas @@ -1,4 +1,4 @@ -Unit uRESTDWConsts; +Unit uRESTDWConsts; {$I ..\..\Source\Includes\uRESTDW.inc} @@ -62,7 +62,7 @@ // controle de versão RESTDWVersionINFO = 'v2.1.0-'; - RESTDWRelease = '3850'; + RESTDWRelease = '792'; RESTDWCodeProject = 'Galaga - SourceForge'; RESTDWVersao = RESTDWVersionINFO + RESTDWRelease + '(' + RESTDWCodeProject + ')'; RESTDWDialogoTitulo = 'REST DataWare Components ' + RESTDWVersao; diff --git a/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas b/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas index 4994e9b50..3c38c34f8 100644 --- a/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas +++ b/CORE/Source/Plugins/Memdataset/uRESTDWMemoryDataset.pas @@ -427,10 +427,8 @@ TDoubleLinkedBufIndex = class(TRESTDWIndex) TRESTDWMemTable = Class(TDataset, IRESTDWMemTable) Private FSaveLoadState : TSaveLoadState; - aFilterRecs, FMaxIndexesCount, FPacketRecords, - FRecordFilterPos, FRecordPos, FRecordSize, FBookmarkOfs, @@ -1170,8 +1168,6 @@ constructor TRESTDWMemTable.Create(AOwner: TComponent); Begin Inherited Create(AOwner); FRecordPos := -1; - FRecordFilterPos := -1; - aFilterRecs := FRecordFilterPos; FLastID := Low(Integer); FAutoInc := 1; FRecords := TRecordList.Create; @@ -1534,9 +1530,7 @@ destructor TRESTDWMemTable.Destroy; FClearing := False; End; FLastID := Low(Integer); - FRecordPos := -1; - FRecordFilterPos := FRecordPos; - aFilterRecs := FRecordFilterPos; + FRecordPos := -1; End; Function TRESTDWMemTable.AllocRecordBuffer: TRecordBuffer; @@ -1716,7 +1710,7 @@ destructor TRESTDWMemTable.Destroy; End; End; -Function TRESTDWMemTable.GetRecord(Buffer: {$IFDEF NEXTGEN}TRecBuf{$ELSE}TRecordBuffer{$ENDIF}; +Function TRESTDWMemTable.GetRecord(Buffer: {$IFDEF NEXTGEN}TRecBuf{$ELSE}TRecordBuffer{$ENDIF}; GetMode: TGetMode; DoCheck: Boolean): TGetResult; var @@ -1729,29 +1723,20 @@ destructor TRESTDWMemTable.Destroy; If FRecordPos <= 0 then Begin Result := grBOF; - FRecordPos := -1; - FRecordFilterPos := FRecordPos; + FRecordPos := -1; End Else Begin -// aFilterRecs := RecordCount; Repeat Dec(FRecordPos); If Filtered then - Begin - Accept := RecordFilter; - If Accept Then - Dec(aFilterRecs); - End - Else - FRecordFilterPos := FRecordPos; + Accept := RecordFilter; Until Accept Or (FRecordPos < 0); If Not Accept Then Begin Result := grBOF; FRecordPos := -1; End; - FRecordFilterPos := aFilterRecs; End; End; gmCurrent : Begin @@ -1771,18 +1756,13 @@ destructor TRESTDWMemTable.Destroy; Repeat Inc(FRecordPos); If Filtered Then - Begin - Accept := RecordFilter; - If Accept Then - Inc(aFilterRecs); - End; + Accept := RecordFilter; Until Accept or (FRecordPos > FRecords.Count - 1); If Not Accept Then Begin Result := grEOF; - FRecordPos := RecordCount - 1; + FRecordPos := RecordCount - 1; End; - FRecordFilterPos := aFilterRecs; End; End; End; @@ -2448,7 +2428,6 @@ destructor TRESTDWMemTable.Destroy; If Active then Begin CheckBrowseMode; - aFilterRecs := 0; If Filtered <> Value then inherited SetFiltered(Value); First; @@ -2482,8 +2461,8 @@ destructor TRESTDWMemTable.Destroy; Begin SaveState := SetTempState(dsFilter); Try - RecordToBuffer(Records[FRecordPos], PRESTDWMTMemBuffer(TempBuffer)); - {$IFDEF FPC} + RecordToBuffer(Records[FRecordPos], PRESTDWMTMemBuffer(TempBuffer)); + {$IFDEF FPC} If (FFilterParser <> nil) and FFilterParser.Eval() then Begin FFilterParser.EnableWildcardMatching := @@ -2491,10 +2470,11 @@ destructor TRESTDWMemTable.Destroy; FFilterParser.CaseInsensitive := foCaseInsensitive in FilterOptions; Result := FFilterParser.Value; End; - {$ELSE} - If FFilterExpression <> nil then - Result := FFilterExpression.Evaluate(); - {$ENDIF} +{$ELSE} + If FFilterExpression <> nil then + Result := FFilterExpression.Evaluate(); + +{$ENDIF} If Assigned(OnFilterRecord) then OnFilterRecord(Self, Result); Except @@ -2662,16 +2642,12 @@ destructor TRESTDWMemTable.Destroy; Procedure TRESTDWMemTable.InternalFirst; Begin - FRecordPos := -1; - FRecordFilterPos := 0; - aFilterRecs := FRecordFilterPos; + FRecordPos := -1; End; Procedure TRESTDWMemTable.InternalLast; Begin - FRecordPos := FRecords.Count; - FRecordFilterPos := RecordCount; - aFilterRecs := FRecordFilterPos; + FRecordPos := FRecords.Count; End; Function TRESTDWMemTable.GetDataset: TDataset; @@ -4834,15 +4810,7 @@ procedure TRESTDWMemTable.InternalCreateIndex(F : TRESTDWDataSetIndex); Begin CheckActive; UpdateCursorPos; - If (filtered) And - (TRESTDWMemTableEx(Self).GetFilteredRecordCount > 0) Then - Begin - If (FRecordFilterPos = -1) Then - Result := 1 - Else - Result := FRecordFilterPos; - End - Else If (FRecordPos = -1) and (RecordCount > 0) then + If (FRecordPos = -1) and (RecordCount > 0) then Result := 1 Else Result := FRecordPos + 1; @@ -6684,7 +6652,6 @@ constructor TRESTDWMemTableEx.Create(AOwner: TComponent); fFilteredRecordCount := i; Finally - aFilterRecs := 0; If (fFilteredRecordCount > 0) and assigned(savePlace) and BookmarkValid(savePlace) then GotoBookmark(savePlace); FreeBookmark(savePlace); diff --git a/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas b/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas index a694f9a8c..c28753d5b 100644 --- a/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas +++ b/CORE/Source/Sockets/Ics/uRESTDWIcsBase.pas @@ -40,7 +40,7 @@ interface OverbyteIcsWinSock, OverbyteIcsWSocket, OverbyteIcsWndControl, OverbyteIcsHttpAppServer, OverbyteIcsUtils, OverbyteIcsFormDataDecoder, OverbyteIcsMimeUtils, OverbyteIcsSSLEAY, OverbyteIcsHttpSrv, - OverbyteIcsWSocketS, OverbyteIcsSslX509Utils, OverbyteIcsSslBase; + OverbyteIcsWSocketS, OverbyteIcsSslX509Utils; type TPoolerHttpConnection = class(THttpAppSrvConnection) diff --git a/CORE/Source/Wizards/RDWCGIWizard.pas b/CORE/Source/Wizards/RDWCGIWizard.pas index 9d06dca90..ede162167 100644 --- a/CORE/Source/Wizards/RDWCGIWizard.pas +++ b/CORE/Source/Wizards/RDWCGIWizard.pas @@ -343,9 +343,7 @@ Function GetDelphiGlobalKey : String; Begin Result := ''; - {$IF DEFINED(DELPHI12UP)} // delphi 11 Alexandria - Result := '\Software\Embarcadero\BDS\23.0\Globals'; - {$ELSEIF DEFINED(DELPHI11UP)} // delphi 11 Alexandria + {$IF DEFINED(DELPHI11UP)} // delphi 11 Alexandria Result := '\Software\Embarcadero\BDS\22.0\Globals'; {$ELSEIF DEFINED(DELPHI10_4UP)} // delphi 10.4 Sydney Result := '\Software\Embarcadero\BDS\21.0\Globals'; diff --git a/CORE/Source/Wizards/STLWizard.pas b/CORE/Source/Wizards/STLWizard.pas index e186ceb5e..d363d5a53 100644 --- a/CORE/Source/Wizards/STLWizard.pas +++ b/CORE/Source/Wizards/STLWizard.pas @@ -458,9 +458,6 @@ {$IFDEF ver350} // delphi 11 Result := '\Software\Embarcadero\BDS\22.0\Globals'; {$ENDIF} - {$IFDEF ver360} // delphi 11 - Result := '\Software\Embarcadero\BDS\23.0\Globals'; - {$ENDIF} End; Function Getideprojectpath: String; diff --git a/CORE/Source/Wizards/templates/URDWDm.dfm b/CORE/Source/Wizards/templates/URDWDm.dfm index 9650c884c..787c77c31 100644 --- a/CORE/Source/Wizards/templates/URDWDm.dfm +++ b/CORE/Source/Wizards/templates/URDWDm.dfm @@ -1,6 +1,30 @@ object %0:s: T%0:s - Encoding = esUtf8 - QueuedRequest = False Height = 480 Width = 640 + object RESTDWServerEvents1: TRESTDWServerEvents + IgnoreInvalidParams = False + Events = < + item + Routes = [crAll] + NeedAuthorization = True + Params = < + item + TypeObject = toParam + ObjectDirection = odIN + ObjectValue = ovString + ParamName = 'entrada' + Encoded = True + end> + DataMode = dmDataware + Name = 'helloworld' + EventName = 'helloworld' + BaseURL = '/' + DefaultContentType = 'application/json' + CallbackEvent = False + OnlyPreDefinedParams = False + OnReplyEvent = RESTDWServerEvents1EventshelloworldReplyEvent + end> + Left = 232 + Top = 264 + end end \ No newline at end of file diff --git a/CORE/Source/Wizards/templates/URDWDm.pas b/CORE/Source/Wizards/templates/URDWDm.pas index 0aa6210c5..ab093e58f 100644 --- a/CORE/Source/Wizards/templates/URDWDm.pas +++ b/CORE/Source/Wizards/templates/URDWDm.pas @@ -3,15 +3,18 @@ interface uses + uRESTDWComponentBase, uRESTDWParams, uRESTDWServerEvents, uRESTDWDatamodule, - uRESTDWJSONObject, System.Classes, System.SysUtils; type T%1:s = class(%2:s) + RESTDWServerEvents1: TRESTDWServerEvents; + procedure RESTDWServerEvents1EventshelloworldReplyEvent( + var Params: TRESTDWParams; var Result: string); private { Private declarations } public @@ -26,5 +29,8 @@ implementation {$R *.dfm} - -end. \ No newline at end of file +procedure T%1:s.RESTDWServerEvents1EventshelloworldReplyEvent( + var Params: TRESTDWParams; var Result: string); +begin + Result := ('{"Message":"'+Params.Itemsstring['entrada'].Asstring+'"}'); +end; \ No newline at end of file From fbc8e8e89ebd602bbf900c556b45d67b2fe4f110 Mon Sep 17 00:00:00 2001 From: "ronierys2@hotmail.com" Date: Mon, 13 May 2024 19:09:04 -0300 Subject: [PATCH 3/3] Update uRESTDWMessageCoderMIME.pas --- .../Mechanics/uRESTDWMessageCoderMIME.pas | 289 +++++++++--------- 1 file changed, 141 insertions(+), 148 deletions(-) diff --git a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas index 4b252634a..ccc87476c 100644 --- a/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas +++ b/CORE/Source/Basic/Mechanics/uRESTDWMessageCoderMIME.pas @@ -284,158 +284,151 @@ destructor TRESTDWMessageDecoderMIME.Destroy; Function TRESTDWMessageDecoderMIME.ReadBody(ADestStream : TStream; Var VMsgEnd : Boolean) : TRESTDWMessageDecoder; -var - LContentType, LContentTransferEncoding: string; - LDecoder: TRESTDWDecoder; - LBytes : TRESTDWBytes; - LLine: string; - LBuffer: string; //Needed for binhex4 because cannot decode line-by-line. - LIsThisTheFirstLine: Boolean; //Needed for binary encoding - BoundaryStart, BoundaryEnd: string; - IsBinaryContentTransferEncoding: Boolean; -begin - LIsThisTheFirstLine := True; - VMsgEnd := False; - Result := nil; - if FBodyEncoded then begin - LContentType := TRESTDWMessage(Owner).ContentType; - LContentTransferEncoding := TRESTDWMessage(Owner).ContentTransferEncoding; - end else begin - LContentType := FHeaders.Values['Content-Type']; {Do not Localize} - LContentTransferEncoding := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize} - end; - if LContentTransferEncoding = '' then begin - if IsHeaderMediaType(LContentType, 'application/mac-binhex40') then begin {Do not Localize} - LContentTransferEncoding := 'binhex40'; {do not localize} - end; - end; - - // RLebeau 08/17/09 - According to RFC 2045 Section 6.4: - // "If an entity is of type "multipart" the Content-Transfer-Encoding is not - // permitted to have any value other than "7bit", "8bit" or "binary"." - // - // However, came across one message where the "Content-Type" was set to - // "multipart/related" and the "Content-Transfer-Encoding" was set to - // "quoted-printable". Outlook and Thunderbird were apparently able to parse - // the message correctly, but Indy was not. So let's check for that scenario - // and ignore illegal "Content-Transfer-Encoding" values if present... - - if IsHeaderMediaType(LContentType, 'multipart') and (LContentTransferEncoding <> '') then {do not localize} - begin - if PosInStrArray(LContentTransferEncoding, ['7bit', '8bit', 'binary'], False) = -1 then begin {do not localize} - LContentTransferEncoding := ''; - end; - end; - - if TextIsSame(LContentTransferEncoding, 'base64') then begin {Do not Localize} - LDecoder := TRESTDWDecoderMIMELineByLine.Create(nil); - end else if TextIsSame(LContentTransferEncoding, 'quoted-printable') then begin {Do not Localize} - LDecoder := TRESTDWDecoderQuotedPrintable.Create(nil); - end else if TextIsSame(LContentTransferEncoding, 'binhex40') then begin {Do not Localize} - LDecoder := TRESTDWDecoderBinHex4.Create(nil); - end else begin - LDecoder := nil; - end; - Try - if LDecoder <> nil then begin - LDecoder.DecodeBegin(ADestStream); - end; - - if MIMEBoundary <> '' then begin - BoundaryStart := '--' + MIMEBoundary; {Do not Localize} - BoundaryEnd := BoundaryStart + '--'; {Do not Localize} - end; - - case PosInStrArray(LContentTransferEncoding, ['7bit', 'quoted-printable', 'base64', '8bit', 'binary'], False) of {do not localize} - 0..2: IsBinaryContentTransferEncoding := False; - 3..4: IsBinaryContentTransferEncoding := True; - else - // According to RFC 2045 Section 6.4: - // "Any entity with an unrecognized Content-Transfer-Encoding must be - // treated as if it has a Content-Type of "application/octet-stream", - // regardless of what the Content-Type header field actually says." - IsBinaryContentTransferEncoding := True; - end; - Repeat - if not FProcessFirstLine then begin - if IsBinaryContentTransferEncoding then - LBytes := ReadLnRFCB(VMsgEnd, EOL, '.') {do not localize} - Else - LLine := ReadLnRFC(VMsgEnd); - end else begin - LLine := FFirstLine; - FFirstLine := ''; {Do not Localize} - FProcessFirstLine := False; - // Do not use ADELIM since always ends with . (standard) - if LLine = '.' then begin {Do not Localize} - VMsgEnd := True; - Break; - end; - if TextStartsWith(LLine, '..') then begin - Delete(LLine, 1, 1); - end; - end; - If (IsBinaryContentTransferEncoding) Then - Begin - If Length(LBytes) > 0 Then - ADestStream.WriteBuffer(LBytes[0], Length(LBytes)); - SetLength(LBytes, 0); - If (VMsgEnd) Then - Break; - End; - // New boundary - end self and create new coder - if MIMEBoundary <> '' then begin - if TextIsSame(LLine, BoundaryStart) then begin - Result := TRESTDWMessageDecoderMIME.Create(Owner); - Break; - // End of all coders (not quite ALL coders) - end; - if TextIsSame(LLine, BoundaryEnd) then begin - // POP the boundary - if Owner is TRESTDWMessage then begin - TRESTDWMessage(Owner).MIMEBoundary.Pop; - end; - Break; - end; - end; - if Not Assigned(LDecoder) then - Begin - // Data to save, but not decode - If Not IsBinaryContentTransferEncoding then - If Assigned(ADestStream) then - WriteStringToStream(ADestStream, LLine + EOL); - end - else - begin - // Data to decode - // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are - // intact - if LDecoder is TRESTDWDecoderQuotedPrintable then begin - // For TIdDecoderQuotedPrintable, we have to make sure all EOLs are intact -// LLine := LLine + EOF; - LDecoder.Decode(LLine); - end else if LDecoder is TRESTDWDecoderBinHex4 then begin - //We cannot decode line-by-line because lines don't have a whole - //number of 4-byte blocks due to the : inserted at the start of - //the first line, so buffer the file... - LBuffer := LBuffer + LLine; - end else if LLine <> '' then begin - LDecoder.Decode(LLine); - end; - end; - Until False; - If LDecoder <> Nil Then +Var + LContentType, + LContentTransferEncoding, + LLine, + LBinaryLineBreak, + LBuffer, //Needed for binhex4 because cannot decode line-by-line. + LBoundaryStart, + LBoundaryEnd : String; + LIsThisTheFirstLine, //Needed for binary encoding + LIsBinaryContentTransferEncoding : Boolean; + LDecoder : TRESTDWDecoder; +Begin + LIsThisTheFirstLine := True; + VMsgEnd := False; + Result := Nil; + If FBodyEncoded Then + Begin + LContentType := TRESTDWMessage(Owner).ContentType; + LContentTransferEncoding := TRESTDWMessage(Owner).ContentTransferEncoding; + End + Else + Begin + LContentType := FHeaders.Values['Content-Type']; {Do not Localize} + LContentTransferEncoding := FHeaders.Values['Content-Transfer-Encoding']; {Do not Localize} + End; + If LContentTransferEncoding = '' Then + Begin + If IsHeaderMediaType(LContentType, 'application/mac-binhex40') Then {Do not Localize} + LContentTransferEncoding := 'binhex40' {do not localize} + Else If Not IsHeaderMediaType(LContentType, 'application/octet-stream') Then {Do not Localize} + LContentTransferEncoding := '7bit'; {do not localize} + End + Else If IsHeaderMediaType(LContentType, 'multipart') Then {do not localize} + Begin + If PosInStrArray(LContentTransferEncoding, ['7bit', '8bit', 'binary'], False) = -1 Then {do not localize} + LContentTransferEncoding := ''; + End; + If TextIsSame(LContentTransferEncoding, 'base64') Then {Do not Localize} + LDecoder := TRESTDWDecoderMIMELineByLine.Create(Nil) + Else If TextIsSame(LContentTransferEncoding, 'quoted-printable') Then {Do not Localize} + LDecoder := TRESTDWDecoderQuotedPrintable.Create(Nil) + Else If TextIsSame(LContentTransferEncoding, 'binhex40') Then {Do not Localize} + LDecoder := TRESTDWDecoderBinHex4.Create (Nil) + Else + LDecoder := nil; + Try + If LDecoder <> Nil Then + LDecoder.DecodeBegin(ADestStream); + If MIMEBoundary <> '' Then + Begin + LBoundaryStart := '--' + MIMEBoundary; {Do not Localize} + LBoundaryEnd := LBoundaryStart + '--'; {Do not Localize} + End; + If LContentTransferEncoding <> '' Then + Begin + Case PosInStrArray(LContentTransferEncoding, ['7bit', 'quoted-printable', 'base64', '8bit', 'binary'], False) Of {do not localize} + 0..2: LIsBinaryContentTransferEncoding := False; + 3..4: LIsBinaryContentTransferEncoding := True; + Else + LIsBinaryContentTransferEncoding := True; + LContentTransferEncoding := ''; + End; + End + Else + LIsBinaryContentTransferEncoding := True; + Repeat + If Not FProcessFirstLine Then Begin - If LDecoder Is TRESTDWDecoderBinHex4 Then + If LIsBinaryContentTransferEncoding Then Begin - //Now decode the complete block... - LDecoder.Decode(LBuffer); + LLine := ReadLnRFC(VMsgEnd, EOL, '.'); {do not localize} + LBinaryLineBreak := EOL; + End + Else + LLine := ReadLnRFC(VMsgEnd, LF, '.'); {do not localize} + End + Else + Begin + LLine := FFirstLine; + FFirstLine := ''; {Do not Localize} + FProcessFirstLine := False; + // Do not use ADELIM since always ends with . (standard) + If LLine = '.' Then + Begin {Do not Localize} + VMsgEnd := True; + Break; End; - LDecoder.DecodeEnd; + If TextStartsWith(LLine, '..') Then + Delete(LLine, 1, 1); End; - Finally - FreeAndNil(LDecoder); - End; + If VMsgEnd Then + Break; + If MIMEBoundary <> '' Then + Begin + If TextIsSame(LLine, LBoundaryStart) Then + Begin + Result := TRESTDWMessageDecoderMIME.Create(Owner); + Break; + End; + If TextIsSame(LLine, LBoundaryEnd) Then + Begin + If Owner is TRESTDWMessage Then + TRESTDWMessage(Owner).MIMEBoundary.Pop; + Break; + End; + End; + If LDecoder = Nil Then + Begin + If LIsBinaryContentTransferEncoding Then + Begin {do not localize} + If LIsThisTheFirstLine Then + LIsThisTheFirstLine := False + Else + Begin + If Assigned(ADestStream) Then + WriteStringToStream(ADestStream, LBinaryLineBreak, -1, 1); + End; + If Assigned(ADestStream) Then + WriteStringToStream(ADestStream, LLine, -1, 1); + End + Else + Begin + If Assigned(ADestStream) Then + WriteStringToStream(ADestStream, LLine + EOL, -1, 1); + End; + End + Else + Begin + If LDecoder Is TRESTDWDecoderQuotedPrintable Then + LDecoder.Decode(LLine + EOL) + Else If LDecoder Is TRESTDWDecoderBinHex4 Then + LBuffer := LBuffer + LLine + Else If LLine <> '' Then + LDecoder.Decode(LLine); + End; + Until False; + If LDecoder <> Nil Then + Begin + If LDecoder Is TRESTDWDecoderBinHex4 Then + LDecoder.Decode(LBuffer); + LDecoder.DecodeEnd; + End; + Finally + FreeAndNil(LDecoder); + End; End; Function TRESTDWMessageDecoderMIME.GetAttachmentFilename(Const AContentType,