|
Registriert seit: 18. Nov 2015 Ort: Kehl 678 Beiträge Delphi 11 Alexandria |
#17
Also ich würde sagen zerlege mal deine Execute Routine in einzelne Methoden.
Du greifst immer wieder auf Vcl Formulare zu. Weg damit. So ist dem Problem nicht wirklich beizukommen. Hier mal ein Vorschlag (Auf die schnelle geändert aber du Siehst denke ich die Idee dahinter)
Delphi-Quellcode:
unit httpThread;
interface uses Classes, SysUtils, Dialogs, Forms, Controls, ShellAPI, Windows, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, IdURI, IdCookieManager, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack, IdSSL, IdSSLOpenSSL, IdCoder, xmldom, XMLIntf, msxmldom, XMLDoc, ActiveX; type tLogMessageProc = procedure(const aMessage: string) of object; http = class(TThread) private { Private-Deklarationen } fhttp: TIdHttp; fUser, fPass, fHardwarekennung, fURL, fcfg, fsrc, fsalt: string; fLogError: tLogMessageProc; flogMessage: tLogMessageProc; /// <summary> /// Returns true if there is a Problem /// </summary> function checkProblem(const aXMLNodes: iXMLNodeList): boolean; procedure doApplicationUpdate(fparams: tstringlist; const nlist: iXMLNodeList; const PHPXML: IXMLDOCUMENT); procedure doDownloadFile(const aFilename, aTimestamp: string); procedure doXMLDecode(const nlist: iXMLNodeList); procedure logError(const aMessage: string); procedure logmessage(const aMessage: string); procedure FillParams(const Values: Tstrings); procedure showMessageinMainThread(const aMessage: string); function getxmlFromServer(aXML: IXMLDOCUMENT; aServer: TIdHttp; const aUrl: string; aParams: Tstrings): boolean; protected procedure Execute; override; public constructor Create(const User, Pass, Hardwarekennung, URL, cfg, src, salt: string; aLogerror: tLogMessageProc; aLogMessage: tLogMessageProc); end; implementation function getVersion: string; begin result := 'unknown'; end; function http.checkProblem(const aXMLNodes: iXMLNodeList): boolean; begin result := true; if (aXMLNodes.FindNode('problem') <> nil) then begin if (((aXMLNodes.FindNode('blocked') <> nil)) and (aXMLNodes.FindNode('blocked').Text > '0000-00-00 00:00:00')) or (((aXMLNodes.FindNode('removed') <> nil)) and (aXMLNodes.FindNode('removed').Text > '0000-00-00 00:00:00')) then begin try DeleteFile(PChar(fcfg)); except end; Application.Terminate; end; Queue( procedure begin showmessage('Username or password not valid. Please check your input.'); end); // 'Username or password not valid. Please check your input.' exit; end; result := False; end; procedure http.doApplicationUpdate(fparams: tstringlist; const nlist: iXMLNodeList; const PHPXML: IXMLDOCUMENT); var sFile: TStream; sFilename: string; begin // Versionscheck und ggf. Download der aktuellen Version if (nlist.FindNode('version') <> nil) then if (PHPXML.DocumentElement.ChildNodes.FindNode('version').Text <> getVersion) then // Das geht auch in die Hose aus einem Thread heraus // if (MessageDlg(language.Label4.Caption + PHPXML.DocumentElement.ChildNodes.FindNode('version').Text + '!' + #13#10 + // language.label5.Caption, mtConfirmation, mbYesNo, 0) = mrYes) then begin // download.Show; sFilename := extractfilepath(paramstr(0)) + 'update.exe'; try DeleteFile(PChar(sFilename)) except on e: exception do logError(e.message); end; sFile := TFileStream.Create(sFilename, fmCreate); try fparams.Text := 'RPC=update'; fhttp.Post(TIdURI.URLEncode(fURL), fparams, sFile); finally sFile.Free; end; ShellExecute(handle, 'open', PChar(sFilename), PChar(''), '', SW_SHOWNORMAL); /// SP- /VERYSILENT Application.Terminate; end; end; procedure http.doDownloadFile(const aFilename, aTimestamp: string); var lparams: tstringlist; sFile: TStream; sFilename: string; begin sFilename := extractfilepath(paramstr(0)) + aFilename; sFile := TFileStream.Create(sFilename, fmCreate); lparams := tstringlist.Create; try lparams.Text := 'RPC=download'; lparams.Add('file=' + aFilename); logmessage('Try to get File ' + aFilename); fhttp.Post(TIdURI.URLEncode(fURL), lparams, sFile); // sFile fileStream finally lparams.Free; fhttp.Response.Clear; sFile.Free; { TODO : Auskommentiert da die Unit nicht da ist } // SetFileDate(sFilename, UnixToDateTime(aTimestamp); end; end; procedure http.doXMLDecode(const nlist: iXMLNodeList); var cfgdata: tstringlist; begin // XML Verschlüsseln und Speichern try DeleteFile(PChar(fcfg)) except on e: exception do logError(e.message); end; try // Wirklich asynchron? Queue( procedure begin { TODO : Besser hier eine eigene Mime Class benutzen } // Form1.xml.LoadFromXML(Form1.IdDecoderMIME1.DecodeString(nlist.FindNode('cfg').Text, SysUtils.TUTF8Encoding.UTF8)); cfgdata := tstringlist.Create; try { TODO : Auskommentiert da die Unit nicht da ist } // cfgdata.Text := functions.Encrypt(Form1.xml.xml.Text, fsalt + fUser + fPass + fHardwarekennung); cfgdata.SaveToFile(fcfg); finally cfgdata.Free; end; end); except on e: exception do logError(e.message); end; end; procedure http.logError(const aMessage: string); begin if assigned(fLogError) then Queue( procedure begin fLogError(aMessage); { problem connecting server } { TODO Offline Modus starten } end); end; procedure http.logmessage(const aMessage: string); begin if assigned(flogMessage) then Queue( procedure begin flogMessage(aMessage); end); end; procedure http.FillParams(const Values: Tstrings); begin Values.Clear; Values.Add('RPC=login'); Values.Add('username=' + fUser); Values.Add('password=' + fPass); Values.Add('hardware=' + fHardwarekennung); end; procedure http.showMessageinMainThread(const aMessage: string); begin Queue( procedure begin showmessage(aMessage); end); end; function http.getxmlFromServer(aXML: IXMLDOCUMENT; aServer: TIdHttp; const aUrl: string; aParams: Tstrings): boolean; var s: string; begin result := False; s := aServer.Post(TIdURI.URLEncode(fURL), aParams); try aXML.LoadFromXML(s); aXML.Active := true; result := (not aXML.IsEmptyDoc) and (aXML.DocumentElement.HasChildNodes); except on e: exception do logError(e.message); end; end; procedure http.Execute; var currentList: tstringlist; flist: iXMLNodeList; fparams: tstringlist; i: integer; nlist: iXMLNodeList; pfad: string; PHPXML: IXMLDOCUMENT; s: string; s1: string; begin CoInitialize(nil); PHPXML := NewXMLDocument; fhttp := TIdHttp.Create(nil); fparams := tstringlist.Create; try fhttp.HandleRedirects := true; fhttp.AllowCookies := true; fhttp.ReadTimeout := 15000; // Sonst Timeouts auf > Windows 8 BSystemen fhttp.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(fhttp); FillParams(fparams); if getxmlFromServer(PHPXML, fhttp, fURL, fparams) then begin nlist := PHPXML.DocumentElement.ChildNodes; if checkProblem(nlist) then exit; doXMLDecode(nlist); // APPLICATION UPDATE doApplicationUpdate(fparams, nlist, PHPXML); // CONTENT UPDATE currentList := tstringlist.Create; try currentList.Sorted := true; // functions.FindAllFilesUnix(currentList, fsrc, '*', true, False, true, true); // Dateiliste erstellen pfad := extractfilepath(paramstr(0)); s1 := PHPXML.DocumentElement.ChildNodes.FindNode('filelist').xml; for i := currentList.Count - 1 downto 0 do begin s := copy(currentList[i], length(fsrc) + 1); s := copy(s, 0, pos(#255, s) - 1); if (pos('\', s) < 1) and ((extractfileext(s) = '') or (lowercase(extractfileext(s)) = '.xml')) then continue; // APPDATEN: Übergehen - Dateien ohne Endung, Dateien mit Endung XML s := copy(currentList[i], length(pfad) + 1); s := copy(s, 0, pos(#255, s) - 1); if (pos('>' + s + '</file>', s1) < 1) then DeleteFile(PChar(s)); // löschen end; flist := PHPXML.DocumentElement.ChildNodes.FindNode('filelist').ChildNodes; logmessage('flist.count: ' + inttostr(flist.Count)); for i := flist.Count - 1 downto 0 do begin if (pos(flist[i].NodeValue + #255 + flist[i].Attributes['timestamp'], currentList.Text) > 0) then continue; // Datumsvergleich logmessage('entry ' + inttostr(i) + ': ' + flist[i].NodeValue + #255 + flist[i].Attributes['timestamp']); // Download doDownloadFile(flist[i].NodeValue, flist[i].Attributes['timestamp']); end; finally currentList.Free; end; // Applikation laden end else showMessageinMainThread(' problem connecting server'); finally try fparams.Text := 'RPC=logout'; fhttp.Post(TIdURI.URLEncode(fURL), fparams); except on e: exception do logError(e.message); end; fhttp.Free; fparams.Free; end; // Self.Terminate; end; constructor http.Create(const User, Pass, Hardwarekennung, URL, cfg, src, salt: string; aLogerror: tLogMessageProc; aLogMessage: tLogMessageProc); begin inherited Create(False); FreeOnTerminate := true; fUser := User; fPass := Pass; fHardwarekennung := Hardwarekennung; fURL := URL; fcfg := cfg; fsrc := src; fsalt := salt; fLogError := aLogerror; flogMessage := aLogMessage; // Self.Execute; /// Niemals selber aufrufen end; end.
Fritz Westermann
|
![]() |
Themen-Optionen | Thema durchsuchen |
Ansicht | |
ForumregelnEs ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.
BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus. Trackbacks are an
Pingbacks are an
Refbacks are aus
|
|
Nützliche Links |
Heutige Beiträge |
Sitemap |
Suchen |
Code-Library |
Wer ist online |
Alle Foren als gelesen markieren |
LinkBack |
![]() |
![]() |