mORMot Open Source

    TNetTlsContext = record
      ...
        // input: Should server request Two-Way TLS connection                      // added
        TwoWayTls : Boolean;                                                        // added
        // input: Should server verify peer just first time                         // added
        VerifyClientOnce : Boolean;                                                 // added
      ...
    end;

    procedure TOpenSslNetTls.SetupCtx(var Context: TNetTlsContext; Bind: boolean);
    var
      v, PeerVerifyMode: integer;
    begin
      _PeerVerify := self; // safe and simple context for the callbacks
      if Context.IgnoreCertificateErrors then
        SSL_CTX_set_verify(fCtx, SSL_VERIFY_NONE, nil)
      else
      begin
        if Assigned(Context.OnEachPeerVerify) then
          begin                                                                     // added
            PeerVerifyMode := SSL_VERIFY_PEER;                                      // added
            if Context.TwoWayTls then                                               // added
              PeerVerifyMode := PeerVerifyMode or SSL_VERIFY_FAIL_IF_NO_PEER_CERT;  // added
            if Context.VerifyClientOnce then                                        // added
              PeerVerifyMode := PeerVerifyMode or SSL_VERIFY_CLIENT_ONCE;           // added
            SSL_CTX_set_verify(fCtx, PeerVerifyMode, AfterConnectionPeerVerify)     // added
          end                                                                       // added
          // SSL_CTX_set_verify(fCtx, SSL_VERIFY_PEER, AfterConnectionPeerVerify)   // removed
        else
          SSL_CTX_set_verify(fCtx, SSL_VERIFY_PEER, nil);
        if FileExists(TFileName(Context.CACertificatesFile)) then
          SSL_CTX_load_verify_locations(
            fCtx, pointer(Context.CACertificatesFile), nil)
        else
          SSL_CTX_set_default_verify_paths(fCtx);
      end;
      ...
    end;

    InitNetTlsContext(tls, {server=}true,
      'keys\SrvCert.pem',
      'keys\SrvPrivKey.pem',
      'password',
      'keys\CACerts.pem');
    with tls do
      begin
        //OnPeerValidate := MyPeerValidate;               // I guess this works only on client
        //OnAfterPeerValidate := MyAfterPeerValidate;     // I guess this works only on client
        OnEachPeerVerify := MyEachPeerVerify;
        IgnoreCertificateErrors := False;
        AllowDeprecatedTls := False;
        WithPeerInfo := True;
        TwoWayTls := True;
        VerifyClientOnce := True;
      end;

    HttpServer := TRestHttpServer.Create(AHttpPort, [MyRestServer],
      '+', useBidirAsync, 32, secTLS, '', '', [rsoCompressSynLZ,rsoCompressGzip], @tls);
    HttpServer.WebSocketsEnable(MyRestServer,AWebSocketKey)

TTestRec = class(TSQLRecord)
private
  FTestMoney : Currency;
published
  property TestMoney : Currency read FTestMoney write FTestMoney;
end;

TTestRec = class(TSQLRecord)
private
  FTestMoney : Currency;
published
  property TestMoney : Currency read GetTestMoney write SetTestMoney;
end;


function TTestRec.GetTestMoney: Currency;
begin
  Result := FTestMoney;
end;

procedure TTestRec.SetTestMoney(const Value: Currency);
begin
  FTestMoney := Value;
end;

procedure TSQLPropInfoRTTICurrency.GetJSONValues(Instance: TObject; W: TJSONSerializer);
begin
  // temp fix
  {$IFDEF CPU64}
  W.AddCurr64(GetInt64Prop(Instance,pointer(fPropInfo)));
  {$ELSE}
  W.Add(GetFloatProp(Instance,pointer(fPropInfo)));
  {$ENDIF}
end;

procedure TSQLPropInfoRTTICurrency.GetValueVar(Instance: TObject;
  ToSQL: boolean; var result: RawUTF8; wasSQLString: PBoolean);
begin
  if wasSQLString<>nil then
    wasSQLString^ := false;
  // temp fix
  {$IFDEF CPU64}
  result := Curr64ToStr(GetInt64Prop(Instance,pointer(fPropInfo)));
  {$ELSE}
  result := FloatToStr(GetFloatProp(Instance,pointer(fPropInfo)));
  {$ENDIF}
end;

procedure TForm1.TestPDFDoc;
var
  PDF : TPdfDocument;
begin
  PDF := TPdfDocument.Create;
  try
    PDF.DefaultPaperSize := psA4;
    PDF.AddPage;
    PDF.Canvas.SetFont('Arial',30, []);     // default CP is 1250
    PDF.Canvas.TextOut(100,100, #$8A#$D0#$C8#$C6#$8E);
    PDF.SaveToFile('Test.PDF');              // GS will render first char only
  finally
    PDF.Free;
  end;
end;

procedure TForm1.TestPDFDocGDI;
var
  PDF : TPdfDocumentGDI;
begin
  PDF := TPdfDocumentGDI.Create;
  try
    PDF.DefaultPaperSize := psA4;
    PDF.AddPage;
    PDF.VCLCanvas.Font.Name := 'Arial';
    PDF.VCLCanvas.Font.Size := 30;
    PDF.VCLCanvas.Font.Charset := EASTEUROPE_CHARSET;  // same as DEFAULT_CHARSET on my computer
    PDF.VCLCanvas.TextOut(100,100,#$8A#$D0#$C8#$C6#$8E);
    PDF.SaveToFile('TestGDI.PDF');                                    // GS will render first char only
  finally
    PDF.Free;
  end;
end;

procedure TPdfCanvas.ShowText(const text: PDFString; NextLine: boolean);
begin
  if (FContents<>nil) and (text<>'') then
    if (fDoc.FCharSet=ANSI_CHARSET) or IsAnsiCompatible(PAnsiChar(pointer(text))) then begin
      if FPage.Font.Unicode and (FPage.FFont.FTrueTypeFontsIndex<>0) then
        SetPDFFont(TPdfFontTrueType(FPage.Font).WinAnsiFont,FPage.FontSize);
      FContents.Writer.Add('(').AddEscapeText(pointer(text),FPage.Font).Add(')').
        Add(SHOWTEXTCMD[NextLine])
    end else begin
      // gigo
      Doc.EmbeddedTTF := true;
      if FPage.FFont.FTrueTypeFontsIndex<>0 then
        // write TrueType text after conversion to unicode
        FContents.Writer.AddToUnicodeHexText(text,NextLine,self) else
        // this standard font should expect MBCS encoding
        FContents.Writer.Add('<').AddHex(text).Add('>').Add(SHOWTEXTCMD[NextLine]);
    end;
end;

procedure TPdfEnum.TextOut(var R: TEMRExtTextOut);
...
at line 7742
...
begin
  with DC[nDC] do begin
    SetLength(tmp,R.emrtext.nChars+1); // faster than WideString for our purpose
    move(pointer(PtrUInt(@R)+R.emrtext.offString)^,tmp[0],R.emrtext.nChars*2);

    // gigo
    if not IsAnsiCompatible(PWideChar(tmp)) then
      Canvas.Doc.EmbeddedTTF := true;

    // guess the font size
    if font.LogFont.lfHeight<0 then
      ASize := -font.LogFont.lfHeight*Canvas.fFactorY else
      ASize := font.spec.cell*Canvas.fFactorY;
    ...