LCL: raise exception if bitmap is not completely written to disk (bug #8260)

git-svn-id: trunk@11392 -

lcl/graphics.pp

@@ -34,8 +34,9 @@ interface
 
 uses
   SysUtils, Math, Types, Classes, Contnrs, FPCAdds,
-  FPImage, FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, FPReadPNM, FPWritePNM,
+  FPImgCmn, FPImage, FPCanvas,
-  IntfGraphics, FPCanvas,
+  FPReadPNG, FPWritePNG, FPReadBMP, FPWriteBMP, FPReadPNM, FPWritePNM,
+  IntfGraphics,
   AvgLvlTree,
   LCLStrConsts, LCLType, LCLProc, LMessages, LCLIntf, LResources, LCLResCache,
   GraphType, GraphMath, InterfaceBase;

lcl/include/bitmap.inc

@@ -814,12 +814,16 @@ procedure TBitmap.WriteStreamWithFPImage(Stream: TStream; WriteSize: boolean;
   end;
 
   procedure DoWriteOriginal;
+  var
+    BytesWritten: Int64;
   begin
     DoWriteStreamSize(Stream, NtoLE(LongInt(FImage.SaveStream.Size)));
     FImage.SaveStream.Position:=0;
     if Stream is TMemoryStream then
       TMemoryStream(Stream).SetSize(Stream.Position+FImage.SaveStream.Size);
-    Stream.CopyFrom(FImage.SaveStream,FImage.SaveStream.Size);
+    BytesWritten:=Stream.CopyFrom(FImage.SaveStream,FImage.SaveStream.Size);
+    if BytesWritten<>FImage.SaveStream.Size then
+      raise FPImageException.Create(rsErrorWhileSavingBitmap);
   end;
 
 var

lcl/include/lclintf.inc

@@ -482,22 +482,22 @@ end;
 
 procedure NotifyUser(const DialogMessage : String; DialogType : longint);
 begin
-  PromptUser(DialogMessage, DialogType, [idButtonOK], -1, -1);
+  PromptUser(DialogMessage, DialogType, [idButtonOK], 0, -1);
 end;
 
 procedure NotifyUser(const DialogCaption, DialogMessage : String; DialogType : longint);
 begin
-  PromptUser(DialogCaption, DialogMessage, DialogType, [idButtonOK], -1, -1);
+  PromptUser(DialogCaption, DialogMessage, DialogType, [idButtonOK], 0, -1);
 end;
 
 procedure NotifyUserAtXY(const DialogMessage : String; DialogType : longint; X, Y : Longint);
 begin
-  PromptUserAtXY(DialogMessage, DialogType, [idButtonOK], -1, -1, X, Y);
+  PromptUserAtXY(DialogMessage, DialogType, [idButtonOK], 0, -1, X, Y);
 end;
 
 procedure NotifyUserAtXY(const DialogCaption, DialogMessage : String; DialogType : longint; X, Y : Longint);
 begin
-  PromptUserAtXY(DialogCaption, DialogMessage, DialogType, [idButtonOK], -1, -1, X, Y);
+  PromptUserAtXY(DialogCaption, DialogMessage, DialogType, [idButtonOK], 0, -1, X, Y);
 end;
 
 function PromptUser(const DialogMessage : String; DialogType : longint; Buttons : Array of Longint;

lcl/languages/lclstrconsts.ca.po

@@ -289,6 +289,10 @@ msgstr ""
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr ""

lcl/languages/lclstrconsts.de.po

@@ -292,6 +292,10 @@ msgstr "Fehler beim Lesen %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "Fehler beim Ausführen von %s%s%s:%s%s"
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Fehler:"

lcl/languages/lclstrconsts.es.po

@@ -288,6 +288,10 @@ msgstr "Error leyendo %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Error:"

lcl/languages/lclstrconsts.fi.po

@@ -278,6 +278,10 @@ msgstr ""
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Virhe:"

lcl/languages/lclstrconsts.fr.po

@@ -290,6 +290,10 @@ msgstr "Erreur de lecture %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "Erreur en exécutant %s%s%s:%s%s"
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Erreur:"

lcl/languages/lclstrconsts.id.po

@@ -291,6 +291,10 @@ msgstr "Kesalahan pembacaan %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "Kesalahan saat mengeksekusi %s%s%s:%s%s"
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Kesalahan:"

lcl/languages/lclstrconsts.it.po

@@ -288,6 +288,10 @@ msgstr "Errore nella lettura di %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "Errore eseguendo %s%s%s:%s%s"
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Errore:"

lcl/languages/lclstrconsts.nl.po

@@ -278,6 +278,10 @@ msgstr "Fout tijdens het lezen %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Fout:"

lcl/languages/lclstrconsts.pb.po

@@ -278,6 +278,10 @@ msgstr "Erro na leitura %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "Erro ao executar %s%s%s:%s%s"
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Erro:"

lcl/languages/lclstrconsts.pl.po

@@ -293,6 +293,10 @@ msgstr "Błąd odczytu %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Błąd:"

lcl/languages/lclstrconsts.pliso.po

@@ -289,6 +289,10 @@ msgstr "B
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "B³±d:"

lcl/languages/lclstrconsts.plwin.po

@@ -289,6 +289,10 @@ msgstr "B
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "B³¹d:"

lcl/languages/lclstrconsts.po

@@ -278,6 +278,10 @@ msgstr ""
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr ""

lcl/languages/lclstrconsts.ru.po

@@ -289,6 +289,10 @@ msgstr "Ошибка чтения %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "Ошибка при выполнении %s%s%s:%s%s"
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Ошибка:"

lcl/languages/lclstrconsts.ua.po

@@ -278,6 +278,10 @@ msgstr "Помилка читання %s%s%s: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr ""
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "Помилка:"

lcl/languages/lclstrconsts.zh-cn.po

@@ -291,6 +291,10 @@ msgstr "读取 %s%s%s 错误: %s"
 msgid "Error while executing %s%s%s:%s%s"
 msgstr "当执行 %s%s%s 时错误:%s%s "
 
+#: lclstrconsts:rserrorwhilesavingbitmap
+msgid "Error while saving bitmap."
+msgstr ""
+
 #: lclstrconsts:rswin32error
 msgid "Error:"
 msgstr "错误:"

lcl/lclstrconsts.pas

@@ -184,6 +184,7 @@ ResourceString
   rsIsAlreadyAssociatedWith = '%s is already associated with %s';
   rsCanvasDoesNotAllowDrawing = 'Canvas does not allow drawing';
   rsUnsupportedBitmapFormat = 'Unsupported bitmap format.';
+  rsErrorWhileSavingBitmap = 'Error while saving bitmap.';
   rsNoWidgetSet = 'No widgetset object. '
     +'Plz check if the unit "interfaces" was added to the programs uses clause.';
   rsPressOkToIgnoreAndRiskDataCorruptionPressCancelToK = '%s%sPress Ok to '