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

--- Merging r42937 into '.':

Browse Source 
U    packages/fpmake_add.inc
U    packages/fpmake_proc.inc
A    packages/vcl-compat
A    packages/vcl-compat/Makefile
A    packages/vcl-compat/Makefile.fpc
A    packages/vcl-compat/fpmake.pp
A    packages/vcl-compat/src
A    packages/vcl-compat/src/System.NetEncoding.pp
A    packages/vcl-compat/tests
A    packages/vcl-compat/tests/tcnetencoding.pp
A    packages/vcl-compat/tests/testcompat.lpi
A    packages/vcl-compat/tests/testcompat.lpr
--- Recording mergeinfo for merge of r42937 into '.':
 U   .
--- Merging r42939 into '.':
U    packages/vcl-compat/fpmake.pp
--- Recording mergeinfo for merge of r42939 into '.':
 G   .
--- Merging r42975 into '.':
U    packages/paszlib/src/zipper.pp
--- Recording mergeinfo for merge of r42975 into '.':
 G   .
--- Merging r42976 into '.':
U    rtl/win/wininc/struct.inc
--- Recording mergeinfo for merge of r42976 into '.':
 G   .
--- Merging r43058 into '.':
U    utils/fpcm/fpmake.pp
--- Recording mergeinfo for merge of r43058 into '.':
 G   .
--- Merging r43059 into '.':
U    packages/graph/src/ptcgraph/ptcmouse.pp
U    packages/ptc/docs/CHANGES.txt
U    packages/ptc/src/ptcwrapper/ptcwrapper.pp
--- Recording mergeinfo for merge of r43059 into '.':
 G   .
--- Merging r43085 into '.':
G    packages/vcl-compat/fpmake.pp
A    packages/vcl-compat/src/system.netencoding.pp
D    packages/vcl-compat/src/System.NetEncoding.pp
--- Recording mergeinfo for merge of r43085 into '.':
 G   .
--- Merging r43086 into '.':
G    packages/paszlib/src/zipper.pp
--- Recording mergeinfo for merge of r43086 into '.':
 G   .

# revisions: 42937,42939,42975,42976,43058,43059,43085,43086

git-svn-id: branches/fixes_3_2@43173 -
This commit is contained in:
marco 2019-10-12 16:15:55 +00:00
parent 5ab703bffd
commit df577ea8a7
16 changed files with 3997 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -8235,6 +8235,13 @@ packages/uuid/examples/testuid.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/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.fpc 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_gnutls(ADirectory+IncludeTrailingPathDelimiter('gnutls'));
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}
end;
procedure add_vclcompat(const ADirectory: string);
begin
with Installer do
{$include vcl-compat/fpmake.pp}
end;
{$include ide/fpmake.pp}

10
packages/graph/src/ptcgraph/ptcmouse.pp
View File

