PDL::IO::Dumper - data dumping for structs with PDLs

  use PDL::IO::Dumper;
  $s = sdump(<VAR>);
  ...
  <VAR> = eval $s;

  use PDL::IO::Dumper;
  fdump(<VAR>,$filename);
  ...
  <VAR> = frestore($filename);

  use PDL::IO::Dumper;
  fdump(<VAR>,$filename);
  ...
  <VAR> = frestore($filename);

# use PDL::NiceSlice;

package PDL::IO::Dumper;
use File::Temp;


BEGIN{
  use Exporter ();

  package PDL::IO::Dumper;

  $PDL::IO::Dumper::VERSION = '1.3.2';
  
  @PDL::IO::Dumper::ISA = ( Exporter ) ;
  @PDL::IO::Dumper::EXPORT_OK = qw( fdump sdump frestore deep_copy);
  @PDL::IO::Dumper::EXPORT = @EXPORT_OK;
  %PDL::IO::Dumper::EXPORT_TAGS = ( Func=>[@EXPORT_OK]);

  eval "use Convert::UU;";
  $PDL::IO::Dumper::convert_ok = !$@;

  my $checkprog = sub {
      my($prog) = $_[0];
      my $pathsep = $^O =~ /win32/i ? ';' : ':';
      my $exe = $^O =~ /win32/i ? '.exe' : '';
      for(split $pathsep,$ENV{PATH}){return 1 if -x "$_/$prog$exe"}
      return 0;
  };
  # make sure not to use uuencode/uudecode
  # on MSWin32 systems (it doesn't work)
  # Force Convert::UU for BSD systems to see if that fixes uudecode problem
  if ($^O !~ /(MSWin32|bsd)$/) {
     $PDL::IO::Dumper::uudecode_ok = &$checkprog('uudecode') and &$checkprog('uuencode') and ($^O !~ /MSWin32/);
  }

  use PDL;
  use PDL::Exporter;
  use PDL::Config;
  use Data::Dumper 2.121;
  use Carp;
  use IO::File;
}

######################################################################

