Statuscode: ' + IntToStr(StatusCode); LogLine(S); AStream.Write(S[1], Length(S)); end; DocType := HTMLType; end else { other connection types } begin S := E.Message; { Delphi 1 } AStream.Write(S[1], Length(S)); LogLine(S); end; finally Connection.Free; { needs to be reset } Connection := nil; end; end; Status1.Caption := 'Received ' + IntToStr(AStream.Size) + ' bytes'; if CachePages.Checked then begin FName := DiskCache.AddNameToCache(LastUrl, NewLocation, DocType, Error); if FName <> '' then try AStream.SaveToFile(FName); { it's now in cache } except end; end; end else begin { unsupported protocol } S := 'Unsupported protocol: ' + URL1; // GetProtocol(URL1); // if Sender is TFrameBrowser then {main document display} // Raise(ESpecialException.Create(S)) // else {else other errors will get displayed as HTML file} AStream.Write(S[1], Length(S)); LogLine(S); end; end else begin AStream.LoadFromFile(FName); LogLine('FrameBrowserGetPostRequestEx: from Cache' + FName); end; NewURL := NewLocation; { in case location has been changed } if ShowLogHTML.Checked then begin AStream.Position := 0; SetLength(AnsiQuery, AStream.Size); AStream.ReadBuffer(AnsiQuery[1], AStream.Size); LogLine(String(AnsiQuery)); end; Stream := AStream; end; procedure THTTPForm.HTTPSslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect: Boolean); {var CertChain: TX509List; ChainVerifyResult: LongWord; Hash, info: String; VerifyInfo: String; Safe: Boolean; } begin with (Sender as TSslHttpCli).CtrlSocket do begin if (ErrCode <> 0) or Disconnect then begin LogLine(SslServerName + ' SSL Handshake Failed - ' + SslHandshakeRespMsg); Disconnect := TRUE; exit ; end ; (* V9.6 all now done in WSocket // OK LogLine(SslServerName + ' - ' + SslHandshakeRespMsg); if SslSessionReused OR (SslVerifyCertMode = SslVerNone) then begin exit; // nothing to do, go ahead end ; // Is current host already in the list of temporarily accepted hosts ? if NOT Assigned (PeerCert.X509) then begin LogLine(SslServerName + ' SSL No Certificate Set'); exit ; end; Hash := PeerCert.Sha1Hex ; // V8.53 use common host list so each connection does not recheck certificates if FAcceptableSslHosts.IndexOf (SslServerName + Hash ) > -1 then begin exit; // nothing to do, go ahead end ; // Property SslCertChain contains all certificates in current verify chain CertChain := SslCertChain; Safe := false ; // see if validating against Windows certificate store if SslVerifyCertMode = SslVerWinStore then begin {$IFDEF MSCRYPT_Clients} // start engine if not Assigned (MsCertChainEngine) then MsCertChainEngine := TMsCertChainEngine.Create; // see if checking revoocation, CRL checks and OCSP checks in Vista+, very slow!!!! if SslRevokeCheck then MsCertChainEngine.VerifyOptions := [mvoRevocationCheckChainExcludeRoot] else MsCertChainEngine.VerifyOptions := []; // This option doesn't seem to work, at least when a DNS lookup fails MsCertChainEngine.UrlRetrievalTimeoutMsec := 10 * 1000; { Pass the certificate and the chain certificates to the engine } MsCertChainEngine.VerifyCert (PeerCert, CertChain, ChainVerifyResult, True); Safe := (ChainVerifyResult = 0) or { We ignore the case if a revocation status is unknown. } (ChainVerifyResult = Ics_CERT_TRUST_REVOCATION_STATUS_UNKNOWN) or (ChainVerifyResult = Ics_CERT_TRUST_IS_OFFLINE_REVOCATION) or (ChainVerifyResult = Ics_CERT_TRUST_REVOCATION_STATUS_UNKNOWN or Ics_CERT_TRUST_IS_OFFLINE_REVOCATION); VerifyInfo := MsChainVerifyErrorToStr (ChainVerifyResult); { V8.69 } {$ELSE} {$ENDIF MSCRYPT_Clients} end else if SslVerifyCertMode = SslVerBundle then begin { check whether SSL chain verify result was OK } VerifyInfo := PeerCert.FirstVerifyErrMsg; { V8.69 } if PeerCert.VerifyResult = X509_V_OK then Safe := true else if (CertChain.Count > 0) and (CertChain[0].FirstVerifyResult = X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN) then begin Safe := true ; LogLine(SslServerName + ' SSL Self Signed Certificate Succeeded: ' + PeerCert.UnwrapNames (PeerCert.IssuerCName)) ; end; end else begin exit ; // unknown method end ; { V8.69 check OCSP to see if revoked, if we got a chain of certificates } { note this is a soft check, if we don't have a stapled OCSP response from the TLS handshake, we get it from an OCSP HTTP server and cache it but don't wait for the response. So next attempt comes from cache. } if Safe and SslRevokeCheck and (PeerCert.IsCertLoaded and (CertChain.Count > 0)) then begin OcspHttp1.ClearOcsp; OcspHttp1.DebugLevel := DebugConn; OcspHttp1.OcspCert := PeerCert; OcspHttp1.OcspInters := CertChain; if (Length(OcspStapleRaw) > 50) and (OcspStapleStatus = OCSP_RESPONSE_STATUS_SUCCESSFUL) then OcspHttp1.OcspRespRaw := OcspStapleRaw; if OcspHttp1.CheckOcspRevoked(SslContext.GetX509Store, 0) then begin PeerCert.VerifyResult := X509_V_ERR_CRL_SIGNATURE_FAILURE; Safe := False; VerifyInfo := OcspHttp1.OcspLastResp; end; OcspHttp1.OcspInters := Nil; end; if Safe then begin info := SslServerName + ' SSL Chain Verification Succeeded'; LogLine(info) ; // V8.53 use common host list so each connection does not recheck certificates FAcceptableSslHosts.Add (SslServerName + Hash); // keep it to avoid checking again end; // tell user about all the certificates we found if SslReportChain and (CertChain.Count > 0) then begin Info := '! ' + 'VerifyResult: ' + VerifyInfo + ', Peer domain: ' + SslCertPeerName + #13#10 + { V8.52 } IntToStr(CertChain.Count) +' Certificate(s) in the verify chain.' + #13#10 + CertChain.AllCertInfo(True, True); { V8.52 } LogLine(info); end; // all failed if NOT Safe then begin Disconnect := TRUE; exit ; end; *) end; end; procedure THTTPForm.HTTPRedirect(Sender : TObject); var Proto, Dest : String; begin Dest := (Sender as TSslHttpCli).Location; LogLine('Redirected to: ' + Dest); Proto := GetProtocol(URLBase); if IsFullUrl(Dest) then { it's a full URL } begin NewLocation := Normalize(Dest); end else begin NewLocation := CombineURL(URLBase, Dest); end; URLBase := GetUrlBase(NewLocation); // UrlComboBox.Text := NewLocation; { V8.53 } // FrameBrowser.LoadURL (NewLocation); { V8.53 } // FrameBrowser.History[0] := NewLocation; { V8.53 } { cookies may have been sent during redirection, so update again now } (Sender as TSslHttpCli).Cookie := IcsCookies.GetCookies(NewLocation); end; procedure THTTPForm.HTTPSetCookie(Sender : TObject; const Data : String; var Accept : Boolean); begin IcsCookies.SetCookie(Data, (Sender as TSslHttpCli).URL); end; procedure THTTPForm.IcsCookiesNewCookie(Sender : TObject; ACookie : TCookie; var Save : Boolean); var S : String; begin with ACookie do begin S := 'NewCookie: ' + CName + '=' + CValue + ', Domain=' + CDomain + ', Path=' + CPath; if CPersist then S := S + ', Expires=' + DateTimeToStr(CExpireDT) else S := S + ', Not Persisent'; if CSecureOnly then S := S + ', SecureOnly'; if CHttpOnly then S := S + ', HttpOnly'; LogLine(S); end; end; { ----------------THTTPForm.GetImageRequest } procedure THTTPForm.GetImageRequest(Sender : TObject; const URL : ThtString; var Stream : TStream); { the OnImageRequest handler } var S : String; IR : ImageRec; DocType : ThtmlFileType; Dummy : String; begin if Reloading or (not CacheImages.Checked) then begin DiskCache.RemoveFromCache(URL); S := ''; end else DiskCache.GetCacheFilename(URL, S, DocType, Dummy); { see if image is in cache file already } if FileExists(S) and (DocType = ImgType) then begin { yes, it is } AStream.LoadFromFile(S); Stream := AStream; { return image immediately } LogLine('GetImageRequest, from Cache: ' + S); end { see if res, file or zip protocols, get image immediately without a queue } else if not((GetProtocol(URL) = 'http') or (GetProtocol(URL) = 'https')) then begin if Assigned(Connection) then Connection.Free; Connection := TURLConnection.GetConnection(URL); if Connection <> nil then begin LogLine('GetImageRequest Start: ' + URL); try Connection.Get(URL); Stream := Connection.InputStream; except Stream := nil; end; end else Stream := nil; end else begin { http protocol, the image will need to be downloaded } Stream := WaitStream; { wait indicator } IR := ImageRec.Create; IR.Viewer := Sender as ThtmlViewer; IR.URL := URL; { add image to queue, then see if any spare sessions to download it } Pending.Add(IR); Inc(NumImageTot); Progress(NumImageDone, NumImageTot); LogLine('GetImageRequest Queued: ' + URL); PostMessage(Handle, WM_Next_Image, 0, 0); end; end; { ----------------THTTPForm.WMNextImage } procedure THTTPForm.WMNextImage(var AMsg : TMessage); var I, session: integer ; CurImage: ImageRec; begin if Pending.Count = 0 then begin LogLine ('No more queued image downloads'); Progress(NumImageDone, NumImageTot); exit; end; session := -1; for I := 1 to MaxImageSess do begin if FImageHTTPs [I].ImgState <= ImgStateFree then begin session := I; break; end; end; if session < 0 then begin { no free sessions for image downloads, will try later } exit; end; { start a download for first waiting URL, remove from list } CurImage := Pending [0]; Pending.Delete (0); with FImageHTTPs [session] do begin Connection.CheckInputStream; ImgState := ImgStateWaiting; ImRec := CurImage; URL := CurImage.URL; Connection.ProxyURL := ProxyURL; // Connection.ProxyPort := ProxyPort; Connection.ProxyUser := ProxyUser; Connection.ProxyPassword := ProxyPassword; Connection.UserAgent := UserAgent; Connection.Cookie := IcsCookies.GetCookies(URL); inc (FCurHttpSess); DisableControls; LogLine('[' + IntToStr (Connection.Session) + '] GetImageRequest Start: ' + URL); try GetAsync; except LogLine ('Exception starting image download: ' + URL); Inc(NumImageDone); ImgState := ImgStateFree; end; end; end; { ----------------THTTPForm.HttpSessionFree } procedure THTTPForm.HttpSessionFree (session: integer); begin try if session <= 0 then exit ; Progress(NumImageDone, NumImageTot); if NOT Assigned (FImageHTTPs [session]) then exit; if (FImageHTTPs [session].ImgState > ImgStateFree) and (FCurHttpSess > 0) then dec (FCurHttpSess) ; FImageHTTPs [session].ImgState := ImgStateFree; FImageHTTPs [session].Connection.InputStream.Clear; if Pending.Count <> 0 then PostMessage(Handle, WM_Next_Image, 0, 0) { next queued request } else begin CheckEnableControls; end; except LogLine ('[' + IntToStr (session) + '] !! Failed to Free Image Download Session'); FImageHTTPs [session].ImgState := ImgStateFree; end; end; { ----------------THTTPForm.HttpStopSessions } procedure THTTPForm.HttpStopSessions; var I: integer ; begin Pending.Clear ; FCurHttpSess := 0; for I := 1 to MaxImageSess do begin if Assigned (FImageHTTPs [I]) then begin if FImageHTTPs [I].ImgState > ImgStateFree then begin FImageHTTPs [I].ImgState := ImgStateFree; try if Assigned (FImageHTTPs [I].Connection) then begin if Assigned (FImageHTTPs [I].Connection) then begin LogLine ('[' + IntToStr (I) + '] !! Aborting Image Download'); FImageHTTPs [I].ImgState := ImgStateCancel; FImageHTTPs [I].Connection.Abort; { sync } FImageHTTPs [I].ImgState := ImgStateFree; end; end; except ; end; end; end; end; end; { ----------------THTTPForm.ImageRequestDone } procedure THTTPForm.ImageRequestDone(Sender : TObject; RqType : THttpRequest; Error : Word); { arrive here when ImHTTP.GetAsync has completed } var ImageHTTP: TImageHTTP; FName : String; begin ImageHTTP := (Sender as TImageHTTP); try with ImageHTTP do begin if ImgState in [ImgStateFree, ImgStateCancel] then begin LogLine('[' + IntToStr (Connection.Session) + '] GetImageRequest Ignored: ' + URL); end else if (Error = 0) then begin LogLine('[' + IntToStr (Connection.Session) + '] GetImageRequest Done OK: ' + URL); if Assigned(Connection.InputStream) then begin { Stream can be Nil } ImRec.Viewer.InsertImage (URL, Connection.InputStream) ; // 11.6 was FrameBrowser.InsertImage but gone { save image in cache file } if CacheImages.Checked then begin FName := DiskCache.AddNameToCache(URL, '', ImgType, False); if FName <> '' then try ImageHTTP.Connection.InputStream.SaveToFile(FName); except end; end; Connection.InputStream.Clear; end else LogLine('[' + IntToStr (Connection.Session) + '] GetImageRequest No Stream: ' + URL); end else LogLine('[' + IntToStr (Connection.Session) + '] GetImageRequest Failed, Error ' + IntToStr (Error) + ': ' + URL); end; except LogLine('[' + IntToStr (Connection.Session) + '] GetImageRequest Exception: ' + ImageHTTP.URL); end; Inc(NumImageDone); { free session, also checks for more downloads, if any } HttpSessionFree (ImageHTTP.Connection.Session); end; procedure THTTPForm.CheckEnableControls; begin if not FrameBrowser.Processing and (not Assigned(Connection) or (Connection.State in [httpReady, httpNotConnected])) and (Pending.Count = 0) and (FCurHttpSess = 0) then begin EnableControls; Status2.Caption := 'DONE'; end; end; procedure THTTPForm.ClearProcessing; var I : Integer; begin for I := 0 to Pending.Count - 1 do begin ImageRec(Pending.Items[I]).Free; end; Pending.Clear; HttpStopSessions; end; procedure THTTPForm.CacheImagesClick(Sender : TObject); begin CacheImages.Checked := not CacheImages.Checked; end; procedure THTTPForm.CachePagesClick(Sender : TObject); begin CachePages.Checked := not CachePages.Checked; end; { ----------------THTTPForm.CancelButtonClick } procedure THTTPForm.CancelButtonClick(Sender : TObject); begin AnAbort := True; if Assigned(Connection) then Connection.Abort; ClearProcessing; CheckEnableControls; end; { ----------------THTTPForm.HistoryChange } procedure THTTPForm.HistoryChange(Sender : TObject); { OnHistoryChange handler -- history list has changed } var I : Integer; Cap : String; begin with Sender as TFrameBrowser do begin if History.Count > 1 then begin if UrlComboBox.Text <> History[0] then begin // V8.53 UrlComboBox.Text := History[0]; // ANGUS end; end; { check to see which buttons are to be enabled } FwdButton.Enabled := FwdButtonEnabled; BackButton.Enabled := BackButtonEnabled; { Enable and caption the appropriate history menuitems } HistoryMenuItem.Visible := History.Count > 0; for I := 0 to MaxHistories - 1 do with Histories[I] do if I < History.Count then begin Cap := History.Strings[I]; { keep local file name } if TitleHistory[I] <> '' then Cap := Cap + '--' + TitleHistory[I]; Caption := Copy(Cap, 1, 80); Visible := True; Checked := I = HistoryIndex; end else Histories[I].Visible := False; Caption := DocumentTitle; { keep the Form caption updated } FrameBrowser.SetFocus; end; end; { ----------------THTTPForm.HistoryClick } procedure THTTPForm.HistoryClick(Sender : TObject); { A history list menuitem got clicked on } var I : Integer; begin { Changing the HistoryIndex loads and positions the appropriate document } I := (Sender as TMenuItem).Tag; URLBase := GetUrlBase(FrameBrowser.History.Strings[I]); { update URLBase for new document } FrameBrowser.HistoryIndex := I; UrlComboBox.Text := FrameBrowser.History[I]; // ANGUS end; { ----------------THTTPForm.WMLoadURL } procedure THTTPForm.WMLoadURL(var Message : TMessage); begin GetButtonClick(Self); end; procedure THTTPForm.Openfile1Click(Sender : TObject); { Open a local disk file } begin if CurrentLocalFile <> '' then OpenDialog.InitialDir := ExtractFilePath(CurrentLocalFile) else OpenDialog.InitialDir := ExtractFilePath(ParamStr(0)); OpenDialog.FilterIndex := 1; OpenDialog.Filename := ''; if OpenDialog.Execute then begin UrlComboBox.Text := 'file:///' + DosToHTMLNoSharp(OpenDialog.Filename); GetButtonClick(nil); Caption := FrameBrowser.DocumentTitle; CurrentLocalFile := FrameBrowser.CurrentFile; end; end; { ----------------THTTPForm.HotSpotTargetCovered } procedure THTTPForm.HotSpotTargetCovered(Sender : TObject; const Target, URL : ThtString); { mouse moved over or away from a hot spot. Change the status line } begin if URL = '' then Status3.Caption := '' else if Target <> '' then Status3.Caption := 'Target: ' + Target + ' URL: ' + URL else Status3.Caption := 'URL: ' + URL end; { ----------------THTTPForm.HotSpotTargetClick } procedure THTTPForm.HotSpotTargetClick(Sender : TObject; const Target, URL : ThtString; var Handled : Boolean); { a link was clicked. URL is a full url here have protocol and path added. If you need the actual link String, it's available in the TFrameBrowser URL property } const snd_Async = $0001; { play asynchronously } var Protocol, Ext, FullUrl : String; PC : array [0 .. 255] of Char; S, Params : String; K : Integer; // Tmp : String; PID : LongWord; // V8.65 begin LogLine('HotSpotTargetClick: ' + URL); if IsFullUrl(URL) then // ANGUS not always a full URL... FullUrl := URL else FullUrl := CombineURL(URLBase, URL); Protocol := GetProtocol(FullUrl); if Protocol = 'mailto' then begin IcsShellExec(FullUrl, PID); { V8.65 } // Tmp := FullUrl + #0; { for Delphi 1 } { call mail program } { Note: ShellExecute causes problems when run from Delphi 4 IDE } // ShellExecute(Handle, nil, @Tmp[1], nil, nil, SW_SHOWNORMAL); Handled := True; exit; end; { Note: it would be nice to handle ftp protocol here also as some downloads use this protocol } Ext := LowerCase(GetURLExtension(FullUrl)); if Pos('http', Protocol) > 0 then begin if (CompareText(Ext, 'zip') = 0) or (CompareText(Ext, 'exe') = 0) or (CompareText(Ext, 'pdf') = 0) or (CompareText(Ext, 'iso') = 0) or (CompareText(Ext, 'doc') = 0) or (CompareText(Ext, 'xls') = 0) then begin { download can't be done here. Post a message to do it later at WMDownload } DownLoadUrl := FullUrl; PostMessage(Handle, wm_DownLoad, 0, 0); Handled := True; exit; end; end; if (Protocol = 'file') then begin S := FullUrl; K := Pos(' ', S); { look for parameters } if K = 0 then K := Pos('?', S); { could be '?x,y' , etc } if K > 0 then begin Params := Copy(S, K + 1, 255); { save any parameters } SetLength(S, K - 1); { truncate S } end else Params := ''; S := HTMLToDos(S); if Ext = 'wav' then begin Handled := True; sndPlaySound(StrPCopy(PC, S), snd_Async); end else if Ext = 'exe' then begin Handled := True; // StartProcess(StrPCopy(PC, S + ' ' + Params), sw_Show); IcsShellExec(S + ' ' + Params, PID); { V8.65 } end else if (Ext = 'mid') or (Ext = 'avi') then begin Handled := True; // StartProcess(StrPCopy(PC, 'MPlayer.exe /play /close ' + S), sw_Show); IcsShellExec('MPlayer.exe /play /close ' + S, PID); { V8.65 } end; { else ignore other extensions } end; end; procedure THTTPForm.ViewerClear(Sender : TObject); { A ThtmlViewer is about to be cleared. Cancel any image processing destined for it } var I : Integer; Vw : ThtmlViewer; begin Vw := Sender as ThtmlViewer; for I := Pending.Count - 1 downto 0 do with ImageRec(Pending.Items[I]) do if Viewer = Vw then begin Free; Pending.Delete(I); end; end; procedure THTTPForm.DeleteCacheClick(Sender : TObject); begin DiskCache.EraseCache; end; procedure THTTPForm.wmDropFiles(var Message : TMessage); { handles dragging of file into browser window } var S : String; Count : Integer; begin Count := DragQueryFile(message.WPARAM, 0, @S[1], 200); SetLength(S, Count); DragFinish(message.WPARAM); if Count > 0 then begin UrlComboBox.Text := 'file://' + DosToHTMLNoSharp(S); GetButtonClick(nil); CurrentLocalFile := FrameBrowser.CurrentFile; end; message.Result := 0; end; procedure THTTPForm.Exit1Click(Sender : TObject); begin Close; end; procedure THTTPForm.ShowDiagWindowClick(Sender : TObject); begin ShowDiagWindow.Checked := not ShowDiagWindow.Checked; LogForm.Visible := ShowDiagWindow.Checked; end; procedure THTTPForm.ShowImagesClick(Sender : TObject); begin FrameBrowser.ViewImages := not FrameBrowser.ViewImages; ShowImages.Checked := FrameBrowser.ViewImages; end; procedure THTTPForm.ShowLogHTMLClick(Sender : TObject); begin ShowLogHTML.Checked := not ShowLogHTML.Checked; end; procedure THTTPForm.ShowLogHTTPClick(Sender: TObject); begin ShowLogHTTP.Checked := not ShowLogHTTP.Checked; end; procedure THTTPForm.ReloadClick(Sender : TObject); { the Reload button was clicked } begin ReloadButton.Enabled := False; Reloading := True; FrameBrowser.Reload; ReloadButton.Enabled := True; FrameBrowser.SetFocus; end; procedure THTTPForm.WMDownLoad(var Message : TMessage); { Handle download of file } var DownLoadForm : TDownLoadForm; begin SaveDialog.Filename := GetURLFilenameAndExt(DownLoadUrl); SaveDialog.InitialDir := Cache; if SaveDialog.Execute then begin DownLoadForm := TDownLoadForm.Create(Self); try with DownLoadForm do begin Filename := SaveDialog.Filename; DownLoadUrl := Self.DownLoadUrl; ProxyURL := Self.ProxyURL; // ProxyPort := Self.ProxyPort; UserAgent := UserAgent; ShowModal; end; finally DownLoadForm.Free; end; end; end; procedure THTTPForm.FormShow(Sender : TObject); { OnShow handler. Handles loading when a new instance is initiated by WinExec } var S : String; I : Integer; begin if (ParamCount >= 1) then begin { Parameter is file to load } S := CmdLine; I := Pos('" ', S); if I > 0 then Delete(S, 1, I + 1) { delete EXE name in quotes } else Delete(S, 1, Length(ParamStr(0))); { in case no quote marks } I := Pos('"', S); while I > 0 do { remove any quotes from parameter } begin Delete(S, I, 1); I := Pos('"', S); end; S := Trim(S); if not IsFullUrl(S) then S := 'file:///' + DosToHtml(S); UrlComboBox.Text := Trim(S); { Parameter is URL to load } PostMessage(Handle, wm_LoadURL, 0, 0); end {$IFDEF M4Viewer} else begin SelectStartingMode; if M4ConfigDeleteCache then DiskCache.EraseCache; UrlComboBox.Text := startfile; SendMessage(Handle, wm_LoadURL, 0, 0); end; {$ELSE} else begin UrlComboBox.Text := 'res:///page0.htm'; SendMessage(Handle, wm_LoadURL, 0, 0); end; {$ENDIF} end; { ----------------THTTPForm.BlankWindowRequest } procedure THTTPForm.BlankWindowRequest(Sender : TObject; const Target, URL : ThtString); { OnBlankWindowRequest handler. Either a Target of _blank or an unknown target was called for. Load a new instance } var S : String; PID: LongWord; begin S := URL; if not IsFullUrl(S) then S := CombineURL(URLBase, S); S := ParamStr(0) + ' "' + S + '"'; // StartProcess(PChar(S), sw_Show); IcsShellExec(S, PID); { V8.65 } end; procedure THTTPForm.Find1Click(Sender : TObject); begin FindDialog.Execute; end; procedure THTTPForm.FindDialogFind(Sender : TObject); begin with FindDialog do begin if not FrameBrowser.FindEx(FindText, frMatchCase in Options, not(frDown in Options)) then MessageDlg('No further occurances of "' + FindText + '"', mtInformation, [mbOK], 0); end; end; procedure THTTPForm.Edit1Click(Sender : TObject); begin with FrameBrowser do begin Copy1.Enabled := SelLength <> 0; SelectAll1.Enabled := (ActiveViewer <> nil) and (ActiveViewer.CurrentFile <> ''); Find1.Enabled := SelectAll1.Enabled; end; end; procedure THTTPForm.SelectAll1Click(Sender : TObject); begin FrameBrowser.SelectAll; end; procedure THTTPForm.Copy1Click(Sender : TObject); begin FrameBrowser.CopyToClipboard; end; procedure THTTPForm.URLComboBoxKeyPress(Sender : TObject; var Key : Char); { trap CR in combobox } begin if (Key = #13) and (UrlComboBox.Text <> '') then begin Key := #0; GetButtonClick(Self); end; end; procedure THTTPForm.URLComboBoxClick(Sender : TObject); begin if UrlComboBox.Text <> '' then GetButtonClick(Self); end; { ----------------THTTPForm.RightClick } procedure THTTPForm.RightClick(Sender : TObject; Parameters : TRightClickParameters); { OnRightClick handler. Bring up popup menu allowing saving of image or opening a link in another window } var Pt : TPoint; S, Dest : String; I : Integer; Viewer : ThtmlViewer; HintWindow : ThtHintWindow; ARect : TRect; begin Viewer := Sender as ThtmlViewer; with Parameters do begin FoundObject := Image; // if (FoundObject <> nil) and (FoundObject.Bitmap <> nil) then begin // 11.6 again Bitmap not graphic? if (FoundObject <> nil) and (FoundObject.Graphic <> nil) then begin // 11.6 was Bitmap if not IsFullUrl(FoundObject.Source) then FoundObjectName := CombineURL(FrameBrowser.GetViewerUrlBase(Viewer), FoundObject.Source) else FoundObjectName := FoundObject.Source; SaveImageAs.Enabled := True; end else SaveImageAs.Enabled := False; if URL <> '' then begin S := URL; I := Pos('#', S); if I >= 1 then begin Dest := System.Copy(S, I, 255); { local destination } S := System.Copy(S, 1, I - 1); { the file name } end else Dest := ''; { no local destination } if S = '' then S := Viewer.CurrentFile; if IsFullUrl(S) then NewWindowFile := S + Dest else NewWindowFile := CombineURL(FrameBrowser.GetViewerUrlBase(Viewer), S) + Dest; OpenInNewWindow.Enabled := True; end else OpenInNewWindow.Enabled := False; GetCursorPos(Pt); if Length(CLickWord) > 0 then begin HintWindow := ThtHintWindow.Create(Self); try ARect := Rect(0, 0, 0, 0); DrawText(HintWindow.Canvas.Handle, @CLickWord[1], Length(CLickWord), ARect, DT_CALCRECT); with ARect do HintWindow.ActivateHint (Rect(Pt.X + 20, Pt.Y - (Bottom - Top) - 15, Pt.X + 30 + Right, Pt.Y - 15), CLickWord); PopupMenu.Popup(Pt.X, Pt.Y); finally HintWindow.Free; end; end else PopupMenu.Popup(Pt.X, Pt.Y); end; end; procedure THTTPForm.SaveImageAsClick(Sender : TObject); { response to popup menu selection to save image } var Stream : TMemorystream; S : String; DocType : ThtmlFileType; AConnection : TURLConnection; Dummy : String; begin SaveDialog.InitialDir := Cache; SaveDialog.Filename := GetURLFilenameAndExt(FoundObjectName); if SaveDialog.Execute then begin Stream := TMemorystream.Create; try if DiskCache.GetCacheFilename(FoundObjectName, S, DocType, Dummy) then begin Stream.LoadFromFile(S); Stream.SaveToFile(SaveDialog.Filename); end else begin AConnection := TURLConnection.GetConnection(FoundObjectName); if AConnection <> nil then try AConnection.InputStream := Stream; AConnection.Get(FoundObjectName); Stream.SaveToFile(SaveDialog.Filename); finally AConnection.Free; end; end; finally Stream.Free; end; end; end; procedure THTTPForm.OpenInNewWindowClick(Sender : TObject); { response to popup menu selection to open link } var PID: LongWord; // PC : array [0 .. 255] of Char; begin // StartProcess(StrPCopy(PC, ParamStr(0) + ' "' + NewWindowFile + '"'), sw_Show); IcsShellExec(ParamStr(0) + ' "' + NewWindowFile + '"', PID); { V8.65 } end; procedure THTTPForm.SaveURLClick(Sender : TObject); { put the entry in the combobox in the list. It will be saved on exit } begin with UrlComboBox do begin if Items.IndexOf(Text) < 0 then Items.Add(Text); end; end; procedure THTTPForm.HTTPDocData1(Sender : TObject; Buffer : Pointer; Len : Integer); begin Status1.Caption := 'Text: ' + IntToStr(Connection.RcvdCount) + ' bytes'; Status1.Update; Progress(Connection.RcvdCount, Connection.ContentLength); end; procedure THTTPForm.FormClose(Sender : TObject; var Action : TCloseAction); begin if Assigned(Connection) then Connection.Abort; ClearProcessing; // FreeAndNil (MsCertChainEngine) ; end; procedure THTTPForm.Progress(Num, Den : Integer); var Percent : Integer; begin if Den = 0 then Percent := 0 else Percent := (100 * Num) div Den; Gauge.Position := Percent; Gauge.Update; end; procedure THTTPForm.Status2Resize(Sender : TObject); begin Gauge.SetBounds(5, 7, Status2.ClientWidth - 10, Status2.ClientHeight - 14); end; procedure THTTPForm.CheckException(Sender : TObject; E : Exception); begin if E is ESpecialException then begin ShowMessage(E.Message); AnAbort := False; end else Application.ShowException(E); end; procedure THTTPForm.DisableControls; begin UrlComboBox.Enabled := False; CancelButton.Enabled := True; ReloadButton.Enabled := False; Animate1.Visible := True; Animate1.Play(1, Animate1.FrameCount, 0); Gauge.Visible := True; end; procedure THTTPForm.EnableControls; begin UrlComboBox.Enabled := True; CancelButton.Enabled := False; ReloadButton.Enabled := FrameBrowser.CurrentFile <> ''; Reloading := False; Animate1.Active := False; Animate1.Visible := False; Gauge.Visible := False; end; procedure THTTPForm.BackButtonClick(Sender : TObject); begin FrameBrowser.GoBack; if FrameBrowser.HistoryIndex > FrameBrowser.History.Count then UrlComboBox.Text := FrameBrowser.History[FrameBrowser.HistoryIndex]; // ANGUS CheckEnableControls; end; procedure THTTPForm.FwdButtonClick(Sender : TObject); begin FrameBrowser.GoFwd; if FrameBrowser.HistoryIndex > FrameBrowser.History.Count then UrlComboBox.Text := FrameBrowser.History[FrameBrowser.HistoryIndex]; // ANGUS CheckEnableControls; end; { ----------------TImageHTTP.CreateIt } constructor TImageHTTP.CreateIt(AOwner : TComponent; IRec : TObject); begin inherited Create(AOwner); ImRec := IRec as ImageRec; Connection := THTTPConnection.Create; Connection.CheckInputStream; // creates stream end; { ----------------TImageHTTP.GetAsync } procedure TImageHTTP.GetAsync; begin Connection.GetAsync(URL); end; { ----------------TImageHTTP.Destroy } destructor TImageHTTP.Destroy; begin if Assigned(ImRec) then begin ImRec.Free; end; Connection.Free; inherited Destroy; end; { ----------------THTTPForm.Processing } procedure THTTPForm.Processing(Sender : TObject; ProcessingOn : Boolean); begin if ProcessingOn then begin { disable various buttons and menuitems during processing } FwdButton.Enabled := False; BackButton.Enabled := False; ReloadButton.Enabled := False; end else begin FwdButton.Enabled := FrameBrowser.FwdButtonEnabled; BackButton.Enabled := FrameBrowser.BackButtonEnabled; ReloadButton.Enabled := FrameBrowser.CurrentFile <> ''; CheckEnableControls; end; end; procedure THTTPForm.PrintPreviewClick(Sender : TObject); var {$IFDEF UseOldPreviewForm} pf: TPreviewForm; {$ELSE UseOldPreviewForm} pf: TBegaHtmlPrintPreviewForm; {$ENDIF UseOldPreviewForm} Viewer: ThtmlViewer; Abort: Boolean; begin Viewer := FrameBrowser.ActiveViewer; if Assigned(Viewer) then begin {$IFDEF UseOldPreviewForm} pf := TPreviewForm.CreateIt(Self, Viewer, Abort); {$ELSE UseOldPreviewForm} pf := TBegaHtmlPrintPreviewForm.Create(Self); pf.FrameViewer := FrameBrowser; Abort := False; {$ENDIF UseOldPreviewForm} try if not Abort then pf.ShowModal; finally pf.Free; end; end; end; procedure THTTPForm.File1Click(Sender : TObject); begin Print1.Enabled := FrameBrowser.ActiveViewer <> nil; PrintPreview.Enabled := Print1.Enabled; end; procedure THTTPForm.Print1Click(Sender : TObject); begin with PrintDialog do if Execute then if PrintRange = prAllPages then FrameBrowser.Print(1, 9999) else FrameBrowser.Print(FromPage, ToPage); end; procedure THTTPForm.PrintHeader(Sender : TObject; Canvas : TCanvas; NumPage, W, H : Integer; var StopPrinting : Boolean); var AFont : TFont; begin AFont := TFont.Create; AFont.Name := 'Arial'; AFont.Size := 8; with Canvas do begin Font.Assign(AFont); SetBkMode(Handle, Transparent); SetTextAlign(Handle, TA_Bottom or TA_Left); if FrameBrowser.ActiveViewer <> nil then begin TextOut(50, H - 5, FrameBrowser.ActiveViewer.DocumentTitle); SetTextAlign(Handle, TA_Bottom or TA_Right); TextOut(W - 50, H - 5, FrameBrowser.ActiveViewer.CurrentFile); end; end; AFont.Free; end; procedure THTTPForm.PrintFooter(Sender : TObject; Canvas : TCanvas; NumPage, W, H : Integer; var StopPrinting : Boolean); var AFont : TFont; begin AFont := TFont.Create; AFont.Name := 'Arial'; AFont.Size := 8; with Canvas do begin Font.Assign(AFont); SetTextAlign(Handle, TA_Bottom or TA_Left); TextOut(50, 20, DateToStr(Date)); SetTextAlign(Handle, TA_Bottom or TA_Right); TextOut(W - 50, 20, 'Page ' + IntToStr(NumPage)); end; AFont.Free; end; procedure THTTPForm.FrameBrowserMeta(Sender : TObject; const HttpEq, Name, Content : ThtString); begin LogLine('FrameBrowserMeta, HttpEq=' + HttpEq + ', MetaName=' + name + ', MetaContent=' + Content); end; procedure THTTPForm.FrameBrowserScript(Sender : TObject; const Name, ContentType, Src, Script : ThtString); begin LogLine('FrameBrowserScript, Name=' + name + ', Src=' + Src + ', Script=' + Script); end; procedure THTTPForm.About1Click(Sender : TObject); begin AboutBox := TAboutBox.CreateIt(Self, 'FrameBrowser ICSv9 Demo', 'TFrameBrowser'); try AboutBox.ShowModal; finally AboutBox.Free; end; end; procedure THTTPForm.Proxy1Click(Sender : TObject); begin ProxyForm := TProxyForm.Create(Self); ProxyForm.ProxyURLEdit.Text := ProxyURL; // ProxyForm.PortEdit.Text := ProxyPort; ProxyForm.ProxyUsername.Text := ProxyUser; ProxyForm.ProxyPassword.Text := ProxyPassword; ProxyForm.UserAgent.Text := UserAgent; ProxyForm.SslVersionList.ItemIndex := SslVersionList; // ProxyForm.SslAcceptableHostsEdit.Text := SslAcceptableHostsEdit; ProxyForm.SslVerifyCertMode.ItemIndex := SslVerifyCertMode; ProxyForm.SslRevokeCheck.Checked := SslRevokeCheck; ProxyForm.SslReportChain.Checked := SslReportChain; ProxyForm.SslRootCertsFileEdit.Text := SslRootCertsFile; { V8.69 } try if ProxyForm.ShowModal = mrOK then begin ProxyURL := ProxyForm.ProxyURLEdit.Text; // ProxyPort := ProxyForm.PortEdit.Text; ProxyUser := ProxyForm.ProxyUsername.Text; ProxyPassword := ProxyForm.ProxyPassword.Text; UserAgent := ProxyForm.UserAgent.Text; SslVersionList:= ProxyForm.SslVersionList.ItemIndex; // SslAcceptableHostsEdit:= ProxyForm.SslAcceptableHostsEdit.Text; SslVerifyCertMode:= ProxyForm.SslVerifyCertMode.ItemIndex; SslRevokeCheck:= ProxyForm.SslRevokeCheck.Checked; SslReportChain:= ProxyForm.SslReportChain.Checked; SslContext.SslCliSecurity := TSslCliSecurity(SslVersionList); { V8.54} SslRootCertsFile := ProxyForm.SslRootCertsFileEdit.Text; { V8.69 } if SslContext.IsCtxInitialized then // may have changed SSL options begin if Assigned (Connection) then Connection.ResetSSL; SslContext.DeInitContext; end; end; finally ProxyForm.Free; end; end; procedure THTTPForm.DemoInformation1Click(Sender : TObject); begin UrlComboBox.Text := 'res:///page0.htm'; GetButtonClick(Self); end; procedure THTTPForm.FrameBrowserMouseMove(Sender : TObject; Shift : TShiftState; X, Y : Integer); var TitleStr : String; begin if not Timer1.Enabled and (Sender is ThtmlViewer) and Assigned(ActiveControl) and ActiveControl.Focused then begin TitleViewer := ThtmlViewer(Sender); TitleStr := TitleViewer.TitleAttr; if TitleStr = '' then OldTitle := '' else if TitleStr <> OldTitle then begin TimerCount := 0; Timer1.Enabled := True; OldTitle := TitleStr; end; end; end; procedure THTTPForm.CloseHints; begin Timer1.Enabled := False; HintWindow.ReleaseHandle; HintVisible := False; TitleViewer := nil; end; procedure THTTPForm.Timer1Timer(Sender : TObject); const StartCount = 2; { timer counts before hint window opens } EndCount = 20; { after this many timer counts, hint window closes } var Pt, Pt1 : TPoint; ARect : TRect; TitleStr : ThtString; begin if not Assigned(TitleViewer) then begin CloseHints; exit; end; Inc(TimerCount); GetCursorPos(Pt); try { in case TitleViewer becomes corrupted } Pt1 := TitleViewer.ScreenToClient(Pt); TitleStr := TitleViewer.TitleAttr; if (TitleStr = '') or not PtInRect(TitleViewer.ClientRect, Pt1) then begin OldTitle := ''; CloseHints; exit; end; if TitleStr <> OldTitle then begin TimerCount := 0; OldTitle := TitleStr; HintWindow.ReleaseHandle; HintVisible := False; exit; end; if TimerCount > EndCount then CloseHints else if (TimerCount >= StartCount) and not HintVisible then begin ARect := HintWindow.CalcHintRect(300, TitleStr, nil); with ARect do HintWindow.ActivateHint(Rect(Pt.X, Pt.Y + 18, Pt.X + Right, Pt.Y + 18 + Bottom), TitleStr); HintVisible := True; end; { note: this exception can occur when switching frames while TitleViewer is active. It is adequately handled here and only appears in the IDE when "Stop on Delphi Exceptions" is turned on } except CloseHints; end; end; //-- BG ---------------------------------------------------------- 16.08.2015 -- procedure THTTPForm.AppMessage(var Msg: TMsg; var Handled: Boolean); var WinCtrl: TWinControl; begin if Msg.message = WM_MOUSEWHEEL then begin WinCtrl := FindVCLWindow(Point(Word(Msg.lParam), HiWord(Msg.lParam))); if (WinCtrl is TPaintPanel) {$ifndef UseOldPreviewForm} or (WinCtrl is TBegaZoomBox) {$endif UseOldPreviewForm} then begin // perform mouse wheel scrolling for the control under the mouse: WinCtrl.Perform(CM_MOUSEWHEEL, Msg.WParam, Msg.LParam); Handled := True; end; end; end; end.