Евгений Корепов

В приведенном коде процедура FormCreate: procedure TFormMain.FormCreate(Sender: TObject); begin Timer.Interval:=10; Хотя такой короткий не нужен для большинства случаев.

К сожалению компоненты баз данных пишут далекие от мира теоретики. На своем горьком опыте убедился что защита от ошибок транспорта нулевая, контроль целостности передаваемых данных нулевой, даже примитивная обработка локальных исключений тоже нулевая. На реальном производстве, переключение с кабеля на wifi, переход с одной wifi сети в другую, или переключение на мобильный интернет приводит к краху приложения и потере какой нибудь накладной на буровые головки стоимостью в пару десятков миллионов рублей. В некоторых проектах использую передачу JSON по HTTPS, с контрольными суммами блоков данных и автоинкрементными счетчиками переданных/принятых блоков. Конечно на стороне сервера приходится держать прокладку, но зато работает стабильно.

Накидал примерный проект для корректной работы с потоками. Создаем поток, в который с помощью очереди закидываем задания и в таймере получаем результат выполнения. Вместо изжившего себя TIdHTTP, использовал THTTPClient (вдруг вам понадобится, к примеру, запускать это приложение на 6 андроиде и обращаться по https - Indy такое уже не сможет). Код юнита с потоком: unit UnitGetHttpThread; interface uses classes, SysUtils, System.Generics.Collections, System.SyncObjs, System.Net.HttpClient; type THTTPRec=record Command : String; Query : String; ErrorMsg : String; ErrorCode : Integer; Page : String; Stream : TMemoryStream; ItemImageIndex : Integer; end; THTTPThread=class(TThread) private FQueueRequest: TThreadedQueue<THTTPRec>; FQueueResult: TThreadedQueue<THTTPRec>; FHTTPRec: THTTPRec; function GetHTTP(AHTTPRec: THTTPRec) : THTTPRec; protected HTTPClient: THTTPClient; procedure Execute; override; public constructor Create(AQueueRequest, AQueueResult : TThreadedQueue<THTTPRec>); destructor Destroy; override; end; implementation constructor THTTPThread.Create(AQueueRequest, AQueueResult : TThreadedQueue<THTTPRec>); begin FreeOnTerminate:=False; FQueueRequest:=AQueueRequest; FQueueResult:=AQueueResult; HTTPClient:=THTTPClient.Create; Inherited Create(FALSE); end; destructor THTTPThread.Destroy; begin HTTPClient.Free; inherited Destroy; end; procedure THTTPThread.Execute; begin while Not Terminated do if FQueueRequest.PopItem(FHTTPRec) = TWaitResult.wrSignaled Then begin if FHTTPRec.Command.Equals('stop') then begin FHTTPRec.ErrorCode:=200; FHTTPRec.ErrorMsg:='Ok'; FQueueResult.PushItem(FHTTPRec); Continue; end; FHTTPRec.ErrorCode:=0; FHTTPRec.ErrorMsg:=''; FHTTPRec:=GetHTTP(FHTTPRec); if Not FHTTPRec.Command.Equals('error') then FQueueResult.PushItem(FHTTPRec); end; end; function THTTPThread.GetHTTP(AHTTPRec: THTTPRec) : THTTPRec; Var HTTPResponse: IHTTPResponse; begin try if AHTTPRec.Command.Equals('image') then begin HTTPResponse:=HTTPClient.Get(AHTTPRec.Query,AHTTPRec.Stream); AHTTPRec.ErrorCode:=HTTPResponse.StatusCode; AHTTPRec.ErrorMsg:=HTTPResponse.StatusText; end Else begin HTTPResponse:=HTTPClient.Get(AHTTPRec.Query); AHTTPRec.Page:=HTTPResponse.ContentAsString; AHTTPRec.ErrorCode:=HTTPResponse.StatusCode; AHTTPRec.ErrorMsg:=HTTPResponse.StatusText; end; except AHTTPRec.ErrorCode:=-1; AHTTPRec.ErrorMsg:='ErrorGetURL'; end; Result:=AHTTPRec; end; end. Код основной формы (основного потока): unit UnitFormMain; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, System.Generics.Collections, UnitGetHttpThread, FMX.Layouts, FMX.ListBox, System.JSON; type TFormMain = class(TForm) MainContentDownloadBaseListBox: TListBox; Timer: TTimer; procedure TimerTimer(Sender: TObject); procedure FormCreate(Sender: TObject); private { Private declarations } FQueueRequest: TThreadedQueue<THTTPRec>; FQueueResult: TThreadedQueue<THTTPRec>; HTTPThread : THTTPThread; public { Public declarations } procedure GetHTTP(ACommand : String; AListItemIndex : Integer; BaseID : String); procedure FillListBoxImage(AHTTPRec : THTTPRec); procedure FillListBoxItem(AHTTPRec : THTTPRec); end; var FormMain: TFormMain; implementation {$R *.fmx} procedure TFormMain.FormCreate(Sender: TObject); begin Timer.Interval:=10; FQueueRequest:=TThreadedQueue<THTTPRec>.Create(50, 1000, 10); FQueueResult:=TThreadedQueue<THTTPRec>.Create(50, 1000, 10); HTTPThread:=THTTPThread.Create(FQueueRequest,FQueueResult); GetHTTP('json', -1, ''); // запускаем карусель end; procedure TFormMain.TimerTimer(Sender: TObject); Var FHTTPRec : THTTPRec; begin while FQueueResult.PopItem(FHTTPRec) = TWaitResult.wrSignaled do begin if FHTTPRec.ErrorCode=200 then begin if FHTTPRec.Command.Equals('json') then FillListBoxItem(FHTTPRec); if FHTTPRec.Command.Equals('image') then FillListBoxImage(FHTTPRec); if FHTTPRec.Command.Equals('stop') then begin Timer.Enabled:=False; // AniIndicator.Visible:=False; // AniIndicator.Enabled:=False; end; end Else begin Timer.Enabled:=False; // AniIndicator.Visible:=False; // AniIndicator.Enabled:=False; // LabelTitle.Text:='Не удалось получить данные, проверьте подключение к Интернет.'; end; end; end; procedure TFormMain.FillListBoxItem(AHTTPRec : THTTPRec); Var JSON : TJSONObject; I : Integer; BaseName, BaseCaption, BaseCategory, BaseID, BaseData: String; Item, ItemRadio: TListBoxItem; begin JSON := TJSONObject.ParseJSONValue(AHTTPRec.Page) as TJSONObject; if Not Assigned(JSON) then Exit; for I:=0 To JSON.Count-1 do Begin BaseData := JSON.Pairs[i].ToString; BaseData := BaseData.Substring(pos('"', BaseData)); BaseName := BaseData.Remove(pos('"', BaseData) - 1); BaseData := BaseData.Substring(pos('"', BaseData)); BaseData := BaseData.Substring(pos(':', BaseData)); { JSON1 := TJSONObject.ParseJSONValue(BaseData) as TJSONObject; BaseCaption := JSON1.Values['caption'].Value; BaseCategory := JSON1.Values['category'].Value; BaseID := JSON1.Values['id'].Value; } if MainContentDownloadBaseListBox.Items.IndexOf(BaseID) = -1 then Begin Item := TListBoxItem.Create(Self); Item.Height := 120; Item.StyleLookup := 'ListBoxItemDownloadBaseStyle'; Item.Text := BaseID; Item.StylesData['name'] := BaseName; Item.StylesData['caption'] := BaseCaption; Item.StylesData['category'] := BaseCategory; GetHTTP('image', Item.Index, BaseID); // отсылаем в поток запрос на скачивание картинки MainContentDownloadBaseListBox.AddObject(Item); End; End; GetHTTP('stop', -1, ''); end; procedure TFormMain.FillListBoxImage(AHTTPRec : THTTPRec); begin MainContentDownloadBaseListBox.ListItems[AHTTPRec.ItemImageIndex].ItemData.Bitmap.LoadFromStream(AHTTPRec.Stream); end; procedure TFormMain.GetHTTP(ACommand : String; AListItemIndex : Integer; BaseID : String); Var FHTTPRec : THTTPRec; begin FHTTPRec.Page:=''; Timer.Enabled:=True; if ACommand='stop' then begin FHTTPRec.Command:='stop'; FQueueRequest.PushItem(FHTTPRec); end; if ACommand='json' then begin FHTTPRec.Command:=ACommand; FHTTPRec.Query:='https://ссылка получения json'; FQueueRequest.PushItem(FHTTPRec); end; if ACommand='image' then begin FHTTPRec.Command:=ACommand; FHTTPRec.Query:='https://ссылка получения картинки'+BaseID; FHTTPRec.ItemImageIndex:=AListItemIndex; FHTTPRec.Stream:=TMemoryStream.Create; FQueueRequest.PushItem(FHTTPRec); end; end; end. Одним потоком забираем все что нужно из сети - и json данные и картинки, ну и все что еще прикрутите.