sub PDL::IO::Dumper::sdump {
# Make an initial dump...
  my($s) = Data::Dumper->Dump([@_]);
  my(%pdls);
# Find the bless(...,'PDL') lines
  while($s =~ s/bless\( do\{\\\(my \$o \= '?(-?\d+)'?\)\}\, \'PDL\' \)/sprintf('$PDL_%u',$1)/e) {
    $pdls{$1}++;
  }

## Check for duplicates -- a weak proxy for recursion...
  my($v);
  my($dups);
  foreach $v(keys %pdls) {
    $dups++ if($pdls{$v} >1);
  }
  print STDERR "Warning: duplicated PDL ref.  If sdump hangs, you have a circular reference.\n"  if($dups);

  # This next is broken into two parts to ensure $s is evaluated *after* the 
  # find_PDLs call (which modifies $s using the s/// operator).

  my($s2) =  "{my(\$VAR1);\n".&PDL::IO::Dumper::find_PDLs(\$s,@_)."\n\n";
  return $s2.$s."\n}";

#
}

######################################################################

sub PDL::IO::Dumper::fdump { 
  my($struct,$file) = @_;
  my $fh = IO::File->new( ">$file" );
  unless ( defined $fh ) {
      Carp::cluck ("fdump: couldn't open '$file'\n");
      return undef;
  }
  $fh->print( "####################\n## PDL::IO::Dumper dump file -- eval this in perl/PDL.\n\n" );
  $fh->print( sdump($struct) );
  $fh->close();
  return $struct;
}

######################################################################

sub PDL::IO::Dumper::frestore {
  local($_);
  my($fname) = shift;

  my $fh = IO::File->new( "<$fname" );
  unless ( defined $fh ) {
    Carp::cluck("frestore:  couldn't open '$file'\n");
    return undef;
  }

  my($file) = join("",<$fh>);
  
  $fh->close;

  return eval $file;
}

######################################################################

sub PDL::IO::Dumper::deep_copy {
  return eval sdump @_;
}

######################################################################

$PDL::IO::Dumper::small_thresh = 8;   # Smaller than this gets inlined
$PDL::IO::Dumper::med_thresh   = 400; # Smaller than this gets eval'ed
                                      # Any bigger gets uuencoded

sub PDL::IO::Dumper::big_PDL {
  my($a) = shift;
  
  return 0 
    if($a->nelem <= $PDL::IO::Dumper::small_thresh 
       && !(keys %{$a->hdr()})
       );
  
  return 1
    if($a->nelem <= $PDL::IO::Dumper::med_thresh
       && ( !( ( (tied %{$a->hdr()}) || '' ) =~ m/^Astro::FITS::Header\=/)  )
       );

  return 2;
}

######################################################################

%PDL::IO::Dumper::stringify_formats = (
   "byte"=>"%d",
   "short"=>"%d",
   "long"=>"%d",
   "float"=>"%.6g",
   "double"=>"%.16g"
  );


sub PDL::IO::Dumper::stringify_PDL{
  my($pdl) = shift;
  
  if(!ref $pdl) {
    confess "PDL::IO::Dumper::stringify -- got a non-pdl value!\n";
    die;
  }

  ## Special case: empty PDL
  if($pdl->nelem == 0) {
    return "which(pdl(0))";
  }

  ## Normal case:  Figure out how to dump each number and dump them 
  ## in sequence as ASCII strings...

  my($pdlflat) = $pdl->flat;
  my($t) = $pdl->type;

  my($s);
  my(@s);
  my($dmp_elt);

  if(defined $PDL::IO::Dumper::stringify_formats{$t}) {
    $dmp_elt = eval "sub { sprintf '$PDL::IO::Dumper::stringify_formats{$t}',shift }";
  } else {
    if(!$PDL::IO::Dumper::stringify_warned) {
      print STDERR "PDL::IO::Dumper:  Warning, stringifying a '$t' PDL using default method\n\t(Will be silent after this)\n";
      $PDL::IO::Dumper::stringify_warned = 1;
    }
    $dmp_elt = sub { my($a) = shift; "$a"; };
  }
  $i = 0;

  my($i);
  for($i = 0; $i < $pdl->nelem; $i++) {
    push(@s, &{$dmp_elt}( $pdlflat->slice("($i)") )  );
  }

 
  ## Assemble all the strings and bracket with a pdl() call.
  
  $s = ($PDL::IO::Dumper::stringify_formats{$t}?$t:'pdl').
       "(" . join(   "," , @s  ) .   ")".
       (($_->getndims > 1) && ("->reshape(" . join(",",$pdl->dims) . ")"));

  return $s;
}


######################################################################

# should we use OS/library-level routines for creating
# a temporary filename?
#
sub _make_tmpname () {
    # should we use File::Spec routines to create the file name?
    return File::Temp::tmpnam() . ".fits";
}

# For uudecode_PDL:
#
# uudecode on OS-X needs the -s option otherwise it strips off the
# path of the data file - which messes things up. We could change the
# logic so that we explicitly tell uudecode where to create the output
# file, except that this is also OS-dependent (-o <filename> on OS-X/linux,
# -p on solaris/OS-X to write to stdout, any others?),
# so we go this way for now as it is less-likely to break things
#
my $uudecode_string = "|uudecode";
$uudecode_string .= " -s" if $^O =~ m/darwin|((free|open)bsd)|dragonfly/;

sub PDL::IO::Dumper::uudecode_PDL {
    my $lines = shift;
    my $out;
    my $fname = _make_tmpname();
    if($PDL::IO::Dumper::uudecode_ok) {
	my $fh = IO::File->new( $uudecode_string );
	$lines =~ s/^[^\n]*\n/begin 664 $fname\n/o;
	$fh->print( $lines );
	$fh->close;
    }
    elsif($PDL::IO::Dumper::convert_ok) {
	my $fh = IO::File->new(">$fname");
	my $fits = Convert::UU::uudecode($lines);
	$fh->print( $fits );
	$fh->close();
    } else {
      barf("Need either uudecode(1) or Convert::UU to decode dumped PDL.\n");
  }

  $out = rfits($fname);
  unlink($fname);

  $out;
}
 

sub PDL::IO::Dumper::dump_PDL {
  local($_) = shift;
  my($pdlid) = @_;
  my(@out);

  my($style) = &PDL::IO::Dumper::big_PDL($_);

  if($style==0) {
    @out = ("", "( ". &PDL::IO::Dumper::stringify_PDL($_). " )");
  }

  else {
    my(@s);

    ## midsized case
    if($style==1){
      @s = ("my(\$$pdlid) = (",
	    &PDL::IO::Dumper::stringify_PDL($_),
	    ");\n");
    }

    ## huge case
    else { 
      
      ##
      ## Write FITS file, uuencode it, snarf it up, and clean up the
      ## temporary directory
      ##
      my $fname = _make_tmpname();
      wfits($_,$fname);
      my(@uulines);

      if($PDL::IO::Dumper::uudecode_ok) {
	  my $fh = IO::File->new( "uuencode $fname $fname |" );
	  @uulines = <$fh>;
	  $fh->close;
    } elsif($PDL::IO::Dumper::convert_ok) {
	# Convert::UU::uuencode does not accept IO::File handles
        # (at least in version 0.52 of the module)
	#
	open(FITSFILE,"<$fname");
	@uulines = ( Convert::UU::uuencode(*FITSFILE) );
    } else {
	barf("dump_PDL: Requires either uuencode or Convert:UU");
    }
      unlink $fname;
      
      ## 
      ## Generate commands to uudecode the FITS file and resnarf it
      ##
      @s = ("my(\$$pdlid) = PDL::IO::Dumper::uudecode_PDL(<<'DuMPERFILE'\n",
	    @uulines,
	    "\nDuMPERFILE\n);\n",
	    "\$$pdlid->hdrcpy(".$_->hdrcpy().");\n"
	    );

      ##
      ## Unfortunately, FITS format mangles headers (and gives us one
      ## even if we don't want it).  Delete the FITS header if we don't
      ## want one.  
      ##
      if( !scalar(keys %{$_->hdr()}) ) {
	push(@s,"\$$pdlid->sethdr(undef);\n");
      }
    }

    ## 
    ## Generate commands to reconstitute the header
    ## information in the PDL -- common to midsized and huge case.
    ##
    ## We normally want to reconstitute, because FITS headers mangle
    ## arbitrary hashes and we can reconsitute efficiently with a private 
    ## sdump().  The one known exception to this is when there's a FITS
    ## header object (Astro::FITS::Header) tied to the original 
    ## PDL's header.  Other types of tied object will get handled just
    ## like normal hashes.
    ##
    ## Ultimately, Data::Dumper will get fixed to handle tied objects, 
    ## and this kludge will go away.
    ## 

    if( scalar(keys %{$_->hdr()}) ) {
      if( ((tied %{$_->hdr()}) || '') =~ m/Astro::FITS::Header\=/) {
	push(@s,"# (Header restored from FITS file)\n");
      } else {
	push(@s,"\$$pdlid->sethdr( eval <<'EndOfHeader_${pdlid}'\n",
	     &PDL::IO::Dumper::sdump($_->hdr()),
	     "\nEndOfHeader_${pdlid}\n);\n",
	     "\$$pdlid->hdrcpy(".$_->hdrcpy().");\n"
	     );
      }
    }
    
    @out = (join("",@s), undef);
  }

  return @out;
}
  
######################################################################

sub PDL::IO::Dumper::find_PDLs {
  local($_);
  my($out)="";
  my($sp) = shift;

  findpdl:foreach $_(@_) {
    next findpdl unless ref($_);

    if(UNIVERSAL::isa($_,'ARRAY')) {
      my($a);
      foreach $a(@{$_}) {
	$out .= find_PDLs($sp,$a);
      }
    } 
    elsif(UNIVERSAL::isa($_,'HASH')) {
      my($a);
      foreach $a(values %{$_}) {
	$out .= find_PDLs($sp,$a)
	}
    } elsif(UNIVERSAL::isa($_,'PDL')) {

      # In addition to straight PDLs, 
      # this gets subclasses of PDL, but NOT magic-hash subclasses of
      # PDL (because they'd be gotten by the previous clause).
      # So if you subclass PDL but your actual data structure is still
      # just a straight PDL (and not a hash with PDL field), you end up here.
      #

      my($pdlid) = sprintf('PDL_%u',$$_);
      my(@strings) = &PDL::IO::Dumper::dump_PDL($_,$pdlid);
      
      $out .= $strings[0];
      $$sp =~ s/\$$pdlid/$strings[1]/g if(defined($strings[1]));  
    }
    elsif(UNIVERSAL::isa($_,'SCALAR')) {
      # This gets other kinds of refs -- PDLs have already been gotten.
      # Naked PDLs are themselves SCALARs, so the SCALAR case has to come 
      # last to let the PDL case run.
      $out .= find_PDLs( $sp, ${$_} );
    }
  
  }
  return $out;
}
      
1;