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

* Initial version of System.NetEncoding.pp

Browse Source 
git-svn-id: trunk@42937 -
This commit is contained in:
michael 2019-09-07 19:20:04 +00:00
parent dfb00e85a0
commit 8cfee11345
10 changed files with 3943 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -9412,6 +9412,13 @@ packages/uuid/examples/testuid.pp svneol=native#text/plain
packages/uuid/fpmake.pp svneol=native#text/plain packages/uuid/fpmake.pp svneol=native#text/plain
packages/uuid/src/libuuid.pp svneol=native#text/plain packages/uuid/src/libuuid.pp svneol=native#text/plain
packages/uuid/src/macuuid.pp svneol=native#text/plain packages/uuid/src/macuuid.pp svneol=native#text/plain
packages/vcl-compat/Makefile svneol=native#text/plain
packages/vcl-compat/Makefile.fpc svneol=native#text/plain
packages/vcl-compat/fpmake.pp svneol=native#text/plain
packages/vcl-compat/src/System.NetEncoding.pp svneol=native#text/plain
packages/vcl-compat/tests/tcnetencoding.pp svneol=native#text/plain
packages/vcl-compat/tests/testcompat.lpi svneol=native#text/plain
packages/vcl-compat/tests/testcompat.lpr svneol=native#text/plain
packages/webidl/Makefile svneol=native#text/plain packages/webidl/Makefile svneol=native#text/plain
packages/webidl/Makefile.fpc svneol=native#text/plain packages/webidl/Makefile.fpc svneol=native#text/plain
packages/webidl/examples/parsewebidl.lpi svneol=native#text/plain packages/webidl/examples/parsewebidl.lpi svneol=native#text/plain

1
packages/fpmake_add.inc
View File

@ -142,4 +142,5 @@
add_webidl(ADirectory+IncludeTrailingPathDelimiter('webidl')); add_webidl(ADirectory+IncludeTrailingPathDelimiter('webidl'));
add_gnutls(ADirectory+IncludeTrailingPathDelimiter('gnutls')); add_gnutls(ADirectory+IncludeTrailingPathDelimiter('gnutls'));
add_ide(ADirectory+IncludeTrailingPathDelimiter('ide')); add_ide(ADirectory+IncludeTrailingPathDelimiter('ide'));
add_vclcompat(ADirectory+IncludeTrailingPathDelimiter('vcl-compat'));

6
packages/fpmake_proc.inc
View File

@ -807,5 +807,11 @@ begin
{$include webidl/fpmake.pp} {$include webidl/fpmake.pp}
end; end;
procedure add_vclcompat(const ADirectory: string);
begin
with Installer do
{$include vcl-compat/fpmake.pp}
end;
{$include ide/fpmake.pp} {$include ide/fpmake.pp}

2955
packages/vcl-compat/Makefile Normal file
View File

File diff suppressed because it is too large Load Diff

102
packages/vcl-compat/Makefile.fpc Normal file
View File

