paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 17:59:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@47357 -
This commit is contained in:
nickysn 2020-11-09 00:06:32 +00:00
commit 93ecf5f155
34 changed files with 572 additions and 66 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitattributes vendored
View File

@ -11941,6 +11941,9 @@ rtl/riscv64/strings.inc svneol=native#text/plain
rtl/riscv64/stringss.inc svneol=native#text/plain
rtl/sinclairql/Makefile.fpc svneol=native#text/plain
rtl/sinclairql/buildrtl.pp svneol=native#text/plain
rtl/sinclairql/qdos.inc svneol=native#text/plain
rtl/sinclairql/qdosfuncs.inc svneol=native#text/plain
rtl/sinclairql/qdosh.inc svneol=native#text/plain
rtl/sinclairql/rtl.cfg svneol=native#text/plain
rtl/sinclairql/rtldefs.inc svneol=native#text/plain
rtl/sinclairql/si_prc.pp svneol=native#text/plain
@ -18559,6 +18562,8 @@ tests/webtbs/tw37969.pp svneol=native#text/pascal
tests/webtbs/tw38012.pp svneol=native#text/pascal
tests/webtbs/tw38022.pp svneol=native#text/pascal
tests/webtbs/tw3805.pp svneol=native#text/plain
tests/webtbs/tw38051.pp svneol=native#text/pascal
tests/webtbs/tw38054.pp svneol=native#text/plain
tests/webtbs/tw3814.pp svneol=native#text/plain
tests/webtbs/tw3827.pp svneol=native#text/plain
tests/webtbs/tw3829.pp svneol=native#text/plain

2
compiler/m68k/ra68kmot.pas
View File

@ -1522,6 +1522,8 @@ const
end
else
begin
if actasmtoken = AS_LPAREN then
oper.initref;
if not oper.SetupVar(expr,false) then
begin
{ not a variable, check special variables.. }

5
compiler/pexpr.pas
View File

@ -290,13 +290,14 @@ implementation
statement_syssym:=new_dispose_statement(false);
end;
in_ord_x :
in_ord_x,
in_chr_byte:
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr([ef_accept_equal]);
consume(_RKLAMMER);
p1:=geninlinenode(in_ord_x,false,p1);
p1:=geninlinenode(l,false,p1);
statement_syssym := p1;
end;

2
compiler/pinline.pas
View File

@ -382,7 +382,7 @@ implementation
{ create call to fpc_getmem }
para := ccallparanode.create(cordconstnode.create
(tpointerdef(p.resultdef).pointeddef.size,s32inttype,true),nil);
(tpointerdef(p.resultdef).pointeddef.size,ptruinttype,true),nil);
addstatement(newstatement,cassignmentnode.create(
ctemprefnode.create(temp),
ccallnode.createintern('fpc_getmem',para)));

2
compiler/ppu.pas
View File

