Here's a patch against Tk804.027 which adds binary data support, but for GIF only. The patch includes additional tests in the t/photo.t file.
I found that the internal Tk image handling code is already binary-ready, at least for the GIF format. Unfortunately Perl/Tk converts every string into a utf8-flagged string, which means that the data has again to be converted back to bytes before handing to the image handling code, which consumes space and time. It seems to be non-trivial to avoid these unnecessary conversions.
--- t/photo.t (revision 1365)
+++ t/photo.t (revision 1367)
@@ -14,7 +14,7 @@ $numFormats++ unless $@;
my $mw = MainWindow->new();
$mw->geometry('+100+100');
-plan tests => (2*(7 * $numFormats) + 2);
+plan tests => (2*(7 * $numFormats) + 2 + 2);
my @files = ();
@@ -81,6 +81,38 @@ foreach my $leaf('Tk.xbm','Xcamel.gif')
}
$row += 3;
}
+
+# Extra tests
+my $col = 0;
+$mw->Label(-text => "Extra tests")->grid(-row => $row++, -column => $
+col);
+my $file = Tk->findINC('Xcamel.gif');
+my $data = do { open my $fh, $file or die $!; local $/; <$fh> };
+
+if ($Tk::VERSION <= 804.027)
+ {
+ skip("Binary GIF data not supported",1,1);
+ }
+else
+ {
+ my $image = $mw->Photo(-data => $data);
+ ok(defined $image, 1, "Read binary GIF data");
+ $mw->Label(-background => 'white', -image => $image)->grid(-row =>
+$row, -column => $col);
+ $mw->update;
+ }
+$col++;
+
+if (!eval { require MIME::Base64; 1 })
+ {
+ skip("Need MIME::Base64 module",1,1);
+ }
+else
+ {
+ my $image = $mw->Photo(-data => MIME::Base64::encode_base64($data))
+;
+ ok(defined $image, 1, "Read base64 encoded GIF data");
+ $mw->Label(-background => 'white', -image => $image)->grid(-row =>
+$row, -column => $col);
+ $mw->update;
+ }
+$col++;
$mw->after(2500,[destroy => $mw]);
MainLoop;
--- objGlue.c (revision 1365)
+++ objGlue.c (revision 1367)
@@ -584,7 +584,17 @@ Tcl_GetByteArrayFromObj(Tcl_Obj * objPtr
/* FIXME: presumably should downgrade from UTF-8,
what frees it ?
*/
- return (unsigned char *) Tcl_GetStringFromObj (objPtr, lengthPtr);
+ /* SRT: Is this correct? */
+ sv_utf8_downgrade(objPtr, 0);
+ if (lengthPtr)
+ {
+ return (unsigned char *) SvPV(objPtr, *lengthPtr);
+ }
+ else
+ {
+ return (unsigned char *) SvPV(objPtr, PL_na);
+ }
+/* return (unsigned char *) Tcl_GetStringFromObj (objPtr, lengthPtr);
+ */
}
|