@ -0,0 +1,102 @@
#
# Makefile.fpc for running fpmake
#
[package]
name=vcl-compat
version=3.3.1
[require]
packages=rtl fcl-base fcl-web fcl-xml fpmkunit
[install]
fpcpackage=y
[default]
fpcdir=../..
[prerules]
FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
ifdef OS_TARGET
FPC_TARGETOPT+=--os=$(OS_TARGET)
endif
ifdef CPU_TARGET
FPC_TARGETOPT+=--cpu=$(CPU_TARGET)
endif
LOCALFPMAKE=./fpmake$(SRCEXEEXT)
[rules]
# Do not pass the Makefile's unit and binary target locations. Fpmake uses it's own.
override FPCOPT:=$(filter-out -FU%,$(FPCOPT))
override FPCOPT:=$(filter-out -FE%,$(FPCOPT))
# Do not pass the package-unitdirectories. Fpmake adds those and this way they don't apear in the .fpm
override FPCOPT:=$(filter-out $(addprefix -Fu,$(COMPILER_UNITDIR)),$(FPCOPT))# Compose general fpmake-parameters
# Compose general fpmake-parameters
ifdef FPMAKEOPT
FPMAKE_OPT+=$(FPMAKEOPT)
endif
FPMAKE_OPT+=--localunitdir=../..
FPMAKE_OPT+=--globalunitdir=..
FPMAKE_OPT+=$(FPC_TARGETOPT)
FPMAKE_OPT+=$(addprefix -o ,$(FPCOPT))
FPMAKE_OPT+=--compiler=$(FPC)
FPMAKE_OPT+=-bu
.NOTPARALLEL:
fpmake$(SRCEXEEXT): fpmake.pp
$(FPCFPMAKE) fpmake.pp $(FPMAKE_SKIP_CONFIG) $(addprefix -Fu,$(COMPILER_FPMAKE_UNITDIR)) $(FPCMAKEOPT) $(OPT)
all: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT)
smart: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -XX -o -CX
release: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dRELEASE
debug: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) compile $(FPMAKE_OPT) -o -dDEBUG
# If no fpmake exists and (dist)clean is called, do not try to build fpmake, it will
# most often fail because the dependencies are cleared.
# In case of a clean, simply do nothing
ifeq ($(FPMAKE_BIN_CLEAN),)
clean:
else
clean:
$(FPMAKE_BIN_CLEAN) clean $(FPMAKE_OPT)
endif
# In case of a distclean, perform an 'old'-style distclean. This to avoid problems
# when the package is compiled using fpcmake prior to running this clean using fpmake
ifeq ($(FPMAKE_BIN_CLEAN),)
distclean: $(addsuffix _distclean,$(TARGET_DIRS)) fpc_cleanall
else
distclean:
ifdef inUnix
{ $(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT); if [ $$? != "0" ]; then { echo Something wrong with fpmake exectable. Remove the executable and call make recursively to recover.; $(DEL) $(FPMAKE_BIN_CLEAN); $(MAKE) fpc_cleanall; }; fi; }
else
$(FPMAKE_BIN_CLEAN) distclean $(FPMAKE_OPT)
endif
-$(DEL) $(LOCALFPMAKE)
endif
cleanall: distclean
install: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR)
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR)
endif
# distinstall also installs the example-sources and omits the location of the source-
# files from the fpunits.cfg files.
distinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_PREFIX) --baseinstalldir=$(INSTALL_LIBDIR)/fpc/$(FPC_VERSION) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
else
$(LOCALFPMAKE) install $(FPMAKE_OPT) --prefix=$(INSTALL_BASEDIR) --baseinstalldir=$(INSTALL_BASEDIR) --unitinstalldir=$(INSTALL_UNITDIR) -ie -fsp 0
endif
zipinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX)
zipdistinstall: fpmake$(SRCEXEEXT)
$(LOCALFPMAKE) zipinstall $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) -ie -fsp 0
zipsourceinstall: fpmake$(SRCEXEEXT)
ifdef UNIXHier
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=share/src/fpc-\$$\(PACKAGEVERSION\)/$(INSTALL_FPCSUBDIR)/\$$\(PACKAGEDIRECTORY\)
else
$(LOCALFPMAKE) archive $(FPMAKE_OPT) --zipprefix=$(DIST_DESTDIR)/$(ZIPPREFIX) --prefix=source\\$(INSTALL_FPCSUBDIR)\\\$$\(PACKAGEDIRECTORY\)
endif

43
packages/vcl-compat/fpmake.pp Normal file
View File

@ -0,0 +1,43 @@
{$ifndef ALLPACKAGES}
{$mode objfpc}{$H+}
program fpmake;
uses fpmkunit;
Var
P : TPackage;
T : TTarget;
begin
With Installer do
begin
{$endif ALLPACKAGES}
P:=AddPackage('vcl-compat');
P.ShortName:='vclcomp';
P.Author := 'Michael Van Canneyt';
P.License := 'LGPL with modification';
P.HomepageURL := 'www.freepascal.org';
P.Email := '';
P.Description := 'Various non-visual VCL compatibility units.';
{$ifdef ALLPACKAGES}
P.Directory:=ADirectory;
{$endif ALLPACKAGES}
P.Version:='3.3.1';
P.Dependencies.Add('fcl-base');
P.Dependencies.Add('fcl-xml');
P.Dependencies.Add('fcl-web');
P.Dependencies.Add('rtl-extra');
P.SourcePath.Add('src');
P.IncludePath.Add('src');
T:=P.Targets.AddUnit('System.NetEncoding.pp');
T.ResourceStrings := True;
{$ifndef ALLPACKAGES}
Run;
end;
end.
{$endif ALLPACKAGES}

515
packages/vcl-compat/src/System.NetEncoding.pp Normal file
View File