@ -50,7 +50,7 @@ const
CurrentPPUVersion = 208;
{ for any other changes to the ppu format, increase this version number
(it's a cardinal) }
CurrentPPULongVersion = 11;
CurrentPPULongVersion = 12;
{ unit flags }
uf_big_endian = $000004;

1
compiler/psystem.pas
View File

@ -70,6 +70,7 @@ implementation
systemunit.insert(csyssym.create('Slice',in_slice_x));
systemunit.insert(csyssym.create('Seg',in_seg_x));
systemunit.insert(csyssym.create('Ord',in_ord_x));
systemunit.insert(csyssym.create('Chr',in_chr_byte));
systemunit.insert(csyssym.create('Pred',in_pred_x));
systemunit.insert(csyssym.create('Succ',in_succ_x));
systemunit.insert(csyssym.create('Exclude',in_exclude_x_y));

87
compiler/systems/t_sinclairql.pas
View File

@ -35,6 +35,7 @@ type
private
Origin: DWord;
UseVLink: boolean;
ExeLength: longint;
function WriteResponseFile(isdll: boolean): boolean;
procedure SetSinclairQLInfo;
function MakeSinclairQLExe: boolean;
@ -54,7 +55,7 @@ implementation
const
DefaultOrigin = $20000;
DefaultOrigin = $0;
constructor TLinkerSinclairQL.Create;
@ -83,7 +84,7 @@ begin
end
else
begin
ExeCmd[1]:='vlink -b rawbin1 $FLAGS $GCSECTIONS $OPT $STRIP -o $EXE -T $RES';
ExeCmd[1]:='vlink -b rawseg -q $FLAGS $GCSECTIONS $OPT $STRIP -o $EXE -T $RES';
end;
end;
end;
@ -105,10 +106,8 @@ end;
function TLinkerSinclairQL.WriteResponseFile(isdll: boolean): boolean;
var
linkres : TLinkRes;
i : longint;
HPath : TCmdStrListItem;
s : string;
linklibc : boolean;
begin
WriteResponseFile:=False;
@ -177,9 +176,13 @@ begin
Add('SECTIONS');
Add('{');
Add(' . = 0x'+hexstr(Origin,8)+';');
Add(' .text : { *(.text .text.* _CODE _CODE.* ) }');
Add(' .data : { *(.data .data.* .rodata .rodata.* .fpc.* ) }');
Add(' .bss : { *(_BSS _BSS.*) *(.bss .bss.*) *(_BSSEND _BSSEND.*) *(_HEAP _HEAP.*) *(.stack .stack.*) *(_STACK _STACK.*) }');
Add(' .text : {');
Add(' _stext = .;');
Add(' *(.text .text.* _CODE _CODE.* ) ');
Add(' *(.data .data.* .rodata .rodata.* .fpc.* ) ');
Add(' *(_BSS _BSS.*) *(.bss .bss.*) *(_BSSEND _BSSEND.*) *(_HEAP _HEAP.*) *(.stack .stack.*) *(_STACK _STACK.*) ');
Add(' _etext = .;');
Add(' }');
Add('}');
end;
@ -200,6 +203,9 @@ var
GCSectionsStr : string;
FlagsStr : string;
ExeName: string;
fd,fs: file;
buf: pointer;
bufread,bufsize: longint;
begin
StripStr:='';
GCSectionsStr:='';
@ -213,12 +219,10 @@ begin
if UseVLink then
begin
if create_smartlink_sections then
GCSectionsStr:='-gc-all -sc';
GCSectionsStr:='-gc-all';
end;
ExeName:=current_module.exefilename;
if apptype = app_gui then
Replace(ExeName,target_info.exeext,'.prg');
{ Call linker }
SplitBinCmd(Info.ExeCmd[1],BinStr,CmdStr);
@ -232,12 +236,57 @@ begin
Replace(cmdstr,'$DYNLINK',DynLinkStr);
MakeSinclairQLExe:=DoExec(BinStr,CmdStr,true,false);
{ Kludge:
With the above linker script, vlink will produce two files,
"exename. text" and "exename. text.rel text". The former is the
binary itself, the second is the relocation info. Here we copy
the two together. I'll try to get vlink to do this for me in the
future. (KB) }
if MakeSinclairQLExe then
begin
ExeLength:=0;
bufsize:=16384;
{$push}
{$i-}
buf:=GetMem(bufsize);
assign(fd,exename);
rewrite(fd,1);
assign(fs,exename+'. text');
reset(fs,1);
repeat
blockread(fs,buf^,bufsize,bufread);
blockwrite(fd,buf^,bufread);
until eof(fs);
close(fs);
// erase(fs);
assign(fs,exename+'. text.rel text');
reset(fs,1);
repeat
blockread(fs,buf^,bufsize,bufread);
blockwrite(fd,buf^,bufread);
until eof(fs);
close(fs);
// erase(fs);
ExeLength:=FileSize(fd);
close(fd);
{$pop}
MakeSinclairQLExe:=not (ExeLength = 0);
end;
end;
function TLinkerSinclairQL.MakeExecutable:boolean;
const
DefaultBootString = '10 $SYM=RESPR($BINSIZE):LBYTES"win1_$EXENAME",$SYM:CALL $SYM';
var
success : boolean;
bootfile : TScript;
ExeName: String;
BootStr: String;
begin
if not(cs_link_nolink in current_settings.globalswitches) then
Message1(exec_i_linking,current_module.exefilename);
@ -251,6 +300,24 @@ begin
if (success) and not(cs_link_nolink in current_settings.globalswitches) then
DeleteFile(outputexedir+Info.ResName);
if (success) then
begin
ExeName:=current_module.exefilename;
BootStr:=DefaultBootString;
Replace(BootStr,'$BINSIZE',tostr(ExeLength)); { FIX ME }
Replace(BootStr,'$EXENAME',ExeName);
Replace(ExeName,target_info.exeext,'');
Replace(BootStr,'$SYM',ExeName);
{ Write bootfile }
bootfile:=TScript.Create(outputexedir+ExeName);
bootfile.Add(BootStr);
bootfile.writetodisk;
bootfile.Free;
end;
MakeExecutable:=success; { otherwise a recursive call to link method }
end;

8
compiler/x86/cgx86.pas
View File

@ -178,8 +178,6 @@ unit cgx86;
winstackpagesize = 4096;
{$endif NOTARGETWIN}
function UseAVX: boolean;
function UseIncDec: boolean;
{ returns true, if the compiler should use leave instead of mov/pop }
@ -196,12 +194,6 @@ unit cgx86;
paramgr,procinfo,
tgobj,ncgutil;
function UseAVX: boolean;
begin
Result:={$ifdef i8086}false{$else i8086}(FPUX86_HAS_AVXUNIT in fpu_capabilities[current_settings.fputype]){$endif i8086};
end;
{ modern CPUs prefer add/sub over inc/dec because add/sub break instructions dependencies on flags
because they modify all flags }
function UseIncDec: boolean;

19
compiler/x86/cpubase.pas
View File

@ -385,11 +385,15 @@ topsize2memsize: array[topsize] of integer =
function requires_fwait_on_8087(op: TAsmOp): boolean;
{$endif i8086}
function UseAVX: boolean;
function UseAVX512: boolean;
implementation
uses
globtype,
rgbase,verbose;
rgbase,verbose,
cpuinfo;
const
{$if defined(x86_64)}
@ -948,4 +952,17 @@ implementation
{$endif i8086}
function UseAVX: boolean;
begin
Result:={$ifdef i8086}false{$else i8086}(FPUX86_HAS_AVXUNIT in fpu_capabilities[current_settings.fputype]){$endif i8086};
end;
function UseAVX512: boolean;
begin
// Result:=(current_settings.fputype in fpu_avx_instructionsets) {$ifndef i8086}or (CPUX86_HAS_AVXUNIT in cpu_capabilities[current_settings.cputype]){$endif i8086};
Result:=false;
end;
end.

27
compiler/x86/nx86add.pas
View File

@ -1268,15 +1268,32 @@ unit nx86add;
{ we can use only right as left operand if the operation is commutative }
if (right.location.loc=LOC_MMREGISTER) and (op in [OP_ADD,OP_MUL]) then
begin
location.register:=right.location.register;
cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,tfloat2tcgsize[tfloatdef(left.resultdef).floattype],left.location,location.register,nil);
if UseAVX then
begin
location.register:=cg.getmmregister(current_asmdata.CurrAsmList,OS_VECTOR);
cg.a_opmm_loc_reg_reg(current_asmdata.CurrAsmList,op,tfloat2tcgsize[tfloatdef(left.resultdef).floattype],left.location,right.location.register,location.register,nil);
end
else
begin
location.register:=right.location.register;
cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,tfloat2tcgsize[tfloatdef(left.resultdef).floattype],left.location,location.register,nil);
end;
end
else
begin
location_force_mmreg(current_asmdata.CurrAsmList,left.location,false);
location.register:=left.location.register;
cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,
tfloat2tcgsize[tfloatdef(tarraydef(left.resultdef).elementdef).floattype],right.location,location.register,nil);
if UseAVX then
begin
location.register:=cg.getmmregister(current_asmdata.CurrAsmList,OS_VECTOR);
cg.a_opmm_loc_reg_reg(current_asmdata.CurrAsmList,op,
tfloat2tcgsize[tfloatdef(tarraydef(left.resultdef).elementdef).floattype],right.location,left.location.register,location.register,nil);
end
else
begin
location.register:=left.location.register;
cg.a_opmm_loc_reg(current_asmdata.CurrAsmList,op,
tfloat2tcgsize[tfloatdef(tarraydef(left.resultdef).elementdef).floattype],right.location,location.register,nil);
end;
end;
end
else