@ -1,6 +1,6 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2013 by Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (c) 2013,2019 by Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (c) 1999-2000 by Florian Klaempfl
member of the Free Pascal development team
@ -47,10 +47,10 @@ function RPressed: Boolean;
{ returns true if the middle button is pressed }
function MPressed: Boolean;
(*!!!!! the following functions aren't implemented yet:
{ positions the mouse pointer }
procedure SetMousePos(x,y: LongInt);
(*!!!!! the following functions aren't implemented yet:
{ returns at which position "button" was last pressed in x,y and returns the
number of times this button has been pressed since the last time this
function was called with "button" as parameter. For button you can use the
@ -197,6 +197,12 @@ begin
buttons := MouseButtonState;
end;
procedure SetMousePos(x,y: LongInt);
begin
if InGraphMode then
PTCWrapperObject.MoveMouseTo(x, y);
end;
begin
MouseFound := True;
end.

4
packages/paszlib/src/zipper.pp
View File

@ -1046,7 +1046,7 @@ begin
Count:=C.Read(Buf^,FBufferSize);
For I:=0 to Count-1 do
UpdC32(Buf[i]);
FOutFile.Write(Buf^,Count);
FOutFile.WriteBuffer(Buf^,Count);
inc(BytesNow,Count);
if BytesNow>NextMark Then
begin
@ -2312,7 +2312,7 @@ var
AEndHdr := SwapECD(AEndHdr);
{$ENDIF}
if (AEndHdr.Signature = END_OF_CENTRAL_DIR_SIGNATURE) and
(I + SizeOf(AEndHdr) + AEndHdr.ZipFile_Comment_Length = BufSize) then
(I + SizeOf(AEndHdr) + AEndHdr.ZipFile_Comment_Length <= BufSize) then
begin
AEndHdrPos := FZipStream.Size - BufSize + I;
FZipStream.Seek(AEndHdrPos + SizeOf(AEndHdr), soBeginning);

3
packages/ptc/docs/CHANGES.txt
View File

@ -1,3 +1,6 @@
0.99.x
- added and implemented SetMousePos in unit ptcmouse
0.99.15
- dead key support under Windows and X11 (via XIM)
- more character scripts (Latin 2, Latin 3, Latin 4, Latin 9, Katakana,

39
packages/ptc/src/ptcwrapper/ptcwrapper.pp
View File

@ -1,6 +1,6 @@
{
Free Pascal PTCPas framebuffer library threaded wrapper
Copyright (C) 2010, 2011, 2012, 2013 Nikolay Nikolov (nickysn@users.sourceforge.net)
Copyright (C) 2010, 2011, 2012, 2013, 2019 Nikolay Nikolov (nickysn@users.sourceforge.net)
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
@ -87,6 +87,13 @@ type
Result: TPTCModeList;
end;
TPTCWrapperMoveMouseToRequest = record
X, Y: Integer;
Processed: Boolean;
Result: Boolean;
end;
TPTCWrapperThread = class(TThread)
private
FConsole: IPTCConsole;
@ -109,6 +116,7 @@ type
FCloseRequest: TPTCWrapperCloseRequest;
FOptionRequest: TPTCWrapperOptionRequest;
FGetModesRequest: TPTCWrapperGetModesRequest;
FMoveMouseToRequest: TPTCWrapperMoveMouseToRequest;
protected
procedure Execute; override;
public
@ -136,6 +144,8 @@ type
function NextEvent(out AEvent: IPTCEvent; AWait: Boolean; const AEventMask: TPTCEventMask): Boolean;
function PeekEvent(AWait: Boolean; const AEventMask: TPTCEventMask): IPTCEvent;
function MoveMouseTo(AX, AY: Integer): Boolean;
property IsOpen: Boolean read FOpen;
end;
@ -160,6 +170,7 @@ begin
FCloseRequest.Processed := True;
FOptionRequest.Processed := True;
FGetModesRequest.Processed := True;
FMoveMouseToRequest.Processed := True;
FSurfaceCriticalSection := TCriticalSection.Create;
@ -257,6 +268,12 @@ procedure TPTCWrapperThread.Execute;
FGetModesRequest.Result := FConsole.Modes;
FGetModesRequest.Processed := True;
end;
if not FMoveMouseToRequest.Processed then
begin
FMoveMouseToRequest.Result := FConsole.MoveMouseTo(FMoveMouseToRequest.X, FMoveMouseToRequest.Y);
FMoveMouseToRequest.Processed := True;
end;
end;
begin
@ -523,4 +540,24 @@ begin
until (not AWait) or (Result <> nil);
end;
function TPTCWrapperThread.MoveMouseTo(AX, AY: Integer): Boolean;
begin
FSurfaceCriticalSection.Acquire;
try
with FMoveMouseToRequest do
begin
X := AX;
Y := AY;
Processed := False;
end;
finally
FSurfaceCriticalSection.Release;
end;
repeat
ThreadSwitch;
until FMoveMouseToRequest.Processed;
Result := FMoveMouseToRequest.Result;
end;
end.

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

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

@ -0,0 +1,44 @@
{$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.';
P.OSes := P.OSes - [embedded];
{$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.

2
rtl/win/wininc/struct.inc
View File

@ -6068,7 +6068,7 @@ Const
PPREVENTMEDIAREMOVAL = ^PREVENT_MEDIA_REMOVAL;
{PRINTDLG = record conflicts with PrintDlg function }
TPRINTDLG = packed record
TPRINTDLG = {$ifndef win64}packed {$endif}record
lStructSize : DWORD;
hwndOwner : HWND;
hDevMode : HGLOBAL;

13
utils/fpcm/fpmake.pp
View File

@ -1,16 +1,5 @@
{$IFDEF MORPHOS}
{$IFDEF HASAMIGA}
{$DEFINE NO_UNIT_PROCESS}
{$DEFINE NO_THREADING}
{$ENDIF}
{$IFDEF AROS}
{$DEFINE NO_UNIT_PROCESS}
{$DEFINE NO_THREADING}
{$ENDIF}
{$IFDEF AMIGA}
{$DEFINE NO_UNIT_PROCESS}
{$DEFINE NO_THREADING}
{$ENDIF}
{$IFDEF OS2}