В исходниках уже проделывается все что есть в вашем коде, посмотрите внимательно. У меня ошибка появляется в моем коде Else if Assigned(ABitmap) then ABitmap.Assign(ABitmapSurface); т.е. когда вроде как не требуется уменьшать изображение, т.е. ошибка появляется где то в этом коде исходников: begin SetSize(Source.Width, Source.Height); if Map(TMapAccess.Write, BitmapData) then try for I := 0 to TBitmapSurface(Source).Height - 1 do Move(TBitmapSurface(Source).Scanline[I]^, BitmapData.GetScanline(I)^, BitmapData.BytesPerLine); finally Unmap(BitmapData); end; end;

Посмотрел исходники, оказывается там все это уже есть: unit FMX.Graphics; procedure TBitmap.AssignFromSurface(const Source: TBitmapSurface); var BitmapData: TBitmapData; MaxSize: Integer; ResampledSurface: TBitmapSurface; I: Integer; SourceRect: TRectF; begin MaxSize := CanvasClass.GetAttribute(TCanvasAttribute.MaxBitmapSize); if (Source.Width > MaxSize) or (Source.Height > MaxSize) then begin SourceRect := TRectF.Create(0, 0, Source.Width, Source.Height); SourceRect.Fit(TRectF.Create(0, 0, MaxSize, MaxSize)); ResampledSurface := TBitmapSurface.Create; try ResampledSurface.StretchFrom(Source, Trunc(SourceRect.Width), Trunc(SourceRect.Height), PixelFormat); AssignFromSurface(ResampledSurface); finally ResampledSurface.Free; end; end else begin SetSize(Source.Width, Source.Height); if Map(TMapAccess.Write, BitmapData) then try for I := 0 to TBitmapSurface(Source).Height - 1 do Move(TBitmapSurface(Source).Scanline[I]^, BitmapData.GetScanline(I)^, BitmapData.BytesPerLine); finally Unmap(BitmapData); end; end; end; Так что весь мой код не имеет смысла. В процедуре можно ограничится следующим кодом: procedure TFormMain.CheckAndLoadFromStream(const AStream : TStream; const ABitmap : TBitmap); Var ABitmapSurface : TBitmapSurface; begin ABitmapSurface:=TBitmapSurface.Create; AStream.Position:=0; TBitmapCodecManager.LoadFromStream(AStream,ABitmapSurface); if Assigned(ABitmap) then ABitmap.Assign(ABitmapSurface); FreeAndNil(ABitmapSurface); end; Ну и изредка глючить он будет по прежнему...

