"Fossies" - the Fresh Open Source Software Archive

Member "PDL-2.080/GENERATED/PDL/IO/Pnm.pm" (28 May 2022, 10541 Bytes) of package /linux/misc/PDL-2.080.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Pnm.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 2.079_vs_2.080.

    1 #
    2 # GENERATED WITH PDL::PP! Don't modify!
    3 #
    4 package PDL::IO::Pnm;
    5 
    6 our @EXPORT_OK = qw(rpnm wpnm pnminraw pnminascii pnmout );
    7 our %EXPORT_TAGS = (Func=>\@EXPORT_OK);
    8 
    9 use PDL::Core;
   10 use PDL::Exporter;
   11 use DynaLoader;
   12 
   13 
   14    
   15    our @ISA = ( 'PDL::Exporter','DynaLoader' );
   16    push @PDL::Core::PP, __PACKAGE__;
   17    bootstrap PDL::IO::Pnm ;
   18 
   19 
   20 
   21 
   22 
   23 
   24 #line 9 "pnm.pd"
   25 
   26 
   27 use strict;
   28 use warnings;
   29 
   30 =head1 NAME
   31 
   32 PDL::IO::Pnm -- pnm format I/O for PDL
   33 
   34 =head1 SYNOPSIS
   35 
   36   use PDL::IO::Pnm;
   37   $im = wpnm $pdl, $file, $format[, $raw];
   38   rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm";
   39 
   40 =head1 DESCRIPTION
   41 
   42 pnm I/O for PDL.
   43 
   44 =cut
   45 
   46 use PDL::Core qw/howbig convert/;
   47 use PDL::Types;
   48 use PDL::Basic;  # for max/min
   49 use PDL::IO::Misc;
   50 use Carp;
   51 use File::Temp qw( tempfile );
   52 
   53 # return the upper limit of data values an integer PDL data type
   54 # can hold
   55 sub dmax {
   56     my $type = shift;
   57     my $sz = 8*howbig($type);
   58     $sz-- if !PDL::Type->new($type)->unsigned;
   59     return ((1 << $sz)-1);
   60 }
   61 #line 62 "Pnm.pm"
   62 
   63 
   64 
   65 
   66 
   67 
   68 =head1 FUNCTIONS
   69 
   70 =cut
   71 
   72 
   73 
   74 
   75 #line 948 "../../blib/lib/PDL/PP.pm"
   76 
   77 
   78 
   79 =head2 pnminraw
   80 
   81 =for sig
   82 
   83   Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n;
   84             int isbin; PerlIO *fp)
   85 
   86 
   87 =for ref
   88 
   89 Read in a raw pnm file.
   90 
   91 read a raw pnm file. The C<type> argument is only there to
   92 determine the type of the operation when creating C<im> or trigger
   93 the appropriate type conversion (maybe we want a byte+ here so that
   94 C<im> follows I<strictly> the type of C<type>).
   95 
   96 
   97 =for bad
   98 
   99 pnminraw does not process bad values.
  100 It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays.
  101 
  102 
  103 =cut
  104 #line 105 "Pnm.pm"
  105 
  106 
  107 
  108 #line 950 "../../blib/lib/PDL/PP.pm"
  109 
  110 *pnminraw = \&PDL::pnminraw;
  111 #line 112 "Pnm.pm"
  112 
  113 
  114 
  115 #line 948 "../../blib/lib/PDL/PP.pm"
  116 
  117 
  118 
  119 =head2 pnminascii
  120 
  121 =for sig
  122 
  123   Signature: (type(); byte+ [o] im(m,n); int ms => m; int ns => n;
  124             int format; PerlIO *fp)
  125 
  126 
  127 =for ref
  128 
  129 Read in an ascii pnm file.
  130 
  131 
  132 =for bad
  133 
  134 pnminascii does not process bad values.
  135 It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays.
  136 
  137 
  138 =cut
  139 #line 140 "Pnm.pm"
  140 
  141 
  142 
  143 #line 950 "../../blib/lib/PDL/PP.pm"
  144 
  145 *pnminascii = \&PDL::pnminascii;
  146 #line 147 "Pnm.pm"
  147 
  148 
  149 
  150 #line 948 "../../blib/lib/PDL/PP.pm"
  151 
  152 
  153 
  154 =head2 pnmout
  155 
  156 =for sig
  157 
  158   Signature: (a(m); int israw; int isbin; PerlIO *fp)
  159 
  160 
  161 =for ref
  162 
  163 Write a line of pnm data.
  164 
  165 This function is implemented this way so that broadcasting works
  166 naturally.
  167 
  168 
  169 =for bad
  170 
  171 pnmout does not process bad values.
  172 It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays.
  173 
  174 
  175 =cut
  176 #line 177 "Pnm.pm"
  177 
  178 
  179 
  180 #line 950 "../../blib/lib/PDL/PP.pm"
  181 
  182 *pnmout = \&PDL::pnmout;
  183 #line 184 "Pnm.pm"
  184 
  185 
  186 
  187 
  188 
  189 #line 47 "pnm.pd"
  190 
  191 =head2 rpnm
  192 
  193 =for ref
  194 
  195 Read a pnm (portable bitmap/pixmap, pbm/ppm) file into an ndarray.
  196 
  197 =for usage
  198 
  199   Usage:  $im = rpnm $file;
  200 
  201 Reads a file (or open file-handle) in pnm format (ascii or raw) into a pdl (magic numbers P1-P6).
  202 Based on the input format it returns pdls with arrays of size (width,height)
  203 if binary or grey value data (pbm and pgm) or (3,width,height) if rgb
  204 data (ppm). This also means for a palette image that the distinction between
  205 an image and its lookup table is lost which can be a problem in cases (but can
  206 hardly be avoided when using netpbm/pbmplus).  Datatype is dependent
  207 on the maximum grey/color-component value (for raw and binary formats
  208 always PDL_B). rpnm tries to read chopped files by zero padding the
  209 missing data (well it currently doesn't, it barfs; I'll probably fix it
  210 when it becomes a problem for me ;). You can also read directly into an
  211 existing pdl that has to have the right size(!). This can come in handy
  212 when you want to read a sequence of images into a datacube.
  213 
  214 For details about the formats see appropriate manpages that come with the
  215 netpbm/pbmplus packages.
  216 
  217 =for example
  218 
  219   $stack = zeroes(byte,3,500,300,4);
  220   rpnm $stack->slice(':,:,:,(0)'),"PDL.ppm";
  221 
  222 reads an rgb image (that had better be of size (500,300)) into the
  223 first plane of a 3D RGB datacube (=4D pdl datacube). You can also do
  224 inplace transpose/inversion that way.
  225 
  226 =cut
  227 
  228 sub rpnm {PDL->rpnm(@_)}
  229 sub PDL::rpnm {
  230     barf 'Usage: $im = rpnm($file) or $im = $pdl->rpnm($file)'
  231        if !@_ || @_>3;
  232     my $pdl = ref($_[1]) && UNIVERSAL::isa($_[1], 'PDL')
  233       ? (splice @_, 0, 2)[1] : shift->initialize;
  234     my $file = shift;
  235 
  236     my $fh;
  237     if (ref $file) {
  238       $fh = $file;
  239     } else {
  240       open $fh, $file or barf "Can't open pnm file '$file': $!";
  241     }
  242     binmode $fh;
  243 
  244     read($fh,(my $magic),2);
  245     barf "Oops, this is not a PNM file" unless $magic =~ /P([1-6])/;
  246     my $magicno = $1;
  247     print "reading pnm file with magic $magic\n" if $PDL::debug>1;
  248 
  249     my $israw = $magicno > 3 ? 1 : 0;
  250     my $isrgb = ($magicno % 3) == 0;
  251     my $ispbm = ($magicno % 3) == 1;
  252     my ($params, @dims) = ($ispbm ? 2 : 3, 0, 0, $ispbm ? 1 : 0);
  253     # get the header information
  254     my $pgot = 0;
  255     while (($pgot<$params) && defined(my $line=<$fh>)) {
  256        $line =~ s/#.*$//;
  257     next if $line =~ /^\s*$/;    # just white space
  258     while ($line !~ /^\s*$/ && $pgot < $params) {
  259         if ($line =~ /\s*(\S+)(.*)$/) {
  260         $dims[$pgot++] = $1; $line = $2; }
  261         else {
  262         barf "no valid header info in pnm";}
  263     }
  264     }
  265     # the file ended prematurely
  266     barf "no valid header info in pnm" if $pgot < $params;
  267     barf "Dimensions must be > 0" if ($dims[0] <= 0) || ($dims[1] <= 0);
  268 
  269     my ($type) = grep $dims[2] <= dmax($_), $PDL_B,$PDL_US,$PDL_L;
  270     barf "rraw: data from ascii pnm file out of range" if !defined $type;
  271 
  272     my @Dims = @dims[0,1];
  273     $Dims[0] *= 3 if $isrgb;
  274     $pdl = $pdl->zeroes(PDL::Type->new($type),3,@dims[0,1])
  275       if $pdl->isnull and $isrgb;
  276     my $npdl = $isrgb ? $pdl->clump(2) : $pdl;
  277     if ($israw) {
  278        pnminraw (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1],
  279      $ispbm, $fh);
  280     } else {
  281        pnminascii (convert(pdl(0),$type), $npdl, $Dims[0], $Dims[1],
  282     $magicno, $fh);
  283     }
  284     print("loaded pnm file, $dims[0]x$dims[1], gmax: $dims[2]",
  285        $isrgb ? ", RGB data":"", $israw ? ", raw" : " ASCII"," data\n")
  286     if $PDL::debug;
  287 
  288     # need to byte swap for little endian platforms
  289     $pdl->type->bswap->($pdl) if !isbigendian() and $israw;
  290     return $pdl;
  291 }
  292 
  293 =head2 wpnm
  294 
  295 =for ref
  296 
  297 Write a pnm (portable bitmap/pixmap, pbm/ppm) file into a file or open file-handle.
  298 
  299 =for usage
  300 
  301   Usage:  $im = wpnm $pdl, $file, $format[, $raw];
  302 
  303 Writes data in a pdl into pnm format (ascii or raw) (magic numbers P1-P6).
  304 The $format is required (normally produced by B<wpic>) and routine just
  305 checks if data is compatible with that format. All conversions should
  306 already have been done. If possible, usage of B<wpic> is preferred. Currently
  307 RAW format is chosen if compliant with range of input data. Explicit control
  308 of ASCII/RAW is possible through the optional $raw argument. If RAW is
  309 set to zero it will enforce ASCII mode. Enforcing RAW is
  310 somewhat meaningless as the routine will always try to write RAW
  311 format if the data range allows (but maybe it should reduce to a RAW
  312 supported type when RAW == 'RAW'?). For details about the formats
  313 consult appropriate manpages that come with the netpbm/pbmplus
  314 packages.
  315 
  316 =cut
  317 
  318 my %type2base = (PBM => 1, PGM => 2, PPM => 3);
  319 *wpnm = \&PDL::wpnm;
  320 sub PDL::wpnm {
  321     barf ('Usage: wpnm($pdl,$filename,$format[,$raw]) ' .
  322        'or $pdl->wpnm($filename,$format[,$raw])') if $#_ < 2;
  323     my ($pdl,$file,$type,$raw) = @_;
  324     barf "wpnm: unknown format '$type'" if !exists $type2base{$type};
  325 
  326     # need to copy input arg since bswap[24] work inplace
  327     # might be better if the bswap calls detected if run in
  328     # void context
  329     my $swap_inplace = $pdl->is_inplace;
  330 
  331     # check the data
  332     my @Dims = $pdl->dims;
  333     barf "wpnm: expecting 3D (3,w,h) input"
  334     if ($type =~ /PPM/) && (($#Dims != 2) || ($Dims[0] != 3));
  335     barf "wpnm: expecting 2D (w,h) input"
  336     if ($type =~ /P[GB]M/) && ($#Dims != 1);
  337     barf "wpnm: user should convert float etc data to appropriate type"
  338     if !$pdl->type->integer;
  339     my $max = $pdl->max;
  340     barf "wpnm: expecting prescaled data (0-65535)"
  341     if $pdl->min < 0 or $max > 65535;
  342 
  343     # check for raw format
  344     my $israw =
  345       (defined($raw) && !$raw) ? 0 :
  346       (($pdl->get_datatype == $PDL_B) || ($pdl->get_datatype == $PDL_US) || ($type eq 'PBM')) ? 3 :
  347       0;
  348 
  349     my $magic = 'P' . ($type2base{$type} + $israw);
  350     my $isrgb = $type eq 'PPM';
  351 
  352     my $pref = ($file !~ /^\s*[|>]/) ? ">" : "";  # test for plain file name
  353     my ($already_open, $fh) = 0;
  354     if (ref $file) {
  355       $fh = $file, $already_open = 1;
  356     } else {
  357       open $fh, $pref . $file or barf "Can't open pnm file: $!";
  358     }
  359     binmode $fh;
  360 
  361     print "writing ". ($israw ? "raw" : "ascii") .
  362       "format with magic $magic, max=$max\n" if $PDL::debug;
  363     # write header
  364     print $fh "$magic\n";
  365     print $fh "$Dims[-2] $Dims[-1]\n";
  366     if ($type ne 'PBM') {   # fix maxval for raw output formats
  367        my $outmax = 0;
  368        if ($max < 256) {
  369           $outmax =   "255";
  370        } elsif ($max < 65536) {
  371           $outmax = "65535";
  372        } else {
  373           $outmax = $max;
  374        };
  375        print $fh "$outmax\n";
  376     };
  377 
  378     # if rgb clump first two dims together
  379     my $out = ($isrgb ? $pdl->slice(':,:,-1:0')->clump(2)
  380          : $pdl->slice(':,-1:0'));
  381     # handle byte swap issues for little endian platforms
  382     if (!isbigendian() and $israw) {
  383       $out = $out->copy unless $swap_inplace;
  384       $out->type->bswap->($out);
  385     }
  386     pnmout($out,$israw,$type eq "PBM",$fh);
  387     # check if our child returned an error (in case of a pipe)
  388     barf "wpnm: pbmconverter error: $!" if !$already_open and !close $fh;
  389 }
  390 
  391 
  392 
  393 ;# Exit with OK status
  394 
  395 1;
  396 
  397 =head1 BUGS
  398 
  399 C<rpnm> currently relies on the fact that the header is separated
  400 from the image data by a newline. This is not required by the p[bgp]m
  401 formats (in fact any whitespace is allowed) but most of the pnm
  402 writers seem to comply with that. Truncated files are currently
  403 treated ungracefully (C<rpnm> just barfs).
  404 
  405 =head1 AUTHOR
  406 
  407 Copyright (C) 1996,1997 Christian Soeller <c.soeller@auckland.ac.nz>
  408 All rights reserved. There is no warranty. You are allowed
  409 to redistribute this software / documentation under certain
  410 conditions. For details, see the file COPYING in the PDL
  411 distribution. If this file is separated from the PDL distribution,
  412 the copyright notice should be included in the file.
  413 
  414 
  415 =cut
  416 
  417 
  418 ############################## END PM CODE ################################
  419 #line 420 "Pnm.pm"
  420 
  421 
  422 
  423 
  424 # Exit with OK status
  425 
  426 1;