diff --git a/.gitattributes b/.gitattributes index 50732800a6..51ee64f254 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1954,7 +1954,6 @@ packages/fcl-base/examples/testbs.pp svneol=native#text/plain packages/fcl-base/examples/testcgi.html -text packages/fcl-base/examples/testcgi.pp svneol=native#text/plain packages/fcl-base/examples/testcont.pp svneol=native#text/plain -packages/fcl-base/examples/testexprpars.pp svneol=native#text/plain packages/fcl-base/examples/testez.pp svneol=native#text/plain packages/fcl-base/examples/testhres.pp svneol=native#text/plain packages/fcl-base/examples/testini.pp svneol=native#text/plain @@ -2040,6 +2039,7 @@ packages/fcl-base/src/wtex.pp svneol=native#text/plain packages/fcl-base/tests/fclbase-unittests.lpi svneol=native#text/plain packages/fcl-base/tests/fclbase-unittests.pp svneol=native#text/plain packages/fcl-base/tests/tchashlist.pp svneol=native#text/plain +packages/fcl-base/tests/testexprpars.pp svneol=native#text/plain packages/fcl-base/tests/tests_fptemplate.pp svneol=native#text/plain packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain packages/fcl-db/Makefile svneol=native#text/plain @@ -3166,6 +3166,9 @@ packages/fcl-web/src/base/restcodegen.pp svneol=native#text/plain packages/fcl-web/src/base/webpage.pp svneol=native#text/plain packages/fcl-web/src/base/websession.pp svneol=native#text/plain packages/fcl-web/src/base/webutil.pp svneol=native#text/plain +packages/fcl-web/src/hpack/uhpack.pp svneol=native#text/plain +packages/fcl-web/src/hpack/uhpackimp.pp svneol=native#text/plain +packages/fcl-web/src/hpack/uhpacktables.pp svneol=native#text/plain packages/fcl-web/src/jsonrpc/Makefile svneol=native#text/plain packages/fcl-web/src/jsonrpc/Makefile.fpc svneol=native#text/plain packages/fcl-web/src/jsonrpc/fpdispextdirect.pp svneol=native#text/plain @@ -3181,10 +3184,14 @@ packages/fcl-web/src/webdata/fpextjs.pp svneol=native#text/plain packages/fcl-web/src/webdata/fpwebdata.pp svneol=native#text/plain packages/fcl-web/src/webdata/readme.txt svneol=native#text/plain packages/fcl-web/src/webdata/sqldbwebdata.pp svneol=native#text/plain +packages/fcl-web/tests/README.txt svneol=native#text/plain packages/fcl-web/tests/cgigateway.lpi svneol=native#text/plain packages/fcl-web/tests/cgigateway.pp svneol=native#text/plain +packages/fcl-web/tests/fpcunithpack.lpi svneol=native#text/plain +packages/fcl-web/tests/fpcunithpack.lpr svneol=native#text/plain packages/fcl-web/tests/testcgiapp.lpi svneol=native#text/plain packages/fcl-web/tests/testcgiapp.pp svneol=native#text/plain +packages/fcl-web/tests/uhpacktest1.pas svneol=native#text/plain packages/fcl-xml/Makefile svneol=native#text/plain packages/fcl-xml/Makefile.fpc svneol=native#text/plain packages/fcl-xml/Makefile.fpc.fpcmake svneol=native#text/plain diff --git a/packages/fcl-base/tests/fclbase-unittests.pp b/packages/fcl-base/tests/fclbase-unittests.pp index 8e35e16eb4..19bd30e3bc 100644 --- a/packages/fcl-base/tests/fclbase-unittests.pp +++ b/packages/fcl-base/tests/fclbase-unittests.pp @@ -3,7 +3,8 @@ program fclbase_unittests; {$mode objfpc}{$H+} uses - Classes, consoletestrunner, tests_fptemplate, tchashlist; + Classes, consoletestrunner, tests_fptemplate, tchashlist, + testexprpars; var Application: TTestRunner; diff --git a/packages/fcl-base/examples/testexprpars.pp b/packages/fcl-base/tests/testexprpars.pp similarity index 100% rename from packages/fcl-base/examples/testexprpars.pp rename to packages/fcl-base/tests/testexprpars.pp diff --git a/packages/fcl-db/src/base/sqlscript.pp b/packages/fcl-db/src/base/sqlscript.pp index 0a8489c2ac..0f07232f4c 100644 --- a/packages/fcl-db/src/base/sqlscript.pp +++ b/packages/fcl-db/src/base/sqlscript.pp @@ -124,6 +124,8 @@ type property Aborted; property Line; published + Property UseDollarString; + Property DollarStrings; property Directives; property Defines; property Script; diff --git a/packages/fcl-db/src/sqldb/sqldb.pp b/packages/fcl-db/src/sqldb/sqldb.pp index 0576cb16e8..1aea8488f6 100644 --- a/packages/fcl-db/src/sqldb/sqldb.pp +++ b/packages/fcl-db/src/sqldb/sqldb.pp @@ -693,6 +693,8 @@ type Property DataBase : TDatabase Read FDatabase Write SetDatabase; Property Transaction : TDBTransaction Read FTransaction Write SetTransaction; property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective; + Property UseDollarString; + Property DollarStrings; property Directives; property Defines; property Script; diff --git a/packages/fcl-web/src/base/custcgi.pp b/packages/fcl-web/src/base/custcgi.pp index 97c1c3726b..3f3df29516 100644 --- a/packages/fcl-web/src/base/custcgi.pp +++ b/packages/fcl-web/src/base/custcgi.pp @@ -373,6 +373,9 @@ begin end; end; end; + // Microsoft-IIS hack. IIS includes the script name in the PATH_INFO + if Pos('IIS', ServerSoftware) > 0 then + SetHTTPVariable(hvPathInfo,StringReplace(PathInfo, ScriptName, '', [rfReplaceAll, rfIgnoreCase])); R:=UpCase(Method); if (R='POST') or (R='PUT') or (ContentLength>0) then ReadContent; diff --git a/packages/fcl-web/src/hpack/uhpack.pp b/packages/fcl-web/src/hpack/uhpack.pp new file mode 100644 index 0000000000..9ce4d08e8e --- /dev/null +++ b/packages/fcl-web/src/hpack/uhpack.pp @@ -0,0 +1,87 @@ +(* + HPACK: Header Compression for HTTP/2 (rfc7541) + ---------------------------------------------- + Pascal implementation of HTTP/2 headers send and receive process. + + Code based in Twitter's HPACK for java https://github.com/twitter/hpack + + History: + + 2016.04.21 - Initial development by Jose Mejuto + + Package source files + + uhpackapi.pas (this file) + uhpack.pas + uhpacktables.pas + rfc7541.txt (rfc based on) + + Basic API: + + HPackDecoder.Create(MaxHeaderSize,MaxHeaderTableSize) + MaxHeaderSize: Each header block must not exceed this value (default: 8192) + MaxHeaderTableSize: Max size for the dynamic table (default: 4096) + + HPackDecoder.Decode(DataStream) + This procedure receives a RawByteString or a Stream and decodes its headers. + If an OnAddHeader is created it will be called for each decoded header. + After all data has been sent to "Decode" the plain headers can be accessed + using "DecodedHeaders". After headers has been processed the function + "EndHeaderBlockTruncated" should be called to verify that the headers has + been successfully decoded. + + HPackEncoder.Create(MaxHeaderTableSize) + Creates the Encoder with a MaxHeaderTableSize. + + HPackEncoder.AddHeader(OutputStream,Name,Value,bSensitive) + Encodes a header pair Name/Value and also a sensitive flag (header should + not be stored in internal tables nor in encoder, nor in decoder) in the + OutputStream parameter. + + THPACKException + Exception raised if some internal state do not work as expected, or sent + information does not meets the structure expected. + If the exception happens, even as some of the errors could be recovered, the + best approach is to free the object and recreate again and also drop the + http2 connection and restart it, as when this exception is raised is quite + sure that the connection is out of sync with remote end point. + + License: + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +*) + +unit uhpack; + +(* + This file exposes only the needed symbols instead the whole + infrastructure to handle HPack. +*) + +{$mode objfpc}{$H+} + +interface + +uses + uhpackimp; + +const + HPACK_MAX_HEADER_SIZE = uhpackimp.HPACK_MAX_HEADER_SIZE; + HPACK_MAX_HEADER_TABLE_SIZE = uhpackimp.HPACK_MAX_HEADER_TABLE_SIZE; + +type + THPackDecoder=uhpackimp.THPackDecoder; + THPackEncoder=uhpackimp.THPackEncoder; + THPackHeaderAddEvent = uhpackimp.THPackHeaderAddEvent; + THPACKException= uhpackimp.THPACKException; + THPackHeaderTextList = uhpackimp.THPackHeaderTextList; + +implementation + +end. + diff --git a/packages/fcl-web/src/hpack/uhpackimp.pp b/packages/fcl-web/src/hpack/uhpackimp.pp new file mode 100644 index 0000000000..98bc48493f --- /dev/null +++ b/packages/fcl-web/src/hpack/uhpackimp.pp @@ -0,0 +1,1887 @@ +unit uhpackimp; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, uhpacktables; + +const + HPACK_MAX_HEADER_SIZE = 8192; + HPACK_MAX_HEADER_TABLE_SIZE = 4096; + +(* + * Tries to "inline" some specific and short time critical functions. + *) +{$DEFINE USEINLINE} + +(* + * This setting applies a bit manual optimizations here and there, but most + * of them could stop correctly working if static information is changed in a + * future, like THPackStaticTable fields (count and order). This optimizations + * only gain around 0.50% in speed time. + *) +{$DEFINE MANUALOPTIMIZATIONS} + +type + + THPackHeaderAddEvent = procedure (aName,aValue: RawByteString; aSensitive: Boolean) of object; + THPACKException=class (Exception); + + THPackHeaderTextItem=record + HeaderName: RawByteString; + HeaderValue: RawByteString; + IsSensitive: Boolean; + end; + PHPackHeaderTextItem=^THPackHeaderTextItem; + + { THPackHeaderTextList } + + THPackHeaderTextList=class(TObject) + private + function Get(Index: integer): PHPackHeaderTextItem; overload; + function GetAsText: string; + function GetCount: integer; + protected + FList: TFPList; + public + constructor Create; + destructor Destroy; override; + function Add(const aName, aValue: RawByteString; const aSensitive: Boolean=false + ): integer; + procedure Clear; + function GetHeaderValue(const aName: String; out aValue: String): Boolean; + property Count: integer read GetCount; + property Item[Index: integer]: PHPackHeaderTextItem read Get; default; + property Text: string read GetAsText; + end; + + { THPackHeaderField } + + THPackHeaderField=class + private + protected + FName: RawByteString; + FValue: RawByteString; + public + const + HEADER_ENTRY_OVERHEAD = 32; + public + // Section 4.1. Calculating Table Size + // The additional 32 octets account for an estimated + // overhead associated with the structure. + class function SizeOf(const aName, aValue: RawByteString): Integer; + + constructor Create(const aName,aValue: RawByteString); + function Size: Integer; + + end; + + { THPackHuffmanEncoder } + + THPackHuffmanEncoder=class + private + protected + FCodes: PDWORD; + FLengths: PByte; + public + constructor Create; + constructor Create(const aCodes: PDWORD; const aLengths: PByte); + function GetEncodedLength(aData: RawByteString): integer; + procedure Encode(aOutputStream: TStream; aData: RawByteString); + procedure Encode(aOutputStream: TStream; aData: RawByteString; aOff,aLen: integer); + end; + + { THPackHuffmanNode } + + THPackHuffmanNode=class + private + protected + FSymbol: integer; // terminal nodes have a symbol + FBits: integer; // number of bits matched by the node + FChildren: array of THPackHuffmanNode; // internal nodes have children + class procedure Insert(aRoot: THPackHuffmanNode; aSymbol: integer; aCode: integer; aLength: BYTE); + class function BuildTree(const aCodes: PDWORD; const aLengths: PByte): THPackHuffmanNode; + public + constructor Create; + constructor Create(aSymbol: Integer; aBits: Integer); + destructor Destroy; override; + function isTerminal: Boolean;{$IFDEF USEINLINE}inline;{$ENDIF} + end; + + { THPackHuffmanDecoder } + + THPackHuffmanDecoder=class + private + protected + FCodes: PDWORD; + FLengths: PByte; + FRoot: THPackHuffmanNode; + public + constructor Create; + constructor Create(const aCodes: PDWORD; const aLengths: PByte); + destructor Destroy; override; + function Decode(aBuf: RawByteString): RawByteString; + end; + + THPackHuffman=class + private + protected + class var + FRefCount: Integer; + public + constructor Create; + destructor Destroy; override; + class var Encoder: THPackHuffmanEncoder; + class var Decoder: THPackHuffmanDecoder; + end; + + { THPackDynamicTable } + + THPackDynamicTable=class + private + FSize: integer; + FCapacity: integer; + protected + // a circular queue of header fields + FHeaderFields: array of THPackHeaderField; + FHead: integer; + FTail: integer; + procedure SetCapacity(aCapacity: integer); + procedure Clear; + function Remove: THPackHeaderField; + function EntriesCount: integer; {$IFDEF USEINLINE}inline;{$ENDIF} + public + constructor Create(aInitialCapacity: integer); + destructor Destroy; override; + procedure Add(aHeaderField: THPackHeaderField); + function GetEntry(aIndex: integer): THPackHeaderField; {$IFDEF USEINLINE}inline;{$ENDIF} + function GetNameIndex(const aName: RawByteString): integer; + function GetEntry(const aName, aValue: RawByteString): THPackHeaderField; + function GetEntryIndex(const aName, aValue: RawByteString): integer; + function GetEntryIndex(const aHeader: THPackHeaderField): integer; + procedure EnsureCapacityToHold(const aHeaderSize: integer); + property Size: integer read FSize; + property Capacity: integer read FCapacity; + end; + + { THPackStaticTable } + + THPackStaticTable=class + private + HPackStaticTable: array [1..61] of THPackHeaderField; static; + protected + public + class procedure InitializeStaticTable; + class procedure DestroyStaticTable; + class function GetEntry(aIndex: integer): THPackHeaderField; + (** + * Returns the lowest index value for the given header field name in the static table. + * Returns -1 if the header field name is not in the static table. + *) + class function GetIndex(const aName: RawByteString): Integer; + (** + * Returns the index value for the given header field in the static table. + * Returns -1 if the header field is not in the static table. + *) + class function GetIndex(const aName,aValue: RawByteString): integer; + class function TableLength: integer; {$IFDEF USEINLINE}inline;{$ENDIF} + end; + + { THPackDecoder } + + THPackDecoder=class + private + DynamicTable: THPackDynamicTable; + MaxHeaderSize: integer; + MaxDynamicTableSize: integer; + EncoderMaxDynamicTableSize: integer; + MaxDynamicTableSizeChangeRequired: Boolean; + HeaderSize: integer; + State: THPackState; + IndexType: THPackIndexType; + FIndex: integer; + HuffmanEncoded: Boolean; + SkipLength: integer; + NameLength: integer; + ValueLength: integer; + FName: RawByteString; + FMustReset: Boolean; + protected + FHeaderListenerAddHeader: THPackHeaderAddEvent; + FDecodedHeaders: THPackHeaderTextList; + Huffman: THPackHuffman; + + procedure Reset; + function GetHeaderField(aIndex: integer): THPackHeaderField; + procedure SetDynamicTableSize(aDynamicTableSize: integer); + procedure ReadName (aIndex: integer); + function ReadStringLiteral(aStream: TStream; aLength: integer): RawByteString; + procedure AddHeader(aName,aValue: RawByteString; aSensitive: Boolean); + procedure InsertHeader(aName,aValue: RawByteString; aIndexType: THPackIndexType); + function DecodeULE128(aStream: TStream): integer; + procedure IndexHeader(aIndex: integer); + function ExceedsMaxHeaderSize(aSize: integer): Boolean; + + procedure DoAddHeader(aName,aValue: RawByteString; aSensitive: Boolean); virtual; + + public + constructor Create; + constructor Create(aMaxHeaderSize, aMaxHeaderTableSize: integer); + destructor Destroy; override; + procedure Decode(aStream: TStream); + procedure Decode(aString: RawByteString); + function GetMaxHeaderTableSize: Integer; + procedure SetMaxHeaderTableSize(aMaxHeaderTableSize: integer); + function EndHeaderBlockTruncated: Boolean; + property OnAddHeader: THPackHeaderAddEvent read FHeaderListenerAddHeader write FHeaderListenerAddHeader; + property DecodedHeaders: THPackHeaderTextList read FDecodedHeaders; + end; + + { THPackEncoder } + + THPackEncoder=class + private + private + // Used for debugging purposes, modifies class behaviour using or not + // indexing, or Huffman compression. + UseIndexing: Boolean; + ForceHuffmanOn: Boolean; + ForceHuffmanOff: Boolean; + + procedure EncodeLiteral(aOutStream: TStream; const aName: RawByteString; const aValue: RawByteString; const aIndexType: THPackIndexType; const aNameIndex: Integer); + procedure EncodeInteger(aOutStream: TStream; const aMask: integer; const n: integer; const i: integer); + procedure EncodeStringLiteral(aOutStream: TStream; const aString: RawByteString); + function GetNameIndex(const aName: RawByteString): integer; + procedure Add(const aName, aValue: RawByteString); + procedure Clear; + + protected + DynamicTable: THPackDynamicTable; + Huffman: THPackHuffman; + public + constructor Create; + constructor Create(const aMaxHeaderTableSize: Integer); + constructor Create(const aMaxHeaderTableSize: Integer; + const aUseIndexing: Boolean; + const aForceHuffmanOn: Boolean; + const aForceHuffmanOff: Boolean); + destructor Destroy; override; + procedure EncodeHeader(aOutStream: TStream; const aName: RawByteString; const aValue: RawByteString; const aSensitive: Boolean); + procedure SetMaxHeaderTableSize(aOutStream: TStream; const aNewMaxHeaderTableSize: Integer); + + end; + +implementation + +const + NOT_FOUND=-1; + +{ THPackHeaderTextList } + +function THPackHeaderTextList.Get(Index: integer): PHPackHeaderTextItem; +begin + Result:=PHPackHeaderTextItem(FList[Index]); +end; + +function THPackHeaderTextList.GetAsText: string; +const + HEADER_SEPARATOR_MARK: char=':'; +var + j: integer; + P: PHPackHeaderTextItem; + O: string; + w: integer; + wl, lle: integer; + Allocated: integer; + LE : string; + procedure EnsureSpace(const aNeeded: integer);{$IFDEF USEINLINE}inline;{$ENDIF} + begin + if (w+aNeeded)>Allocated then begin + Allocated:=Allocated+aNeeded; + SetLength(O,Allocated); + end; + end; + +begin + LE:=LineEnding; + LLE:=Length(LE); + Allocated:=HPACK_MAX_HEADER_SIZE*2; + SetLength(O,Allocated); + w:=1; + for j := 0 to Pred(FList.Count) do begin + P:=PHPackHeaderTextItem(FList[j]); + wl:=Length(P^.HeaderName); + if wl=0 then begin + Raise THPACKException.Create('Header name is empty'); + end; + EnsureSpace(wl); + move(P^.HeaderName[1],O[w],wl); + inc(w,wl); + wl:=1; + EnsureSpace(wl); + move(HEADER_SEPARATOR_MARK,O[w],wl); + inc(w,wl); + wl:=Length(P^.HeaderValue); + if wl>0 then begin + EnsureSpace(wl); + move(P^.HeaderValue[1],O[w],wl); + inc(w,wl); + end; + EnsureSpace(lle); + move(LE[1],O[w],lle); + inc(w,lle); + end; + SetLength(O,w-1); + Result:=O; +end; + +function THPackHeaderTextList.GetCount: integer; +begin + Result:=FList.Count; +end; + +constructor THPackHeaderTextList.Create; +begin + FList:=TFPList.Create; +end; + +destructor THPackHeaderTextList.Destroy; +begin + Clear; + FList.Free; +end; + +function THPackHeaderTextList.Add(const aName, aValue: RawByteString; + const aSensitive: Boolean=false): integer; +var + P: PHPackHeaderTextItem; +begin + New(P); + P^.HeaderName:=aName; + P^.HeaderValue:=aValue; + P^.IsSensitive:=aSensitive; + Result:=FList.Add(P); +end; + +procedure THPackHeaderTextList.Clear; +var + j: integer; +begin + for j := 0 to Pred(FList.Count) do begin + Dispose(PHPackHeaderTextItem(FList[j])); + end; + FList.Clear; +end; + +function THPackHeaderTextList.GetHeaderValue(const aName: String; out + aValue: String): Boolean; +var + j: integer; + p: PHPackHeaderTextItem; +begin + for j := 0 to Pred(FList.Count) do begin + P:=PHPackHeaderTextItem(FList[j]); + if p^.HeaderName=aName then begin + aValue:=p^.HeaderValue; + Result:=true; + exit; + end; + end; + aValue:=''; + Result:=false; +end; + +{ THPackEncoder } + +constructor THPackEncoder.Create(const aMaxHeaderTableSize: Integer); +begin + Create(aMaxHeaderTableSize,true,false,false); +end; + +constructor THPackEncoder.Create(const aMaxHeaderTableSize: Integer; + const aUseIndexing: Boolean; const aForceHuffmanOn: Boolean; + const aForceHuffmanOff: Boolean); +begin + if aMaxHeaderTableSize < 0 then begin + Raise THPACKException.CreateFmt('Illegal capacity: %d',[aMaxHeaderTableSize]); + end; + DynamicTable:=THPackDynamicTable.Create(aMaxHeaderTableSize); + UseIndexing := aUseIndexing; + ForceHuffmanOn := aForceHuffmanOn; + ForceHuffmanOff := aForceHuffmanOff; + Huffman:=THPackHuffman.Create; +end; + +destructor THPackEncoder.Destroy; +begin + Clear; + FreeAndNil(Huffman); + FreeAndNil(DynamicTable); + inherited Destroy; +end; + +procedure THPackEncoder.EncodeHeader(aOutStream: TStream; + const aName: RawByteString; const aValue: RawByteString; + const aSensitive: Boolean); +var + NameIndex: integer; + StaticTableIndex: integer; + HeaderSize: integer; + ThisHeaderField: THPackHeaderField; + Index: integer; + IndexType: THPackIndexType; +begin + // If the header value is sensitive then it must never be indexed + if aSensitive then begin + NameIndex := GetNameIndex(aName); + EncodeLiteral(aOutStream, aName, aValue, THPackIndexType.eHPackNEVER, NameIndex); + exit; + end; + + // If the peer will only use the static table + if DynamicTable.Capacity = 0 then begin + StaticTableIndex := THPackStaticTable.GetIndex(aName, aValue); + if StaticTableIndex = NOT_FOUND then begin + NameIndex := THPackStaticTable.GetIndex(aName); + EncodeLiteral(aOutStream, aName, aValue, THPackIndexType.eHPackNONE, NameIndex); + end else begin + EncodeInteger(aOutStream, $80, 7, StaticTableIndex); + end; + exit; + end; + + HeaderSize := THPackHeaderField.sizeOf(aName, aValue); + + // If the headerSize is greater than the max table size then it must be encoded literally + if HeaderSize > DynamicTable.Capacity then begin + NameIndex := GetNameIndex(aName); + EncodeLiteral(aOutStream, aName, aValue, THPackIndexType.eHPackNONE, NameIndex); + Exit; + end; + + ThisHeaderField := DynamicTable.GetEntry(aName, aValue); + if Assigned(ThisHeaderField) then begin + Index := DynamicTable.GetEntryIndex(ThisHeaderField) + THPackStaticTable.TableLength; + // Section 6.1. Indexed Header Field Representation + EncodeInteger(aOutStream, $80, 7, Index); + end else begin + StaticTableIndex := THPackStaticTable.GetIndex(aName, aValue); + if StaticTableIndex <> NOT_FOUND then begin + // Section 6.1. Indexed Header Field Representation + EncodeInteger(aOutStream, $80, 7, StaticTableIndex); + end else begin + NameIndex := GetNameIndex(aName); + if UseIndexing then begin + DynamicTable.EnsureCapacityToHold(HeaderSize); + end; + if UseIndexing then begin + IndexType:=THPackIndexType.eHPackINCREMENTAL; + end else begin + IndexType:=THPackIndexType.eHPackNONE; + end; + EncodeLiteral(aOutStream, aName, aValue, IndexType, NameIndex); + if UseIndexing then begin + Add(aName, aValue); + end; + end; + end; +end; + +procedure THPackEncoder.SetMaxHeaderTableSize(aOutStream: TStream; + const aNewMaxHeaderTableSize: Integer); +begin + if aNewMaxHeaderTableSize < 0 then begin + Raise THPACKException.CreateFmt('Illegal Capacity %d',[aNewMaxHeaderTableSize]); + end; + if DynamicTable.Capacity = aNewMaxHeaderTableSize then begin + //No change needed + exit; + end; + DynamicTable.SetCapacity(aNewMaxHeaderTableSize); + //DynamicTable.EnsureCapacityToHold(0); + EncodeInteger(aOutStream, $20, 5, aNewMaxHeaderTableSize); +end; + +procedure THPackEncoder.EncodeLiteral(aOutStream: TStream; + const aName: RawByteString; const aValue: RawByteString; + const aIndexType: THPackIndexType; const aNameIndex: Integer); +(** + * Encode literal header field according to Section 6.2. + *) +var + Mask: Integer; + PrefixBits: Integer; + v: integer; +begin + case aIndexType of + eHPackINCREMENTAL: + begin + Mask := $40; + PrefixBits := 6; + end; + eHPackNONE: + begin + Mask := $00; + PrefixBits := 4; + end; + eHPackNEVER: + begin + Mask := $10; + PrefixBits := 4; + end; + else + Raise THPACKException.Create('Should not reach here'); + end; + if aNameIndex=NOT_FOUND then begin + v:=0; + end else begin + v:=aNameIndex; + end; + EncodeInteger(aOutStream, Mask, PrefixBits, v); + if aNameIndex = NOT_FOUND then begin + EncodeStringLiteral(aOutStream, aName); + end; + EncodeStringLiteral(aOutStream, aValue); +end; + +procedure THPackEncoder.EncodeInteger(aOutStream: TStream; const aMask: integer; + const n: integer; const i: integer); +var + nBits: Integer; + Len: DWORD; +begin + if (n < 0) or (n > 8) then begin + Raise THPACKException.CreateFmt('Encode Integer Illegal Argument Exception ("N<0|N>8": %d)',[n]); + end; + nBits := $FF shr (8 - n); + if i < nBits then begin + aOutStream.WriteByte(BYTE(aMask or i)); + end else begin + aOutStream.WriteByte(BYTE(aMask or nBits)); + Len := i - nBits; + while (true) do begin + if (Len and (not $7F)) = 0 then begin + aOutStream.WriteByte(BYTE(Len)); + exit; + end else begin + aOutStream.WriteByte(Byte((Len and $7F) or $80)); + Len:=Len shr 7; + end; + end; + end; +end; + +procedure THPackEncoder.EncodeStringLiteral(aOutStream: TStream; + const aString: RawByteString); +var + HuffmanLength: integer; +begin + if Length(aString)=0 then begin + EncodeInteger(aOutStream, $00, 7, 0); + exit; + end; + HuffmanLength := THpackHuffman.Encoder.GetEncodedLength(aString); + if ((HuffmanLength < Length(aString)) and not forceHuffmanOff) or forceHuffmanOn then begin + EncodeInteger(aOutStream, $80, 7, HuffmanLength); + if Length(aString)>0 then begin + THPackHuffman.Encoder.Encode(aOutStream, aString); + end; + end else begin + EncodeInteger(aOutStream, $00, 7, Length(aString)); + if Length(aString)>0 then begin + aOutStream.Write(aString[1],Length(aString)); + end; + end; +end; + +function THPackEncoder.GetNameIndex(const aName: RawByteString): integer; +var + Index: integer; +begin + Index := THPackStaticTable.GetIndex(aName); + if Index = NOT_FOUND then begin + Index := DynamicTable.GetNameIndex(aName); + if Index >= 0 then begin + inc(Index,THPackStaticTable.TableLength); + end; + end; + Result:=Index; +end; + +procedure THPackEncoder.Add(const aName, aValue: RawByteString); +(** + * Add the header field to the dynamic table. + * Entries are evicted from the dynamic table until the size of the table + * and the new header field is less than the table's capacity. + * If the size of the new entry is larger than the table's capacity, + * the dynamic table will be cleared. + *) +var +// HeaderSize: Integer; + Header: THPackHeaderField; +begin + (* + HeaderSize := THPackHeaderField.SizeOf(aName, aValue); + + // Clear the table if the header field size is larger than the capacity. + if HeaderSize > Capacity then begin + Clear; + // Do not add this entry to the DynamicTable + exit; + end; + + // Evict oldest entries until we have enough capacity. + while (Size + HeaderSize) > Capacity do begin + Remove().Free; + end; + *) + // Copy name and value that modifications of original do not affect the dynamic table. + + Header:=THPackHeaderField.Create(aName,aValue); + DynamicTable.Add(Header); + + //Inc(Size,HeaderSize); +end; + +procedure THPackEncoder.Clear; +(** + * Remove all entries from the dynamic table. + *) +begin + DynamicTable.Clear; +end; + +constructor THPackEncoder.Create; +begin + Create(HPACK_MAX_HEADER_TABLE_SIZE,true,false,false); +end; + +{ THPackHuffman } + +constructor THPackHuffman.Create; +begin + if FRefCount=0 then begin + Encoder:=THPackHuffmanEncoder.Create; + Decoder:=THPackHuffmanDecoder.Create; + end; + inc(FRefCount); +end; + +destructor THPackHuffman.Destroy; +begin + dec(FRefCount); + if FRefCount=0 then begin + FreeAndNil(Encoder); + FreeAndNil(Decoder); + end; + inherited Destroy; +end; + +{ THPackStaticTable } + +class function THPackStaticTable.TableLength: integer; +begin + Result:=Length(HPackStaticTable); +end; + +class procedure THPackStaticTable.InitializeStaticTable; +const + EMPTY=''; +begin + // Appendix A: Static Table + // http://tools.ietf.org/html/rfc7541#appendix-A + HPackStaticTable[01]:=THPackHeaderField.Create(':authority',EMPTY); + HPackStaticTable[02]:=THPackHeaderField.Create(':method', 'GET'); + HPackStaticTable[03]:=THPackHeaderField.Create(':method', 'POST'); + HPackStaticTable[04]:=THPackHeaderField.Create(':path', '/'); + HPackStaticTable[05]:=THPackHeaderField.Create(':path', '/index.html'); + HPackStaticTable[06]:=THPackHeaderField.Create(':scheme', 'http'); + HPackStaticTable[07]:=THPackHeaderField.Create(':scheme', 'https'); + HPackStaticTable[08]:=THPackHeaderField.Create(':status', '200'); + HPackStaticTable[09]:=THPackHeaderField.Create(':status', '204'); + HPackStaticTable[10]:=THPackHeaderField.Create(':status', '206'); + HPackStaticTable[11]:=THPackHeaderField.Create(':status', '304'); + HPackStaticTable[12]:=THPackHeaderField.Create(':status', '400'); + HPackStaticTable[13]:=THPackHeaderField.Create(':status', '404'); + HPackStaticTable[14]:=THPackHeaderField.Create(':status', '500'); + HPackStaticTable[15]:=THPackHeaderField.Create('accept-charset', EMPTY); + HPackStaticTable[16]:=THPackHeaderField.Create('accept-encoding', 'gzip, deflate'); + HPackStaticTable[17]:=THPackHeaderField.Create('accept-language', EMPTY); + HPackStaticTable[18]:=THPackHeaderField.Create('accept-ranges', EMPTY); + HPackStaticTable[19]:=THPackHeaderField.Create('accept', EMPTY); + HPackStaticTable[20]:=THPackHeaderField.Create('access-control-allow-origin', EMPTY); + HPackStaticTable[21]:=THPackHeaderField.Create('age', EMPTY); + HPackStaticTable[22]:=THPackHeaderField.Create('allow', EMPTY); + HPackStaticTable[23]:=THPackHeaderField.Create('authorization', EMPTY); + HPackStaticTable[24]:=THPackHeaderField.Create('cache-control', EMPTY); + HPackStaticTable[25]:=THPackHeaderField.Create('content-disposition', EMPTY); + HPackStaticTable[26]:=THPackHeaderField.Create('content-encoding', EMPTY); + HPackStaticTable[27]:=THPackHeaderField.Create('content-language', EMPTY); + HPackStaticTable[28]:=THPackHeaderField.Create('content-length', EMPTY); + HPackStaticTable[29]:=THPackHeaderField.Create('content-location', EMPTY); + HPackStaticTable[30]:=THPackHeaderField.Create('content-range', EMPTY); + HPackStaticTable[31]:=THPackHeaderField.Create('content-type', EMPTY); + HPackStaticTable[32]:=THPackHeaderField.Create('cookie', EMPTY); + HPackStaticTable[33]:=THPackHeaderField.Create('date', EMPTY); + HPackStaticTable[34]:=THPackHeaderField.Create('etag', EMPTY); + HPackStaticTable[35]:=THPackHeaderField.Create('expect', EMPTY); + HPackStaticTable[36]:=THPackHeaderField.Create('expires', EMPTY); + HPackStaticTable[37]:=THPackHeaderField.Create('from', EMPTY); + HPackStaticTable[38]:=THPackHeaderField.Create('host', EMPTY); + HPackStaticTable[39]:=THPackHeaderField.Create('if-match', EMPTY); + HPackStaticTable[40]:=THPackHeaderField.Create('if-modified-since', EMPTY); + HPackStaticTable[41]:=THPackHeaderField.Create('if-none-match', EMPTY); + HPackStaticTable[42]:=THPackHeaderField.Create('if-range', EMPTY); + HPackStaticTable[43]:=THPackHeaderField.Create('if-unmodified-since', EMPTY); + HPackStaticTable[44]:=THPackHeaderField.Create('last-modified', EMPTY); + HPackStaticTable[45]:=THPackHeaderField.Create('link', EMPTY); + HPackStaticTable[46]:=THPackHeaderField.Create('location', EMPTY); + HPackStaticTable[47]:=THPackHeaderField.Create('max-forwards', EMPTY); + HPackStaticTable[48]:=THPackHeaderField.Create('proxy-authenticate', EMPTY); + HPackStaticTable[49]:=THPackHeaderField.Create('proxy-authorization', EMPTY); + HPackStaticTable[50]:=THPackHeaderField.Create('range', EMPTY); + HPackStaticTable[51]:=THPackHeaderField.Create('referer', EMPTY); + HPackStaticTable[52]:=THPackHeaderField.Create('refresh', EMPTY); + HPackStaticTable[53]:=THPackHeaderField.Create('retry-after', EMPTY); + HPackStaticTable[54]:=THPackHeaderField.Create('server', EMPTY); + HPackStaticTable[55]:=THPackHeaderField.Create('set-cookie', EMPTY); + HPackStaticTable[56]:=THPackHeaderField.Create('strict-transport-security', EMPTY); + HPackStaticTable[57]:=THPackHeaderField.Create('transfer-encoding', EMPTY); + HPackStaticTable[58]:=THPackHeaderField.Create('user-agent', EMPTY); + HPackStaticTable[59]:=THPackHeaderField.Create('vary', EMPTY); + HPackStaticTable[60]:=THPackHeaderField.Create('via', EMPTY); + HPackStaticTable[61]:=THPackHeaderField.Create('www-authenticate', EMPTY); +end; + +class procedure THPackStaticTable.DestroyStaticTable; +var + j: integer; +begin + for j := Low(HPackStaticTable) to High(HPackStaticTable) do begin + HPackStaticTable[j].Free; + HPackStaticTable[j]:=nil; + end; +end; + +class function THPackStaticTable.GetEntry(aIndex: integer): THPackHeaderField; +begin + Result:=HPackStaticTable[aIndex]; +end; + +class function THPackStaticTable.GetIndex(const aName: RawByteString + ): Integer; +var + lLeft,lRight: integer; + Half: integer; + c: integer; +begin + lLeft:=Low(HPackStaticTable); + lRight:=High(HPackStaticTable); + {$IFDEF MANUALOPTIMIZATIONS} + // Manual optimization + if aName[1]>'c' then begin + lLeft:=33; + end; + {$ENDIF} + while lLeft<=lRight do begin + Half:=(lLeft+lRight) div 2; // No overflow problem, low amount of elements + c:=CompareStr(aName,HPackStaticTable[Half].FName); + if c=0 then begin + dec(Half); + while Half>=lLeft do begin + if HPackStaticTable[Half].FName<>aName then begin + break; + end; + dec(Half); + end; + Result:=Half+1; + exit; + end else if c<0 then begin + lRight:=Half-1; + end else begin + // c > 0 + lLeft:=Half+1; + end; + end; + Result:=NOT_FOUND; +end; + +class function THPackStaticTable.GetIndex(const aName, aValue: RawByteString): Integer; +var + lLeft,lRight: integer; + Half: integer; + c: integer; +begin + lLeft:=Low(HPackStaticTable); + lRight:=High(HPackStaticTable); + {$IFDEF MANUALOPTIMIZATIONS} + // Manual optimization + if aName[1]>'c' then begin + lLeft:=33; + end; + {$ENDIF} + while lLeft<=lRight do begin + Half:=(lLeft+lRight) div 2; // No overflow problem, low amount of elements + c:=CompareStr(aName,HPackStaticTable[Half].FName); + if c=0 then begin + c:=CompareStr(aValue,HPackStaticTable[Half].FValue); + if c=0 then begin + Result:=Half; + exit; + end else if c<0 then begin + lRight:=Half-1; + end else begin + // c > 0 + lLeft:=Half+1; + end; + end else if c<0 then begin + lRight:=Half-1; + end else begin + // c > 0 + lLeft:=Half+1; + end; + end; + Result:=NOT_FOUND; +end; + +{ THPackDecoder } + +procedure THPackDecoder.Reset; +begin + HeaderSize := 0; + State := THPackState.READ_HEADER_REPRESENTATION; + IndexType := THPackIndexType.eHPackNONE; + FDecodedHeaders.Clear; + FMustReset:=false; +end; + +function THPackDecoder.EndHeaderBlockTruncated: Boolean; +begin + Result:= HeaderSize > MaxHeaderSize; + FMustReset:=true; +end; + +procedure THPackDecoder.SetMaxHeaderTableSize(aMaxHeaderTableSize: integer); +begin + if FMustReset then Reset; + MaxDynamicTableSize := aMaxHeaderTableSize; + if (MaxDynamicTableSize < EncoderMaxDynamicTableSize) then begin + // decoder requires less space than encoder + // encoder MUST signal this change + MaxDynamicTableSizeChangeRequired := true; + DynamicTable.SetCapacity(MaxDynamicTableSize); + end; +end; + +function THPackDecoder.GetHeaderField(aIndex: integer): THPackHeaderField; +begin + Result:=DynamicTable.GetEntry(aIndex + 1); +end; + +procedure THPackDecoder.SetDynamicTableSize(aDynamicTableSize: integer); +begin + if aDynamicTableSize > MaxDynamicTableSize then begin + Raise THPACKException.Create('Invalid MAX_DYNAMIC_TABLE_SIZE'); + end; + EncoderMaxDynamicTableSize := aDynamicTableSize; + MaxDynamicTableSizeChangeRequired := false; + DynamicTable.SetCapacity(aDynamicTableSize); +end; + +procedure THPackDecoder.ReadName(aIndex: integer); +var + HeaderField: THPackHeaderField; +begin + if aIndex <= THPackStaticTable.TableLength then begin + HeaderField:= THPackStaticTable.GetEntry(aIndex); + FName := HeaderField.FName; + end else if (aIndex - THPackStaticTable.TableLength <= DynamicTable.EntriesCount) then begin + HeaderField := DynamicTable.GetEntry(aIndex - THPackStaticTable.TableLength); + FName := HeaderField.FName; + end else begin + Raise THPACKException.Create('Illegal index value'); + end; +end; + +function THPackDecoder.ReadStringLiteral(aStream: TStream; aLength: integer + ): RawByteString; +var + buf: RawByteString; +begin + SetLength(buf,aLength); + if (aStream.Read(buf[1],aLength) <> aLength) then begin + Raise THPACKException.Create('Decompression exception in ReadStringLiteral'); + end; + + if (HuffmanEncoded) then begin + Result:=Huffman.Decoder.Decode(buf); + end else begin + Result:=buf; + end; +end; + +procedure THPackDecoder.AddHeader(aName, aValue: RawByteString; aSensitive: Boolean); +var + NewSize: Integer; +begin + if aName='' then begin + Raise THPACKException.Create('Header name is empty'); + end; + NewSize := HeaderSize + Length(aName) + Length(aValue); + if NewSize <= MaxHeaderSize then begin + DoAddHeader(aName, aValue, aSensitive); + HeaderSize := newSize; + end else begin + // truncation will be reported during EndHeaderBlockTruncated + HeaderSize := MaxHeaderSize + 1; + end; +end; + +procedure THPackDecoder.InsertHeader(aName, aValue: RawByteString; + aIndexType: THPackIndexType); +begin + AddHeader(aName, aValue, aIndexType = THPackIndexType.eHPackNEVER); + + case (aIndexType) of + eHPackNONE, + eHPackNEVER: exit; + eHPackINCREMENTAL: begin + DynamicTable.Add(THPackHeaderField.Create(aName, aValue)); + end; + else + Raise THPACKException.Create('Should not reach here'); + end; +end; + +function THPackDecoder.DecodeULE128(aStream: TStream): integer; +var + EntryMark: int64; + Shift: integer; + b: BYTE; + function InAvailable(): int64; inline; + begin + Result:=aStream.Size-aStream.Position; + end; +begin + Shift:=0; + Result:=0; + EntryMark:=aStream.Position; + while (Shift < 32) do begin + if (InAvailable() = 0) then begin + // Buffer does not contain entire integer, + // reset reader index and return -1. + aStream.Position:=EntryMark; + exit(-1); + end; + b := aStream.ReadByte; + if ((Shift = 28) and ((b and $F8) <> 0)) then begin + break; + end; + + Result:=Result or ((b and $7F) shl Shift); + + if ((b and $80) = 0) then begin + exit; + end; + Inc(shift,7); + end; + + // Value exceeds Integer.MAX_VALUE + aStream.Position:=EntryMark; + Raise THPACKException.Create('Decompression error DecodeULE128'); +end; + +procedure THPackDecoder.IndexHeader(aIndex: integer); +var + HeaderField: THPackHeaderField; +begin + if (aIndex <= THPackStaticTable.TableLength) then begin + HeaderField := THPackStaticTable.GetEntry(aIndex); + //addHeader(headerListener, headerField.name, headerField.value, false); + AddHeader(HeaderField.FName, HeaderField.FValue, False); + end else if (aIndex - THPackStaticTable.TableLength <= DynamicTable.EntriesCount) then begin + HeaderField := DynamicTable.GetEntry(aIndex - THPackStaticTable.TableLength); + //addHeader(headerListener, headerField.name, headerField.value, false); + AddHeader(HeaderField.FName, HeaderField.FValue, False); + end else begin + Raise THPACKException.Create('Illegal index value'); + end; +end; + +function THPackDecoder.ExceedsMaxHeaderSize(aSize: integer): Boolean; +begin + // Check new header size against max header size + if aSize + HeaderSize <= MaxHeaderSize then begin + exit(False); + end; + // truncation will be reported during EndHeaderBlockTruncated + HeaderSize := MaxHeaderSize + 1; + Result:=true; +end; + +procedure THPackDecoder.DoAddHeader(aName, aValue: RawByteString; aSensitive: Boolean); +begin + if Assigned(FHeaderListenerAddHeader) then begin + FHeaderListenerAddHeader(aName,aValue,aSensitive); + end; + FDecodedHeaders.Add(aName,aValue,aSensitive); +end; + +constructor THPackDecoder.Create; +begin + Create(HPACK_MAX_HEADER_SIZE,HPACK_MAX_HEADER_TABLE_SIZE); +end; + +constructor THPackDecoder.Create(aMaxHeaderSize, aMaxHeaderTableSize: integer); +begin + Huffman:=THPackHuffman.Create; + DynamicTable := THPackDynamicTable.Create(aMaxHeaderTableSize); + MaxHeaderSize := aMaxHeaderSize; + MaxDynamicTableSize := aMaxHeaderTableSize; + EncoderMaxDynamicTableSize := aMaxHeaderTableSize; + MaxDynamicTableSizeChangeRequired := false; + FDecodedHeaders:=THPackHeaderTextList.Create; + Reset(); +end; + +destructor THPackDecoder.Destroy; +begin + FreeAndNil(Huffman); + FreeAndNil(DynamicTable); + FreeAndNil(FDecodedHeaders); + inherited Destroy; +end; + +procedure THPackDecoder.Decode(aStream: TStream); + function InAvailable(): int64; inline; + begin + Result:=aStream.Size-aStream.Position; + end; +var + b: BYTE; + MaxSize: integer; + HeaderIndex: integer; + NameIndex: integer; + NewHeaderSize: integer; + tmpbuffer: RawByteString; + Value: RawByteString; +begin + if FMustReset then Reset; + while InAvailable() > 0 do begin + case State of + READ_HEADER_REPRESENTATION: begin + b := aStream.ReadByte; + if MaxDynamicTableSizeChangeRequired and ((b and $E0) <> $20) then begin + // Encoder MUST signal maximum dynamic table size change + Raise THPACKException.Create('Max dynamic table size change not notified'); + end; + if (b > 127) then begin + // Indexed Header Field + FIndex := b and $7F; + if (Findex = 0) then begin + Raise THPACKException.Create('Illegal index value in Decode'); + end else if (Findex = $7F) then begin + State := THPackState.READ_INDEXED_HEADER; + end else begin + IndexHeader(Findex); + end; + end else if ((b and $40) = $40) then begin + // Literal Header Field with Incremental Indexing + IndexType := THPackIndexType.eHPackINCREMENTAL; + FIndex := b and $3F; + if (Findex = 0) then begin + State := THPackState.READ_LITERAL_HEADER_NAME_LENGTH_PREFIX; + end else if (findex = $3F) then begin + State := THPackState.READ_INDEXED_HEADER_NAME; + end else begin + // Index was stored as the prefix + ReadName(Findex); + State := THPackState.READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX; + end; + end else if ((b and $20) = $20) then begin + // Dynamic Table Size Update + Findex := b and $1F; + if (Findex = $1F) then begin + State := THPackState.READ_MAX_DYNAMIC_TABLE_SIZE; + end else begin + SetDynamicTableSize(Findex); + State := THPackState.READ_HEADER_REPRESENTATION; + end; + end else begin + // Literal Header Field without Indexing / never Indexed + if (b and $10) = $10 then begin + IndexType:=THPackIndexType.eHPackNEVER; + end else begin + IndexType:=THPackIndexType.eHPackNONE; + end; + Findex := b and $0F; + if (Findex = 0) then begin + State := THPackState.READ_LITERAL_HEADER_NAME_LENGTH_PREFIX; + end else if (Findex = $0F) then begin + State := THpackState.READ_INDEXED_HEADER_NAME; + end else begin + // Index was stored as the prefix + ReadName(FIndex); + State := THpackState.READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX; + end; + end; + end; + READ_MAX_DYNAMIC_TABLE_SIZE: begin + MaxSize := decodeULE128(aStream); + if (MaxSize = -1) then begin + exit; + end; + // Check for numerical overflow + if (MaxSize > High(Integer) - Findex) then begin + Raise THPACKException.Create('Decompression exception in Decode-READ_MAX_DYNAMIC_TABLE_SIZE'); + end; + SetDynamicTableSize(Findex + MaxSize); + State := THPackState.READ_HEADER_REPRESENTATION; + end; + READ_INDEXED_HEADER: begin + HeaderIndex := decodeULE128(aStream); + if (HeaderIndex = -1) then begin + exit; + end; + // Check for numerical overflow + if (HeaderIndex > High(Integer) - Findex) then begin + Raise THPACKException.Create('Decompression exception in Decode-READ_INDEXED_HEADER'); + end; + + IndexHeader(Findex + HeaderIndex); + State := THPackState.READ_HEADER_REPRESENTATION; + end; + READ_INDEXED_HEADER_NAME: begin + // Header Name matches an entry in the Header Table + NameIndex := decodeULE128(aStream); + if (NameIndex = -1) then begin + Exit; + end; + + // Check for numerical overflow + if (NameIndex > High(Integer) - Findex) then begin + Raise THPACKException.Create('Decompression exception in Decode-READ_INDEXED_HEADER_NAME'); + end; + + ReadName(Findex + NameIndex); + State := THPackState.READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX; + end; + READ_LITERAL_HEADER_NAME_LENGTH_PREFIX: begin + b := aStream.ReadByte; + HuffmanEncoded := (b and $80) = $80; + Findex := b and $7F; + if (Findex = $7f) then begin + State := THPackState.READ_LITERAL_HEADER_NAME_LENGTH; + end else begin + NameLength := Findex; + + // Disallow empty names -- they cannot be represented in HTTP/1.x + if (NameLength = 0) then begin + Raise THPACKException.Create('Empty name'); + end; + + // Check name length against max header size + if ExceedsMaxHeaderSize(NameLength) then begin + if (IndexType = THPackIndexType.eHPackNONE) then begin + // Name is unused so skip bytes + FName := ''; + SkipLength := NameLength; + State := THPackState.SKIP_LITERAL_HEADER_NAME; + break; + end; + + // Check name length against max dynamic table size + if (NameLength + HPACK_HEADER_ENTRY_OVERHEAD > DynamicTable.Capacity) then begin + DynamicTable.Clear(); + Fname := ''; + SkipLength := NameLength; + State := THPackState.SKIP_LITERAL_HEADER_NAME; + break; + end; + end; + State := THPackState.READ_LITERAL_HEADER_NAME; + end; + end; + READ_LITERAL_HEADER_NAME_LENGTH: begin + // Header Name is a Literal String + NameLength := decodeULE128(aStream); + if (NameLength = -1) then begin + exit; + end; + + // Check for numerical overflow + if (NameLength > High(Integer) - Findex) then begin + Raise THPACKException.Create('Decompression exception in Decode-READ_LITERAL_HEADER_NAME_LENGTH'); + end; + inc(NameLength,Findex); + + // Check name length against max header size + if ExceedsMaxHeaderSize(NameLength) then begin + if (IndexType = THPackIndexType.eHPackNONE) then begin + // Name is unused so skip bytes + Fname := ''; + SkipLength := NameLength; + State := THPackState.SKIP_LITERAL_HEADER_NAME; + break; + end; + + // Check name length against max dynamic table size + if (NameLength + HPACK_HEADER_ENTRY_OVERHEAD > DynamicTable.Capacity) then begin + DynamicTable.Clear(); + Fname := ''; + SkipLength := NameLength; + State := THPackState.SKIP_LITERAL_HEADER_NAME; + break; + end; + State := THPackState.READ_LITERAL_HEADER_NAME; + end; + end; + READ_LITERAL_HEADER_NAME: begin + // Wait until entire name is readable + if (InAvailable() < NameLength) then begin + exit; + end; + + FName := ReadStringLiteral(aStream, NameLength); + + State := THPackState.READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX; + end; + SKIP_LITERAL_HEADER_NAME: begin + SetLength(tmpbuffer,SkipLength); + dec(SkipLength, aStream.Read(tmpbuffer[1],SkipLength)); + + if (SkipLength = 0) then begin + State := THPackState.READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX; + end; + end; + READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX: begin + b := aStream.ReadByte; + HuffmanEncoded := (b and $80) = $80; + Findex := b and $7F; + if (Findex = $7f) then begin + State := THPackState.READ_LITERAL_HEADER_VALUE_LENGTH; + end else begin + ValueLength := Findex; + + // Check new header size against max header size + NewHeaderSize := NameLength + ValueLength; + if ExceedsMaxHeaderSize(NewHeaderSize) then begin + // truncation will be reported during EndHeaderBlockTruncated + HeaderSize := MaxHeaderSize + 1; + + if (IndexType = THPackIndexType.eHPackNONE) then begin + // Value is unused so skip bytes + State := THPackState.SKIP_LITERAL_HEADER_VALUE; + break; + end; + + // Check new header size against max dynamic table size + if NewHeaderSize + HPACK_HEADER_ENTRY_OVERHEAD > DynamicTable.Capacity then begin + DynamicTable.Clear(); + State := THPackState.SKIP_LITERAL_HEADER_VALUE; + break; + end; + end; + + if (ValueLength = 0) then begin + InsertHeader(FName, '', IndexType); + State := THPackState.READ_HEADER_REPRESENTATION; + end else begin + State := THPackState.READ_LITERAL_HEADER_VALUE; + end; + end; + end; + READ_LITERAL_HEADER_VALUE_LENGTH: begin + // Header Value is a Literal String + ValueLength := decodeULE128(aStream); + if (ValueLength = -1) then begin + Exit; + end; + + // Check for numerical overflow + if (ValueLength > High(Integer) - Findex) then begin + Raise THPACKException.Create('Decompression exception in Decode-READ_LITERAL_HEADER_VALUE_LENGTH'); + end; + + inc(ValueLength,Findex); + + // Check new header size against max header size + NewHeaderSize := NameLength + ValueLength; + if (NewHeaderSize + HeaderSize > MaxHeaderSize) then begin + // truncation will be reported during EndHeaderBlockTruncated + HeaderSize := MaxHeaderSize + 1; + + if (IndexType = THPackIndexType.eHPackNONE) then begin + // Value is unused so skip bytes + State := THPackState.SKIP_LITERAL_HEADER_VALUE; + break; + end; + + // Check new header size against max dynamic table size + if (NewHeaderSize + HPACK_HEADER_ENTRY_OVERHEAD > DynamicTable.Capacity) then begin + DynamicTable.Clear(); + State := THPackState.SKIP_LITERAL_HEADER_VALUE; + break; + end; + end; + State := THPackState.READ_LITERAL_HEADER_VALUE; + end; + READ_LITERAL_HEADER_VALUE: begin + // Wait until entire value is readable + if (InAvailable() < ValueLength) then begin + Exit; + end; + + Value := ReadStringLiteral(aStream, ValueLength); + InsertHeader(FName, value, IndexType); + State := THPackState.READ_HEADER_REPRESENTATION; + end; + SKIP_LITERAL_HEADER_VALUE: begin + SetLength(tmpbuffer,ValueLength); + dec(ValueLength, aStream.Read(tmpbuffer[1],ValueLength)); + + if (ValueLength = 0) then begin + State := THPackState.READ_HEADER_REPRESENTATION; + end; + end; + end; + end; +end; + +procedure THPackDecoder.Decode(aString: RawByteString); +var + Stream: TStringStream; +begin + Stream:=TStringStream.Create(aString); + try + Decode(Stream); + finally + Stream.Free; + end; +end; + +function THPackDecoder.GetMaxHeaderTableSize: Integer; +begin + Result:=DynamicTable.Capacity; +end; + +{ THPackDynamicTable } + +procedure THPackDynamicTable.SetCapacity(aCapacity: integer); +(* + * Set the maximum Size of the dynamic table. + * Entries are evicted from the dynamic table until the Size of the table + * is less than or equal to the maximum Size. + *) +var + tmp: array of THPackHeaderField; + MaxEntries: integer; + Len,Cursor, i: integer; + Entry: THPackHeaderField; +begin + if aCapacity < 0 then begin + Raise THPACKException.Create('Illegal Capacity: '+ inttostr(acapacity)); + end; + + // initially FCapacity will be -1 so init won't return here + if FCapacity = aCapacity then begin + exit; + end; + FCapacity := aCapacity; + + if FCapacity = 0 then begin + Clear; + end else begin + // initially FSize will be 0 so remove won't be called + while (FSize > FCapacity) do begin + Remove().Free; + end; + end; + MaxEntries := aCapacity div HPACK_HEADER_ENTRY_OVERHEAD; + if (Acapacity mod HPACK_HEADER_ENTRY_OVERHEAD <> 0) then begin + inc(MaxEntries); + end; + + // check if FCapacity change requires us to reallocate the array + if (Length(FHeaderFields)<>0) and (Length(FHeaderFields) = MaxEntries) then begin + exit; + end; + + SetLength(tmp,MaxEntries); + + // initially length will be 0 so there will be no copy + Len := EntriesCount(); + Cursor := Ftail; + for i := 0 to Pred(Len) do begin + Entry:=FHeaderFields[Cursor]; + inc(Cursor); + tmp[i]:=Entry; + if Cursor=Length(FHeaderFields) then begin + Cursor:=0; + end; + end; + + Ftail := 0; + Fhead := Ftail + Len; + FheaderFields := tmp; + +end; + +procedure THPackDynamicTable.Clear; +begin + while (FTail <> FHead) do begin + FHeaderFields[Ftail].Free; + FHeaderFields[Ftail]:=nil; + inc(FTail); + if FTail = Length(FheaderFields) then begin + FTail := 0; + end; + end; + FHead := 0; + FTail := 0; + FSize := 0; +end; + +function THPackDynamicTable.Remove: THPackHeaderField; +var + Removed: THPackHeaderField; +begin + Removed := FHeaderFields[Ftail]; + if (Removed = nil) then begin + exit(nil); + end; + dec(FSize,Removed.Size()); + FHeaderFields[Ftail] := nil; + inc(FTail); + if FTail = Length(FheaderFields) then begin + FTail := 0; + end; + Result:= Removed; +end; + +function THPackDynamicTable.EntriesCount: integer;{$IFDEF USEINLINE}inline;{$ENDIF} +begin + if FHead < FTail then begin + Result:= Length(FHeaderFields) - FTail + FHead; + end else begin + Result:= FHead - FTail; + end; +end; + +constructor THPackDynamicTable.Create(aInitialCapacity: integer); +begin + SetCapacity(aInitialCapacity); +end; + +destructor THPackDynamicTable.Destroy; +var + j: integer; +begin + for j := Low(FHeaderFields) to High(FHeaderFields) do begin + FHeaderFields[j].Free; + FHeaderFields[j]:=nil; + end; + inherited Destroy; +end; + +procedure THPackDynamicTable.Add(aHeaderField: THPackHeaderField); +var + HeaderSize: integer; +begin + HeaderSize := aHeaderField.size; + if HeaderSize > Fcapacity then begin + Clear; + exit; + end; + while (Fsize + HeaderSize > FCapacity) do begin + Remove().Free; + end; + FHeaderFields[FHead] := aHeaderField; + inc(FHead); + inc(FSize,aHeaderField.Size); + if FHead = Length(FHeaderFields) then begin + FHead := 0; + end; +end; + +function THPackDynamicTable.GetEntry(aIndex: integer): THPackHeaderField; {$IFDEF USEINLINE}inline;{$ENDIF} +var + i: integer; +begin + if (aIndex <= 0) or (aIndex > EntriesCount()) then begin + Raise THPACKException.Create('Index out of bounds in GetEntry'); + end; + i := FHead - aIndex; + if i < 0 then begin + Result:= FHeaderFields[i + Length(FHeaderFields)]; + end else begin + Result:= FHeaderFields[i]; + end; +end; + +function THPackDynamicTable.GetNameIndex(const aName: RawByteString): integer; +var + j: integer; + H: THPackHeaderField; +begin + for j := 1 to Pred(EntriesCount()) do begin + H:=GetEntry(j); + if H.FName=aName then begin + Result:=j; + Exit; + end; + end; + Result:=NOT_FOUND; +end; + +function THPackDynamicTable.GetEntry(const aName, aValue: RawByteString + ): THPackHeaderField; +var + j: integer; + H: THPackHeaderField; +begin + for j := 1 to Pred(EntriesCount()) do begin + H:=GetEntry(j); + if (H.FName=aName) and (H.FValue=aValue) then begin + Result:=H; + Exit; + end; + end; + Result:=nil; +end; + +function THPackDynamicTable.GetEntryIndex(const aName, aValue: RawByteString + ): integer; +var + j: integer; + H: THPackHeaderField; +begin + for j := 1 to Pred(EntriesCount()) do begin + H:=GetEntry(j); + if (H.FName=aName) and (H.FValue=aValue) then begin + Result:=j; + Exit; + end; + end; + Result:=NOT_FOUND; +end; + +function THPackDynamicTable.GetEntryIndex(const aHeader: THPackHeaderField + ): integer; +var + j: integer; + H: THPackHeaderField; +begin + for j := 1 to Pred(EntriesCount()) do begin + H:=GetEntry(j); + if H=aHeader then begin + Result:=j; + Exit; + end; + end; + Result:=NOT_FOUND; +end; + +procedure THPackDynamicTable.EnsureCapacityToHold(const aHeaderSize: integer); +var + Index: integer; +begin + while (Size + aHeaderSize > FCapacity) do begin + Index := EntriesCount; + if Index = 0 then begin + break; + end; + Remove.Free; + end; +end; + +{ THPackHuffmanNode } + +class procedure THPackHuffmanNode.Insert(aRoot: THPackHuffmanNode; + aSymbol: integer; aCode: integer; aLength: BYTE); +var + Current: THPackHuffmanNode; + Terminal: THPackHuffmanNode; + i: integer; + Shift,Start,iEnd: integer; +begin + // traverse tree using the most significant bytes of code + Current:=aRoot; + while (aLength > 8) do begin + if (Current.isTerminal) then begin + Raise THPACKException.Create('Invalid Huffman code: prefix not unique'); + end; + dec(aLength,8); + i := integer((DWORD(aCode) {Unsigned Shift} shr aLength) and DWORD($FF)); + if (Current.FChildren[i] = Nil) then begin + Current.FChildren[i] := THPackHuffmanNode.Create; + end; + Current := Current.FChildren[i]; + end; + + Terminal := THPackHuffmanNode.Create(aSymbol, aLength); + Shift := 8 - aLength; + Start := (aCode shl Shift) and $FF; + iEnd := 1 << Shift; + for i := Start to Pred(Start + iEnd) do begin + Current.FChildren[i]:=Terminal; + end; +end; + +class function THPackHuffmanNode.BuildTree(const aCodes: PDWORD; + const aLengths: PByte): THPackHuffmanNode; +var + Root: THPackHuffmanNode; + i: integer; +begin + Root := THPackHuffmanNode.Create; + for i := 0 to Pred(HPACK_HUFFMAN_CODES_LENGTH) do begin + Insert(Root,i,aCodes[i],aLengths[i]); + end; + Result:=Root; +end; + +constructor THPackHuffmanNode.Create; +begin + FSymbol := 0; + FBits := 8; + SetLength(FChildren,256); +end; + +constructor THPackHuffmanNode.Create(aSymbol: integer; aBits: integer); +begin + //assert(FBits > 0 && FBits <= 8); + if (aBits<1) or (aBits > 8) then begin + Raise THPACKException.Create('BUG'); + end; + FSymbol := aSymbol; + FBits := aBits; + SetLength(FChildren,0); +end; + +destructor THPackHuffmanNode.Destroy; +var + j,i: Integer; + Node: THPackHuffmanNode; +begin + for j := Low(FChildren) to high(FChildren) do begin + Node:=FChildren[j]; + if Assigned(Node) then begin + for i := j to High(FChildren) do begin + if Node=FChildren[i] then begin + FChildren[i]:=nil; + end; + end; + end; + Node.Free; + end; + inherited Destroy; +end; + +function THPackHuffmanNode.isTerminal: Boolean; +begin + if Length(FChildren)=0 then begin + Result:=true; + end else begin + Result:=false; + end; +end; + +{ THPackHuffmanDecoder } + +constructor THPackHuffmanDecoder.Create; +begin + Create(HPackHuffmanCodes,HPackHuffmanCodeLength); +end; + +constructor THPackHuffmanDecoder.Create(const aCodes: PDWORD; + const aLengths: PByte); +begin + FCodes:=aCodes; + FLengths:=aLengths; + FRoot:=THPackHuffmanNode.BuildTree(aCodes,aLengths); +end; + +destructor THPackHuffmanDecoder.Destroy; +begin + FreeAndNil(FRoot); + inherited Destroy; +end; + +function THPackHuffmanDecoder.Decode(aBuf: RawByteString): RawByteString; +var + WritePoint: integer; + RealSize: integer; + Node: THPackHuffmanNode; + Current: integer; + Bits: Integer; + i,b,c: Integer; + Mask: integer; + OutputBuffer: RawByteString; + procedure WriteByte(const aByte: Byte); {$IFDEF USEINLINE}inline;{$ENDIF} + begin + if WritePoint>RealSize then begin + SetLength(OutputBuffer,RealSize*2); + RealSize:=RealSize*2; + end; + Byte(OutputBuffer[WritePoint]):=aByte; + inc(WritePoint); + end; +begin + if aBuf='' then begin + Result:=''; + exit; + end; + WritePoint:=1; + RealSize:=Length(aBuf)*2; //Huffman usually reach a 50% compress at best. + SetLength(OutputBuffer,RealSize); + Node := FRoot; + Current := 0; + Bits := 0; + for i := 0 to Pred(Length(aBuf)) do begin + b := Byte(aBuf[i+1]); + Current := (current shl 8) or b; + inc(Bits,8); + while (Bits >= 8) do begin + c := integer((DWORD(Current) {unsigned shift} shr (Bits - 8)) and DWORD($FF)); + Node := Node.FChildren[c]; + dec(Bits,Node.FBits); + if (Node.isTerminal) then begin + if (Node.FSymbol = HPACK_HUFFMAN_EOS) then begin + Raise THPACKException.Create('EOS_DECODED'); + end; + WriteByte(Byte(Node.FSymbol)); + Node := Froot; + end; + end; + end; + while (Bits > 0) do begin + c := (current shl (8 - Bits)) and $FF; + Node := Node.FChildren[c]; + if (Node.isTerminal and (Node.FBits <= Bits)) then begin + dec(Bits,Node.FBits); + WriteByte(Byte(Node.FSymbol)); + Node := Froot; + end else begin + break; + end; + end; + + // Section 5.2. String Literal Representation + // Padding not corresponding to the most significant Bits of the code + // for the EOS symbol (0xFF) MUST be treated as a decoding error. + Mask := (1 shl Bits) - 1; + if (current and Mask) <> Mask then begin + Raise THPACKException.Create('INVALID_PADDING'); + end; + SetLength(OutputBuffer,WritePoint-1); + Result:=OutputBuffer; +end; + +{ THPackHuffmanEncoder } + +constructor THPackHuffmanEncoder.Create; +begin + Create(HPackHuffmanCodes,HPackHuffmanCodeLength); +end; + +constructor THPackHuffmanEncoder.Create(const aCodes: PDWORD; + const aLengths: PByte); +begin + FCodes:=aCodes; + FLengths:=aLengths; +end; + +procedure THPackHuffmanEncoder.Encode(aOutputStream: TStream; aData: RawByteString); +begin + Encode(aOutputStream, aData, 0, Length(aData)); +end; + +procedure THPackHuffmanEncoder.Encode(aOutputStream: TStream; + aData: RawByteString; aOff, aLen: integer); +var + Current: DWORD=0; + n: integer=0; + i: integer; + Code: DWORD; + b,nBits: integer; + v: DWORD; +begin + if not Assigned(aOutputStream) then begin + Raise THPACKException.Create('Output stream is nil'); + end else if aData = '' then begin + Raise THPACKException.Create('Data is empty'); + end else if ((aOff < 0) or (aLen < 0) or ((aOff + aLen) < 0) or (aOff > Length(aData)) or ((aOff + aLen) > Length(aData))) then begin + Raise THPACKException.Create('Index out of bounds'); + end else if aLen = 0 then begin + exit; + end; + + for i := 0 to Pred(aLen) do begin + b := BYTE(aData[aOff + i + 1]) and $FF; + Code := FCodes[b]; + nBits := FLengths[b]; + + Current := Current shl nBits; + Current := Current or Code; + inc(n,nBits); + + while (n >= 8) do begin + dec(n,8); + v:=Current shr n; + aOutputStream.WriteByte(Byte(v)); + end; + end; + + if (n > 0) then begin + Current := Current shl (8-n); + Current:=Current or (DWORD($FF) {unsigned shift} shr n); // this should be EOS symbol + aOutputStream.WriteByte(Byte(Current)); + end; +end; + +function THPackHuffmanEncoder.GetEncodedLength(aData: RawByteString + ): integer; +var + Len: integer; + i: integer; +begin + if aData = '' then begin + Raise THPACKException.Create('Data is empty'); + end; + + Len := 0; + for i := 1 to Length(aData) do begin + inc(Len,FLengths[BYTE(aData[i])]); + end; + Result:=(Len + 7) shr 3; +end; + +{ THPackHeaderField } + +class function THPackHeaderField.SizeOf(const aName, aValue: RawByteString + ): Integer; +begin + Result:=Length(aName) + Length(aValue) + HEADER_ENTRY_OVERHEAD; +end; + +constructor THPackHeaderField.Create(const aName, aValue: RawByteString); +begin + FName:=aName; + FValue:=aValue; +end; + +function THPackHeaderField.Size: Integer; +begin + Result:=Length(FName) + Length(FValue) + HEADER_ENTRY_OVERHEAD; +end; + +initialization + THPackStaticTable.InitializeStaticTable; +finalization; + THPackStaticTable.DestroyStaticTable; + +end. + diff --git a/packages/fcl-web/src/hpack/uhpacktables.pp b/packages/fcl-web/src/hpack/uhpacktables.pp new file mode 100644 index 0000000000..f79e919ea4 --- /dev/null +++ b/packages/fcl-web/src/hpack/uhpacktables.pp @@ -0,0 +1,94 @@ +unit uhpacktables; + +interface + +const + + HPACK_HUFFMAN_CODES_LENGTH=257; + + HPackHuffmanCodes: array [0..HPACK_HUFFMAN_CODES_LENGTH-1] of DWORD =( + $1ff8, $7fffd8, $fffffe2, $fffffe3, $fffffe4, $fffffe5, $fffffe6, $fffffe7, + $fffffe8, $ffffea, $3ffffffc, $fffffe9, $fffffea, $3ffffffd, $fffffeb, $fffffec, + $fffffed, $fffffee, $fffffef, $ffffff0, $ffffff1, $ffffff2, $3ffffffe, $ffffff3, + $ffffff4, $ffffff5, $ffffff6, $ffffff7, $ffffff8, $ffffff9, $ffffffa, $ffffffb, + $14, $3f8, $3f9, $ffa, $1ff9, $15, $f8, $7fa, + $3fa, $3fb, $f9, $7fb, $fa, $16, $17, $18, + $0, $1, $2, $19, $1a, $1b, $1c, $1d, + $1e, $1f, $5c, $fb, $7ffc, $20, $ffb, $3fc, + $1ffa, $21, $5d, $5e, $5f, $60, $61, $62, + $63, $64, $65, $66, $67, $68, $69, $6a, + $6b, $6c, $6d, $6e, $6f, $70, $71, $72, + $fc, $73, $fd, $1ffb, $7fff0, $1ffc, $3ffc, $22, + $7ffd, $3, $23, $4, $24, $5, $25, $26, + $27, $6, $74, $75, $28, $29, $2a, $7, + $2b, $76, $2c, $8, $9, $2d, $77, $78, + $79, $7a, $7b, $7ffe, $7fc, $3ffd, $1ffd, $ffffffc, + $fffe6, $3fffd2, $fffe7, $fffe8, $3fffd3, $3fffd4, $3fffd5, $7fffd9, + $3fffd6, $7fffda, $7fffdb, $7fffdc, $7fffdd, $7fffde, $ffffeb, $7fffdf, + $ffffec, $ffffed, $3fffd7, $7fffe0, $ffffee, $7fffe1, $7fffe2, $7fffe3, + $7fffe4, $1fffdc, $3fffd8, $7fffe5, $3fffd9, $7fffe6, $7fffe7, $ffffef, + $3fffda, $1fffdd, $fffe9, $3fffdb, $3fffdc, $7fffe8, $7fffe9, $1fffde, + $7fffea, $3fffdd, $3fffde, $fffff0, $1fffdf, $3fffdf, $7fffeb, $7fffec, + $1fffe0, $1fffe1, $3fffe0, $1fffe2, $7fffed, $3fffe1, $7fffee, $7fffef, + $fffea, $3fffe2, $3fffe3, $3fffe4, $7ffff0, $3fffe5, $3fffe6, $7ffff1, + $3ffffe0, $3ffffe1, $fffeb, $7fff1, $3fffe7, $7ffff2, $3fffe8, $1ffffec, + $3ffffe2, $3ffffe3, $3ffffe4, $7ffffde, $7ffffdf, $3ffffe5, $fffff1, $1ffffed, + $7fff2, $1fffe3, $3ffffe6, $7ffffe0, $7ffffe1, $3ffffe7, $7ffffe2, $fffff2, + $1fffe4, $1fffe5, $3ffffe8, $3ffffe9, $ffffffd, $7ffffe3, $7ffffe4, $7ffffe5, + $fffec, $fffff3, $fffed, $1fffe6, $3fffe9, $1fffe7, $1fffe8, $7ffff3, + $3fffea, $3fffeb, $1ffffee, $1ffffef, $fffff4, $fffff5, $3ffffea, $7ffff4, + $3ffffeb, $7ffffe6, $3ffffec, $3ffffed, $7ffffe7, $7ffffe8, $7ffffe9, $7ffffea, + $7ffffeb, $ffffffe, $7ffffec, $7ffffed, $7ffffee, $7ffffef, $7fffff0, $3ffffee, + $3fffffff // EOS + ); + + HPackHuffmanCodeLength: array [0..256] of byte =( + 13, 23, 28, 28, 28, 28, 28, 28, 28, 24, 30, 28, 28, 30, 28, 28, + 28, 28, 28, 28, 28, 28, 30, 28, 28, 28, 28, 28, 28, 28, 28, 28, + 6, 10, 10, 12, 13, 6, 8, 11, 10, 10, 8, 11, 8, 6, 6, 6, + 5, 5, 5, 6, 6, 6, 6, 6, 6, 6, 7, 8, 15, 6, 12, 10, + 13, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 8, 7, 8, 13, 19, 13, 14, 6, + 15, 5, 6, 5, 6, 5, 6, 6, 6, 5, 7, 7, 6, 6, 6, 5, + 6, 7, 6, 5, 5, 6, 7, 7, 7, 7, 7, 15, 11, 14, 13, 28, + 20, 22, 20, 20, 22, 22, 22, 23, 22, 23, 23, 23, 23, 23, 24, 23, + 24, 24, 22, 23, 24, 23, 23, 23, 23, 21, 22, 23, 22, 23, 23, 24, + 22, 21, 20, 22, 22, 23, 23, 21, 23, 22, 22, 24, 21, 22, 23, 23, + 21, 21, 22, 21, 23, 22, 23, 23, 20, 22, 22, 22, 23, 22, 22, 23, + 26, 26, 20, 19, 22, 23, 22, 25, 26, 26, 26, 27, 27, 26, 24, 25, + 19, 21, 26, 27, 27, 26, 27, 24, 21, 21, 26, 26, 28, 27, 27, 27, + 20, 24, 20, 21, 22, 21, 21, 23, 22, 22, 25, 25, 24, 24, 26, 23, + 26, 27, 26, 26, 27, 27, 27, 27, 27, 28, 27, 27, 27, 27, 27, 26, + 30 // EOS + ); + + HPACK_HUFFMAN_EOS: integer = 256; + + HPACK_HEADER_ENTRY_OVERHEAD = 32; + +type + THPackIndexType=( + eHPackINCREMENTAL, // Section 6.2.1. Literal Header Field with Incremental Indexing + eHPackNONE, // Section 6.2.2. Literal Header Field without Indexing + eHPackNEVER // Section 6.2.3. Literal Header Field never Indexed + ); + + THPackState =( + READ_HEADER_REPRESENTATION, + READ_MAX_DYNAMIC_TABLE_SIZE, + READ_INDEXED_HEADER, + READ_INDEXED_HEADER_NAME, + READ_LITERAL_HEADER_NAME_LENGTH_PREFIX, + READ_LITERAL_HEADER_NAME_LENGTH, + READ_LITERAL_HEADER_NAME, + SKIP_LITERAL_HEADER_NAME, + READ_LITERAL_HEADER_VALUE_LENGTH_PREFIX, + READ_LITERAL_HEADER_VALUE_LENGTH, + READ_LITERAL_HEADER_VALUE, + SKIP_LITERAL_HEADER_VALUE + ); + +implementation + +end. + diff --git a/packages/fcl-web/tests/README.txt b/packages/fcl-web/tests/README.txt new file mode 100644 index 0000000000..a5b95202c4 --- /dev/null +++ b/packages/fcl-web/tests/README.txt @@ -0,0 +1,5 @@ +In order to run the HPACK testcase, you must download and unzip the HPACK testsuite: + +https://github.com/http2jp/hpack-test-case + +The test code expects to find it under the 'hpack-test-case-master' directory. diff --git a/packages/fcl-web/tests/fpcunithpack.lpi b/packages/fcl-web/tests/fpcunithpack.lpi new file mode 100644 index 0000000000..e177ad84c8 --- /dev/null +++ b/packages/fcl-web/tests/fpcunithpack.lpi @@ -0,0 +1,122 @@ + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <i18n> + <EnableI18N LFM="False"/> + </i18n> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="3"> + <Item1 Name="Default" Default="True"/> + <Item2 Name="Debug"> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <Target> + <Filename Value="fpcunithpack"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\src"/> + </SearchPaths> + <Parsing> + <SyntaxOptions> + <IncludeAssertionCode Value="True"/> + </SyntaxOptions> + </Parsing> + <CodeGeneration> + <Checks> + <IOChecks Value="True"/> + <RangeChecks Value="True"/> + <OverflowChecks Value="True"/> + <StackChecks Value="True"/> + </Checks> + </CodeGeneration> + <Linking> + <Debugging> + <UseHeaptrc Value="True"/> + <UseExternalDbgSyms Value="True"/> + </Debugging> + </Linking> + </CompilerOptions> + </Item2> + <Item3 Name="Release"> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\src"/> + </SearchPaths> + <CodeGeneration> + <SmartLinkUnit Value="True"/> + <Optimizations> + <OptimizationLevel Value="3"/> + </Optimizations> + </CodeGeneration> + <Linking> + <Debugging> + <GenerateDebugInfo Value="False"/> + </Debugging> + <LinkSmart Value="True"/> + </Linking> + </CompilerOptions> + </Item3> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + <CommandLineParams Value="--all"/> + </local> + </RunParams> + <RequiredPackages Count="1"> + <Item1> + <PackageName Value="FCL"/> + </Item1> + </RequiredPackages> + <Units Count="2"> + <Unit0> + <Filename Value="fpcunithpack.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="uhpacktest1.pas"/> + <IsPartOfProject Value="True"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <PathDelim Value="\"/> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="..\src"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fcl-web/tests/fpcunithpack.lpr b/packages/fcl-web/tests/fpcunithpack.lpr new file mode 100644 index 0000000000..279bc04fa2 --- /dev/null +++ b/packages/fcl-web/tests/fpcunithpack.lpr @@ -0,0 +1,27 @@ +program fpcunithpack; + +{$mode objfpc}{$H+} + +uses + Classes, consoletestrunner, uhpacktest1,sysutils; + +type + + { TLazTestRunner } + + TMyTestRunner = class(TTestRunner) + protected + // override the protected methods of TTestRunner to customize its behavior + end; + +var + Application: TMyTestRunner; + +begin + DefaultFormat:=fPlain; + DefaultRunAllTests:=True; + Application := TMyTestRunner.Create(nil); + Application.Initialize; + Application.Run; + Application.Free; +end. diff --git a/packages/fcl-web/tests/uhpacktest1.pas b/packages/fcl-web/tests/uhpacktest1.pas new file mode 100644 index 0000000000..4366553a45 --- /dev/null +++ b/packages/fcl-web/tests/uhpacktest1.pas @@ -0,0 +1,889 @@ +(* + * Test program for pascal HPack for http2 + * + * This test code uses sample headers from https://github.com/http2jp/hpack-test-case + * to test decoding of available samples and then reencode and decode again + * using plain only, indexing only, huffman only, and both at same time. + * + * The JSON parsing adds around a 15% speed penalty. + * + *) + +unit uhpacktest1; + +{$mode objfpc}{$H+} + +{$DEFINE QUIET} +{$DEFINE FULL_QUIET} + +{$IFDEF FULL_QUIET} + {$DEFINE QUIET} +{$ENDIF} + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, uhpack, fpjson, jsonparser, jsonscanner; + +type + + { THPackTestCaseCycle } + + THPackTestCaseCycle= class(TTestCase) + private + HPDecoder: THPackDecoder; + HPIntfDecoderPlain: THPackDecoder; + HPIntfDecoderPlainIndexed: THPackDecoder; + HPIntfDecoderHuffman: THPackDecoder; + HPIntfDecoderHuffmanIndexed: THPackDecoder; + HPIntfEncoderPlain: THPackEncoder; + HPIntfEncoderPlainIndexed: THPackEncoder; + HPIntfEncoderHuffman: THPackEncoder; + HPIntfEncoderHuffmanIndexed: THPackEncoder; + SequenceCounter: integer; + StoryCounter: integer; + GroupsCounter: integer; + WireBytes: integer; + DecodedBytes: integer; + procedure TestThisSequence(const aGroup: integer; const aStory: integer; const aJSon: TJSONData); + procedure TestCaseStory(const aGroup: integer; const aStory: integer; const aJSon: TJSONData); + procedure RunSampleHeadersTest; + protected + function GetTestName: string; override; + published + procedure TestHookUp; + end; + + { THPackTestDecoder } + + THPackTestDecoder= class(TTestCase) + private + HPDecoder: THPackDecoder; + DummyDecoder: THPackDecoder; + DummyEncoder: THPackEncoder; + protected + procedure SetUp; override; + procedure TearDown; override; + published + procedure VerifyIncompleteIndexRead; + procedure InvalidTableIndexZero; + procedure IndexShiftOverflow; + procedure DynamicTableSizeUpdate; + procedure DynamicTableSizeUpdateRequired; + procedure IllegalDynamicTableSizeUpdate; + procedure MaxDynamicTableSizeSignOverflow; + procedure ReduceMaxDynamicTableSize; + procedure TooLargeDynamicTableSizeUpdate; + procedure MissingDynamicTableSizeUpdate; + procedure LiteralWithIncrementalIndexingWithEmptyName; + procedure LiteralWithIncrementalIndexingCompleteEviction; + procedure LiteralWithIncrementalIndexingWithLargeName; + procedure LiteralWithIncrementalIndexingWithLargeValue; + procedure LiteralWithoutIndexingWithEmptyName; + procedure LiteralWithoutIndexingWithLargeName; + procedure LiteralWithoutIndexingWithLargeValue; + procedure LiteralNeverIndexedWithEmptyName; + procedure LiteralNeverIndexedWithLargeName; + procedure LiteralNeverIndexedWithLargeValue; + end; + +implementation + +function HexToBinString(aHex: RawByteString): RawByteString; +var + j: integer; + t: integer; +begin + t:=0; + for j := 1 to Length(aHex) do begin + if (aHex[j] in ['a'..'f','A'..'F','0'..'9']) then begin + inc(t); + if t<>j then begin + aHex[t]:=aHex[j]; + end; + end else begin + if (aHex[j]<>#32) and (aHex[j]<>'-') then begin + Raise Exception.Create('Internal: Invalid hex format character'); + end; + end; + end; + if t<>j then SetLength(aHex,t); + if t mod 2 <>0 then begin + Raise Exception.Create('Internal: Invalid hex chars count (odd)'); + end; + SetLength(Result,Length(aHex) div 2); + HexToBin(@aHex[1],@Result[1],Length(Result)); +end; + +function BinStringToHex(const aBinString: string): string; +begin + Result:=''; + SetLength(Result,Length(aBinString)*2); + BinToHex(@aBinString[1],@Result[1],Length(aBinString)); +end; + +function ErrorHeader(const aString: string): string; +begin + if Length(aString)<38 then begin + Result:='**'+aString+StringOfChar('*',38-Length(aString)); + end else begin + Result:='**'+aString+'**'; + end; +end; + +{ THPackTestDecoder } + +procedure THPackTestDecoder.SetUp; +begin + //Setup 2 dummy encoder & decoder to avoid multiple + //creation of internal tables. This should be fixed some + //way in the future. + DummyDecoder:=THPackDecoder.Create; + DummyEncoder:=THPackEncoder.Create; + inherited SetUp; +end; + +procedure THPackTestDecoder.TearDown; +begin + FreeAndNil(DummyEncoder); + FreeAndNil(DummyDecoder); + inherited TearDown; +end; + +procedure THPackTestDecoder.VerifyIncompleteIndexRead; +var + Data: TStringStream; +begin + Data:=TStringStream.Create(HexToBinString('FFF0')); + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(Data); + AssertEquals(Data.Size-Data.Position,1); + HPDecoder.Decode(Data); + AssertEquals(Data.Size-Data.Position,1); + finally + Data.Free; + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.InvalidTableIndexZero; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('80')); + FAIL('Exception missing'); + except + on e: Exception do begin + if not (e is THPACKException) then begin + Raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.IndexShiftOverflow; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('FF8080808008')); + FAIL('Exception missing'); + except + on e: Exception do begin + if not (e is THPACKException) then begin + Raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.DynamicTableSizeUpdate; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('20')); + AssertEquals(0,HPDecoder.GetMaxHeaderTableSize); + HPDecoder.Decode(HexToBinString('3FE11F')); + assertEquals(4096, HPDecoder.GetMaxHeaderTableSize); + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.DynamicTableSizeUpdateRequired; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.SetMaxHeaderTableSize(32); + HPDecoder.Decode(HexToBinString('3F00')); + assertEquals(31, HPDecoder.GetMaxHeaderTableSize); + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.IllegalDynamicTableSizeUpdate; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('3FE21F')); + FAIL('Exception missing'); + except + on e: Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.MaxDynamicTableSizeSignOverflow; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('3FE1FFFFFF07')); + except + on e: Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.ReduceMaxDynamicTableSize; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.SetMaxHeaderTableSize(0); + AssertEquals(0, HPDecoder.GetMaxHeaderTableSize()); + HPDecoder.Decode(HexToBinString('2081')); + AssertEquals(0, HPDecoder.GetMaxHeaderTableSize()); + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.TooLargeDynamicTableSizeUpdate; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.SetMaxHeaderTableSize(0); + AssertEquals(0, HPDecoder.GetMaxHeaderTableSize()); + try + HPDecoder.Decode(HexToBinString('21')); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.MissingDynamicTableSizeUpdate; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.SetMaxHeaderTableSize(0); + AssertEquals(0, HPDecoder.GetMaxHeaderTableSize()); + try + HPDecoder.Decode(HexToBinString('81')); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithIncrementalIndexingWithEmptyName; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('000005')+'value'); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithIncrementalIndexingCompleteEviction; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('4004')+'name'+HexToBinString('05')+'value'); + AssertFalse(HPDecoder.EndHeaderBlockTruncated); + HPDecoder.Decode(HexToBinString('417F811F')+StringOfChar('a',4096)); + AssertFalse(HPDecoder.EndHeaderBlockTruncated); + HPDecoder.Decode(HexToBinString('4004')+'name'+ HexToBinString('05')+'value'+HexToBinString('BE')); + AssertEquals('name',HPDecoder.DecodedHeaders[0]^.HeaderName); + AssertEquals('value',HPDecoder.DecodedHeaders[0]^.HeaderValue); + AssertEquals('name',HPDecoder.DecodedHeaders[1]^.HeaderName); + AssertEquals('value',HPDecoder.DecodedHeaders[1]^.HeaderValue); + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithIncrementalIndexingWithLargeName; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('417F811F')+StringOfChar('a',16384)+HexToBinString('00')); + // Verify header block is reported as truncated + AssertTrue(HPDecoder.EndHeaderBlockTruncated); + // Verify next header is inserted at index 62 + HPDecoder.Decode(HexToBinString('4004')+'name'+ HexToBinString('05')+'value'+HexToBinString('BE')); + AssertEquals('name',HPDecoder.DecodedHeaders[0]^.HeaderName); + AssertEquals('value',HPDecoder.DecodedHeaders[0]^.HeaderValue); + AssertEquals('name',HPDecoder.DecodedHeaders[1]^.HeaderName); + AssertEquals('value',HPDecoder.DecodedHeaders[1]^.HeaderValue); + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithIncrementalIndexingWithLargeValue; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('4004')+'name'+HexToBinString('7F813F')+StringOfChar('a',8192)); + // Verify header block is reported as truncated + AssertTrue(HPDecoder.EndHeaderBlockTruncated); + // Verify next header is inserted at index 62 + HPDecoder.Decode(HexToBinString('4004')+'name'+ HexToBinString('05')+'value'+HexToBinString('BE')); + AssertEquals('name',HPDecoder.DecodedHeaders[0]^.HeaderName); + AssertEquals('value',HPDecoder.DecodedHeaders[0]^.HeaderValue); + AssertEquals('name',HPDecoder.DecodedHeaders[1]^.HeaderName); + AssertEquals('value',HPDecoder.DecodedHeaders[1]^.HeaderValue); + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithoutIndexingWithEmptyName; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('000005')+'value'); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithoutIndexingWithLargeName; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('007F817F')+StringOfChar('a',16384)+HexToBinString('00')); + // Verify header block is reported as truncated + AssertTrue(HPDecoder.EndHeaderBlockTruncated); + try + HPDecoder.Decode(HexToBinString('BE')); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralWithoutIndexingWithLargeValue; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('0004')+'name'+HexToBinString('7F813F')+StringOfChar('a',8192)); + // Verify header block is reported as truncated + AssertTrue(HPDecoder.EndHeaderBlockTruncated); + try + HPDecoder.Decode(HexToBinString('BE')); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralNeverIndexedWithEmptyName; +begin + HPDecoder:=THPackDecoder.Create; + try + try + HPDecoder.Decode(HexToBinString('100005')+'value'); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralNeverIndexedWithLargeName; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('107F817F')+StringOfChar('a',16384)+HexToBinString('00')); + // Verify header block is reported as truncated + AssertTrue(HPDecoder.EndHeaderBlockTruncated); + try + HPDecoder.Decode(HexToBinString('BE')); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestDecoder.LiteralNeverIndexedWithLargeValue; +begin + HPDecoder:=THPackDecoder.Create; + try + HPDecoder.Decode(HexToBinString('1004')+'name'+HexToBinString('7F813F')+StringOfChar('a',8192)); + // Verify header block is reported as truncated + AssertTrue(HPDecoder.EndHeaderBlockTruncated); + try + HPDecoder.Decode(HexToBinString('BE')); + FAIL('Exception missing'); + except + on E:Exception do begin + if not (e is THPACKException) then begin + raise; + end; + end; + end; + finally + FreeAndNil(HPDecoder); + end; +end; + +procedure THPackTestCaseCycle.TestHookUp; +begin + RunSampleHeadersTest; +end; + +function THPackTestCaseCycle.GetTestName: string; +begin + Result:='Sample headers cycled'; +end; + +procedure THPackTestCaseCycle.TestThisSequence(const aGroup: integer; const aStory: integer; const aJSon: TJSONData); +var + HeadersPath: TJSonData; + HexWire: string; + BinWire: RawByteString; + BinWire2: RawByteString; + Sequence: integer; + ExpectedHeaders: THPackHeaderTextList; + j, HeaderTableSize: integer; + lName,lValue: string; + TestPassed: integer; + function GetInteger(const aPath: string; const aOptional: Boolean=false): integer; + var + tmp: TJSonData; + begin + tmp:=aJSon.FindPath(aPath); + if Assigned(tmp) then begin + Result:=tmp.AsInteger; + end else begin + if not aOptional then begin + Raise Exception.Create('Missing '+aPath); + end else begin + Result:=-1; + end; + end; + end; + function GetString(const aPath: string): String; + var + tmp: TJSonData; + begin + tmp:=aJSon.FindPath(aPath); + if Assigned(tmp) then begin + Result:=tmp.AsString; + end else begin + Raise Exception.Create('Missing '+aPath); + end; + end; + procedure GetHeadersPair(const aHeaders: TJSonData; out aName,aValue: string); + var + Enumerator: TBaseJSONEnumerator; + begin + aName:=''; + aValue:=''; + if aHeaders.Count<>1 then begin + Raise Exception.Create('Unexpected headers count = '+aHeaders.AsJSON); + end; + Enumerator:=aHeaders.GetEnumerator; + try + if Assigned(Enumerator) then begin + if Enumerator.MoveNext then begin + aName:=Enumerator.Current.Key; + aValue:=Enumerator.Current.Value.AsString; + if Enumerator.MoveNext then begin + Raise Exception.Create('Too many header parts, expected A=B'); + end; + Exit; + end; + end; + Raise Exception.Create('Unexpected reach'); + finally + Enumerator.Free; + end; + end; + + function EncodeHeaders(const aEncoder: THPackEncoder; const aHeadersList: THPackHeaderTextList): String; + var + OutStream: TStringStream; + j: integer; + begin + Result:=''; + OutStream:=TStringStream.Create(''); + try + for j := 0 to Pred(aHeadersList.Count) do begin + aEncoder.EncodeHeader(OutStream,aHeadersList[j]^.HeaderName,aHeadersList[j]^.HeaderValue,aHeadersList[j]^.IsSensitive); + end; + Result:=OutStream.DataString; + finally + FreeAndNil(OutStream); + end; + end; + +begin + TestPassed:=0; + Sequence:=GetInteger('seqno'); + HexWire:=GetString('wire'); + HeaderTableSize:=GetInteger('header_table_size',true); + if HeaderTableSize=-1 then begin + HeaderTableSize:=HPACK_MAX_HEADER_TABLE_SIZE; + end; + if HeaderTableSize<>HPDecoder.GetMaxHeaderTableSize then begin + {$IFNDEF QUIET} + writeln('Max header table size changed from ',HPDecoder.GetMaxHeaderTableSize,' to ',HeaderTableSize); + {$ENDIF} + HPDecoder.SetMaxHeaderTableSize(HeaderTableSize); + end; + ExpectedHeaders:=THPackHeaderTextList.Create; + {$IFNDEF QUIET} + write('SEQ: ',aGroup,'-',aStory,'-',Sequence,#13); + {$ENDIF} + try + HeadersPath:=aJSon.FindPath('headers'); + if not Assigned(HeadersPath) then begin + Raise Exception.Create('Missing headers'); + end; + for j := 0 to Pred(HeadersPath.Count) do begin + GetHeadersPair(HeadersPath.Items[j],lName,lValue); + ExpectedHeaders.Add(lName,lValue); + end; + BinWire:=HexToBinString(HexWire); + HPDecoder.Decode(BinWire); + if HPDecoder.EndHeaderBlockTruncated then begin + raise Exception.Create('FAIL EndHeaderBlock'); + end; + if HPDecoder.DecodedHeaders.Text<>ExpectedHeaders.Text then begin + raise Exception.Create('Expected headers different than decoded ones.'); + end; + + TestPassed:=1; + + // Now reencode with our engine and decode again, result must be the same. + BinWire2:=EncodeHeaders(HPIntfEncoderPlain,ExpectedHeaders); + HPIntfDecoderPlain.Decode(BinWire2); + if HPIntfDecoderPlain.EndHeaderBlockTruncated then begin + raise Exception.Create('FAIL EndHeaderBlock REcoded (Plain).'); + end; + if HPIntfDecoderPlain.DecodedHeaders.Text<>ExpectedHeaders.Text then begin + raise Exception.Create('Expected headers different than REcoded ones (Plain).'); + end; + + TestPassed:=2; + + // Now reencode with our engine and decode again, result must be the same. + BinWire2:=EncodeHeaders(HPIntfEncoderPlainIndexed,ExpectedHeaders); + HPIntfDecoderPlainIndexed.Decode(BinWire2); + if HPIntfDecoderPlainIndexed.EndHeaderBlockTruncated then begin + raise Exception.Create('FAIL EndHeaderBlock REcoded (Plain & Indexed).'); + end; + if HPIntfDecoderPlainIndexed.DecodedHeaders.Text<>ExpectedHeaders.Text then begin + raise Exception.Create('Expected headers different than REcoded ones (Plain & Indexed).'); + end; + + TestPassed:=3; + + // Now reencode with our engine using huffman and decode again, result must be the same. + BinWire2:=EncodeHeaders(HPIntfEncoderHuffman,ExpectedHeaders); + HPIntfDecoderHuffman.Decode(BinWire2); + if HPIntfDecoderHuffman.EndHeaderBlockTruncated then begin + raise Exception.Create('FAIL EndHeaderBlock REcoded (Huffman).'); + end; + if HPIntfDecoderHuffman.DecodedHeaders.Text<>ExpectedHeaders.Text then begin + raise Exception.Create('Expected headers different than REcoded ones (Huffman).'); + end; + + TestPassed:=4; + + // Now reencode with our engine using huffman & indexed and decode again, result must be the same. + BinWire2:=EncodeHeaders(HPIntfEncoderHuffmanIndexed,ExpectedHeaders); + HPIntfDecoderHuffmanIndexed.Decode(BinWire2); + if HPIntfDecoderHuffmanIndexed.EndHeaderBlockTruncated then begin + raise Exception.Create('FAIL EndHeaderBlock REcoded (Huffman & Indexed).'); + end; + if HPIntfDecoderHuffmanIndexed.DecodedHeaders.Text<>ExpectedHeaders.Text then begin + raise Exception.Create('Expected headers different than REcoded ones (Huffman & Indexed).'); + end; + inc(DecodedBytes,Length(HPIntfDecoderHuffmanIndexed.DecodedHeaders.Text)); + inc(WireBytes,Length(BinWire2)); + + TestPassed:=1000; + finally + if TestPassed<1000 then begin + {$IFNDEF FULL_QUIET} + writeln(StdErr,ErrorHeader('TEST FAIL - Section passed '+inttostr(TestPassed))); + writeln(StdErr,ErrorHeader('Expected headers')); + writeln(StdErr,ExpectedHeaders.Text); + writeln(StdErr,ErrorHeader('Got headers')); + case TestPassed of + 0: writeln(StdErr,HPDecoder.DecodedHeaders.Text); + 1: writeln(StdErr,HPIntfDecoderPlain.DecodedHeaders.Text); + 2: writeln(StdErr,HPIntfDecoderPlainIndexed.DecodedHeaders.Text); + 3: writeln(StdErr,HPIntfDecoderHuffman.DecodedHeaders.Text); + 4: writeln(StdErr,HPIntfDecoderHuffmanIndexed.DecodedHeaders.Text); + else + writeln(StdErr,'Unknown decoder in use.'); + end; + writeln(StdErr,ErrorHeader('Location')); + writeln(StdErr,'SEQ: ',aGroup,'-',aStory,'-',Sequence); + {$ENDIF} + end else begin + inc(SequenceCounter); + end; + ExpectedHeaders.Free; + end; +end; + +procedure THPackTestCaseCycle.TestCaseStory(const aGroup: integer; const aStory: integer; + const aJSon: TJSONData); +var + JSonData: TJSONData; + CaseData: TJSonData; + CaseCounter,Cases: integer; + TestPass: Boolean; +begin + TestPass:=false; + JSonData:=ajSon.FindPath('description'); + if Assigned(JSonData) then begin + {$IFNDEF QUIET} + writeln(JSonData.AsString); + {$ENDIF} + end; + JSonData:=ajSon.FindPath('cases'); + if Assigned(JSonData) then begin + Cases:=JSonData.Count; + {$IFNDEF QUIET} + writeln('Sequences in case ',Cases); + {$ENDIF} + HPDecoder:=THPackDecoder.Create(HPACK_MAX_HEADER_SIZE,HPACK_MAX_HEADER_TABLE_SIZE); + + // This encoders, decoders are for cycle compress, decompress tests. + HPIntfDecoderPlain:=THPackDecoder.Create(HPACK_MAX_HEADER_SIZE,HPACK_MAX_HEADER_TABLE_SIZE); + HPIntfDecoderPlainIndexed:=THPackDecoder.Create(HPACK_MAX_HEADER_SIZE,HPACK_MAX_HEADER_TABLE_SIZE); + HPIntfDecoderHuffman:=THPackDecoder.Create(HPACK_MAX_HEADER_SIZE,HPACK_MAX_HEADER_TABLE_SIZE); + HPIntfDecoderHuffmanIndexed:=THPackDecoder.Create(HPACK_MAX_HEADER_SIZE,HPACK_MAX_HEADER_TABLE_SIZE); + + HPIntfEncoderPlain:=THPackEncoder.Create(HPACK_MAX_HEADER_TABLE_SIZE,false,false,true); + HPIntfEncoderPlainIndexed:=THPackEncoder.Create(HPACK_MAX_HEADER_TABLE_SIZE,true,false,true); + HPIntfEncoderHuffman:=THPackEncoder.Create(HPACK_MAX_HEADER_TABLE_SIZE,false,true,false); + HPIntfEncoderHuffmanIndexed:=THPackEncoder.Create(HPACK_MAX_HEADER_TABLE_SIZE,true,true,false); + try + CaseCounter:=0; + while CaseCounter<Cases do begin + CaseData:=JSonData.Items[CaseCounter]; + TestThisSequence(aGroup,aStory,CaseData); + inc(CaseCounter); + end; + TestPass:=true; + finally + if not TestPass then begin + {$IFNDEF FULL_QUIET} + writeln(StdErr,ErrorHeader('Sequence failed')); + writeln(StdErr,'Seq expected: ',CaseCounter); + {$ENDIF} + end else begin + inc(StoryCounter); + end; + FreeAndNil(HPDecoder); + FreeAndNil(HPIntfDecoderPlain); + FreeAndNil(HPIntfDecoderPlainIndexed); + FreeAndNil(HPIntfDecoderHuffman); + FreeAndNil(HPIntfDecoderHuffmanIndexed); + FreeAndNil(HPIntfEncoderPlain); + FreeAndNil(HPIntfEncoderPlainIndexed); + FreeAndNil(HPIntfEncoderHuffman); + FreeAndNil(HPIntfEncoderHuffmanIndexed); + end; + end; +end; + +procedure THPackTestCaseCycle.RunSampleHeadersTest; +const + TestCaseBase: string ='hpack-test-case-master'+PathDelim; + TestCaseGroups: array [0..10] of string = + ( + 'go-hpack', + 'haskell-http2-linear', + 'haskell-http2-linear-huffman', + 'haskell-http2-naive', + 'haskell-http2-naive-huffman', + 'haskell-http2-static', + 'haskell-http2-static-huffman', + 'nghttp2', + 'nghttp2-16384-4096', + 'nghttp2-change-table-size', + 'node-http2-hpack' + ); + TestCaseStoryMask: string ='story_%.2d.json'; +var + TheFile: string; + JSonParser: TJSONParser; + JSonData: TJSonData; + MyStream: TFileStream; + j: integer; + FolderCounter: integer; + FailCounter: Integer=0; + ElapsedTime: QWord; +begin + SequenceCounter:=0; + StoryCounter:=0; + GroupsCounter:=0; + WireBytes:=0; + DecodedBytes:=0; + ElapsedTime:=GetTickCount64; + FolderCounter:=0; + while FolderCounter<=High(TestCaseGroups) do begin + j:=0; + while true do begin + TheFile:=IncludeTrailingPathDelimiter(TestCaseBase)+IncludeTrailingPathDelimiter(TestCaseGroups[FolderCounter])+format(TestCaseStoryMask,[j]); + if not FileExists(TheFile) then begin + break; + end; + MyStream:=TFileStream.Create(TheFile,fmOpenRead or fmShareDenyWrite); + JSonParser:=TJSONParser.Create(MyStream,[]); + JSonData:=JSonParser.Parse; + {$IFNDEF QUIET} + writeln('Check story ',Thefile); + {$ENDIF} + try + try + TestCaseStory(FolderCounter,j,JSonData); + finally + FreeAndNil(JSonData); + FreeAndNil(JSonParser); + FreeAndNil(MyStream); + end; + except + on e: exception do begin + {$IFNDEF FULL_QUIET} + writeln(StdErr,ErrorHeader('Story failed')); + writeln(StdErr,TheFile); + writeln(StdErr,ErrorHeader('Fail condition')); + writeln(StdErr,e.Message); + inc(FailCounter); + {$ENDIF} + break; + end; + end; + inc(j); + end; + inc(GroupsCounter); + inc(FolderCounter); + end; + ElapsedTime:=GetTickCount64-ElapsedTime; + {$IFNDEF QUIET} + writeln; + writeln; + {$ENDIF} + {$IFNDEF FULL_QUIET} + writeln(ErrorHeader('Summary')); + writeln('Groups: ',GroupsCounter); + writeln('Stories: ',StoryCounter); + writeln('Sequences: ',SequenceCounter); + writeln('Time: ',ElapsedTime/1000:1:3,' seconds.'); + writeln('Wire bytes / Decoded bytes: ',WireBytes,' / ',DecodedBytes); + writeln('Compression ratio: ',WireBytes/DecodedBytes:1:3); + writeln('Failed tests: ',FailCounter); + {$ENDIF} + if FailCounter>0 then begin + Fail('Failed cycle tests: %d',[FailCounter]); + end; +end; + +initialization + + RegisterTest(THPackTestCaseCycle); + RegisterTest(THPackTestDecoder); +end. + diff --git a/packages/hash/Makefile.fpc b/packages/hash/Makefile.fpc index c6c4084090..10c313d644 100644 --- a/packages/hash/Makefile.fpc +++ b/packages/hash/Makefile.fpc @@ -7,7 +7,7 @@ name=hash version=3.0.1 [require] -packages=rtl +packages=rtl [install] fpcpackage=y diff --git a/packages/hash/fpmake.pp b/packages/hash/fpmake.pp index 3439fd81bd..e38e8947ae 100644 --- a/packages/hash/fpmake.pp +++ b/packages/hash/fpmake.pp @@ -36,7 +36,8 @@ begin T:=P.Targets.AddUnit('src/uuid.pas'); T:=P.Targets.AddUnit('src/hmac.pp'); T:=P.Targets.AddUnit('src/unixcrypt.pas'); - T.OSes:=[Linux]; + + T.OSes:=[Linux]; T:=P.Targets.AddExampleunit('examples/mdtest.pas'); T:=P.Targets.AddExampleunit('examples/crctest.pas'); T:=P.Targets.AddExampleunit('examples/sha1test.pp'); diff --git a/packages/ibase/src/ibase60.inc b/packages/ibase/src/ibase60.inc index 908090ac37..de1cf8c67e 100644 --- a/packages/ibase/src/ibase60.inc +++ b/packages/ibase/src/ibase60.inc @@ -92,6 +92,7 @@ Type ISC_INT64 = int64; ISC_UINT64 = qword; ISC_LONG = Longint; + ISC_ULONG = dword; PISC_USHORT = ^ISC_USHORT; PISC_STATUS = ^ISC_STATUS; @@ -155,7 +156,7 @@ Type GDS_QUAD = record gds_quad_high : ISC_LONG; - gds_quad_low : ISC_LONG; + gds_quad_low : ISC_ULONG; end; TGDS_QUAD = GDS_QUAD; PGDS_QUAD = ^GDS_QUAD; diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index 3d2231c5d3..b6e9f7d0a8 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -54,6 +54,14 @@ Type Function TransFormFunctionName(El : TPasElement; AContext : TConvertContext) : String; Function GetExceptionObjectname(AContext : TConvertContext) : String; Function ResolveType(El : TPasElement; AContext : TConvertContext) : TPasType; + Function CreateCallStatement(const caltname: string;para: array of string): TJSCallExpression; + Function CreateCallStatement(const pex2: TJSElement;para: array of string): TJSCallExpression; + Function CreateProcedureDeclaration(const El: TPasElement):TJSFunctionDeclarationStatement; + Function CreateUnary(ms: array of string; E: TJSElement): TJSUnary; + Function CreateMemberExpression(ms: array of string): TJSDotMemberExpression; + Procedure Addproceduretoclass(sl: TJSStatementList; E: TJSElement;const P: TPasProcedure); + Function GetFunctionDefinitionInUnary(const fd: TJSFunctionDeclarationStatement;const funname: string; inunary: boolean): TJSFunctionDeclarationStatement; + Function GetFunctionUnaryName(var je: TJSElement;var fundec: TJSFunctionDeclarationStatement): TJSString; // Statements Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement;virtual; Function ConvertBeginEndStatement(El: TPasImplBeginBlock; AContext: TConvertContext): TJSElement;virtual; @@ -106,7 +114,9 @@ Type Function ConvertType(El: TPasElement; AContext : TConvertContext): TJSElement;virtual; Function ConvertVariable(El: TPasVariable; AContext : TConvertContext): TJSElement;virtual; Function ConvertElement(El : TPasElement; AContext : TConvertContext) : TJSElement; virtual; - + function ConvertClassType(const EL: TPasClassType;const AContext: TConvertContext): TJSElement; + Function ConvertClassMember(El: TPasElement;AContext: TConvertContext): TJSElement; + Function ConvertClassconstructor(El: TPasConstructor;AContext: TConvertContext): TJSElement; Property CurrentContext : TJSElement Read FCurrentContext Write SetCurrentContext; Public Function ConvertElement(El : TPasElement) : TJSElement; @@ -343,7 +353,8 @@ Var R : TJSBinary; C : TJSBinaryClass; A,B : TJSElement; - + funname:String; + pex : TJSPrimaryExpressionIdent; begin Result:=Nil; C:=BinClasses[EL.OpCode]; @@ -379,14 +390,51 @@ begin end; eopSubIdent : begin - Result:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El)); - TJSDotMemberExpression(Result).Mexpr:=A; - if Not (B is TJSPrimaryExpressionIdent) then - DOError('Member expression must be an identifier'); - TJSDotMemberExpression(Result).Name:=TJSPrimaryExpressionIdent(B).Name; - FreeAndNil(B); + if (B is TJSPrimaryExpressionIdent) then + begin + Result := TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); + TJSDotMemberExpression(Result).Mexpr := A; + TJSDotMemberExpression(Result).Name := TJSPrimaryExpressionIdent(B).Name; + FreeAndNil(B); + end; + if (B is TJSCallExpression) then + begin + Result := B; + funname := TJSPrimaryExpressionIdent(TJSCallExpression(B).Expr).Name; + TJSCallExpression(B).Expr := + TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); + TJSDotMemberExpression(TJSCallExpression(B).Expr).Mexpr := A; + TJSDotMemberExpression(TJSCallExpression(B).Expr).Name := funname; + end; + if not ((B is TJSPrimaryExpressionIdent) or (B is TJSCallExpression)) then; + // DOError('Member expression must be an identifier'); + end + else + if (A is TJSPrimaryExpressionIdent) and + (TJSPrimaryExpressionIdent(A).Name = '_super') then + begin + Result := B; + funname := TJSPrimaryExpressionIdent(TJSCallExpression(b).Expr).Name; + pex := TJSPrimaryExpressionIdent.Create(0, 0, ''); + pex.Name := 'self'; + TJSCallExpression(b).Args.Elements.AddElement.Expr := pex; + if TJSCallExpression(b).Args.Elements.Count > 1 then + TJSCallExpression(b).Args.Elements.Exchange( + 0, TJSCallExpression(b).Args.Elements.Count - 1); + if CompareText(funname, 'Create') = 0 then + begin + TJSCallExpression(B).Expr := + TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El)); + TJSDotMemberExpression(TJSCallExpression(b).Expr).Mexpr := A; + TJSDotMemberExpression(TJSCallExpression(b).Expr).Name := funname; + end + else + begin + TJSCallExpression(B).Expr := + CreateMemberExpression(['call', funname, 'prototype', '_super']); + end; end - else + else DoError('Unknown/Unsupported operand type for binary expression'); end; if (Result=Nil) and (C<>Nil) then @@ -474,9 +522,12 @@ begin end; Function TPasToJSConverter.ConvertInheritedExpression(El: TInheritedExpr; AContext : TConvertContext): TJSElement; - +var + je: TJSPrimaryExpressionIdent; begin - Result:=Nil; + je := TJSPrimaryExpressionIdent.Create(0, 0, ''); + je.Name := '_super'; + Result := je; // TInheritedExpr = class(TPasExpr) end; @@ -612,6 +663,8 @@ Function TPasToJSConverter.CreateTypeDecl(El: TPasElement; AContext : TConvertCo begin Result:=Nil; + if (El is TPasClassType) then + Result := convertclassType(TPasClassType(El), AContext); // Need to do something for classes and records. end; @@ -668,6 +721,9 @@ begin E:=ConvertElement(P as TPasProcedure,AContext) else DoError('Unknown class: "%s" ',[P.ClassName]); + if (Pos('.', P.Name) > 0) then + Addproceduretoclass(TJSStatementList(Result), E, P as TPasProcedure) + else AddToSL; end; if (El is TProcedureBody) then @@ -716,18 +772,146 @@ TPasTypeRef = class(TPasUnresolvedTypeRef) } end; +function TPasToJSConverter.ConvertClassType(const El: TPasClassType; + const AContext: TConvertContext): TJSElement; +var + call: TJSCallExpression; + pex: TJSPrimaryExpressionIdent; + asi: TJSSimpleAssignStatement; + unary2: TJSUnary; + unary: TJSUnary; + je: TJSElement; + FD: TJSFuncDef; + cons: TJSFunctionDeclarationStatement; + FS: TJSFunctionDeclarationStatement; + memname: string; + ctname: string; + tmember: TPasElement; + j: integer; + ret: TJSReturnStatement; +begin + ctname := El.FullName; + unary := TJSUnary(CreateElement(TJSUnary,El)); + asi := TJSSimpleAssignStatement(CreateElement(TJSSimpleAssignStatement,El)); + unary.A := asi; + pex := TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent,El)); + pex.Name := El.Name; + asi.LHS := pex; + FS := TJSFunctionDeclarationStatement( + CreateElement(TJSFunctionDeclarationStatement, EL)); + call := CreateCallStatement(FS, []); + asi.Expr := call; + Result := unary; + FD := TJSFuncDef.Create; + FS.AFunction := FD; + FD.Body := TJSFunctionBody(CreateElement(TJSFunctionBody, El)); + FD.Body.A := TJSSourceElements(CreateElement(TJSSourceElements, El)); + if Assigned(El.AncestorType) then + begin + pex := TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent, El)); + call.Args := TJSArguments(CreateElement(TJSArguments, El)); + pex.Name := El.AncestorType.Name; + call.Args.Elements.AddElement.Expr := pex; + FD.Params.Add('_super'); + unary2 := TJSUnary(CreateElement(TJSUnary, El)); + call := CreateCallStatement('__extends', [El.Name, '_super']); + unary2.A := call; + TJSSourceElements(FD.Body.A).Statements.AddNode.Node := unary2; + end; + //create default onstructor + cons := CreateProcedureDeclaration(El); + TJSSourceElements(FD.Body.A).Statements.AddNode.Node := cons; + cons.AFunction.Name := El.Name; + + //convert class member + for j := 0 to El.Members.Count - 1 do + begin + tmember := TPasElement(El.Members[j]); + memname := tmember.FullName; + je := ConvertClassMember(tmember, AContext); + if Assigned(je) then + TJSSourceElements(FD.Body.A).Statements.AddNode.Node := je; + end; + + //add return statment + ret := TJSReturnStatement(CreateElement(TJSReturnStatement, El)); + TJSSourceElements(FD.Body.A).Statements.AddNode.Node := ret; + pex := TJSPrimaryExpressionIdent(CreateElement(TJSPrimaryExpressionIdent, El)); + ret.Expr := pex; + pex.Name := el.Name; + Result := unary; +end; + +function TPasToJSConverter.ConvertClassMember(El: TPasElement; + AContext: TConvertContext): TJSElement; +var + FS: TJSFunctionDeclarationStatement; + par: string; +begin + Result := nil; + if (El is TPasProcedure) and (not (El is TPasConstructor)) then + begin + FS := CreateProcedureDeclaration(El); + Result := CreateUnary([TPasProcedure(El).Name, 'prototype', + El.Parent.FullName], FS); + end; + if (El is TPasConstructor)then + begin + Result:=ConvertClassconstructor(TPasClassConstructor(El),AContext); + end; + if (el is TPasProperty) then + ConvertProperty(TPasProperty(El), AContext); + +end; + +Function TPasToJSConverter.ConvertClassconstructor(El: TPasConstructor; + AContext: TConvertContext): TJSElement; +var + FS: TJSFunctionDeclarationStatement; + n: integer; + fun1sourceele: TJSSourceElements; + ret: TJSReturnStatement; + nmem: TJSNewMemberExpression; + pex: TJSPrimaryExpressionIdent; +begin + FS := CreateProcedureDeclaration(El); + FS.AFunction.Name := El.Name; + Fs.AFunction.Body := TJSFunctionBody(CreateElement(TJSFunctionBody, EL.Body)); + fun1sourceele := TJSSourceElements.Create(0, 0, ''); + fs.AFunction.Body.A := fun1sourceele; + ret := TJSReturnStatement.Create(0, 0, ''); + fun1sourceele.Statements.AddNode.Node := ret; + nmem := TJSNewMemberExpression.Create(0, 0, ''); + ret.Expr := nmem; + pex := TJSPrimaryExpressionIdent.Create(0, 0, ''); + nmem.Mexpr := pex; + pex.Name := El.Parent.FullName; + for n := 0 to El.ProcType.Args.Count - 1 do + begin + if n = 0 then + nmem.Args := TJSArguments.Create(0, 0, ''); + fs.AFunction.Params.Add(TPasArgument(El.ProcType.Args[n]).Name); + pex := TJSPrimaryExpressionIdent.Create(0, 0, ''); + pex.Name := TPasArgument(El.ProcType.Args[n]).Name; + nmem.Args.Elements.AddElement.Expr := pex; + end; + Result := CreateUnary([TPasProcedure(El).Name, El.Parent.FullName], FS); +end; + Function TPasToJSConverter.ConvertProcedure(El: TPasProcedure; AContext : TConvertContext): TJSElement; Var FS : TJSFunctionDeclarationStatement; FD : TJSFuncDef; - + n:Integer; begin FS:=TJSFunctionDeclarationStatement(CreateElement(TJSFunctionDeclarationStatement,EL)); Result:=FS; FD:=TJSFuncDef.Create; FD.Name:=TransFormFunctionName(El,AContext); FS.AFunction:=FD; + for n := 0 to El.ProcType.Args.Count - 1 do + FD.Params.Add(TPasArgument(El.ProcType.Args[0]).Name); FD.Body:=TJSFunctionBody(CreateElement(TJSFunctionBody,EL.Body)); FD.Body.A:=ConvertElement(El.Body,AContext); { @@ -1220,7 +1404,190 @@ begin else Result:=Nil; end; +function TPasToJSConverter.CreateCallStatement(const caltname: string; + para: array of string): TJSCallExpression; +var + call: TJSCallExpression; + pex2: TJSPrimaryExpressionIdent; +begin + pex2 := TJSPrimaryExpressionIdent.Create(0, 0, ''); + pex2.Name := caltname; + call := CreateCallStatement(pex2, para); + Result := call; +end; +function TPasToJSConverter.CreateCallStatement(const pex2: TJSElement; + para: array of string): TJSCallExpression; +var + p: string; + pex3: TJSPrimaryExpressionIdent; + call: TJSCallExpression; + argarray: TJSArguments; +begin + call := TJSCallExpression.Create(0, 0, ''); + call.Expr := pex2; + argarray := TJSArguments.Create(0, 0, ''); + call.Args := argarray; + for p in para do + begin + pex3 := TJSPrimaryExpressionIdent.Create(0, 0, ''); + pex3.Name := p; + argarray.Elements.AddElement.Expr := pex3; + end; + Result := call; +end; + +function TPasToJSConverter.CreateUnary(ms: array of string; E: TJSElement): TJSUnary; +var + unary: TJSUnary; + asi: TJSSimpleAssignStatement; + mem1: TJSDotMemberExpression; +begin + unary := TJSUnary.Create(0, 0, ''); + //mainbody.A:=unary; + asi := TJSSimpleAssignStatement.Create(0, 0, ''); + unary.A := asi; + asi.Expr := E; + asi.LHS := CreateMemberExpression(ms); + Result := unary; +end; + +function TPasToJSConverter.CreateMemberExpression(ms: array of string): TJSDotMemberExpression; +var + pex: TJSPrimaryExpressionIdent; + mem2: TJSDotMemberExpression; + mem1: TJSDotMemberExpression; + k: integer; + m: string; +begin + if Length(ms) < 2 then + DoError('member exprision with les than two member'); + k := 0; + for m in ms do + begin + mem1 := mem2; + mem2 := TJSDotMemberExpression.Create(0, 0, ''); + mem2.Name := ms[k]; + if k = 0 then + Result := mem2 + else + mem1.Mexpr := mem2; + Inc(k); + end; + mem2.Free; + pex := TJSPrimaryExpressionIdent.Create(0, 0, ''); + pex.Name := ms[k - 1]; + mem1.Mexpr := pex; +end; +Procedure TPasToJSConverter.Addproceduretoclass(sl: TJSStatementList; + E: TJSElement; const P: TPasProcedure); +var + clname, funname, varname: string; + classfound: boolean; + fundec, fd, main_const: TJSFunctionDeclarationStatement; + SL2: TJSStatementList; + un1: TJSUnary; + asi: TJSAssignStatement; +begin + SL2 := TJSStatementList(sl); + clname := Copy(p.Name, 1, Pos('.', P.Name) - 1); + funname := Copy(p.Name, Pos('.', P.Name) + 1, Length(p.Name) - Pos('.', P.Name)); + classfound := False; + while Assigned(SL2) and (not classfound) do + begin + if SL2.A is TJSUnary then + begin + un1 := TJSUnary(SL2.A); + asi := TJSAssignStatement(un1.A); + varname := TJSPrimaryExpressionIdent(asi.LHS).Name; + if varname = (clname) then + begin + classfound := True; + fd := TJSFunctionDeclarationStatement(TJSCallExpression(asi.Expr).Expr); + end; + end; + SL2 := TJSStatementList(SL2.B); + end; + + if not (classfound) then + Exit; + + fundec := GetFunctionDefinitionInUnary(fd, funname, True); + if Assigned(fundec) then + begin + if (p is TPasConstructor) then + begin + main_const := GetFunctionDefinitionInUnary(fd, clname, False); + main_const.AFunction := TJSFunctionDeclarationStatement(E).AFunction; + main_const.AFunction.Name := clname; + end + else + begin + fundec.AFunction := TJSFunctionDeclarationStatement(E).AFunction; + fundec.AFunction.Name := ''; + end; + end; +end; + +function TPasToJSConverter.GetFunctionDefinitionInUnary( + const fd: TJSFunctionDeclarationStatement; const funname: string; + inunary: boolean): TJSFunctionDeclarationStatement; +var + k: integer; + fundec: TJSFunctionDeclarationStatement; + je: TJSElement; + cname: TJSString; +begin + Result := nil; + for k := 0 to TJSSourceElements(FD.AFunction.Body.A).Statements.Count - 1 do + begin + je := TJSSourceElements(FD.AFunction.Body.A).Statements.Nodes[k].Node; + if inunary then + cname := GetFunctionUnaryName(je, fundec) + else + begin + if je is TJSFunctionDeclarationStatement then + begin + cname := TJSFunctionDeclarationStatement(je).AFunction.Name; + fundec := TJSFunctionDeclarationStatement(je); + end; + end; + if funname = cname then + Result := fundec; + end; +end; + +Function TPasToJSConverter.GetFunctionUnaryName(var je: TJSElement; + var fundec: TJSFunctionDeclarationStatement): TJSString; +var + cname: TJSString; + asi: TJSAssignStatement; + un1: TJSUnary; +begin + if not (je is TJSUnary) then + Exit; + un1 := TJSUnary(je); + asi := TJSAssignStatement(un1.A); + if not (asi.Expr is TJSFunctionDeclarationStatement) then + Exit; + fundec := TJSFunctionDeclarationStatement(asi.Expr); + cname := TJSDotMemberExpression(asi.LHS).Name; + Result := cname; +end; + +function TPasToJSConverter.CreateProcedureDeclaration(const El: TPasElement): +TJSFunctionDeclarationStatement; +var + FD: TJSFuncDef; + FS: TJSFunctionDeclarationStatement; +begin + FS := TJSFunctionDeclarationStatement( + CreateElement(TJSFunctionDeclarationStatement, EL)); + Result := FS; + FD := TJSFuncDef.Create; + FS.AFunction := FD; + Result := FS; +end; Function TPasToJSConverter.ConvertExceptOn(El: TPasImplExceptOn; AContext : TConvertContext): TJSElement; Var @@ -1379,3 +1746,4 @@ end; end. + diff --git a/packages/rtl-extra/src/unix/ipc.pp b/packages/rtl-extra/src/unix/ipc.pp index 063ca3599a..597e5de6b3 100644 --- a/packages/rtl-extra/src/unix/ipc.pp +++ b/packages/rtl-extra/src/unix/ipc.pp @@ -508,6 +508,8 @@ type {$elseif defined(Linux)} PMSQid_ds = ^TMSQid_ds; TMSQid_ds = record +{ 32 bit } +{$IFNDEF CPU64} msg_perm : TIPC_perm; msg_first : PMsg; msg_last : PMsg; @@ -519,6 +521,20 @@ type msg_qbytes : word; msg_lspid : ipc_pid_t; msg_lrpid : ipc_pid_t; +{$ELSE cpu64} +{ 64 bit } + msg_perm : TIPC_perm; + msg_stime : time_t; + msg_rtime : time_t; + msg_ctime : time_t; + msg_cbytes : qword; + msg_qnum : qword; + msg_qbytes : qword; + msg_lspid : ipc_pid_t; + msg_lrpid : ipc_pid_t; + pad1 : qword; + pad2 : qword; +{$ENDIF} end; {$else} {$if defined(Darwin)} diff --git a/rtl/win/windirs.pp b/rtl/win/windirs.pp index 25965a8808..f5113d4a83 100644 --- a/rtl/win/windirs.pp +++ b/rtl/win/windirs.pp @@ -1,5 +1,18 @@ unit windirs; +{******************************************************************************* + +IMPORTANT NOTES: + +SHGetFolderPath function is deprecated. Only some CSIDL values are supported. + +As of Windows Vista, this function is merely a wrapper for SHGetKnownFolderPath. +The CSIDL value is translated to its associated KNOWNFOLDERID and then SHGetKnownFolderPath +is called. New applications should use the known folder system rather than the older +CSIDL system, which is supported only for backward compatibility. + +*******************************************************************************} + {$mode objfpc} {$H+} @@ -8,7 +21,8 @@ interface uses windows; -Const +// CSIDL_* contants are also declared in "ShellApi" and "shfolder" units. +const CSIDL_PROGRAMS = $0002; { %SYSTEMDRIVE%\Program Files } CSIDL_PERSONAL = $0005; { %USERPROFILE%\My Documents } CSIDL_FAVORITES = $0006; { %USERPROFILE%\Favorites } @@ -51,68 +65,104 @@ Const CSIDL_FLAG_CREATE = $8000; { (force creation of requested folder if it doesn't exist yet) } -Function GetWindowsSpecialDir(ID : Integer) : String; + +function GetWindowsSpecialDir(ID: Integer; CreateIfNotExists: Boolean = True): String; +function GetWindowsSpecialDirUnicode(ID: Integer; CreateIfNotExists: Boolean = True): UnicodeString; + +function GetWindowsSystemDirectory: String; +function GetWindowsSystemDirectoryUnicode: UnicodeString; implementation uses sysutils; -Type - PFNSHGetFolderPath = Function(Ahwnd: HWND; Csidl: Integer; Token: THandle; Flags: DWord; Path: {$ifdef FPC_UNICODE_RTL}PWideChar{$ELSE}PChar{$ENDIF}): HRESULT; stdcall; +type + // HRESULT SHGetFolderPath( + // _In_ HWND hwndOwner, + // _In_ int nFolder, + // _In_ HANDLE hToken, + // _In_ DWORD dwFlags, + // _Out_ LPTSTR pszPath + // ); + TSHGetFolderPathW = function(Ahwnd: HWND; Csidl: Integer; Token: THandle; + Flags: DWORD; Path: PWideChar): HRESULT; stdcall; + +const + SSHGetFolderPathW = 'SHGetFolderPathW'; + SLibName = 'shell32.dll'; var - SHGetFolderPath : PFNSHGetFolderPath = Nil; - CFGDLLHandle : THandle = 0; + _SHGetFolderPathW : TSHGetFolderPathW = nil; + DLLHandle: THandle = 0; -Procedure InitDLL; - -Var - pathBuf: array[0..MAX_PATH-1] of {$ifdef FPC_UNICODE_RTL}WideChar{$else}Ansichar{$endif}; - pathLength: Integer; +procedure InitDLL; +var + DLLPath: UnicodeString; begin - { Load shfolder.dll using a full path, in order to prevent spoofing (Mantis #18185) - Don't bother loading shell32.dll because shfolder.dll itself redirects SHGetFolderPath - to shell32.dll whenever possible. } - pathLength:=GetSystemDirectory(pathBuf, MAX_PATH); - if (pathLength>0) and (pathLength<MAX_PATH-14) then { 14=length('\shfolder.dll'#0) } + if DLLHandle = 0 then begin - StrLCopy(@pathBuf[pathLength],'\shfolder.dll',MAX_PATH-pathLength-1); - CFGDLLHandle:=LoadLibrary(pathBuf); - - if (CFGDLLHandle<>0) then + // Load DLL using a full path, in order to prevent spoofing (Mantis #18185) + DLLPath := GetWindowsSystemDirectoryUnicode; + if Length(DLLPath) > 0 then begin - Pointer(ShGetFolderPath):=GetProcAddress(CFGDLLHandle,{$ifdef FPC_UNICODE_RTL}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif}); - If @ShGetFolderPath=nil then - begin - FreeLibrary(CFGDLLHandle); - CFGDllHandle:=0; - end; + DLLPath := IncludeTrailingPathDelimiter(DLLPath) + SLibName; + DLLHandle := LoadLibraryW(PWideChar(DLLPath)); + if DLLHandle <> 0 then + Pointer(_SHGetFolderPathW) := GetProcAddress(DLLHandle, SSHGetFolderPathW); end; end; - If (@ShGetFolderPath=Nil) then - Raise Exception.Create('Could not determine SHGetFolderPath Function'); + if @_SHGetFolderPathW = nil then + raise Exception.Create('Could not locate SHGetFolderPath function'); end; -Function GetWindowsSpecialDir(ID : Integer) : String; - -Var - APath : Array[0..MAX_PATH] of char; - +procedure FinitDLL; begin - Result:=''; - if (CFGDLLHandle=0) then - InitDLL; - If (SHGetFolderPath<>Nil) then - begin - if SHGetFolderPath(0,ID or CSIDL_FLAG_CREATE,0,0,@APATH[0])=S_OK then - Result:=IncludeTrailingPathDelimiter(StrPas(@APath[0])); - end; + if DLLHandle <> 0 then + begin + FreeLibrary(DLLHandle); + DLLHandle := 0; + end; end; -Initialization -Finalization - if CFGDLLHandle<>0 then - FreeLibrary(CFGDllHandle); +function GetWindowsSystemDirectoryUnicode: UnicodeString; +var + Buffer: array [0..MAX_PATH] of WideChar; + CharCount: Integer; +begin + CharCount := GetSystemDirectoryW(@Buffer[0], MAX_PATH); + // CharCount is length in TCHARs not including the terminating null character. + // If result did not fit, CharCount will be bigger than buffer size. + if (CharCount > 0) and (CharCount < MAX_PATH) then + Result := StrPas(Buffer) + else + Result := ''; +end; + +function GetWindowsSystemDirectory: String; +begin + Result := String(GetWindowsSystemDirectoryUnicode); +end; + +function GetWindowsSpecialDirUnicode(ID: Integer; CreateIfNotExists: Boolean = True): UnicodeString; +var + Buffer: array [0..MAX_PATH] of WideChar; +begin + InitDLL; + Result := ''; + if CreateIfNotExists then + ID := ID or CSIDL_FLAG_CREATE; + if _SHGetFolderPathW(0, ID, 0, 0, @Buffer[0]) = S_OK then + Result := IncludeTrailingPathDelimiter(StrPas(Buffer)); +end; + +function GetWindowsSpecialDir(ID: Integer; CreateIfNotExists: Boolean = True): String; +begin + Result := String(GetWindowsSpecialDirUnicode(ID, CreateIfNotExists)); +end; + +finalization + FinitDLL; + end. diff --git a/utils/fpdoc/dw_latex.pp b/utils/fpdoc/dw_latex.pp index 0c2193875d..22d261da28 100644 --- a/utils/fpdoc/dw_latex.pp +++ b/utils/fpdoc/dw_latex.pp @@ -169,30 +169,30 @@ Function TLaTeXWriter.SplitLine (ALine : String): String; InString : Boolean; begin - Result:=0; - L:=Length(S); - if (L>MaxVerbatimLength) then - begin - InString:=False; - Result:=0; - I:=1; - C:=@S[1]; - While (I<=MaxVerbatimLength) do - begin - If C^='''' then - InString:=Not Instring - else if Not InString then - begin - if Not (C^ in NonSplit) then - Result:=I; - end; - Inc(I); - Inc(C); - end; - end; - If Result=0 then - Result:=L+1; - end; + Result:=0; + L:=Length(S); + if (L>MaxVerbatimLength) then + begin + InString:=False; + Result:=0; + I:=1; + C:=@S[1]; + While (I<=L) and (Result<=MaxVerbatimLength) do + begin + If C^='''' then + InString:=Not Instring + else if Not InString then + begin + if Not (C^ in NonSplit) then + Result:=I; + end; + Inc(I); + Inc(C); + end; + end; + If (Result=0) or (Result=1) then + Result:=L+1; + end; Var SP : Integer;