К сожалению этот код выполняется неимоверно долго. На моём HTC One, загрузка с локального хранилища 30 картинок 250х250 производится за 15-20 секунд. Прямая операция Assigned(ABitmap) происходит фактически мгновенно. Так что ради полутора процентов пользователей, замедлять работу приложения на два порядка я не готов.

Посмотрите через штатный Монитор ресурсов Windows работу с диском во время тормозов. У меня была подобная проблема на XE8 - оказалось что конфликтует с КриптоПРО, дергает какую то dll и любое действие растягивается на сорок минут. С техподдержкой эмбаркадеры неделю потратили на выяснение. Начали с запуска "bds.exe -rtest", закончили запуском специального приложения для подробного мониторинга IDE.

Может тогда наоборот, попробовать использовать один экземпляр HTTP на весь сеанс работы? Чем черт не шутит, вдруг метод инженерного тыка сработает.

Я смирился. У меня в приложении с ~20000 пользователями ошибка вылезает у 290 :-( Т.е. это примерно 1.5%.

THTTPClient не визуальный, так же у него отсутствуют события OnAuthEvent и другие. Все ручками надо обрабатывать.

На счет драйверов на телефон посмотрите эти http://4pda.ru/forum/index.php?showtopic=612373&st=1580 (спойлер Инструменты), или ищите китайского прародителя. У меня 2 DEXP для тестов, к обоим, с трудом, но нашел драйвера. И попробуйте HTTPClient создавать перед каждым обращением в качестве теста. Ну и после запроса к серверу сразу грохать. У меня в одном проекте было подозрение что HTTPClient валится после пары сотен запросов, то ли утечка памяти, то ли еще что, разбираться не стал, в реальности количество обращений к серверу было гораздо меньше. P.S. Вот этот способ использовал для установки драйверов (они не подписаны) http://4pda.ru/forum/index.php?showtopic=612373&st=1580#entry37324657

Симпатично, черт побери! ;-)

