From 2478ad9e6b540a6ce0d91765b1ac21c7401a838a Mon Sep 17 00:00:00 2001
From: Ed J <mohawk2@users.noreply.github.com>
Date: Fri, 27 Sep 2024 03:41:55 +0000
Subject: [PATCH] IO::Pic use IO::GD for JPEG if available

---
 Changes              |  1 +
 IO/Pnm/Pic.pm        | 47 +++++++++++++++++++++++++++++---------------
 IO/Pnm/t/pic_16bit.t | 16 +++++++++------
 3 files changed, 42 insertions(+), 22 deletions(-)

diff --git a/Changes b/Changes
index 055e1e28c..3e4699fa6 100644
--- a/Changes
+++ b/Changes
@@ -9,6 +9,7 @@
 - remove t_raster2float
 - IO::GD add OO to_rpic for ndarrays (3,x,y) if truecolour, y=0 at bottom, like rpic
 - IO::GD stop read_true_png segfaulting with non-true PNG
+- IO::Pic use IO::GD for JPEG if available, helps Windows with no NetPBM
 
 2.092 2024-09-07
 - add Type::howbig
diff --git a/IO/Pnm/Pic.pm b/IO/Pnm/Pic.pm
index b84bb7cb1..efa4f4657 100644
--- a/IO/Pnm/Pic.pm
+++ b/IO/Pnm/Pic.pm
@@ -87,6 +87,20 @@ sub init_converter_table {
   $Dflags = '';
   %converter = ();
 
+  if (eval {require PDL::IO::GD; 1}) {
+    $converter{JPEG} = {referral => {
+      put => sub {
+        my $pdl = $_[0];
+        $pdl = $pdl->mv(0,-1) if $pdl->ndims > 2 && $pdl->dim(0) == 3;
+        PDL::IO::GD->new(pdl=>$pdl->slice(',-1:0'))->write_Jpeg($_[1], -1);
+      },
+      get => sub {
+        my $pdl = PDL::IO::GD->new($_[1])->to_rpic;
+        $pdl->diff2->zcheck ? $pdl->slice('(0)')->sever : $pdl; # greyscale
+      },
+    }};
+  }
+
   # Pbmplus systems have cjpeg/djpeg; netpbm systems have pnmtojpeg and
   # jpegtopnm.
   $converter{$_} = {put => "pnmto\L$_", get => "\L${_}topnm"}
@@ -217,21 +231,22 @@ sub PDL::rpic {
     }
 
     $hints = { iparse $rpicopts, $hints } if ref $hints;
-    if (defined($$hints{'FORMAT'})) {
-	$type = $$hints{'FORMAT'};
+    if (defined($$hints{FORMAT})) {
+	$type = $$hints{FORMAT};
         barf "unsupported (input) image format"
-	    unless (exists($converter{$type}) &&
-		    $converter{$type}->{'get'} !~ /NA/);
-      }
-    else {
+          unless exists($converter{$type}) && (
+            ($converter{$type}{referral} && $converter{$type}{referral}{get}) ||
+            $converter{$type}{get} !~ /NA/);
+    } else {
 	$type = chkform($file);
 	barf "can't figure out file type, specify explicitly"
-	    if $type =~ /UNKNOWN/; }
+	    if $type =~ /UNKNOWN/;
+    }
 
     my($converter) = $PDL::IO::Pic::converter;
-    if (defined($converter{$type}->{referral})) {
-      if(ref ($converter{$type}->{referral}->{'get'}) eq 'CODE') {
-	return &{$converter{$type}->{referral}->{'get'}}(@_);
+    if (defined($converter{$type}{referral})) {
+      if(ref ($converter{$type}{referral}{get}) eq 'CODE') {
+	return &{$converter{$type}{referral}{get}}(@_);
       } else {
 	barf "rpic: internal error with referral (format is $type)\n";
       }
@@ -849,16 +864,16 @@ sub getconv {
     if (defined($$hints{'FORMAT'})) {
 	$type = $$hints{'FORMAT'};
         barf "unsupported (output) image format"
-	    unless (exists($converter{$type})
-	      && $converter{$type}->{'put'} !~ /NA/);
-      }
-    else {
+          unless exists($converter{$type}) && (
+            ($converter{$type}{referral} && $converter{$type}{referral}{put}) ||
+            $converter{$type}{put} !~ /NA/);
+    } else {
 	$type = chkext(getext($file),1);
 	if ($type =~ /UNKNOWN/) {
 	    barf "can't figure out desired file type, using PNM" ;
 	    $type = 'PNM';
-	  }
-      }
+	}
+    }
 
     my $conv = $converter{$type}->{'put'};
 
diff --git a/IO/Pnm/t/pic_16bit.t b/IO/Pnm/t/pic_16bit.t
index 2d137e0c7..ed3ded345 100644
--- a/IO/Pnm/t/pic_16bit.t
+++ b/IO/Pnm/t/pic_16bit.t
@@ -13,26 +13,30 @@ $PDL::IO::Pic::debug=20;
 my $tmpdir = tempdir( CLEANUP => 1 );
 
 sub roundtrip {
-  my ($in, $file, $label, @extra) = @_;
+  local $Test::Builder::Level = $Test::Builder::Level + 1;
+  my ($in, $file, $label, $dimonly, @extra) = @_;
   $file = File::Spec->catfile($tmpdir, $file);
   $in->wpic($file);
   my $got = rpic($file, @extra);
-  ok all($in == $got), "$label image save+restore";
+  return is_deeply [$got->dims], [$in->dims] if $dimonly;
+  eval {ok all($in == $got), "$label image save+restore"};
+  is $@, '', "$label compare worked";
 }
 
 # test save/restore of 8-bit image
 roundtrip(my $x = sequence(16,16), 'byte_a.pnm', 'pnm byte');
 
-roundtrip($x, 'byte_a.png', 'png byte',
+roundtrip($x, 'byte_a.png', 'png byte', 0,
   $^O =~ /MSWin32/i ? {FORMAT => 'PNG'} : ()) if $can_png;
 
 # test save/restore of 16-bit image
-roundtrip(
-  my $a16 = sequence(256, 255)->ushort * 231,
+roundtrip(my $a16 = sequence(256, 255)->ushort * 231,
   'tushort_a16.pnm', 'pnm ushort',
 );
 
-roundtrip($a16, 'tushort_a16.png', 'png ushort',
+roundtrip($a16, 'tushort_a16.png', 'png ushort', 0,
   $^O =~ /MSWin32/i ? {FORMAT => 'PNG'} : ()) if $can_png;
 
+roundtrip(sequence(byte,3,32,24), 'byte_a.jpg', 'jpeg byte', 1, {FORMAT => 'JPEG'});
+
 done_testing;