15
packages/fcl-db/src/sqldb/interbase/fbadmin.pp
View File

@ -392,13 +392,16 @@ end;
destructor TFBAdmin.Destroy;
begin
if FSvcHandle<>FB_API_NULLHANDLE then
begin
WaitInterval:=100;
DisConnect;
try
if FSvcHandle<>FB_API_NULLHANDLE then
begin
WaitInterval:=100;
DisConnect; // This can raise an exception
end;
Finally
FOutput.Destroy;
inherited Destroy;
end;
FOutput.Destroy;
inherited Destroy;
end;
function TFBAdmin.Connect: boolean;

11
packages/fcl-json/src/jsonreader.pp
View File

@ -179,7 +179,8 @@ Resourcestring
SErrInvalidNumber = 'Number is not an integer or real number: %s';
SErrNoScanner = 'No scanner. No source specified ?';
SErrorAt = 'Error at line %d, Pos %d: ';
SErrGarbageFound = 'Expected EOF, but got %s';
{ TBaseJSONReader }
@ -189,6 +190,14 @@ begin
if (FScanner=Nil) then
DoError(SErrNoScanner);
DoParse(False,True);
if joStrict in Options then
begin
Repeat
GetNextToken;
Until CurrentToken<>tkWhiteSpace;
If CurrentToken<>tkEOF then
DoError(Format(SErrGarbageFound,[CurrentTokenString]));
end;
end;
{

2
packages/fcl-json/src/jsonscanner.pp
View File

@ -169,6 +169,8 @@ constructor TJSONScanner.Create(const aSource: RawByteString; AOptions: TJSONOpt
begin
FSource:=aSource;
FCurPos:=PAnsiChar(FSource);
if FCurPos<>Nil then
FCurRow:=1;
FOptions:=AOptions;
end;

14
packages/fcl-json/tests/testjsonreader.pp
View File

@ -75,6 +75,8 @@ type
procedure TestMixed;
Procedure TestComment;
procedure TestErrors;
procedure TestGarbageOK;
procedure TestGarbageFail;
end;
TTestReader = Class(TBaseTestReader)
@ -450,6 +452,18 @@ begin
end;
procedure TBaseTestReader.TestGarbageOK;
begin
TestRead('"a"sss',['string:a']);
TestRead('[null]xxx',['sa','null','ea']);
end;
procedure TBaseTestReader.TestGarbageFail;
begin
DoTestError('"a"sss',[joStrict]);
DoTestError('[null]aaa',[joStrict]);
end;
procedure TBaseTestReader.CallNoHandlerStream;

3
packages/fcl-net/src/sslbase.pp
View File

@ -36,6 +36,7 @@ Type
Private
FStrData : Array[0..StrDataCount] of string;
FCertData : Array[0..SSLDataCount] of TSSLData;
FTrustedCertsDir: String;
function GetSSLData(AIndex: Integer): TSSLData;
procedure SetSSLData(AIndex: Integer; AValue: TSSLData);
function GetString(AIndex: Integer): String;
@ -54,6 +55,8 @@ Type
property PrivateKey : TSSLData Index 2 Read GetSSLData Write SetSSLData;
property PFX: TSSLData Index 3 Read GetSSLData Write SetSSLData;
property CertCA: TSSLData Index 4 Read GetSSLData Write SetSSLData;
// OpenSSL allows both a PEM file or a Dir. We separate out the dir.
Property TrustedCertsDir : String Read FTrustedCertsDir Write FTrustedCertsDir;
end;
{ TX509Certificate }

19
packages/fcl-net/src/sslsockets.pp
View File

@ -51,9 +51,12 @@ Type
protected
Procedure SetSSLActive(aValue : Boolean);
function DoVerifyCert: boolean; virtual; // if event define's change not accceptable, suggest to set virtual
Function GetLastSSLErrorString : String; virtual; abstract;
Function GetLastSSLErrorCode : Integer; virtual; abstract;
public
constructor Create; override;
Destructor Destroy; override;
Function GetLastErrorDescription : String;override;
// Class factory methods
Class Procedure SetDefaultHandlerClass(aClass : TSSLSocketHandlerClass);
Class Function GetDefaultHandlerClass : TSSLSocketHandlerClass;
@ -64,6 +67,8 @@ Type
function CreateSelfSignedCertificate: Boolean; virtual;
Property CertGenerator : TX509Certificate Read FCertGenerator;
Property SSLActive: Boolean read FSSLActive;
Property LastSSLErrorString : String Read GetLastSSLErrorString;
Property LastSSLErrorCode : Integer Read GetLastSSLErrorCode;
published
property SSLType: TSSLType read FSSLType write FSSLType;
property VerifyPeerCert: Boolean read FVerifyPeerCert Write FVerifyPeerCert;
@ -92,6 +97,7 @@ Resourcestring
'Please include opensslsockets unit in program and recompile it.';
SErrNoX509Certificate =
'Cannot create a X509 certificate without SLL support';
SSSLErrorCode = 'SSL error code: %d';
{ TSSLSocketHandler }
@ -177,6 +183,19 @@ begin
inherited Destroy;
end;
function TSSLSocketHandler.GetLastErrorDescription: String;
begin
Result:='';
if LastSSLErrorCode<>0 then
Result:=Format(SSSLErrorCode,[GetLastSSLErrorCode]);
if LastSSLErrorString<>'' then
begin
if (Result<>'') then
Result:=Result+': ';
Result:=Result+LastSSLErrorString;
end;
end;
class procedure TSSLSocketHandler.SetDefaultHandlerClass(aClass: TSSLSocketHandlerClass);
begin
FDefaultHandlerClass:=aClass;

19
packages/fcl-net/src/ssockets.pp
View File

@ -70,6 +70,8 @@ type
function Recv(Const Buffer; Count: Integer): Integer; virtual;
function Send(Const Buffer; Count: Integer): Integer; virtual;
function BytesAvailable: Integer; virtual;
// Call this to get extra error info.
Function GetLastErrorDescription : String; virtual;
Property Socket : TSocketStream Read FSocket;
Property LastError : Integer Read FLastError;
end;
@ -289,7 +291,7 @@ resourcestring
strSocketCreationFailed = 'Creation of socket failed: %s';
strSocketBindFailed = 'Binding of socket failed: %s';
strSocketListenFailed = 'Listening on port #%d failed, error: %d';
strSocketConnectFailed = 'Connect to %s failed.';
strSocketConnectFailed = 'Connect to %s failed: %s';
strSocketAcceptFailed = 'Could not accept a client connection on socket: %d, error %d';
strSocketAcceptWouldBlock = 'Accept would block on socket: %d';
strSocketIOTimeOut = 'Failed to set IO Timeout to %d';
@ -380,6 +382,11 @@ begin
{ we need ioctlsocket here }
end;
function TSocketHandler.GetLastErrorDescription: String;
begin
Result:='';
end;
Function TSocketHandler.Close: Boolean;
begin
@ -401,7 +408,7 @@ begin
seAcceptFailed : s := strSocketAcceptFailed;
seAcceptWouldBLock : S := strSocketAcceptWouldBlock;
seIOTimeout : S := strSocketIOTimeOut;
seConnectTimeOut : s := strSocketConnectTimeout;
seConnectTimeOut : s := strSocketConnectTimeout;
end;
s := Format(s, MsgArgs);
inherited Create(s);
@ -1117,6 +1124,7 @@ Var
IsError : Boolean;
TimeOutResult : TCheckTimeOutResult;
Err: Integer;
aErrMsg : String;
{$IFDEF HAVENONBLOCKING}
FDS: TFDSet;
TimeV: TTimeVal;
@ -1171,7 +1179,10 @@ begin
if TimeoutResult=ctrTimeout then
Raise ESocketError.Create(seConnectTimeOut, [Format('%s:%d',[FHost, FPort])])
else
Raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort])]);
begin
aErrMsg:=FHandler.GetLastErrorDescription;
Raise ESocketError.Create(seConnectFailed, [Format('%s:%d',[FHost, FPort]),aErrMsg]);
end;
end;
{ ---------------------------------------------------------------------
@ -1203,7 +1214,7 @@ Var
begin
Str2UnixSockAddr(FFilename,UnixAddr,AddrLen);
If FpConnect(ASocket,@UnixAddr,AddrLen)<>0 then
Raise ESocketError.Create(seConnectFailed,[FFilename]);
Raise ESocketError.Create(seConnectFailed,[FFilename,'']);
end;
{$endif}
end.

33
packages/fcl-web/examples/httpclient/httpget.pas
View File

@ -4,7 +4,7 @@ program httpget;
{$DEFINE USEGNUTLS}
uses
SysUtils, Classes, fphttpclient,
SysUtils, Classes, fphttpclient, ssockets,
{$IFNDEF USEGNUTLS}
fpopenssl, opensslsockets,
{$else}
@ -17,6 +17,9 @@ Type
{ TTestApp }
TTestApp = Class(Tobject)
private
procedure DoHaveSocketHandler(Sender: TObject; AHandler: TSocketHandler);
procedure DoVerifyCertificate(Sender: TObject; AHandler: TSSLSocketHandler; var aAllow: Boolean);
procedure DoProgress(Sender: TObject; Const ContentLength, CurrentPos : Int64);
procedure DoHeaders(Sender : TObject);
procedure DoPassword(Sender: TObject; var RepeatRequest: Boolean);
@ -84,6 +87,7 @@ begin
Writeln('Following redirect from ',ASrc,' ==> ',ADest);
end;
procedure TTestApp.Run;
begin
@ -99,6 +103,9 @@ begin
OnPassword:=@DoPassword;
OnDataReceived:=@DoProgress;
OnHeaders:=@DoHeaders;
VerifySSlCertificate:=True;
OnVerifySSLCertificate:=@DoVerifyCertificate;
AfterSocketHandlerCreate:=@DoHaveSocketHandler;
{ Set this if you want to try a proxy.
Proxy.Host:='195.207.46.20';
Proxy.Port:=8080;
@ -109,6 +116,30 @@ begin
end;
end;
procedure TTestApp.DoHaveSocketHandler(Sender: TObject; AHandler: TSocketHandler);
Var
SSLHandler : TSSLSocketHandler absolute aHandler;
begin
if (aHandler is TSSLSocketHandler) then
begin
SSLHandler.CertificateData.TrustedCertsDir:='/etc/ssl/certs/';
end
end;
procedure TTestApp.DoVerifyCertificate(Sender: TObject; AHandler: TSSLSocketHandler; var aAllow: Boolean);
Var
S : String;
begin
Writeln('SSL Certificate verification requested, allowing');
S:=TEncoding.ASCII.GetAnsiString( aHandler.CertificateData.Certificate.Value);
Writeln('Cert: ',S);
aAllow:=True;
end;
begin
With TTestApp.Create do
try

45
packages/fcl-web/src/base/fphttpclient.pp
View File

@ -14,17 +14,12 @@
**********************************************************************}
unit fphttpclient;
{ ---------------------------------------------------------------------
Todo:
* Proxy support ?
---------------------------------------------------------------------}
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, ssockets, httpdefs, uriparser, base64;
Classes, SysUtils, ssockets, httpdefs, uriparser, base64, sslsockets;
Const
// Socket Read buffer size
@ -42,6 +37,7 @@ Type
// Use this to set up a socket handler. UseSSL is true if protocol was https
TGetSocketHandlerEvent = Procedure (Sender : TObject; Const UseSSL : Boolean; Out AHandler : TSocketHandler) of object;
TSocketHandlerCreatedEvent = Procedure (Sender : TObject; AHandler : TSocketHandler) of object;
THTTPVerifyCertificateEvent = Procedure (Sender : TObject; AHandler : TSSLSocketHandler; var aAllow : Boolean) of object;
TFPCustomHTTPClient = Class;
@ -79,6 +75,7 @@ Type
FOnHeaders: TNotifyEvent;
FOnPassword: TPasswordEvent;
FOnRedirect: TRedirectEvent;
FOnVerifyCertificate: THTTPVerifyCertificateEvent;
FPassword: String;
FIOTimeout: Integer;
FConnectTimeout: Integer;
@ -98,6 +95,7 @@ Type
FOnGetSocketHandler : TGetSocketHandlerEvent;
FAfterSocketHandlerCreated : TSocketHandlerCreatedEvent;
FProxy : TProxyData;
FVerifySSLCertificate: Boolean;
function CheckContentLength: Int64;
function CheckTransferEncoding: string;
function GetCookies: TStrings;
@ -113,7 +111,8 @@ Type
Procedure ExtractHostPort(AURI: TURI; Out AHost: String; Out APort: Word);
Procedure CheckConnectionCloseHeader;
protected
// Called with TSSLSocketHandler as sender
procedure DoVerifyCertificate(Sender: TObject; var Allow: Boolean); virtual;
Function NoContentAllowed(ACode : Integer) : Boolean;
// Peform a request, close connection.
Procedure DoNormalRequest(const AURI: TURI; const AMethod: string;
@ -305,9 +304,6 @@ Type
// Maximum chunk size: If chunk sizes bigger than this are encountered, an error will be raised.
// Set to zero to disable the check.
Property MaxChunkSize : SizeUInt Read FMaxChunkSize Write FMaxChunkSize;
// Called On redirect. Dest URL can be edited.
// If The DEST url is empty on return, the method is aborted (with redirect status).
Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
// Proxy support
Property Proxy : TProxyData Read GetProxy Write SetProxy;
// Authentication.
@ -319,6 +315,11 @@ Type
Property Connected: Boolean read IsConnected;
// Keep-Alive support. Setting to true will set HTTPVersion to 1.1
Property KeepConnection: Boolean Read FKeepConnection Write SetKeepConnection;
// SSL certificate validation.
Property VerifySSLCertificate : Boolean Read FVerifySSLCertificate Write FVerifySSLCertificate;
// Called On redirect. Dest URL can be edited.
// If The DEST url is empty on return, the method is aborted (with redirect status).
Property OnRedirect : TRedirectEvent Read FOnRedirect Write FOnRedirect;
// If a request returns a 401, then the OnPassword event is fired.
// It can modify the username/password and set RepeatRequest to true;
Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
@ -330,6 +331,8 @@ Type
Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
// Called after create socket handler was created, with the created socket handler.
Property AfterSocketHandlerCreate : TSocketHandlerCreatedEvent Read FAfterSocketHandlerCreated Write FAfterSocketHandlerCreated;
// Called when a SSL certificate must be verified.
Property OnVerifySSLCertificate : THTTPVerifyCertificateEvent Read FOnVerifyCertificate Write FOnVerifyCertificate;
end;
@ -357,6 +360,10 @@ Type
Property OnHeaders;
Property OnGetSocketHandler;
Property Proxy;
Property VerifySSLCertificate;
Property AfterSocketHandlerCreate;
Property OnVerifySSLCertificate;
end;
EHTTPClient = Class(EHTTP);
@ -366,8 +373,6 @@ Function DecodeURLElement(Const S : String) : String;
implementation
uses sslsockets;
resourcestring
SErrInvalidProtocol = 'Invalid protocol : "%s"';
SErrReadingSocket = 'Error reading data from socket';
@ -585,13 +590,21 @@ end;
function TFPCustomHTTPClient.GetSocketHandler(const UseSSL: Boolean): TSocketHandler;
Var
SSLHandler : TSSLSocketHandler;
begin
Result:=Nil;
if Assigned(FonGetSocketHandler) then
FOnGetSocketHandler(Self,UseSSL,Result);
if (Result=Nil) then
If UseSSL then
Result:=TSSLSocketHandler.GetDefaultHandler
begin
SSLHandler:=TSSLSocketHandler.GetDefaultHandler;
SSLHandler.VerifyPeerCert:=FVerifySSLCertificate;
SSLHandler.OnVerifyCertificate:=@DoVerifyCertificate;
Result:=SSLHandler;
end
else
Result:=TSocketHandler.Create;
if Assigned(AfterSocketHandlerCreate) then
@ -945,6 +958,12 @@ begin
end;
end;
procedure TFPCustomHTTPClient.DoVerifyCertificate(Sender: TObject; var Allow: Boolean);
begin
If Assigned(FOnVerifyCertificate) then
FOnVerifyCertificate(Self,Sender as TSSLSocketHandler,Allow);
end;
function TFPCustomHTTPClient.GetCookies: TStrings;
begin
If (FCookies=Nil) then

2
packages/fcl-web/src/base/fpjwt.pp
View File

@ -128,7 +128,7 @@ Type
Destructor Destroy; override;
// Owned by the JWT. The JSON header.
Property JOSE : TJOSE Read FJOSE Write SetJOSE;
// Owned by the JWT. The set of claims. The actuall class will depend on the descendant.
// Owned by the JWT. The set of claims. The actual class will depend on the descendant.
Property Claims : TClaims Read FClaims Write SetClaims;
Property Signature : String Read FSignature Write FSignature;
end;

2
packages/fcl-web/src/base/fpwebfile.pp
View File

@ -124,7 +124,7 @@ begin
else
begin
D:=ADirectory;
if Copy(D,1,1)<>'/' then
if (D<>ExpandFileName(D)) then
D:=BaseDir+D;
if not DirectoryExists(D) then
Raise HTTPError.CreateFmt(SErrInvalidDirectory,[D]);

18
packages/gnutls/src/gnutlssockets.pp
View File

@ -40,6 +40,8 @@ Type
function InitSession(AsServer: Boolean): Boolean; virtual;
function DoneSession: Boolean; virtual;
function InitSslKeys: boolean;virtual;
function GetLastSSLErrorCode: Integer; override;
function GetLastSSLErrorString: String; override;
Public
Constructor create; override;
destructor destroy; override;
@ -288,7 +290,7 @@ begin
exit;
Result:=DoHandShake;
if Result and VerifyPeerCert then
Result:=(not DoVerifyCert);
Result:=DoVerifyCert;
if Result then
SetSSLActive(True);
end;
@ -480,8 +482,8 @@ begin
Result:=LoadCertificate(CertificateData.Certificate,CertificateData.PrivateKey);
if Result and Not CertificateData.TrustedCertificate.Empty then
Result:=LoadTrustedCertificate(CertificateData.TrustedCertificate);
if Result and (CertificateData.CertCA.FileName<>'') then
Result:=Result and SetTrustedCertificateDir(CertificateData.CertCA.FileName);
if Result and (CertificateData.TrustedCertsDir<>'') then
Result:=Result and SetTrustedCertificateDir(CertificateData.TrustedCertsDir);
// If nothing was set, set defaults.
if not Assigned(FCred) then
begin
@ -598,6 +600,16 @@ begin
Result:=FGNUTLSLastError;
end;
function TGNUTLSSocketHandler.GetLastSSLErrorString: String;
begin
Result:=FGNUTLSLastErrorString;
end;
function TGNUTLSSocketHandler.GetLastSSLErrorCode: Integer;
begin
Result:=FGNUTLSLastError;
end;
initialization
TSSLSocketHandler.SetDefaultHandlerClass(TGNUTLSSocketHandler);
end.

16
packages/openssl/src/opensslsockets.pp
View File

@ -25,6 +25,8 @@ Type
function InitContext(NeedCertificate: Boolean): Boolean; virtual;
function DoneContext: Boolean; virtual;
function InitSslKeys: boolean;virtual;
Function GetLastSSLErrorString : String; override;
Function GetLastSSLErrorCode : Integer; override;
Public
Constructor create; override;
destructor destroy; override;
@ -171,12 +173,22 @@ begin
Result:=CheckSSL(FCTX.UseCertificate(CertificateData.Certificate));
if Result and not CertificateData.PrivateKey.Empty then
Result:=CheckSSL(FCTX.UsePrivateKey(CertificateData.PrivateKey));
if Result and (CertificateData.CertCA.FileName<>'') then
Result:=CheckSSL(FCTX.LoadVerifyLocations(CertificateData.CertCA.FileName,''));
if Result and ((CertificateData.CertCA.FileName<>'') or (CertificateData.TrustedCertsDir<>'')) then
Result:=CheckSSL(FCTX.LoadVerifyLocations(CertificateData.CertCA.FileName,CertificateData.TrustedCertsDir));
if Result and not CertificateData.PFX.Empty then
Result:=CheckSSL(FCTX.LoadPFX(CertificateData.PFX,CertificateData.KeyPassword));
end;
function TOpenSSLSocketHandler.GetLastSSLErrorString: String;
begin
Result:=FSSLLastErrorString;
end;
function TOpenSSLSocketHandler.GetLastSSLErrorCode: Integer;
begin
Result:=FSSLLastError;
end;
constructor TOpenSSLSocketHandler.create;
begin
inherited create;

2
rtl/inc/systemh.inc
View File

@ -1293,7 +1293,9 @@ Function HexStr(Val:Pointer):shortstring;
{$endif CPUI8086}
{ Char functions }
{$ifdef VER3_2}
Function Chr(b : byte) : Char; [INTERNPROC: fpc_in_chr_byte];
{$endif VER3_2}
Function UpCase(c:Char):Char;
Function LowerCase(c:Char):Char; overload;
function Pos(const substr : shortstring;c:char; Offset: Sizeint = 1): SizeInt;

91
rtl/sinclairql/qdos.inc Normal file
View File

@ -0,0 +1,91 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Karoly Balogh
Interface QDOS OS functions used by the Sinclair QL RTL
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.
**********************************************************************}
{$i qdosh.inc}
const
_MT_ALCHP = $18;
_MT_RECHP = $19;
function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; assembler; nostackframe; public name '_mt_alchp';
asm
movem.l d2-d3/a2-a3,-(sp)
move.l sizegot,-(sp)
move.l jobid,d2
move.l size,d1
moveq.l #_MT_ALCHP,d0
trap #1
move.l (sp)+,d2 // sizegot ptr
tst d0
bne @quit
move.l d2,a1
beq @nosizegot
move.l d1,(a1)
@nosizegot:
move.l a0,d0
@quit:
movem.l (sp)+,d2-d3/a2-a3
end;
procedure mt_rechp(area: pointer); assembler; nostackframe; public name '_mt_rechp';
asm
movem.l d2-d3/a2-a3,-(sp)
move.l area,a0
moveq.l #_MT_RECHP,d0
trap #1
movem.l (sp)+,d2-d3/a2-a3
end;
const
_IO_SBYTE = $05;
_IO_SSTRG = $07;
function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; assembler; public name '_io_sbyte';
asm
move.l d3,-(sp)
move.w timeout,d3
clr.l d1
move.b c,d1
move.l chan,a0
moveq.l #_IO_SBYTE,d0
trap #3
move.l (sp)+,d3
end;
function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; assembler; public name '_io_sstrg';
asm
movem.l d2-d3,-(sp)
move.w len,d2
move.l buf,a1
move.w timeout,d3
move.l chan,a0
moveq.l #_IO_SSTRG,d0
trap #3
tst.l d0
beq @ok
cmp.w #ERR_EF,d0
beq @eof
cmp.w #ERR_NC,d0
bne @quit
@eof:
tst.w d1
beq @quit
@ok:
clr.l d0
move.w d1,d0
@quit:
movem.l (sp)+,d2-d3
end;

22
rtl/sinclairql/qdosfuncs.inc Normal file
View File

@ -0,0 +1,22 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Karoly Balogh
Headers to QDOS OS functions used by the Sinclair QL RTL
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.
**********************************************************************}
{$i qdosh.inc}
function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
procedure mt_rechp(area: pointer); external name '_mt_rechp';
function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';