Вообще работать должно так - идет обращение на сервер, сервер отлупливает и сообщает давай авторизацию, TNetHTTPClient обрабатывает овет в OnAuthEvent и посылает второй запрос с авторизацией. Хотя могу и ошибаться, всегда использую THTTPClient, с TNetHTTPClient не баловался.

HTTPClient.HandleRedirects:=False;

Возможно сервер посылает редирект (код ответа 3хх). Отключите следование редиректу в NetHTTPClient и увидите все запросы и ответы.

При нажатие на кнопку и не должно ничего происходить. Вы сами обрабатываете событие: ... TFormMain = class(TForm) procedure ChatBoxURLButton(PURL: string); ... ChatBox.OnURLButtonClick:=ChatBoxURLButton; // При создании ChatBox ... procedure TFormMain.ChatBoxURLButton(PURL: string); begin OpenURL(PURL); // Открываем url мультиплатформенной процедурой end; // К примеру такой: procedure TFormMain.OpenURL(const AUrl: string); {$IFDEF ANDROID} var Uri: Jnet_Uri; OpenLinkIntent: JIntent; {$ENDIF ANDROID} begin {$IFDEF MSWINDOWS} ShellExecute(0, 'open', PChar(AUrl), nil, nil, SW_SHOWNORMAL); {$ENDIF MSWINDOWS} {$IFDEF ANDROID} Uri := StrToJURI(AUrl); OpenLinkIntent := TJIntent.JavaClass.init(TJIntent.JavaClass.ACTION_VIEW, Uri); SharedActivity.startActivity(OpenLinkIntent); {$ENDIF ANDROID} end;

Очистить : Chat.ClearChildren(Chat); Полоски это TLabel видимо с бордюром, поэкспериментируйте со стилем или с свойством Clip

procedure TForm1.FormCreate(Sender: TObject); begin chat:=TChatBox.Create(Layout1); Chat.Align:=TAlignLayout.Client; Chat.MsgWidthPercentage:=66; Chat.CalloutLength:=10; Chat.CalloutXRadius:=5; Chat.CalloutYRadius:=5; Chat.MessageFontSize:=14; Layout1.AddObject(Chat); end; Как то так...

ChBlack:=Char($2588)+Char($2588); ChWhite:=Char($2591)+Char($2591); Шрифт стандартный, выглядит не много лучше, но тоже не идеально:

Также можно использовать символы юникода http://www.alanwood.net/unicode/block_elements.html , но мне не удалось победить искажения. Кстати почему то считывает у меня только "llo world!", первые две буквы куда то пропадают ;-)

Можно пойти другим путем. Рисовать не на TImage, а использовать шрифты. На http://fontello.com/ сделал шрифт из двух символов - черный квадрат и белый квадрат. Рисовальщик из меня никудышний, не разобрался как увеличить высоту символов в SVG иконке. Шрифт подключил к проекту, отображаю на Memo, у которого установлен мой шрифт. Код такой: procedure TfmMainQRShare.Update; var Row, Column, I : Integer; S : String; ChBlack, ChWhite : String; begin Memo.BeginUpdate; Memo.Lines.Clear; ChBlack:=Char($e802); ChWhite:=Char($e803); QRCode.Free; QRCode := TDelphiZXingQRCode.Create; try QRCode.Data := edtText.Text; QRCode.Encoding := TQRCodeEncoding(cmbEncoding.ItemIndex); QRCode.QuietZone := StrToIntDef(edtQuietZone.Text, 2); for Row := 0 to QRCode.Rows - 1 do begin S:=''; for Column := 0 to QRCode.Columns - 1 do begin if (QRCode.IsBlack[Row, Column]) then S:=S+ChBlack else S:=S+ChWhite; end; Memo.Lines.Add(S); end; finally end; Memo.EndUpdate; end; На картинке видны горизонтальные пробелы между символами, в какой то момент мне удалось методом тыка (редактированием шрифта) от них избавится, но слетела ширина белого квадрата. Оставил вариант который хотя бы читается.

