mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 21:28:14 +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.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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -124,6 +124,8 @@ type
|
||||
property Aborted;
|
||||
property Line;
|
||||
published
|
||||
Property UseDollarString;
|
||||
Property DollarStrings;
|
||||
property Directives;
|
||||
property Defines;
|
||||
property Script;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
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
|
||||
|
||||
[require]
|
||||
packages=rtl
|
||||
packages=rtl
|
||||
|
||||
[install]
|
||||
fpcpackage=y
|
||||
|
||||
@ -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');
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
|
||||
@ -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)}
|
||||
|
||||
@ -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.
|
||||
|
||||
|
||||
@ -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;
|
||||
|
||||
Loading…
Reference in New Issue
Block a user