43
rtl/sinclairql/qdosh.inc Normal file
View File

@ -0,0 +1,43 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2020 by Karoly Balogh
Types and Constants used by QDOS OS functions in the Sinclair QL RTL
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.
**********************************************************************}
type
Tchanid = longint;
Tjobid = longint;
Ttimeout = smallint;
const
ERR_NC = -1; { Operation not complete }
ERR_NJ = -2; { Not a (valid) job. }
ERR_OM = -3; { Out of memory. }
ERR_OR = -4; { Out of range. }
ERR_BO = -5; { Buffer overflow. }
ERR_NO = -6; { Channel not open. }
ERR_NF = -7; { File or device not found. }
ERR_FX = -8; { File already exists. }
ERR_IU = -9; { File or device already in use. }
ERR_EF = -10; { End of file. }
ERR_DF = -11; { Drive full. }
ERR_BN = -12; { Bad device. }
ERR_TE = -13; { Transmission error. }
ERR_FF = -14; { Format failed. }
ERR_BP = -15; { Bad parameter. }
ERR_FE = -16; { File error. }
ERR_EX = -17; { Expression error. }
ERR_OV = -18; { Arithmetic overflow. }
ERR_NI = -19; { Not implemented. }
ERR_RO = -20; { Read only. }
ERR_BL = -21; { Bad line of Basic. }