Вот получение данных с type=1: function TFormMain.ParseJSONArray(AJSONString : String) : TStringList; // для удобства функция возвращает TStringList, так будет проще закинуть результат в Memo Var AJSONArray : TJSONArray; AJSONValue : TJSONValue; I : Integer; begin Result:=TStringList.Create; // Создаем результат фозвращаемый функцией AJSONArray:=TJSONArray(TJSONObject.ParseJSONValue(AJSONString)); // Зная что на входе TJSONArray парсим его, пропуская парсинг TJSONObject if Not Assigned(AJSONArray) then // Если парсинг удался, то AJSONArray<>Nil Exit; for I := 0 to AJSONArray.Count-1 do // Работаем как с обычным массивом begin if AJSONArray.Items[I].TryGetValue('type',AJSONValue) Then // Получаем type if Not AJSONValue.Value.Equals('1') then // если type<>1 переходим на следующую итерацию (код ниже пропускается) Continue; if AJSONArray.Items[I].TryGetValue('number',AJSONValue) Then //Здесь используем полезную функцию TryGetValue, защищая себя от некорректных или отсутствующих 'number' Result.Add(AJSONValue.Value); // Если успешно, то добавляем полученную строку в результирующий StringList end; end; "адресс вайолэйшн" потому что код с XSuperObject не безопасный, будет работать до первой ошибки в входных данных, далее крах приложения.

Мой код на две строчки короче ;-) Плюс в нем есть проверки на не штатные ситуации. На счет читаемости тоже поспорю: "SO(aJSON), A['data'], O[j], S['number']" - не самый лучший пример читаемости, называть глобальную функцию SO и использовать использовать именования типа A, B, C, D было модно в конце 80-х, начале 90-х. Видимо разработчик такой же древний как и я ;-) Когда пишешь код на Fortran и набиваешь его на перфокартах для EC-1045, каждый символ на счету. Теперь же я могу заглянуть в свой год 10-ти летней давности и понять что он делает не анализируя содержимое функций или назначение переменных.

Для работы с JSON в Delphi есть все что нужно - штатная библиотека System.JSON. Быстрая и удобная, работать с ней одно удовольствие. Вот накидал проект, ваш JSON загружаю из файла. unit UnitFormMain; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, System.IOUtils, FMX.Controls.Presentation, FMX.ScrollBox, FMX.Memo, System.JSON; type TFormMain = class(TForm) Memo: TMemo; procedure FormCreate(Sender: TObject); private { Private declarations } public { Public declarations } function ParseJSONArray(AJSONString : String) : TStringList; end; var FormMain: TFormMain; implementation {$R *.fmx} procedure TFormMain.FormCreate(Sender: TObject); Var AJSONString : String; begin AJSONString:=TFile.ReadAllText('D:\Embarcadero\Projects\Test\test062 JSON Array\input.json'); // Загружаем JSON в строку Memo.Lines.Assign(ParseJSONArray(AJSONString)); // Вызываем функцию парсинга, если все удачно - Memo заполнится значениями, если нет - останется пустым. end; function TFormMain.ParseJSONArray(AJSONString : String) : TStringList; // для удобства функция возвращает TStringList, так будет проще закинуть результат в Memo Var AJSONArray : TJSONArray; AJSONValue : TJSONValue; I : Integer; begin Result:=TStringList.Create; // Создаем результат фозвращаемый функцией AJSONArray:=TJSONArray(TJSONObject.ParseJSONValue(AJSONString)); // Зная что на входе TJSONArray парсим его, пропуская парсинг TJSONObject if Not Assigned(AJSONArray) then // Если парсинг удался, то AJSONArray<>Nil Exit; for I := 0 to AJSONArray.Count-1 do // Работаем как с обычным массивом if AJSONArray.Items[I].TryGetValue('number',AJSONValue) Then //Здесь используем полезную функцию TryGetValue, защищая себя от некорректных или отсутствующих 'number' Result.Add(AJSONValue.Value); // Если успешно, то добавляем полученную строку в результирующий StringList end; end. P.S. работает под всеми платформами. Скорость для такого небольшого файла JSON можно принять за мгновенную даже на стареньких телефонах. Мне вот тут один сервис отдавал JSON размером в 6 мегабайт. Онлайн парсер http://pro.jsonlint.com/ которым удобно смотреть структуру зависал наглухо. А в Delphi все отлично и быстро работало

Обновили продукты в онлайн магазине. http://store.embarcadero.ru/catalog/rubric/24 Итого чтобы обновить мою Delphi XE8 до "Delphi 10.1 Berlin Professional"+"Mobile Add-On Pack к Delphi 10.1 Berlin Professional" нужно заплатить 85038,22 рублей. Кажется наем фрилансеров для реализации моих хотелок обойдется дешевле. К торрент версии душа не лежит. Буду и дальше сидеть на XE8, подожду "Delphi 10.8 Bangladesh Professional" с компилятором для Linux и Intel Atom, полноценными сервисами InAppBilling, полной реализацией работы с сенсорами и надеюсь множеством других доделок.