File perl-Tk-XPM-loading-improve-error-message-for-s... of Package perl-Tk

Overview Repositories Revisions Requests Users Attributes Meta

File perl-Tk-XPM-loading-improve-error-message-for-short-files.patch of Package perl-Tk

From 25c1da9e613890e824d6a5c51b07131d3f257f94 Mon Sep 17 00:00:00 2001
From: Slaven Rezic <slaven@rezic.de>
Date: Sat, 2 Feb 2019 14:59:46 +0100
Subject: [PATCH 2/3] XPM loading: improve error message for short files

---
 pTk/mTk/additions/imgXPM.c |  3 +++
 t/photo.t                  | 20 +++++++++++++++++++-
 2 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/pTk/mTk/additions/imgXPM.c b/pTk/mTk/additions/imgXPM.c
index 421b17d7..93af045e 100644
--- a/pTk/mTk/additions/imgXPM.c
+++ b/pTk/mTk/additions/imgXPM.c
@@ -440,6 +440,9 @@ CommonReadXPM(interp, handle, format, imageHandle, destX, destY,
 	while (((p = strchr(p,'\"')) == NULL)) {
 	    p = Gets(handle, buffer,MAX_BUFFER);
 	    if (p == NULL) {
+		sprintf(buffer, "%d", h);
+		Tcl_AppendResult(interp, "XPM image file is truncated; still ", buffer, " line(s) need to be read",
+				 (char *) NULL);
 		return TCL_ERROR;
 	    }
 	    p = buffer;
diff --git a/t/photo.t b/t/photo.t
index 8d4c2a51..059b38a6 100644
--- a/t/photo.t
+++ b/t/photo.t
@@ -15,7 +15,7 @@ $numFormats++ unless $@;
 my $mw  = MainWindow->new();
 $mw->geometry('+100+100');
 
-plan tests => (2*(7 * $numFormats) + 2 + 2 + 1 + 2 + 2);
+plan tests => (2*(7 * $numFormats) + 2 + 2 + 1 + 2 + 2 + 2);
 
 my @files = ();
 
@@ -148,6 +148,24 @@ EOF
     ok $image, "'/*' in XPM data caused no problem";
 }
 
+{
+    # Error case: short read
+    my $image = eval { $mw->Photo(-data => <<'EOF') };
+/* XPM */
+static char *noname[] = {
+/* width height ncolors chars_per_pixel */
+"2 2 2 1",
+/* colors */
+"  c #000000",
+". c #914800",
+/* pixels */
+".."
+};
+EOF
+    like $@, qr{^\QXPM image file is truncated; still 1 line(s) need to be read}, 'Expected error message about truncation';
+    ok !$image, "Truncated image was not created";
+}
+
 $mw->after(2500,[destroy => $mw]);
 MainLoop;
 
-- 
2.21.0

Places

File perl-Tk-XPM-loading-improve-error-message-for-short-files.patch of Package perl-Tk

Places