64
rtl/sinclairql/si_prc.pp
View File

@ -19,23 +19,79 @@ interface
implementation
{$i qdosfuncs.inc}
var
procdesc: PPD; public name '__base';
stacktop: pointer;
stackorig: pointer;
setjmpbuf: jmp_buf;
stklen: longint; external name '__stklen';
binstart: pointer; external name '_stext';
binend: pointer; external name '_etext';
procedure PascalMain; external name 'PASCALMAIN';
{ this function must be the first in this unit which contains code }
{$OPTIMIZATION OFF}
procedure _FPC_proc_start(pd: PPD); cdecl; public name '_start';
function _FPC_proc_start: longint; cdecl; public name '_start';
var
newstack: pointer;
begin
_FPC_proc_start:=0;
asm
move.l d7,-(sp)
{ relocation code }
{ get our actual position in RAM }
lea.l binstart(pc),a0
move.l a0,d0
{ get an offset to the end of the binary. this depends on the
fact that at this point the binary is not relocated yet }
lea.l binend,a1
add.l d0,a1
{ first item in the relocation table is the number of relocs }
move.l (a1),d7
beq @noreloc
{ zero out the number of relocs in RAM, so if our code is
called again, without reload, it won't relocate itself twice }
move.l #0,(a1)+
@relocloop:
{ we read the offsets and relocate them }
move.l (a1)+,d1
add.l d0,(a0,d1)
subq.l #1,d7
bne @relocloop
@noreloc:
move.l (sp)+,d7
{ save the original stack pointer }
move.l a7,stackorig
end;
newstack:=mt_alchp(stklen,nil,-1);
if not assigned(newstack) then
_FPC_proc_start:=ERR_OM
else
begin
asm
move.l newstack,sp
end;
if setjmp(setjmpbuf) = 0 then
PascalMain;
asm
move.l stackorig,sp
end;
mt_rechp(newstack);
end;
end;
procedure _FPC_proc_halt(_ExitCode: longint); cdecl; public name '_haltproc';
procedure _FPC_proc_halt(_ExitCode: longint); public name '_haltproc';
begin
longjmp(setjmpbuf,1);
end;

3
rtl/sinclairql/sysheap.inc
View File

@ -18,12 +18,15 @@
****************************************************************************}
function SysOSAlloc(size: ptruint): pointer;
begin
Result:=mt_alchp(size, nil, -1);
end;
{$define HAS_SYSOSFREE}
procedure SysOSFree(p: pointer; size: ptruint);
begin
mt_rechp(p);
end;