@ -0,0 +1,515 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2019 by Michael Van Canneyt, member of the
Free Pascal development team
VCL compatible TNetEncoding unit
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.
**********************************************************************}
{$mode objfpc}
{$H+}
unit System.NetEncoding;
interface
uses Sysutils, Classes;
type
// Not used here
EHTTPException = class(Exception);
{ TNetEncoding }
TNetEncoding = class
private
Const
StdCount = 3;
Class var
FStdEncodings : Array[1..StdCount] of TNetEncoding;
Class Function GetStdEncoding(aIndex : Integer) : TNetEncoding; Static;
Class Destructor Destroy;
protected
// These must be implemented by descendents
Function DoDecode(const aInput: RawByteString): RawByteString; overload; virtual; abstract;
Function DoEncode(const aInput: RawByteString): RawByteString; overload; virtual; abstract;
// These can be overridden by descendents for effiency
Function DoDecode(const aInput: UnicodeString): UnicodeString; overload; virtual;
Function DoEncode(const aInput: UnicodeString): UnicodeString; overload; virtual;
Function DoDecode(const aInput, aOutput: TStream): Integer; overload; virtual;
Function DoEncode(const aInput, aOutput: TStream): Integer; overload; virtual;
Function DoDecode(const aInput: array of Byte): TBytes; overload; virtual;
Function DoEncode(const aInput: array of Byte): TBytes; overload; virtual;
Function DoDecodeStringToBytes(const aInput: RawByteString): TBytes; virtual; overload;
Function DoDecodeStringToBytes(const aInput: UnicodeString): TBytes; virtual; overload;
Function DoEncodeBytesToString(const aInput: array of Byte): UnicodeString; overload; virtual;
Function DoEncodeBytesToString(const aInput: Pointer; Size: Integer): UnicodeString; overload; virtual;
public
Class Procedure FreeStdEncodings;
// Public stubs, they call the Do* versions
// Stream
Function Decode(const aInput, aOutput: TStream): Integer; overload;
Function Encode(const aInput, aOutput: TStream): Integer; overload;
// TBytes
Function Decode(const aInput: array of Byte): TBytes; overload;
Function Encode(const aInput: array of Byte): TBytes; overload;
// Strings
Function Decode(const aInput: UnicodeString): UnicodeString; overload;
Function Encode(const aInput: UnicodeString): UnicodeString; overload;
Function Decode(const aInput: RawByteString): RawByteString; overload;
Function Encode(const aInput: RawByteString): RawByteString; overload;
// UnicodeString to Bytes
Function DecodeStringToBytes(const aInput: UnicodeString): TBytes;
Function DecodeStringToBytes(const aInput: RawByteString): TBytes;
Function EncodeBytesToString(const aInput: array of Byte): UnicodeString; overload;
Function EncodeBytesToString(const aInput: Pointer; Size: Integer): UnicodeString; overload;
// Default instances
class property Base64: TNetEncoding Index 1 read GetStdEncoding;
class property HTML: TNetEncoding Index 2 read GetStdEncoding;
class property URL: TNetEncoding Index 3 read GetStdEncoding;
end;
{ TBase64Encoding }
TBase64Encoding = class(TNetEncoding)
protected
Function DoDecode(const aInput, aOutput: TStream): Integer; overload; override;
Function DoEncode(const aInput, aOutput: TStream): Integer; overload; override;
Function DoDecode(const aInput: RawByteString): RawByteString; overload; override;
Function DoEncode(const aInput: RawByteString): RawByteString; overload; override;
end;
TURLEncoding = class(TNetEncoding)
protected
Function DoEncode(const aInput: RawBytestring): RawBytestring; overload; override;
Function DoDecode(const aInput: RawBytestring): RawBytestring; overload; override;
end;
THTMLEncoding = class(TNetEncoding)
protected
Function DoDecode(const aInput: UnicodeString): UnicodeString; override;
Function DoDecode(const aInput: RawBytestring): RawBytestring; overload; override;
Function DoEncode(const aInput: UnicodeString): UnicodeString; override;
Function DoEncode(const aInput: RawBytestring): RawBytestring; overload; override;
end;
implementation
uses base64, httpprotocol, HTMLDefs, xmlread;
Resourcestring
sInvalidHTMLEntity = 'Invalid HTML encoded character: %s';
{ TBase64Encoding }
function TBase64Encoding.DoDecode(const aInput, aOutput: TStream): Integer;
Var
S : TBase64DecodingStream;
begin
S:=TBase64DecodingStream.Create(aInput,bdmMIME);
try
Result:=S.Size;
aOutput.CopyFrom(S,Result);
finally
S.Free;
end;
end;
function TBase64Encoding.DoEncode(const aInput, aOutput: TStream): Integer;
Var
S : TBase64DecodingStream;
begin
S:=TBase64DecodingStream.Create(aInput);
try
Result:=S.Size;
aOutput.CopyFrom(S,Result);
finally
S.Free;
end;
end;
function TBase64Encoding.DoDecode(const aInput: RawByteString): RawByteString;
begin
Result:=DecodeStringBase64(aInput,False);
end;
function TBase64Encoding.DoEncode(const aInput: RawByteString): RawByteString;
begin
Result:=EncodeStringBase64(aInput);
end;
{ ---------------------------------------------------------------------
TNetEncoding
---------------------------------------------------------------------}
class procedure TNetEncoding.FreeStdEncodings;
Var
I : Integer;
begin
For I:=1 to StdCount do
FreeAndNil(FStdEncodings[i]);
end;
class destructor TNetEncoding.Destroy;
begin
FreeStdEncodings;
end;
class Function TNetEncoding.GetStdEncoding(aIndex: Integer): TNetEncoding;
begin
if FStdEncodings[aIndex]=Nil then
case aIndex of
1 : FStdEncodings[1]:=TBase64Encoding.Create;
2 : FStdEncodings[2]:=THTMLEncoding.Create;
3 : FStdEncodings[3]:=TURLEncoding.Create;
end;
Result:=FStdEncodings[aIndex];
end;
// Public API
Function TNetEncoding.Encode(const aInput: array of Byte): TBytes;
begin
Result:=DoEncode(aInput);
end;
Function TNetEncoding.Encode(const aInput, aOutput: TStream): Integer;
begin
Result:=DoEncode(aInput, aOutput);
end;
Function TNetEncoding.Decode(const aInput: RawByteString): RawByteString; overload;
begin
Result:=DoDecode(aInput);
end;
Function TNetEncoding.Encode(const aInput: RawByteString): RawByteString; overload;
begin
Result:=DoEncode(aInput);
end;
Function TNetEncoding.Encode(const aInput: UnicodeString): UnicodeString;
begin
Result:=DoEncode(aInput);
end;
Function TNetEncoding.EncodeBytesToString(const aInput: array of Byte): UnicodeString;
begin
Result:=DoEncodeBytesToString(aInput);
end;
Function TNetEncoding.EncodeBytesToString(const aInput: Pointer; Size: Integer): UnicodeString;
begin
Result:=DoEncodeBytesToString(aInput, Size);
end;
Function TNetEncoding.Decode(const aInput, aOutput: TStream): Integer;
begin
Result:=DoDecode(aInput,aOutput);
end;
Function TNetEncoding.Decode(const aInput: UnicodeString): UnicodeString;
begin
Result:=DoDecode(aInput);
end;
Function TNetEncoding.DecodeStringToBytes(const aInput: UnicodeString): TBytes;
begin
Result:=DoDecodeStringToBytes(aInput);
end;
function TNetEncoding.DecodeStringToBytes(const aInput: RawByteString): TBytes;
begin
Result:=DoDecodeStringToBytes(aInput);
end;
Function TNetEncoding.Decode(const aInput: array of Byte): TBytes;
begin
Result:=DoDecode(aInput);
end;
// Protected
Function TNetEncoding.DoDecode(const aInput: UnicodeString): UnicodeString;
Var
U : UTF8String;
begin
U:=UTF8Encode(aInput);
Result:=UTF8Decode(DoDecode(U));
end;
Function TNetEncoding.DoEncode(const aInput: UnicodeString): UnicodeString;
Var
U : UTF8String;
begin
U:=UTF8Encode(aInput);
Result:=UTF8Decode(DoEncode(U));
end;
Function TNetEncoding.DoDecode(const aInput: array of Byte): TBytes;
begin
if Length(aInput)=0 then
Result:=Default(TBytes)
else
Result:=TEncoding.UTF8.GetBytes(DoDecode(UTF8ToString(aInput)));
end;
Function TNetEncoding.DoDecode(const aInput, aOutput: TStream): Integer;
var
Src,Dest: TBytes;
Len : Integer;
begin
Result:=0;
Len:=aInput.Size;
if Len<>0 then
begin
Src:=Default(TBytes);
SetLength(Src,Len);
aInput.ReadBuffer(Src,Len);
Dest:=DoDecode(Src);
Result:=Length(Dest);
aOutput.WriteBuffer(Dest,Result);
end
end;
Function TNetEncoding.DoDecodeStringToBytes(const aInput: UnicodeString): TBytes;
begin
Result:=TEncoding.UTF8.GetBytes(DoDecode(aInput));
end;
Function TNetEncoding.DoEncode(const aInput: array of Byte): TBytes;
begin
if Length(aInput)=0 then
Result:=Default(TBytes)
else
Result:=TEncoding.UTF8.GetBytes(DoEncode(UTF8ToString(aInput)))
end;
function TNetEncoding.DoDecodeStringToBytes(const aInput: RawByteString): TBytes;
Var
U : RawByteString;
begin
U:=AInput;
UniqueString(U);
SetCodePage(U,CP_UTF8,True);
Result:=DoDecodeStringToBytes(UTF8Decode(U));
end;
Function TNetEncoding.DoEncodeBytesToString(const aInput: array of Byte): UnicodeString;
begin
Result:=TEncoding.UTF8.GetString(DoEncode(aInput));
end;
Function TNetEncoding.DoEncodeBytesToString(const aInput: Pointer; Size: Integer): UnicodeString;
Var
Src : TBytes;
begin
Src:=Default(TBytes);
SetLength(Src,Size);
Move(aInput^,Src[0],Size);
DoEncodeBytesToString(Src);
end;
Function TNetEncoding.DoEncode(const aInput, aOutput: TStream): Integer;
var
InBuf: array of Byte;
OutBuf: TBytes;
begin
if aInput.Size > 0 then
begin
SetLength(InBuf, aInput.Size);
aInput.Read(InBuf[0], aInput.Size);
OutBuf:=DoEncode(InBuf);
Result:=Length(OutBuf);
aOutput.Write(OutBuf, Result);
SetLength(InBuf, 0);
end
else
Result:=0;
end;
{ TBase64Encoding }
{ TURLEncoding }
Function TURLEncoding.DoDecode(const aInput: RawByteString): RawByteString;
begin
Result:=HTTPDecode(aInput);
end;
Function TURLEncoding.DoEncode(const aInput: RawByteString): RawByteString;
begin
Result:=HTTPEncode(aInput)
end;
{ THTMLEncoding }
Function THTMLEncoding.DoEncode(const aInput: UnicodeString): UnicodeString;
Var
S : UTF8String;
begin
S:=UTF8Encode(aInput);
Result:=UTF8Decode(DoEncode(S));
end;
Function THTMLEncoding.DoEncode(const aInput: RawByteString): RawByteString;
var
Src, Curr, OrigDest,Dest : PAnsiChar;
Procedure CopyData(S : String);
Var
len : integer;
begin
Len:=(Curr-Src);
if Len>0 then
Move(Src^,Dest^,Len);
Src:=Curr;
Inc(Src);
inc(Dest,Len);
Len:=Length(S);
if Len>0 then
Move(S[1],Dest^,Len);
inc(Dest,Len);
end;
begin
SetLength(Result,Length(aInput)*6);
if Length(aInput)=0 then exit;
Src:=PAnsiChar(aInput);
Curr:=Src;
OrigDest:=PAnsiChar(Result);
Dest:=OrigDest;
// Convert: &, <, >, "
while Curr^<>#0 do
begin
case Curr^ of
'&': CopyData('&amp;');
'<': CopyData('&lt;');
'>': CopyData('&gt;');
'"': CopyData('&quot;');
end;
Inc(Curr);
end;
CopyData('');
SetLength(Result,Dest-OrigDest);
end;
Function THTMLEncoding.DoDecode(const aInput: RawByteString): RawByteString;
Var
S : RawByteString;
begin
S:=aInput;
UniqueString(S);
SetCodePage(S,CP_UTF8,true);
Result:=UTF8Encode(DoDecode(UTF8Decode(S)));
end;
Function THTMLEncoding.DoDecode(const aInput: UnicodeString): UnicodeString;
var
Src, Curr, Dest : PWideChar;
Procedure CopyData(S : UnicodeString);
Var
len : integer;
begin
Len:=(Curr-Src);
if Len>0 then
begin
Move(Src^,Dest^,Len*Sizeof(UnicodeChar));
inc(Dest,Len);
end;
Len:=Length(S);
if Len>0 then
begin
Move(S[1],Dest^,Len*Sizeof(UnicodeChar));
inc(Dest,Len);
end;
end;
Var
Len : Integer;
U : UnicodeChar;
US : Unicodestring;
Ent,OrigDest : PWideChar;
begin
SetLength(Result, Length(aInput));
if Length(Result)=0 then exit;
Src:=PWideChar(aInput);
OrigDest:=PWideChar(Result);
Dest:=OrigDest;
Curr:=Src;
while Curr^ <> #0 do
begin
If Curr^='&' then
begin
CopyData('');
Src:=Curr;
Ent:=Curr;
While Not (Ent^ in [#0,';']) do
Inc(Ent);
Len:=Ent-Curr-1;
SetLength(US,Len);
if Len>0 then
Move(Curr[1],US[1],Len*SizeOf(UnicodeChar));
if not ResolveHTMLEntityReference(US,U) then
raise EConvertError.CreateFmt(sInvalidHTMLEntity,[US]);
CopyData(U);
Curr:=Ent;
Src:=Curr;
Inc(Src);
end;
Inc(Curr);
end;
CopyData('');
SetLength(Result,Dest-OrigDest);
end;
end.

222
packages/vcl-compat/tests/tcnetencoding.pp Normal file
View File

@ -0,0 +1,222 @@
unit tcnetencoding;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, fpcunit, testutils, testregistry, System.NetEncoding;
type
{ TTestBase64Encoding }
TTestBase64Encoding = class(TTestCase)
private
FBytes: TBytes;
FEnc: TBase64Encoding;
FEnDefBytes: TBytes;
procedure AssertBytes(aExpected, aActual: TBytes);
protected
procedure SetUp; override;
procedure TearDown; override;
property Enc : TBase64Encoding Read FEnc;
Property DefBytes : TBytes read FBytes;
Property EncDefBytes : TBytes read FEnDefBytes;
published
procedure TestHookUp;
procedure TestBytesToString;
procedure TestBytesToBytes;
procedure TestStringToString;
end;
{ TTestURLEncoding }
TTestURLEncoding = class(TTestCase)
private
FEnc: TURLEncoding;
protected
procedure SetUp; override;
procedure TearDown; override;
property Enc : TURLEncoding Read FEnc;
published
procedure TestHookUp;
Procedure TestSpace;
procedure TestEqual;
procedure TestAmpersand;
procedure TestQuestion;
end;
{ TTestHTMLEncoding }
TTestHTMLEncoding = class(TTestCase)
private
FEnc: THTMLEncoding;
protected
procedure SetUp; override;
procedure TearDown; override;
property Enc : THTMLEncoding Read FEnc;
published
procedure TestHookUp;
procedure TestLessThan;
procedure TestGreaterThan;
procedure TestAmpersand;
procedure TestBeforeAfter;
end;
implementation
{ TTestHTMLEncoding }
procedure TTestHTMLEncoding.SetUp;
begin
inherited SetUp;
FEnc:=THTMLEncoding.Create;
end;
procedure TTestHTMLEncoding.TearDown;
begin
inherited TearDown;
FEnc:=THTMLEncoding.Create;
end;
procedure TTestHTMLEncoding.TestHookUp;
begin
AssertNotNull('Enc',Enc);
end;
procedure TTestHTMLEncoding.TestLessThan;
begin
AssertEquals('from lessThan','&lt;',Enc.Encode('<'));
AssertEquals('To lessthan','<',Enc.Decode('&lt;'));
end;
procedure TTestHTMLEncoding.TestGreaterThan;
begin
AssertEquals('from greaterThan','&gt;',Enc.Encode('>'));
AssertEquals('To greaterthan','>',Enc.Decode('&gt;'));
end;
procedure TTestHTMLEncoding.TestAmpersand;
begin
AssertEquals('from ampersand','&amp;',Enc.Encode('&'));
AssertEquals('To ampersand','&',Enc.Decode('&amp;'));
end;
procedure TTestHTMLEncoding.TestBeforeAfter;
begin
AssertEquals('from ','A&amp;B',Enc.Encode('A&B'));
AssertEquals('To ','A&B',Enc.Decode('A&amp;B'));
end;
{ TTestURLEncoding }
procedure TTestURLEncoding.SetUp;
begin
inherited SetUp;
FEnc:=TURLENcoding.Create;
end;
procedure TTestURLEncoding.TearDown;
begin
FreeAndNil(FEnc);
inherited TearDown;
end;
procedure TTestURLEncoding.TestHookUp;
begin
AssertNotNull('Enc',Enc);
end;
procedure TTestURLEncoding.TestSpace;
begin
AssertEquals('Space','+',Enc.Encode(' '));
end;
procedure TTestURLEncoding.TestEqual;
begin
AssertEquals('from Equal','%'+hexStr(Ord('='),2),Enc.Encode('='));
AssertEquals('To Equal','=',Enc.Decode('%'+hexStr(Ord('='),2)));
end;
procedure TTestURLEncoding.TestAmpersand;
begin
AssertEquals('From Ampersand','%'+hexStr(Ord('&'),2),Enc.Encode('&'));
AssertEquals('To Ampersand','&',Enc.Decode('%'+hexStr(Ord('&'),2)));
end;
procedure TTestURLEncoding.TestQuestion;
begin
AssertEquals('From QuestionMark','%'+hexStr(Ord('?'),2),Enc.Encode('?'));
AssertEquals('To questionmark','?',Enc.Decode('%'+hexStr(Ord('?'),2)));
end;
{ TTestBase64Encoding }
Const
// Sequence of 5 bytes: 0,1,2,3,4 base64 encoded
SDefBytes = 'AQIDBAU=';
// Sequence of 5 letters: ABCDE base64 encoded
SDefLetters = 'QUJDREU=';
procedure TTestBase64Encoding.SetUp;
Var
I : integer;
begin
Inherited;
FEnc:=TBase64Encoding.Create;
SetLength(FBytes,5);
For I:=0 to 4 do
FBytes[I]:=I+1;
SetLength(FEnDefBytes,Length(SDefBytes));
For I:=0 to Length(SDefBytes)-1 do
FEnDefBytes[I]:=Ord(SDefBytes[I+1]);
end;
procedure TTestBase64Encoding.TearDown;
begin
FreeAndNil(FEnc);
Inherited;
end;
procedure TTestBase64Encoding.TestHookUp;
begin
AssertNotNull('Enc',Enc);
end;
procedure TTestBase64Encoding.AssertBytes(aExpected,aActual : TBytes);
Var
I : Integer;
begin
AssertEquals('Length same',Length(aExpected),Length(aActual));
For I:=0 to Length(aExpected)-1 do
AssertEquals(Format('Byte at pos %d same',[i]),aExpected[i],aActual[i]);
end;
procedure TTestBase64Encoding.TestBytesToString;
begin
AssertEquals('Encoding', SDefBytes,Enc.EncodeBytesToString(DefBytes));
end;
procedure TTestBase64Encoding.TestBytesToBytes;
begin
AssertBytes(EncDefBytes,Enc.Encode(DefBytes));
end;
procedure TTestBase64Encoding.TestStringToString;
begin
AssertEquals('Encoding', SDefLetters,Enc.Encode('ABCDE'));
end;
initialization
RegisterTests([TTestBase64Encoding,TTestURLEncoding,TTestHTMLEncoding]);
end.

62
packages/vcl-compat/tests/testcompat.lpi Normal file
View File

@ -0,0 +1,62 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="12"/>
<General>
<SessionStorage Value="InProjectDir"/>
<Title Value="testcompat"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<BuildModes>
<Item Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
<UseFileFilters Value="True"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="FCL"/>
</Item1>
</RequiredPackages>
<Units>
<Unit>
<Filename Value="testcompat.lpr"/>
<IsPartOfProject Value="True"/>
</Unit>
<Unit>
<Filename Value="tcnetencoding.pp"/>
<IsPartOfProject Value="True"/>
</Unit>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="testcompat"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../src"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

30
packages/vcl-compat/tests/testcompat.lpr Normal file
View File

@ -0,0 +1,30 @@
program testcompat;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}cwstring,{$ENDIF}
Classes, consoletestrunner, tcnetencoding;
type
{ TMyTestRunner }
TMyTestRunner = class(TTestRunner)
protected
// override the protected methods of TTestRunner to customize its behavior
end;
var
Application: TMyTestRunner;
begin
DefaultRunAllTests:=true;
DefaultFormat:=fPlain;
Application := TMyTestRunner.Create(nil);
Application.Initialize;
Application.Title:='testcompat';
Application.Run;
Application.Free;
end.