view release on metacpan or  search on metacpan

iis.pd  view on Meta::CPAN

# Try a few obvious places for the FIFO pipe and create if necessary

sub findfifo {
    $fifi = ""; $fifo = "";
    if (-e "/dev/imt1i" && -e "/dev/imt1o") {
       $fifi = "/dev/imt1i"; $fifo = "/dev/imt1o";
    }
    if (-e "$HOME/dev/imt1i" && -e "$HOME/dev/imt1o") {
       $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o";
    }
    if (-e "$HOME/iraf/dev/imt1i" && -e "$HOME/iraf/dev/imt1o") {
       $fifi = "$HOME/iraf/dev/imt1i"; $fifo = "$HOME/iraf/dev/imt1o";
    }
    if (defined $ENV{'IMTDEV'} && $ENV{'IMTDEV'} =~ /^fifo:(.*):(.*)$/) {
       $fifi = $1; $fifo = $2;
   }
   if ($fifi eq "" && $fifo eq "") { # Still not found use this default
       warn "WARNING: cannot locate FIFO pipes in /dev/, $HOME/dev, ".
           "$HOME/iraf/dev or environment variable \$IMTDEV\n";
       $fifi = "$HOME/dev/imt1i"; $fifo = "$HOME/dev/imt1o";
   }
   print "Using FIFO devices in:  $fifi\n".
         "                   out: $fifo\n" if $PDL::verbose;
   for $pipe ($fifi, $fifo) {
      if (!-p $pipe) {
         print "FIFO $pipe does not exist - try and create now? "; my $ans = <STDIN>;
         system "/usr/etc/mknod $pipe p" if $ans =~ /^y/i;

         if ($ans =~ /^y/i) {
            unlink $pipe if -e $pipe;
            my $path = $ENV{PATH};
            $ENV{PATH} .= ":/etc:/usr/etc";

            # Note system return value is backwards - hence 'and'

            if ( system('mknod', $pipe, 'p') and system('mkfifo',$pipe) ) {
                die "Failed to create named pipe $pipe\n";
            }
            $ENV{PATH} = $path;
         }
      }
   }
1;}


ENDOFPM

################################ XS CODE ######################################

pp_addhdr(<<"EOD");
#include "libiis.h"
EOD

pp_addxs('',<<'EOD');

MODULE = PDL::Graphics::IIS PACKAGE = PDL::Graphics::IIS

void
_iiscur_int()
   PPCODE:
    float x,y;
    char ch;
    int   frame       = (int)SvIV( perl_get_sv("iisframe", FALSE) );

    iis_open(SvPV_nolen(perl_get_sv("fifi",FALSE)),SvPV_nolen(perl_get_sv("fifo",FALSE)),
       (int)SvIV( perl_get_sv("fbconfig", FALSE) ),
       (int)SvIV( perl_get_sv("fb_x", FALSE) ),
       (int)SvIV( perl_get_sv("fb_y", FALSE) ) );
    iis_cur(&x,&y,&ch);
    iis_close();

    EXTEND(sp,3);
    PUSHs(sv_2mortal(newSVnv((float)x)));
    PUSHs(sv_2mortal(newSVnv((float)y)));
    PUSHs(sv_2mortal(newSVpv(&ch,1)));


EOD

# Internal routine for iis()

pp_bless('PDL::Graphics::IIS');

pp_def('_iis',
        Pars => 'image(m,n); min(); max();',
        OtherPars => 'char *perl_title',
	Doc  => undef,
        Code => '

   int   frame = (int)SvIV( perl_get_sv("iisframe", FALSE) );
   unsigned short hdr[8];
   unsigned char *data;
   int j,nlines, x,y, offx, offy, nx, ny, nx2, ny2, baseX, baseY, m1, n1;
   int ntrans;
   float xx, yx, xy, yy, xo, yo; int w_type; /* WCS */
   float fmin, fmax;
   char wcsbuf[SZ_WCSTEXT];
   char title[33];  /* 32 chars + null terminator */
   int chan;

   /* Open pipes etc */

   if (frame<1 || frame>4)
       $CROAK("$iisframe must be in range 1--4");

    iis_open(SvPV_nolen(perl_get_sv("fifi",FALSE)),SvPV_nolen(perl_get_sv("fifo",FALSE)),
       (int)SvIV( perl_get_sv("fbconfig", FALSE) ),
       (int)SvIV( perl_get_sv("fb_x", FALSE) ),
       (int)SvIV( perl_get_sv("fb_y", FALSE) ) );

   /* Convenience variables */

   nx = $SIZE(m);
   ny = $SIZE(n);
   fmin = (float) $min();
   fmax = (float) $max();

   chan = iis_chan(frame);

   /* Work out how many lines to transfer at a go */