mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-16 00:09:17 +02:00
# revisions: 33347,33406,33548,33576,33577,33578,33579,33602,33603,33683
git-svn-id: branches/fixes_3_0@33752 -
This commit is contained in:
marco
parent
57b214161e
commit
34e0fc0133
9
.gitattributes
vendored
9
.gitattributes
vendored
@ -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.html -text
|
||||||
packages/fcl-base/examples/testcgi.pp svneol=native#text/plain
|
packages/fcl-base/examples/testcgi.pp svneol=native#text/plain
|
||||||
packages/fcl-base/examples/testcont.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/testez.pp svneol=native#text/plain
|
||||||
packages/fcl-base/examples/testhres.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
|
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.lpi svneol=native#text/plain
|
||||||
packages/fcl-base/tests/fclbase-unittests.pp 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/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/tests/tests_fptemplate.pp svneol=native#text/plain
|
||||||
packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
|
packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
|
||||||
packages/fcl-db/Makefile 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/webpage.pp svneol=native#text/plain
|
||||||
packages/fcl-web/src/base/websession.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/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 svneol=native#text/plain
|
||||||
packages/fcl-web/src/jsonrpc/Makefile.fpc 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
|
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/fpwebdata.pp svneol=native#text/plain
|
||||||
packages/fcl-web/src/webdata/readme.txt 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/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.lpi svneol=native#text/plain
|
||||||
packages/fcl-web/tests/cgigateway.pp 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.lpi svneol=native#text/plain
|
||||||
packages/fcl-web/tests/testcgiapp.pp 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 svneol=native#text/plain
|
||||||
packages/fcl-xml/Makefile.fpc svneol=native#text/plain
|
packages/fcl-xml/Makefile.fpc svneol=native#text/plain
|
||||||
packages/fcl-xml/Makefile.fpc.fpcmake svneol=native#text/plain
|
packages/fcl-xml/Makefile.fpc.fpcmake svneol=native#text/plain
|
||||||
|
|||||||
@ -3,7 +3,8 @@ program fclbase_unittests;
|
|||||||
{$mode objfpc}{$H+}
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
uses
|
uses
|
||||||
Classes, consoletestrunner, tests_fptemplate, tchashlist;
|
Classes, consoletestrunner, tests_fptemplate, tchashlist,
|
||||||
|
testexprpars;
|
||||||
|
|
||||||
var
|
var
|
||||||
Application: TTestRunner;
|
Application: TTestRunner;
|
||||||
|
|||||||
@ -124,6 +124,8 @@ type
|
|||||||
property Aborted;
|
property Aborted;
|
||||||
property Line;
|
property Line;
|
||||||
published
|
published
|
||||||
|
Property UseDollarString;
|
||||||
|
Property DollarStrings;
|
||||||
property Directives;
|
property Directives;
|
||||||
property Defines;
|
property Defines;
|
||||||
property Script;
|
property Script;
|
||||||
|
|||||||
@ -693,6 +693,8 @@ type
|
|||||||
Property DataBase : TDatabase Read FDatabase Write SetDatabase;
|
Property DataBase : TDatabase Read FDatabase Write SetDatabase;
|
||||||
Property Transaction : TDBTransaction Read FTransaction Write SetTransaction;
|
Property Transaction : TDBTransaction Read FTransaction Write SetTransaction;
|
||||||
property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
|
property OnDirective: TSQLScriptDirectiveEvent read FOnDirective write FOnDirective;
|
||||||
|
Property UseDollarString;
|
||||||
|
Property DollarStrings;
|
||||||
property Directives;
|
property Directives;
|
||||||
property Defines;
|
property Defines;
|
||||||
property Script;
|
property Script;
|
||||||
|
|||||||
@ -373,6 +373,9 @@ begin
|
|||||||
end;
|
end;
|
||||||
end;
|
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);
|
R:=UpCase(Method);
|
||||||
if (R='POST') or (R='PUT') or (ContentLength>0) then
|
if (R='POST') or (R='PUT') or (ContentLength>0) then
|
||||||
ReadContent;
|
ReadContent;
|
||||||
|
|||||||
87
packages/fcl-web/src/hpack/uhpack.pp
Normal file
87
packages/fcl-web/src/hpack/uhpack.pp
Normal file
@ -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.
|
||||||
|
|
||||||
1887
packages/fcl-web/src/hpack/uhpackimp.pp
Normal file
1887
packages/fcl-web/src/hpack/uhpackimp.pp
Normal file
File diff suppressed because it is too large
Load Diff
94
packages/fcl-web/src/hpack/uhpacktables.pp
Normal file
94
packages/fcl-web/src/hpack/uhpacktables.pp
Normal file
@ -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.
|
||||||
|
|
||||||
5
packages/fcl-web/tests/README.txt
Normal file
5
packages/fcl-web/tests/README.txt
Normal file
@ -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.
|
||||||
122
packages/fcl-web/tests/fpcunithpack.lpi
Normal file
122
packages/fcl-web/tests/fpcunithpack.lpi
Normal file
@ -0,0 +1,122 @@
|
|||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<CONFIG>
|
||||||
|
<ProjectOptions>
|
||||||
|
<Version Value="9"/>
|
||||||
|
<PathDelim Value="\"/>
|
||||||
|
<General>
|
||||||
|
<SessionStorage Value="InProjectDir"/>
|
||||||
|
<MainUnit Value="0"/>
|
||||||
|
<Title Value="fpcunithpack"/>
|
||||||
|
<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>
|
||||||
27
packages/fcl-web/tests/fpcunithpack.lpr
Normal file
27
packages/fcl-web/tests/fpcunithpack.lpr
Normal file
@ -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.
|
||||||
889
packages/fcl-web/tests/uhpacktest1.pas
Normal file
889
packages/fcl-web/tests/uhpacktest1.pas
Normal file
@ -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.
|
||||||
|
|
||||||
@ -7,7 +7,7 @@ name=hash
|
|||||||
version=3.0.1
|
version=3.0.1
|
||||||
|
|
||||||
[require]
|
[require]
|
||||||
packages=rtl
|
packages=rtl
|
||||||
|
|
||||||
[install]
|
[install]
|
||||||
fpcpackage=y
|
fpcpackage=y
|
||||||
|
|||||||
@ -36,7 +36,8 @@ begin
|
|||||||
T:=P.Targets.AddUnit('src/uuid.pas');
|
T:=P.Targets.AddUnit('src/uuid.pas');
|
||||||
T:=P.Targets.AddUnit('src/hmac.pp');
|
T:=P.Targets.AddUnit('src/hmac.pp');
|
||||||
T:=P.Targets.AddUnit('src/unixcrypt.pas');
|
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/mdtest.pas');
|
||||||
T:=P.Targets.AddExampleunit('examples/crctest.pas');
|
T:=P.Targets.AddExampleunit('examples/crctest.pas');
|
||||||
T:=P.Targets.AddExampleunit('examples/sha1test.pp');
|
T:=P.Targets.AddExampleunit('examples/sha1test.pp');
|
||||||
|
|||||||
@ -92,6 +92,7 @@ Type
|
|||||||
ISC_INT64 = int64;
|
ISC_INT64 = int64;
|
||||||
ISC_UINT64 = qword;
|
ISC_UINT64 = qword;
|
||||||
ISC_LONG = Longint;
|
ISC_LONG = Longint;
|
||||||
|
ISC_ULONG = dword;
|
||||||
|
|
||||||
PISC_USHORT = ^ISC_USHORT;
|
PISC_USHORT = ^ISC_USHORT;
|
||||||
PISC_STATUS = ^ISC_STATUS;
|
PISC_STATUS = ^ISC_STATUS;
|
||||||
@ -155,7 +156,7 @@ Type
|
|||||||
|
|
||||||
GDS_QUAD = record
|
GDS_QUAD = record
|
||||||
gds_quad_high : ISC_LONG;
|
gds_quad_high : ISC_LONG;
|
||||||
gds_quad_low : ISC_LONG;
|
gds_quad_low : ISC_ULONG;
|
||||||
end;
|
end;
|
||||||
TGDS_QUAD = GDS_QUAD;
|
TGDS_QUAD = GDS_QUAD;
|
||||||
PGDS_QUAD = ^GDS_QUAD;
|
PGDS_QUAD = ^GDS_QUAD;
|
||||||
|
|||||||
@ -54,6 +54,14 @@ Type
|
|||||||
Function TransFormFunctionName(El : TPasElement; AContext : TConvertContext) : String;
|
Function TransFormFunctionName(El : TPasElement; AContext : TConvertContext) : String;
|
||||||
Function GetExceptionObjectname(AContext : TConvertContext) : String;
|
Function GetExceptionObjectname(AContext : TConvertContext) : String;
|
||||||
Function ResolveType(El : TPasElement; AContext : TConvertContext) : TPasType;
|
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
|
// Statements
|
||||||
Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement;virtual;
|
Function ConvertImplBlockElements(El: TPasImplBlock; AContext: TConvertContext): TJSElement;virtual;
|
||||||
Function ConvertBeginEndStatement(El: TPasImplBeginBlock; 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 ConvertType(El: TPasElement; AContext : TConvertContext): TJSElement;virtual;
|
||||||
Function ConvertVariable(El: TPasVariable; AContext : TConvertContext): TJSElement;virtual;
|
Function ConvertVariable(El: TPasVariable; AContext : TConvertContext): TJSElement;virtual;
|
||||||
Function ConvertElement(El : TPasElement; 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;
|
Property CurrentContext : TJSElement Read FCurrentContext Write SetCurrentContext;
|
||||||
Public
|
Public
|
||||||
Function ConvertElement(El : TPasElement) : TJSElement;
|
Function ConvertElement(El : TPasElement) : TJSElement;
|
||||||
@ -343,7 +353,8 @@ Var
|
|||||||
R : TJSBinary;
|
R : TJSBinary;
|
||||||
C : TJSBinaryClass;
|
C : TJSBinaryClass;
|
||||||
A,B : TJSElement;
|
A,B : TJSElement;
|
||||||
|
funname:String;
|
||||||
|
pex : TJSPrimaryExpressionIdent;
|
||||||
begin
|
begin
|
||||||
Result:=Nil;
|
Result:=Nil;
|
||||||
C:=BinClasses[EL.OpCode];
|
C:=BinClasses[EL.OpCode];
|
||||||
@ -379,14 +390,51 @@ begin
|
|||||||
end;
|
end;
|
||||||
eopSubIdent :
|
eopSubIdent :
|
||||||
begin
|
begin
|
||||||
Result:=TJSDotMemberExpression(CreateElement(TJSDotMemberExpression,El));
|
if (B is TJSPrimaryExpressionIdent) then
|
||||||
TJSDotMemberExpression(Result).Mexpr:=A;
|
begin
|
||||||
if Not (B is TJSPrimaryExpressionIdent) then
|
Result := TJSDotMemberExpression(CreateElement(TJSDotMemberExpression, El));
|
||||||
DOError('Member expression must be an identifier');
|
TJSDotMemberExpression(Result).Mexpr := A;
|
||||||
TJSDotMemberExpression(Result).Name:=TJSPrimaryExpressionIdent(B).Name;
|
TJSDotMemberExpression(Result).Name := TJSPrimaryExpressionIdent(B).Name;
|
||||||
FreeAndNil(B);
|
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
|
end
|
||||||
else
|
else
|
||||||
DoError('Unknown/Unsupported operand type for binary expression');
|
DoError('Unknown/Unsupported operand type for binary expression');
|
||||||
end;
|
end;
|
||||||
if (Result=Nil) and (C<>Nil) then
|
if (Result=Nil) and (C<>Nil) then
|
||||||
@ -474,9 +522,12 @@ begin
|
|||||||
end;
|
end;
|
||||||
|
|
||||||
Function TPasToJSConverter.ConvertInheritedExpression(El: TInheritedExpr; AContext : TConvertContext): TJSElement;
|
Function TPasToJSConverter.ConvertInheritedExpression(El: TInheritedExpr; AContext : TConvertContext): TJSElement;
|
||||||
|
var
|
||||||
|
je: TJSPrimaryExpressionIdent;
|
||||||
begin
|
begin
|
||||||
Result:=Nil;
|
je := TJSPrimaryExpressionIdent.Create(0, 0, '');
|
||||||
|
je.Name := '_super';
|
||||||
|
Result := je;
|
||||||
// TInheritedExpr = class(TPasExpr)
|
// TInheritedExpr = class(TPasExpr)
|
||||||
end;
|
end;
|
||||||
|
|
||||||
@ -612,6 +663,8 @@ Function TPasToJSConverter.CreateTypeDecl(El: TPasElement; AContext : TConvertCo
|
|||||||
|
|
||||||
begin
|
begin
|
||||||
Result:=Nil;
|
Result:=Nil;
|
||||||
|
if (El is TPasClassType) then
|
||||||
|
Result := convertclassType(TPasClassType(El), AContext);
|
||||||
// Need to do something for classes and records.
|
// Need to do something for classes and records.
|
||||||
end;
|
end;
|
||||||
|
|
||||||
@ -668,6 +721,9 @@ begin
|
|||||||
E:=ConvertElement(P as TPasProcedure,AContext)
|
E:=ConvertElement(P as TPasProcedure,AContext)
|
||||||
else
|
else
|
||||||
DoError('Unknown class: "%s" ',[P.ClassName]);
|
DoError('Unknown class: "%s" ',[P.ClassName]);
|
||||||
|
if (Pos('.', P.Name) > 0) then
|
||||||
|
Addproceduretoclass(TJSStatementList(Result), E, P as TPasProcedure)
|
||||||
|
else
|
||||||
AddToSL;
|
AddToSL;
|
||||||
end;
|
end;
|
||||||
if (El is TProcedureBody) then
|
if (El is TProcedureBody) then
|
||||||
@ -716,18 +772,146 @@ TPasTypeRef = class(TPasUnresolvedTypeRef)
|
|||||||
}
|
}
|
||||||
end;
|
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;
|
Function TPasToJSConverter.ConvertProcedure(El: TPasProcedure; AContext : TConvertContext): TJSElement;
|
||||||
|
|
||||||
Var
|
Var
|
||||||
FS : TJSFunctionDeclarationStatement;
|
FS : TJSFunctionDeclarationStatement;
|
||||||
FD : TJSFuncDef;
|
FD : TJSFuncDef;
|
||||||
|
n:Integer;
|
||||||
begin
|
begin
|
||||||
FS:=TJSFunctionDeclarationStatement(CreateElement(TJSFunctionDeclarationStatement,EL));
|
FS:=TJSFunctionDeclarationStatement(CreateElement(TJSFunctionDeclarationStatement,EL));
|
||||||
Result:=FS;
|
Result:=FS;
|
||||||
FD:=TJSFuncDef.Create;
|
FD:=TJSFuncDef.Create;
|
||||||
FD.Name:=TransFormFunctionName(El,AContext);
|
FD.Name:=TransFormFunctionName(El,AContext);
|
||||||
FS.AFunction:=FD;
|
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:=TJSFunctionBody(CreateElement(TJSFunctionBody,EL.Body));
|
||||||
FD.Body.A:=ConvertElement(El.Body,AContext);
|
FD.Body.A:=ConvertElement(El.Body,AContext);
|
||||||
{
|
{
|
||||||
@ -1220,7 +1404,190 @@ begin
|
|||||||
else
|
else
|
||||||
Result:=Nil;
|
Result:=Nil;
|
||||||
end;
|
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;
|
Function TPasToJSConverter.ConvertExceptOn(El: TPasImplExceptOn; AContext : TConvertContext): TJSElement;
|
||||||
|
|
||||||
Var
|
Var
|
||||||
@ -1379,3 +1746,4 @@ end;
|
|||||||
|
|
||||||
end.
|
end.
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -508,6 +508,8 @@ type
|
|||||||
{$elseif defined(Linux)}
|
{$elseif defined(Linux)}
|
||||||
PMSQid_ds = ^TMSQid_ds;
|
PMSQid_ds = ^TMSQid_ds;
|
||||||
TMSQid_ds = record
|
TMSQid_ds = record
|
||||||
|
{ 32 bit }
|
||||||
|
{$IFNDEF CPU64}
|
||||||
msg_perm : TIPC_perm;
|
msg_perm : TIPC_perm;
|
||||||
msg_first : PMsg;
|
msg_first : PMsg;
|
||||||
msg_last : PMsg;
|
msg_last : PMsg;
|
||||||
@ -519,6 +521,20 @@ type
|
|||||||
msg_qbytes : word;
|
msg_qbytes : word;
|
||||||
msg_lspid : ipc_pid_t;
|
msg_lspid : ipc_pid_t;
|
||||||
msg_lrpid : 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;
|
end;
|
||||||
{$else}
|
{$else}
|
||||||
{$if defined(Darwin)}
|
{$if defined(Darwin)}
|
||||||
|
|||||||
@ -1,5 +1,18 @@
|
|||||||
unit windirs;
|
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}
|
{$mode objfpc}
|
||||||
{$H+}
|
{$H+}
|
||||||
|
|
||||||
@ -8,7 +21,8 @@ interface
|
|||||||
uses
|
uses
|
||||||
windows;
|
windows;
|
||||||
|
|
||||||
Const
|
// CSIDL_* contants are also declared in "ShellApi" and "shfolder" units.
|
||||||
|
const
|
||||||
CSIDL_PROGRAMS = $0002; { %SYSTEMDRIVE%\Program Files }
|
CSIDL_PROGRAMS = $0002; { %SYSTEMDRIVE%\Program Files }
|
||||||
CSIDL_PERSONAL = $0005; { %USERPROFILE%\My Documents }
|
CSIDL_PERSONAL = $0005; { %USERPROFILE%\My Documents }
|
||||||
CSIDL_FAVORITES = $0006; { %USERPROFILE%\Favorites }
|
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) }
|
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
|
implementation
|
||||||
|
|
||||||
uses
|
uses
|
||||||
sysutils;
|
sysutils;
|
||||||
|
|
||||||
Type
|
type
|
||||||
PFNSHGetFolderPath = Function(Ahwnd: HWND; Csidl: Integer; Token: THandle; Flags: DWord; Path: {$ifdef FPC_UNICODE_RTL}PWideChar{$ELSE}PChar{$ENDIF}): HRESULT; stdcall;
|
// 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
|
var
|
||||||
SHGetFolderPath : PFNSHGetFolderPath = Nil;
|
_SHGetFolderPathW : TSHGetFolderPathW = nil;
|
||||||
CFGDLLHandle : THandle = 0;
|
DLLHandle: THandle = 0;
|
||||||
|
|
||||||
Procedure InitDLL;
|
procedure InitDLL;
|
||||||
|
var
|
||||||
Var
|
DLLPath: UnicodeString;
|
||||||
pathBuf: array[0..MAX_PATH-1] of {$ifdef FPC_UNICODE_RTL}WideChar{$else}Ansichar{$endif};
|
|
||||||
pathLength: Integer;
|
|
||||||
begin
|
begin
|
||||||
{ Load shfolder.dll using a full path, in order to prevent spoofing (Mantis #18185)
|
if DLLHandle = 0 then
|
||||||
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) }
|
|
||||||
begin
|
begin
|
||||||
StrLCopy(@pathBuf[pathLength],'\shfolder.dll',MAX_PATH-pathLength-1);
|
// Load DLL using a full path, in order to prevent spoofing (Mantis #18185)
|
||||||
CFGDLLHandle:=LoadLibrary(pathBuf);
|
DLLPath := GetWindowsSystemDirectoryUnicode;
|
||||||
|
if Length(DLLPath) > 0 then
|
||||||
if (CFGDLLHandle<>0) then
|
|
||||||
begin
|
begin
|
||||||
Pointer(ShGetFolderPath):=GetProcAddress(CFGDLLHandle,{$ifdef FPC_UNICODE_RTL}'SHGetFolderPathW'{$else}'SHGetFolderPathA'{$endif});
|
DLLPath := IncludeTrailingPathDelimiter(DLLPath) + SLibName;
|
||||||
If @ShGetFolderPath=nil then
|
DLLHandle := LoadLibraryW(PWideChar(DLLPath));
|
||||||
begin
|
if DLLHandle <> 0 then
|
||||||
FreeLibrary(CFGDLLHandle);
|
Pointer(_SHGetFolderPathW) := GetProcAddress(DLLHandle, SSHGetFolderPathW);
|
||||||
CFGDllHandle:=0;
|
|
||||||
end;
|
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
If (@ShGetFolderPath=Nil) then
|
if @_SHGetFolderPathW = nil then
|
||||||
Raise Exception.Create('Could not determine SHGetFolderPath Function');
|
raise Exception.Create('Could not locate SHGetFolderPath function');
|
||||||
end;
|
end;
|
||||||
|
|
||||||
Function GetWindowsSpecialDir(ID : Integer) : String;
|
procedure FinitDLL;
|
||||||
|
|
||||||
Var
|
|
||||||
APath : Array[0..MAX_PATH] of char;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result:='';
|
if DLLHandle <> 0 then
|
||||||
if (CFGDLLHandle=0) then
|
begin
|
||||||
InitDLL;
|
FreeLibrary(DLLHandle);
|
||||||
If (SHGetFolderPath<>Nil) then
|
DLLHandle := 0;
|
||||||
begin
|
end;
|
||||||
if SHGetFolderPath(0,ID or CSIDL_FLAG_CREATE,0,0,@APATH[0])=S_OK then
|
|
||||||
Result:=IncludeTrailingPathDelimiter(StrPas(@APath[0]));
|
|
||||||
end;
|
|
||||||
end;
|
end;
|
||||||
|
|
||||||
Initialization
|
function GetWindowsSystemDirectoryUnicode: UnicodeString;
|
||||||
Finalization
|
var
|
||||||
if CFGDLLHandle<>0 then
|
Buffer: array [0..MAX_PATH] of WideChar;
|
||||||
FreeLibrary(CFGDllHandle);
|
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.
|
end.
|
||||||
|
|
||||||
|
|||||||
@ -169,30 +169,30 @@ Function TLaTeXWriter.SplitLine (ALine : String): String;
|
|||||||
InString : Boolean;
|
InString : Boolean;
|
||||||
|
|
||||||
begin
|
begin
|
||||||
Result:=0;
|
Result:=0;
|
||||||
L:=Length(S);
|
L:=Length(S);
|
||||||
if (L>MaxVerbatimLength) then
|
if (L>MaxVerbatimLength) then
|
||||||
begin
|
begin
|
||||||
InString:=False;
|
InString:=False;
|
||||||
Result:=0;
|
Result:=0;
|
||||||
I:=1;
|
I:=1;
|
||||||
C:=@S[1];
|
C:=@S[1];
|
||||||
While (I<=MaxVerbatimLength) do
|
While (I<=L) and (Result<=MaxVerbatimLength) do
|
||||||
begin
|
begin
|
||||||
If C^='''' then
|
If C^='''' then
|
||||||
InString:=Not Instring
|
InString:=Not Instring
|
||||||
else if Not InString then
|
else if Not InString then
|
||||||
begin
|
begin
|
||||||
if Not (C^ in NonSplit) then
|
if Not (C^ in NonSplit) then
|
||||||
Result:=I;
|
Result:=I;
|
||||||
end;
|
end;
|
||||||
Inc(I);
|
Inc(I);
|
||||||
Inc(C);
|
Inc(C);
|
||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
If Result=0 then
|
If (Result=0) or (Result=1) then
|
||||||
Result:=L+1;
|
Result:=L+1;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
Var
|
Var
|
||||||
SP : Integer;
|
SP : Integer;
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user