2
rtl/sinclairql/sysos.inc
View File

@ -15,6 +15,8 @@
**********************************************************************}
{$i qdos.inc}
procedure Error2InOutRes(errno: longint);
begin
end;

19
rtl/sinclairql/system.pp
View File

@ -122,8 +122,12 @@ var
{*****************************************************************************
System Dependent Exit code
*****************************************************************************}
procedure haltproc(e:longint); external name '_haltproc';
procedure system_exit;
begin
haltproc(exitcode);
end;
{*****************************************************************************
@ -146,6 +150,19 @@ begin
CheckInitialStkLen := StkLen;
end;
procedure PrintStr(const s: shortstring);
begin
io_sstrg($00010001,-1,@s[1],ord(s[0]));
end;
procedure PrintStr2(const s: shortstring);
var
i: smallint;
begin
for i:=1 to ord(s[0]) do
io_sbyte($00010001,-1,s[i]);
end;
begin
StackLength := CheckInitialStkLen (InitialStkLen);
@ -160,7 +177,7 @@ begin
InitUnicodeStringManager;
{$endif FPC_HAS_FEATURE_UNICODESTRINGS}
{ Setup stdin, stdout and stderr }
SysInitStdIO;
(* SysInitStdIO;*)
{ Reset IO Error }
InOutRes:=0;
{ Setup command line arguments }

2
rtl/unix/timezone.inc
View File

@ -104,7 +104,7 @@ begin
end;
procedure DoGetLocalTimezone(info:pttinfo;const trans_start,trans_end:longint;var ATZInfo:TTZInfo);
procedure DoGetLocalTimezone(info:pttinfo;const trans_start,trans_end:int64;var ATZInfo:TTZInfo);
begin
ATZInfo.validsince:=trans_start;
ATZInfo.validuntil:=trans_end;

21
tests/webtbs/tw38051.pp Normal file
View File

@ -0,0 +1,21 @@
{ %NORUN }
program tw38051;
const cChr = chr(12); { Ok }
type Tcha = ord(3)..ord(12); { Ok }
type Tchz = 0000003..0000012; { Ok }
type Tcho = char(3)..char(12);{ Ok }
type Tchr = chr(3)..chr(12); { Error: Identifier not found "chr" }
type TArrChr = array [chr(3)..chr(12)] of char; { Ok }
var cz : 0000003..0000012; { Ok }
var ch : chr(3)..chr(12); { Error: Identifier not found "chr" }
var c : char;
begin
c:=chr(12); { Ok }
end.

12
tests/webtbs/tw38054.pp Normal file
View File

@ -0,0 +1,12 @@
{ %norun }
const
l = high(ptrint); // 2000 <--> 2100
type
t = array[ 1..l ]of int8; // 1.95 <--> 2.05 GiBy
var
p: ^t;
begin
new(p);
writeln( sizeof(p^) );
p^[l]:=0; writeln(p^[l])
end .