"Fossies" - the Fresh Open Source Software Archive

Member "PDL-2.080/GENERATED/PDL/IO/Misc.pm" (28 May 2022, 40526 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 "Misc.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::Misc;
    5 
    6 our @EXPORT_OK = qw(rcols wcols swcols rgrep bswap2 bswap4 bswap8 isbigendian rasc rcube _rasc );
    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::Misc ;
   18 
   19 
   20 
   21 
   22 
   23 
   24 #line 7 "misc.pd"
   25 
   26 use strict;
   27 use warnings;
   28 
   29 =head1 NAME
   30 
   31 PDL::IO::Misc - misc IO routines for PDL
   32 
   33 =head1 DESCRIPTION
   34 
   35 Some basic I/O functionality: FITS, tables, byte-swapping
   36 
   37 =head1 SYNOPSIS
   38 
   39  use PDL::IO::Misc;
   40 
   41 =cut
   42 #line 43 "Misc.pm"
   43 
   44 
   45 
   46 
   47 
   48 
   49 =head1 FUNCTIONS
   50 
   51 =cut
   52 
   53 
   54 
   55 
   56 #line 47 "misc.pd"
   57 
   58 
   59 use PDL::Primitive;
   60 use PDL::Types;
   61 use PDL::Options;
   62 use PDL::Bad;
   63 use Carp;
   64 use Symbol qw/ gensym /;
   65 use List::Util;
   66 use strict;
   67 #line 68 "Misc.pm"
   68 
   69 
   70 
   71 #line 948 "../../blib/lib/PDL/PP.pm"
   72 
   73 
   74 
   75 =head2 bswap2
   76 
   77 =for sig
   78 
   79   Signature: (x(); )
   80 
   81 =for ref
   82 
   83 Swaps pairs of bytes in argument x()
   84 
   85 =for bad
   86 
   87 bswap2 does not process bad values.
   88 It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays.
   89 
   90 
   91 =cut
   92 #line 93 "Misc.pm"
   93 
   94 
   95 
   96 #line 950 "../../blib/lib/PDL/PP.pm"
   97 
   98 *bswap2 = \&PDL::bswap2;
   99 #line 100 "Misc.pm"
  100 
  101 
  102 
  103 #line 948 "../../blib/lib/PDL/PP.pm"
  104 
  105 
  106 
  107 =head2 bswap4
  108 
  109 =for sig
  110 
  111   Signature: (x(); )
  112 
  113 =for ref
  114 
  115 Swaps quads of bytes in argument x()
  116 
  117 =for bad
  118 
  119 bswap4 does not process bad values.
  120 It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays.
  121 
  122 
  123 =cut
  124 #line 125 "Misc.pm"
  125 
  126 
  127 
  128 #line 950 "../../blib/lib/PDL/PP.pm"
  129 
  130 *bswap4 = \&PDL::bswap4;
  131 #line 132 "Misc.pm"
  132 
  133 
  134 
  135 #line 948 "../../blib/lib/PDL/PP.pm"
  136 
  137 
  138 
  139 =head2 bswap8
  140 
  141 =for sig
  142 
  143   Signature: (x(); )
  144 
  145 =for ref
  146 
  147 Swaps octets of bytes in argument x()
  148 
  149 =for bad
  150 
  151 bswap8 does not process bad values.
  152 It will set the bad-value flag of all output ndarrays if the flag is set for any of the input ndarrays.
  153 
  154 
  155 =cut
  156 #line 157 "Misc.pm"
  157 
  158 
  159 
  160 #line 950 "../../blib/lib/PDL/PP.pm"
  161 
  162 *bswap8 = \&PDL::bswap8;
  163 #line 164 "Misc.pm"
  164 
  165 
  166 
  167 #line 124 "misc.pd"
  168 
  169 
  170 
  171 
  172 # Internal routine to extend PDL array by size $n along last dimension
  173 # - Would be nice to have a proper extend function rather than hack
  174 # - Is a NO-OP when handed a perl ARRAY ref rather than an ndarray arg
  175 sub _ext_lastD {                           # Called by rcols and rgrep
  176    my ($x,$n) = @_;
  177    if (ref($_[0]) ne 'ARRAY') {
  178       my @nold   = $x->dims;
  179       my @nnew   = @nold;
  180       $nnew[-1] += $n;                      # add $n to the last dimension
  181       my $y      = zeroes($x->type,@nnew);  # New pdl
  182       my $yy     = $y->mv(-1,0)->slice("0:".($nold[-1]-1))->mv(0,-1);
  183       $yy       .= $x;
  184       $_[0]      = $y;
  185    }
  186    1;
  187 }
  188 
  189 # Implements PDL->at() for either 1D PDL or ARRAY arguments
  190 # TODO: Need to add support for multidim ndarrays parallel to rcols
  191 sub _at_1D ($$) {                           # Called by wcols and swcols
  192     my $data = $_[0];
  193     my $index = $_[1];
  194     
  195     if (ref $data eq 'ARRAY') {
  196        return $data->[$index];
  197     } else {
  198        return $data->at($index);
  199     }
  200 }
  201 
  202 # squeezes "fluffy" perl list values into column data type
  203 sub _burp_1D {
  204    my $data = $_[0]->[0]; 
  205    my $databox = $_[0]->[1];
  206    my $index = $_[1];
  207 
  208    my $start = $index - @{$databox} + 1;
  209 
  210    my $tmp; # work around for perl -d "feature"
  211    if (ref $data eq 'ARRAY') {
  212       push @{$data}, @{$databox};
  213    } elsif ( ref($databox->[0]) eq "ARRAY" ) {
  214       # could add POSIX::strtol for hex and octal support but
  215       # can't break float conversions (how?)
  216       ($tmp = $data->slice(":,$start:$index")) .= pdl($databox);
  217    } else {
  218       # could add POSIX::strtol for hex and octal support but
  219       # can't break float conversions (how?)
  220       ($tmp = $data->slice("$start:$index")) .= pdl($databox);
  221    }
  222    $_[0] = [ $data, [] ];
  223 }
  224 
  225 # taken outside of rcols() to avoid clutter
  226 sub _handle_types ($$$) {
  227     my $ncols = shift;
  228     my $deftype = shift;
  229     my $types = shift;
  230 
  231     barf "Unknown PDL type given for DEFTYPE.\n"
  232         unless ref($deftype) eq "PDL::Type";
  233 
  234     my @cols = ref($types) eq "ARRAY" ? @$types : ();
  235         
  236     if ( $#cols > -1 ) {
  237         # truncate if required
  238         $#cols = $ncols if $#cols > $ncols;
  239         
  240         # check input values are sensible
  241         for ( 0 .. $#cols ) {
  242             barf "Unknown value '$cols[$_]' in TYPES array.\n" 
  243                 unless ref($cols[$_]) eq "PDL::Type";
  244         }
  245     }
  246 
  247     # fill in any missing columns
  248     for ( ($#cols+1) .. $ncols ) { push @cols, $deftype; }
  249 
  250     return @cols;
  251 } # sub: _handle_types
  252 
  253 
  254 # Whether an object is an IO handle
  255 use Scalar::Util;
  256 sub _is_io_handle {
  257     my $h = shift;
  258     # reftype catches almost every handle, except: *MYHANDLE
  259     # fileno catches *MYHANDLE, but doesn't catch handles that aren't files
  260     my $reftype = Scalar::Util::reftype($h);
  261     return defined(fileno($h)) || (defined($reftype) && $reftype eq 'GLOB');
  262 }
  263 
  264 
  265 =head2 rcols
  266 
  267 =for ref
  268 
  269 Read specified ASCII cols from a file into ndarrays and perl
  270 arrays (also see L</rgrep>).
  271 
  272 =for usage
  273 
  274   Usage:
  275     ($x,$y,...) = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, $col1, $col2, ... )
  276              $x = rcols( *HANDLE|"filename", { EXCLUDE => '/^!/' }, [] )
  277     ($x,$y,...) = rcols( *HANDLE|"filename", $col1, $col2, ..., { EXCLUDE => '/^!/' } )
  278     ($x,$y,...) = rcols( *HANDLE|"filename", "/foo/", $col1, $col2, ... )
  279 
  280 For each column number specified, a 1D output PDL will be
  281 generated.  Anonymous arrays of column numbers generate
  282 2D output ndarrays with dim0 for the column data and dim1
  283 equal to the number of columns in the anonymous array(s).
  284 
  285 An empty anonymous array as column specification will
  286 produce a single output data ndarray with dim(1) equal
  287 to the number of columns available.
  288 
  289 There are two calling conventions - the old version, where a
  290 pattern can be specified after the filename/handle, and the
  291 new version where options are given as as hash reference.
  292 This reference can be given as either the second or last
  293 argument.
  294 
  295 The default behaviour is to ignore lines beginning with
  296 a # character and lines that only consist of whitespace.
  297 Options exist to only read from lines that match, or do
  298 not match, supplied patterns, and to set the types of the
  299 created ndarrays.
  300 
  301 Can take file name or *HANDLE, and if no explicit column
  302 numbers are specified, all are assumed. For the allowed types,
  303 see L<PDL::Core/Datatype_conversions>.
  304 
  305 Options (case insensitive):
  306 
  307   EXCLUDE or IGNORE
  308   - ignore lines matching this pattern (default B<'/^#/'>).
  309   
  310   INCLUDE or KEEP
  311   - only use lines which match this pattern (default B<''>).
  312   
  313   LINES   
  314   - a string pattern specifying which line numbers to use.
  315   Line numbers start at 0 and the syntax is 'a:b:c' to use
  316   every c'th matching line between a and b (default B<''>).
  317   
  318   DEFTYPE
  319   - default data type for stored data (if not specified, use the type 
  320   stored in C<$PDL::IO::Misc::deftype>, which starts off as B<double>).
  321   
  322   TYPES
  323   - reference to an array of data types, one element for each column 
  324   to be read in.  Any missing columns use the DEFTYPE value (default B<[]>).
  325   
  326   COLSEP
  327   - splits on this string/pattern/qr{} between columns of data. Defaults to
  328   $PDL::IO::Misc::defcolsep.
  329   
  330   PERLCOLS
  331   - an array of column numbers which are to be read into perl arrays
  332   rather than ndarrays.  Any columns not specified in the explicit list
  333   of columns to read will be returned after the explicit columns.
  334   (default B<undef>).
  335 
  336   COLIDS
  337   - if defined to an array reference, it will be assigned the column
  338   ID values obtained by splitting the first line of the file in the
  339   identical fashion to the column data.
  340 
  341   CHUNKSIZE
  342   - the number of input data elements to batch together before appending
  343   to each output data ndarray (Default value is 100).  If CHUNKSIZE is
  344   greater than the number of lines of data to read, the entire file is
  345   slurped in, lines split, and perl lists of column data are generated.
  346   At the end, effectively pdl(@column_data) produces any result ndarrays.
  347 
  348   VERBOSE
  349   - be verbose about IO processing (default C<$PDL::vebose>)
  350 
  351 =for example
  352 
  353 For example:
  354 
  355   $x      = PDL->rcols 'file1';         # file1 has only one column of data
  356   $x      = PDL->rcols 'file2', []; # file2 can have multiple columns, still 1 ndarray output
  357                                         # (empty array ref spec means all possible data fields)
  358 
  359   ($x,$y) = rcols 'table.csv', { COLSEP => ',' };  # read CSV data file
  360   ($x,$y) = rcols *STDOUT;  # default separator for lines like '32 24'
  361 
  362   # read in lines containing the string foo, where the first
  363   # example also ignores lines that begin with a # character.
  364   ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/' };
  365   ($x,$y,$z) = rcols 'file2', 0,4,5, { INCLUDE => '/foo/', EXCLUDE => '' };
  366 
  367   # ignore the first 27 lines of the file, reading in as ushort's
  368   ($x,$y) = rcols 'file3', { LINES => '27:-1', DEFTYPE => ushort };
  369   ($x,$y) = rcols 'file3', { LINES => '27:', TYPES => [ ushort, ushort ] };
  370 
  371   # read in the first column as a perl array and the next two as ndarrays
  372   # with the perl column returned after the ndarray outputs
  373   ($x,$y,$name) = rcols 'file4', 1, 2   , { PERLCOLS => [ 0 ] };
  374   printf "Number of names read in = %d\n", 1 + $#$name;
  375 
  376   # read in the first column as a perl array and the next two as ndarrays
  377   # with PERLCOLS changing the type of the first returned value to perl list ref
  378   ($name,$x,$y) = rcols 'file4', 0, 1, 2, { PERLCOLS => [ 0 ] };
  379 
  380   # read in the first column as a perl array returned first followed by the
  381   # the next two data columns in the file as a single Nx2 ndarray 
  382   ($name,$xy) = rcols 'file4', 0, [1, 2], { PERLCOLS => [ 0 ] };
  383 
  384 
  385   NOTES:
  386 
  387   1. Quotes are required on patterns or use the qr{} quote regexp syntax.
  388   
  389   2. Columns are separated by whitespace by default, use the COLSEP option
  390      separator to specify an alternate split pattern or string or specify an
  391      alternate default separator by setting C<$PDL::IO::Misc::defcolsep> .
  392   
  393   3. Legacy support is present to use C<$PDL::IO::Misc::colsep> to set the
  394      column separator but C<$PDL::IO::Misc::colsep> is not defined by default.
  395      If you set the variable to a defined value it will get picked up.
  396   
  397   4. LINES => '-1:0:3' may not work as you expect, since lines are skipped
  398      when read in, then the whole array reversed.
  399 
  400   5. For consistency with wcols and rcols 1D usage, column data is loaded
  401      into the rows of the pdls (i.e., dim(0) is the elements read per column
  402      in the file and dim(1) is the number of columns of data read.
  403 
  404 =cut
  405 
  406 use vars qw/ $colsep $defcolsep $deftype /;
  407 
  408 $defcolsep = ' ';       # Default column separator
  409 $deftype = double;      # Default type for ndarrays
  410 
  411 my $defchunksize = 100; # Number of perl list items to append to ndarray
  412 my $usecolsep;          # This is the colsep value that is actually used
  413 
  414 # NOTE: XXX
  415 #  need to look at the line-selection code. For instance, if want
  416 #   lines => '-1:0:3', 
  417 #  read in all lines, reverse, then apply the step
  418 #  -> fix point 4 above
  419 # 
  420 # perhaps should just simplify the LINES option - ie remove
  421 # support for reversed arrays?
  422 
  423 sub rcols{ PDL->rcols(@_) }
  424 
  425 sub PDL::rcols {
  426    my $class = shift;
  427    barf 'Usage ($x,$y,...) = rcols( *HANDLE|"filename", ["/pattern/" or \%options], $col1, $col2, ..., [ \%options] )' 
  428    if $#_<0;
  429 
  430    my $is_handle = _is_io_handle $_[0];
  431    my $fh = $is_handle ? $_[0] : gensym;
  432    open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle;
  433    shift;
  434 
  435    # set up default options
  436    my $opt = new PDL::Options( {
  437        CHUNKSIZE => undef,
  438        COLIDS => undef,
  439        COLSEP => undef,
  440        DEFTYPE => $deftype,
  441        EXCLUDE => '/^#/',
  442        INCLUDE => undef,
  443        LINES => '',
  444        PERLCOLS => undef,
  445        TYPES   => [],
  446        VERBOSE=> $PDL::verbose,
  447        } );
  448    $opt->synonyms( { IGNORE => 'EXCLUDE', KEEP => 'INCLUDE' } );
  449 
  450    # has the user supplied any options
  451    if ( defined($_[0]) ) {
  452       # ensure the old-style behaviour by setting the exclude pattern to undef 
  453       if ( $_[0] =~ m|^/.*/$| )        { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); }
  454       elsif ( ref($_[0]) eq "Regexp" ) { $opt->options( { EXCLUDE => undef, INCLUDE => shift } ); }
  455       elsif ( ref($_[0]) eq "HASH" )   { $opt->options( shift ); }
  456    }
  457 
  458    # maybe the last element is a hash array as well
  459    $opt->options( pop ) if defined($_[-1]) and ref($_[-1]) eq "HASH";
  460 
  461    # a reference to a hash array
  462    my $options = $opt->current();   
  463 
  464    # handle legacy colsep variable
  465    $usecolsep = (defined $colsep) ? qr{$colsep} : undef;
  466    $usecolsep = qr{$options->{COLSEP}} if $options->{COLSEP};
  467 
  468    # what are the patterns?
  469    foreach my $pattern ( qw( INCLUDE EXCLUDE ) ) {
  470       if ( $options->{$pattern} and ref($options->{$pattern}) ne "Regexp" ) {
  471          if ( $options->{$pattern} =~ m|^/.*/$| ) {
  472             $options->{$pattern} =~ s|^/(.*)/$|$1|;
  473             $options->{$pattern} = qr($options->{$pattern});
  474          } else {
  475             barf "rcols() - unable to process $pattern value.\n";
  476          }
  477       }
  478    }
  479 
  480    # CHUNKSIZE controls memory/time tradeoff of ndarray IO
  481    my $chunksize = $options->{CHUNKSIZE} || $defchunksize;
  482    my $nextburpindex = -1;
  483 
  484 # which columns are to be read into ndarrays and which into perl arrays?
  485 my @end_perl_cols = ();       # unique perl cols to return at end
  486 
  487 my @perl_cols = ();           # perl cols index list from PERLCOLS option
  488 @perl_cols = @{ $$options{PERLCOLS} } if $$options{PERLCOLS};
  489 
  490 my @is_perl_col;              # true if index corresponds to a perl column
  491 for (@perl_cols) { $is_perl_col[$_] = 1; };
  492 # print STDERR "rcols: \@is_perl_col is @is_perl_col\n";
  493 
  494 my ( @explicit_cols )  = @_;  # call specified columns to read
  495 # print STDERR "rcols: \@explicit_cols is @explicit_cols\n";
  496 
  497 # work out which line numbers are required
  498 # - the regexp's are a bit over the top
  499 my ( $x, $y, $c );
  500 if ( $$options{LINES} ne '' ) {
  501    if ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*$/ ) {
  502       $x = $1; $y = $2;
  503    } elsif ( $$options{LINES} =~ /^\s*([+-]?\d*)\s*:\s*([+-]?\d*)\s*:\s*([+]?\d*)\s*$/ ) {
  504       $x = $1; $y = $2; $c = $3;
  505    } else {
  506       barf "rcols() - unable to parse LINES option.\n";
  507    }
  508 }
  509 
  510 # Since we do not know how many lines there are in advance, things get a bit messy
  511 my ( $index_start, $index_end ) = ( 0, -1 );
  512 $index_start  = $x if defined($x) and $x ne '';
  513 $index_end    = $y if defined($y) and $y ne '';
  514 my $line_step = $c || 1;
  515 
  516 # $line_rev = 0/1 for normal order/reversed
  517 # $line_start/_end refer to the first and last line numbers that we want
  518 # (the values of which we may not know until we've read in all the file)
  519 my ( $line_start, $line_end, $line_rev );
  520 if ( ($index_start >= 0 and $index_end < 0) ) {
  521    # eg 0:-1
  522    $line_rev = 0; $line_start = $index_start;
  523 } elsif ( $index_end >= 0 and $index_start < 0 ) {
  524    # eg -1:0
  525    $line_rev = 1; $line_start = $index_end; 
  526 } elsif ( $index_end >= $index_start and $index_start >= 0 ) {
  527    # eg 0:10
  528    $line_rev = 0; $line_start = $index_start; $line_end = $index_end;
  529 } elsif ( $index_start > $index_end and $index_end >= 0 ) {
  530    # eg 10:0
  531    $line_rev = 1; $line_start = $index_end; $line_end = $index_start;
  532 } elsif ( $index_start <= $index_end ) {
  533    # eg -5:-1
  534    $line_rev = 0;
  535 } else {
  536    # eg -1:-5
  537    $line_rev = 1;
  538 }
  539 
  540 my @ret;
  541 
  542 my ($k,$fhline); 
  543 
  544 my $line_num = -1;
  545 my $line_ctr = $line_step - 1;  # ensure first line is always included
  546 my $index    = -1;
  547 my $pdlsize  =  0;
  548 my $extend   = 10000;
  549 
  550 my $line_store;  # line numbers of saved data
  551 
  552 RCOLS_IO: {
  553 
  554    if ($options->{COLIDS}) {
  555       print STDERR "rcols: processing COLIDS option\n" if $options->{VERBOSE};
  556       undef $!;
  557       if (defined($fhline = <$fh>) ) {        # grab first line's fields for column IDs
  558          $fhline =~ s/\r?\n$//;               # handle DOS on unix files better
  559          my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline);
  560          @{$options->{COLIDS}} = @v;
  561       } else {
  562          die "rcols: reading COLIDS info, $!" if $!;
  563          last RCOLS_IO;
  564       }
  565    }
  566 
  567    while( defined($fhline = <$fh>) ) {
  568 
  569       # chomp $fhline;
  570       $fhline =~ s/\r?\n$//;  # handle DOS on unix files better
  571 
  572       $line_num++;
  573 
  574       # the order of these checks is important, particularly whether we
  575       # check for line_ctr before or after the pattern matching
  576       # Prior to PDL 2.003 the line checks were done BEFORE the
  577       # pattern matching
  578       #
  579       # need this first check, even with it almost repeated at end of loop,
  580       # incase the pattern matching excludes $line_num == $line_end, say
  581       last if     defined($line_end)   and $line_num > $line_end;
  582       next if     defined($line_start) and $line_num < $line_start;
  583       next if     $options->{EXCLUDE} and     $fhline =~ /$options->{EXCLUDE}/;
  584       next if     $options->{INCLUDE} and not $fhline =~ /$options->{INCLUDE}/;
  585       next unless ++$line_ctr == $line_step;
  586       $line_ctr = 0;
  587 
  588       $index++;
  589       my @v = defined($usecolsep) ? split($usecolsep,$fhline) : split(' ',$fhline);
  590 
  591       # map empty fields '' to undef value
  592       @v = map { $_ eq '' ? undef : $_ } @v;
  593 
  594       # if the first line, set up the output ndarrays using all the columns
  595       # if the user doesn't specify anything
  596       if ( $index == 0 ) {
  597 
  598          # Handle implicit multicolumns in command line
  599          if ($#explicit_cols < 0) {                 # implicit single col data
  600             @explicit_cols = ( 0 .. $#v );
  601          }
  602          if (scalar(@explicit_cols)==1 and ref($explicit_cols[0]) eq "ARRAY") {
  603             if ( !scalar(@{$explicit_cols[0]}) ) {  # implicit multi-col data
  604                @explicit_cols = ( [ 0 .. $#v ] );
  605             }
  606          }
  607          my $implicit_pdls = 0;
  608          my $is_explicit = {};
  609          foreach my $col (@explicit_cols) {
  610             if (ref($col) eq "ARRAY") {
  611                $implicit_pdls++ if !scalar(@$col);
  612             } else {
  613                $is_explicit->{$col} = 1;
  614             }
  615          }
  616          if ($implicit_pdls > 1) {
  617             die "rcols: only one implicit multicolumn ndarray spec allowed, found $implicit_pdls!\n";
  618          }
  619          foreach my $col (@explicit_cols) {
  620             if (ref($col) eq "ARRAY" and !scalar(@$col)) {
  621                @$col = grep { !$is_explicit->{$_} } ( 0 .. $#v );
  622             }
  623          }
  624             
  625          # remove declared perl columns from pdl data list
  626          $k = 0;
  627          my @pdl_cols = ();
  628          foreach my $col (@explicit_cols) {
  629             # strip out declared perl cols so they won't be read into ndarrays
  630             if ( ref($col) eq "ARRAY" ) {
  631                @$col = grep { !$is_perl_col[$_] } @{$col};
  632                push @pdl_cols, [ @{$col} ];
  633             } elsif (!$is_perl_col[$col]) {
  634                push @pdl_cols, $col;
  635             }
  636          }
  637          # strip out perl cols in explicit col list for return at end
  638          @end_perl_cols = @perl_cols;
  639          foreach my $col (@explicit_cols) {
  640             if ( ref($col) ne "ARRAY" and defined($is_perl_col[$col]) ) {
  641                @end_perl_cols = grep { $_ != $col } @end_perl_cols;
  642             }
  643          };
  644 
  645          # sort out the types of the ndarrays
  646          my @types = _handle_types( $#pdl_cols, $$options{DEFTYPE}, $$options{TYPES} );
  647          if ( $options->{VERBOSE} ) { # dbg aid
  648             print "Reading data into ndarrays of type: [ ";
  649             foreach my $t ( @types ) {
  650                print $t->shortctype() . " ";
  651             }
  652             print "]\n";
  653          }
  654 
  655          $k = 0;
  656          for (@explicit_cols) {
  657             # Using mixed list+ndarray data structure for performance tradeoff
  658             # between memory usage (perl list) and speed of IO (PDL operations)
  659             if (ref($_) eq "ARRAY") {
  660                # use multicolumn ndarray here
  661                push @ret, [ $class->zeroes($types[$k++],scalar(@{$_}),1), [] ];
  662             } else {
  663                push @ret, ($is_perl_col[$_] ? [ [], [] ] : [ $class->zeroes($types[$k],1), [] ]);
  664                $k++ unless $is_perl_col[$_];
  665             }
  666          }
  667          for (@end_perl_cols) { push @ret, [ [], [] ]; }
  668 
  669          $line_store = [ $class->zeroes(long,1), [] ]; # only need to store integers
  670       }
  671 
  672       # if necessary, extend PDL in buffered manner
  673       $k = 0;
  674       if ( $pdlsize < $index ) {
  675          for (@ret, $line_store) { _ext_lastD( $_->[0], $extend ); }
  676          $pdlsize += $extend;
  677       }
  678 
  679       # - stick perl arrays onto end of $ret
  680       $k = 0;
  681       for (@explicit_cols, @end_perl_cols)  {
  682          if (ref($_) eq "ARRAY") {
  683             push @{ $ret[$k++]->[1] }, [ @v[ @$_ ] ];
  684          } else {
  685             push @{ $ret[$k++]->[1] }, $v[$_];
  686          }
  687       }
  688 
  689       # store the line number
  690       push @{$line_store->[1]}, $line_num;
  691 
  692       # need to burp out list if needed
  693       if ( $index >= $nextburpindex ) {
  694          for (@ret, $line_store) { _burp_1D($_,$index); }
  695          $nextburpindex = $index + $chunksize;
  696       }
  697 
  698       # Thanks to Frank Samuelson for this
  699       last if defined($line_end) and $line_num == $line_end;
  700    }
  701 
  702 }
  703 
  704 close($fh) unless $is_handle;
  705 
  706 # burp one final time if needed and 
  707 # clean out additional ARRAY ref level for @ret
  708 for (@ret, $line_store) {
  709    _burp_1D($_,$index) if defined $_ and scalar @{$_->[1]};
  710    $_ = $_->[0];
  711 }
  712 
  713 # have we read anything in? if not, return empty ndarrays
  714 if ( $index == -1 ) {
  715    print "Warning: rcols() did not read in any data.\n" if $options->{VERBOSE};
  716    if ( wantarray ) {
  717       foreach ( 0 .. $#explicit_cols ) {
  718          if ( $is_perl_col[$_] ) {
  719             $ret[$_] = PDL->null;
  720          } else {
  721             $ret[$_] = [];
  722          }
  723       }
  724       for ( @end_perl_cols ) { push @ret, []; }
  725       return ( @ret );
  726    } else { 
  727       return PDL->null;
  728    }
  729 }
  730 
  731 # if the user has asked for lines => 0:-1 or 0:10 or 1:10 or 1:-1,
  732 # - ie not reversed and the last line number is known -
  733 # then we can skip the following nastiness
  734 if ( $line_rev == 0 and $index_start >= 0 and $index_end >= -1 ) {
  735    for (@ret) {
  736       ## $_ = $_->mv(-1,0)->slice("0:${index}")->mv(0,-1) unless ref($_) eq 'ARRAY';
  737       $_ = $_->mv(-1,0)->slice("0:${index}") unless ref($_) eq 'ARRAY';  # cols are dim(0)
  738    };
  739    if ( $options->{VERBOSE} ) {
  740       if ( ref($ret[0]) eq 'ARRAY' ) {
  741          print "Read in ", scalar( @{ $ret[0] } ), " elements.\n";
  742       } else {
  743          print "Read in ", $ret[0]->nelem, " elements.\n";
  744       }
  745    }
  746    wantarray ? return(@ret) : return $ret[0];
  747 }
  748 
  749 # Work out which line numbers we want. First we clean up the ndarray
  750 # containing the line numbers that have been read in
  751 $line_store = $line_store->slice("0:${index}");
  752 
  753 # work out the min/max line numbers required
  754 if ( $line_rev ) {
  755    if ( defined($line_start) and defined($line_end) ) {
  756       my $dummy = $line_start;
  757       $line_start = $line_end;
  758       $line_end = $dummy;
  759    } elsif ( defined($line_start) ) {
  760       $line_end = $line_start;
  761    } else {
  762       $line_start = $line_end; 
  763    }
  764 }
  765 $line_start = $line_num + 1 + $index_start if $index_start < 0;
  766 $line_end   = $line_num + 1 + $index_end   if $index_end   < 0;
  767 
  768 my $indices;
  769 
  770 { no warnings 'precedence'; 
  771    if ( $line_rev ) {
  772       $indices = which( $line_store >= $line_end & $line_store <= $line_start )->slice('-1:0');
  773    } else {
  774       $indices = which( $line_store >= $line_start & $line_store <= $line_end );
  775    }
  776 }
  777 
  778 # truncate the ndarrays
  779 for my $col ( @explicit_cols ) {
  780    if ( ref($col) eq "ARRAY" ) {
  781       for ( @$col ) {
  782          $ret[$_] = $ret[$_]->index($indices);
  783       }
  784    } else {
  785       $ret[$col] = $ret[$col]->index($indices) unless $is_perl_col[$col] };
  786 }
  787 
  788 # truncate/reverse/etc the perl arrays
  789 my @indices_array = list $indices;
  790 foreach ( @explicit_cols, @end_perl_cols ) {
  791    if ( $is_perl_col[$_] ) {
  792       my @temp = @{ $ret[$_] };
  793       $ret[$_] = [];
  794       foreach my $i ( @indices_array ) { push @{ $ret[$_] }, $temp[$i] };
  795    }
  796 }
  797 
  798 # print some diagnostics
  799 if ( $options->{VERBOSE} ) {
  800    my $done = 0;
  801    foreach my $col (@explicit_cols) {
  802       last if $done;
  803       next if $is_perl_col[$col];
  804       print "Read in ", $ret[$col]->nelem, " elements.\n";
  805       $done = 1;
  806    }
  807    foreach my $col (@explicit_cols, @end_perl_cols) {
  808       last if $done;
  809       print "Read in ", $ret[$col]->nelem, " elements.\n";
  810       $done = 1;
  811    }
  812 }
  813 
  814 # fix 2D pdls to match what wcols generates
  815 foreach my $col (@ret) {
  816    next if ref($col) eq "ARRAY";
  817    $col = $col->transpose if $col->ndims == 2;
  818 }
  819 
  820 wantarray ? return(@ret) : return $ret[0];
  821 }
  822 
  823 
  824 =head2 wcols
  825 
  826 =for ref
  827 
  828   Write ASCII columns into file from 1D or 2D ndarrays and/or 1D listrefs efficiently.
  829 
  830 Can take file name or *HANDLE, and if no file/filehandle is given defaults to STDOUT.
  831 
  832   Options (case insensitive):
  833 
  834     HEADER - prints this string before the data. If the string
  835              is not terminated by a newline, one is added. (default B<''>).
  836 
  837     COLSEP - prints this string between columns of data. Defaults to
  838              $PDL::IO::Misc::defcolsep.
  839 
  840     FORMAT - A printf-style format string that is cycled through
  841              column output for user controlled formatting.
  842 
  843 =for usage
  844 
  845  Usage: wcols $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options];  # or
  846         wcols $format_string, $data1, $data2, $data3,..., *HANDLE|"outfile", [\%options];
  847 
  848    where the $dataN args are either 1D ndarrays, 1D perl array refs,
  849    or 2D ndarrays (as might be returned from rcols() with the [] column
  850    syntax and/or using the PERLCOLS option).  dim(0) of all ndarrays
  851    written must be the same size.  The printf-style $format_string,
  852    if given, overrides any FORMAT key settings in the option hash.
  853 
  854 e.g.,
  855 
  856 =for example
  857 
  858   $x = random(4); $y = ones(4);
  859   wcols $x, $y+2, 'foo.dat';
  860   wcols $x, $y+2, *STDERR;
  861   wcols $x, $y+2, '|wc';
  862 
  863   $x = sequence(3); $y = zeros(3); $c = random(3);
  864   wcols $x,$y,$c; # Orthogonal version of 'print $x,$y,$c' :-)
  865 
  866   wcols "%10.3f", $x,$y; # Formatted
  867   wcols "%10.3f %10.5g", $x,$y; # Individual column formatting
  868 
  869   $x = sequence(3); $y = zeros(3); $units = [ 'm/sec', 'kg', 'MPH' ];
  870   wcols $x,$y, { HEADER => "#   x   y" };
  871   wcols $x,$y, { Header => "#   x   y", Colsep => ', ' };  # case insensitive option names!
  872   wcols " %4.1f  %4.1f  %s",$x,$y,$units, { header => "# Day  Time  Units" };
  873 
  874   $a52 = sequence(5,2); $y = ones(5); $c = [ 1, 2, 4 ];
  875   wcols $a52;         # now can write out 2D pdls (2 columns data in output)
  876   wcols $y, $a52, $c  # ...and mix and match with 1D listrefs as well
  877 
  878   NOTES:
  879 
  880   1. Columns are separated by whitespace by default, use
  881      C<$PDL::IO::Misc::defcolsep> to modify the default value or
  882      the COLSEP option
  883 
  884   2. Support for the C<$PDL::IO::Misc::colsep> global value
  885      of PDL-2.4.6 and earlier is maintained but the initial value
  886      of the global is undef until you set it.  The value will be
  887      then be picked up and used as if defcolsep were specified.
  888 
  889   3. Dim 0 corresponds to the column data dimension for both
  890      rcols and wcols.  This makes wcols the reverse operation
  891      of rcols.
  892 
  893 =cut
  894 
  895 *wcols = \&PDL::wcols;
  896 
  897 sub PDL::wcols {
  898    barf 'Usage: wcols($optional_format_string, 1_or_2D_pdls, *HANDLE|"filename", [\%options])' if @_<1;
  899 
  900    # handle legacy colsep variable
  901    $usecolsep = (defined $colsep) ? $colsep : $defcolsep;
  902 
  903    # if last argument is a reference to a hash, parse the options
  904    my ($format_string, $step, $fh);
  905    my $header;
  906    if ( ref( $_[-1] ) eq "HASH" ) {
  907        my $opt = pop;
  908        foreach my $key ( sort keys %$opt ) {
  909            if ( $key =~ /^H/i ) { $header = $opt->{$key}; }             # option: HEADER
  910        elsif ( $key =~ /^COLSEP/i ) { $usecolsep = $opt->{$key}; }  # option: COLSEP
  911        elsif ( $key =~ /^FORMAT/i ) { $format_string = $opt->{$key}; }  # option: FORMAT
  912            else {
  913                print "Warning: wcols does not understand option <$key>.\n";
  914            }
  915        }
  916    }
  917    if (ref(\$_[0]) eq "SCALAR" || $format_string) {
  918        $format_string = shift if (ref(\$_[0]) eq "SCALAR");
  919        # 1st arg not ndarray, explicit format string overrides option hash FORMAT
  920        $step = $format_string;
  921        $step =~ s/(%%|[^%])//g;  # use step to count number of format items
  922        $step = length ($step);
  923    }
  924    my $file = $_[-1];
  925    my $file_opened;
  926    my $is_handle = !UNIVERSAL::isa($file,'PDL') &&
  927                    !UNIVERSAL::isa($file,'ARRAY') &&
  928                    _is_io_handle $file;
  929    if ($is_handle) {  # file handle passed directly
  930        $fh = $file; pop;
  931    }
  932    else{
  933        if (ref(\$file) eq "SCALAR") {  # Must be a file name
  934           $fh = gensym;
  935          if (!$is_handle) {
  936             $file = ">$file" unless $file =~ /^\|/ or $file =~ /^\>/;
  937              open $fh, $file or barf "File $file can not be opened for writing\n";
  938          }
  939           pop;
  940           $file_opened = 1;
  941        }
  942        else{  # Not a filehandle or filename, assume something else
  943               # (probably ndarray) and send to STDOUT
  944           $fh = *STDOUT;
  945        }
  946    }
  947 
  948    my @p = @_;
  949    my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->dim(0);
  950    my @dogp = ();  # need to break 2D pdls into a their 1D pdl components
  951    for (@p) {
  952       if ( ref $_ eq 'ARRAY' ) {
  953          barf "wcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n;
  954          push @dogp, $_;
  955       } else {
  956          barf "wcols: 1D args must have same number of elements\n" if $_->dim(0) != $n or $_->getndims > 2;
  957          if ( $_->getndims == 2 ) {
  958             push @dogp, $_->dog;
  959          } else {
  960             push @dogp, $_;
  961          }
  962       }
  963    }
  964    if ( defined $header ) {
  965        $header .= "\n" unless $header =~ m/\n$/;
  966        print $fh $header;
  967    }
  968    my $i;
  969    my $pcnt = scalar @dogp;
  970    for ($i=0; $i<$n; $i++) {
  971        if ($format_string) {
  972            my @d;
  973        my $pdone = 0;
  974            for (@dogp) {
  975                push @d,_at_1D($_,$i); $pdone++;
  976                if (@d == $step) {
  977                    printf $fh $format_string,@d;
  978                    printf $fh $usecolsep unless $pdone==$pcnt;
  979                    $#d = -1;
  980                }
  981            }
  982            if (@d && !$i) {
  983                my $str;
  984                if ($#dogp>0) {
  985                    $str = ($#dogp+1).' columns don\'t';
  986                } else {
  987                    $str = '1 column doesn\'t';
  988                }
  989                $str .= " fit in $step column format ".
  990                '(even repeated) -- discarding surplus';
  991                carp $str;
  992                # printf $fh $format_string,@d;
  993                # printf $fh $usecolsep;
  994            }
  995        } else {
  996        my $pdone = 0;
  997            for (@dogp) {
  998            $pdone++;
  999                print $fh _at_1D($_,$i) . ( ($pdone==$pcnt) ? '' : $usecolsep );
 1000            }
 1001        }
 1002        print $fh "\n";
 1003    }
 1004    close($fh) if $file_opened;
 1005    return 1;
 1006 }
 1007 
 1008 =head2 swcols
 1009 
 1010 =for ref
 1011 
 1012 generate string list from C<sprintf> format specifier and a list of ndarrays
 1013 
 1014 C<swcols> takes an (optional) format specifier of the printf
 1015 sort and a list of 1D ndarrays as input. It returns a perl
 1016 array (or array reference if called in scalar context)
 1017 where each element of the array is the string generated by
 1018 printing the corresponding element of the ndarray(s) using
 1019 the format specified. If no format is specified it uses the
 1020 default print format.
 1021 
 1022 =for usage
 1023 
 1024  Usage: @str = swcols format, pdl1,pdl2,pdl3,...;
 1025     or  $str = swcols format, pdl1,pdl2,pdl3,...;
 1026 
 1027 =cut
 1028 
 1029 *swcols = \&PDL::swcols;
 1030 
 1031 sub PDL::swcols{
 1032   my ($format_string,$step);
 1033 
 1034   my @outlist;
 1035 
 1036   if (ref(\$_[0]) eq "SCALAR") {
 1037          $step = $format_string = shift; # 1st arg not ndarray
 1038          $step =~ s/(%%|[^%])//g;  # use step to count number of format items
 1039          $step = length ($step);
 1040   }
 1041   
 1042   my @p = @_;
 1043   my $n = (ref $p[0] eq 'ARRAY') ? $#{$p[0]}+1 : $p[0]->nelem;
 1044   for (@p) {
 1045      if ( ref $_ eq 'ARRAY' ) {
 1046         barf "swcols: 1D args must have same number of elements\n" if scalar(@{$_}) != $n;
 1047      } else {
 1048         barf "swcols: 1D args must have same number of elements\n" if $_->nelem != $n or $_->getndims!=1;
 1049      }
 1050   }
 1051 
 1052   my $i;
 1053   for ($i=0; $i<$n; $i++) {
 1054          if ($format_string) {
 1055            my @d;
 1056            for (@p) {
 1057                   push @d,_at_1D($_,$i);
 1058                   if (@d == $step) {
 1059                          push @outlist,sprintf $format_string,@d;
 1060                          $#d = -1;
 1061                   }
 1062            }
 1063            if (@d && !$i) {
 1064                   my $str;
 1065                   if ($#p>0) {
 1066                          $str = ($#p+1).' columns don\'t';
 1067                   } else {
 1068                          $str = '1 column doesn\'t';
 1069                   }
 1070                   $str .= " fit in $step column format ".
 1071                '(even repeated) -- discarding surplus';
 1072                   carp $str;
 1073                   # printf $fh $format_string,@d;
 1074                   # printf $fh $usecolsep;
 1075            }
 1076          } else {
 1077            for (@p) {
 1078                   push @outlist,sprintf _at_1D($_,$i),$usecolsep;
 1079            }
 1080          }
 1081   }
 1082   wantarray ? return @outlist: return \@outlist;
 1083 }
 1084 
 1085 
 1086 =head2 rgrep
 1087 
 1088 =for ref
 1089 
 1090   Read columns into ndarrays using full regexp pattern matching.
 1091   
 1092 
 1093   Options:
 1094   
 1095   UNDEFINED: This option determines what will be done for undefined 
 1096   values. For instance when reading a comma-separated file of the type 
 1097   C<1,2,,4> where the C<,,> indicates a missing value. 
 1098   
 1099   The default value is to assign C<$PDL::undefval> to undefined values,
 1100   but if C<UNDEFINED> is set this is used instead. This would normally 
 1101   be set to a number, but if it is set to C<Bad> and PDL is compiled
 1102   with Badvalue support (see L<PDL::Bad/>) then undefined values are set to
 1103   the appropriate badvalue and the column is marked as bad.
 1104   
 1105   DEFTYPE: Sets the default type of the columns - see the documentation for
 1106    L</rcols()>
 1107   
 1108   TYPES:   A reference to a Perl array with types for each column - see 
 1109   the documentation for L</rcols()>
 1110   
 1111   BUFFERSIZE: The number of lines to extend the ndarray by. It might speed
 1112   up the reading a little bit by setting this to the number of lines in the
 1113   file, but in general L</rasc()> is a better choice
 1114 
 1115 Usage
 1116 
 1117 =for usage
 1118 
 1119  ($x,$y,...) = rgrep(sub, *HANDLE|"filename")
 1120 
 1121 e.g.
 1122 
 1123 =for example
 1124 
 1125  ($x,$y) = rgrep {/Foo (.*) Bar (.*) Mumble/} $file;
 1126 
 1127 i.e. the vectors C<$x> and C<$y> get the progressive values
 1128 of C<$1>, C<$2> etc.
 1129 
 1130 =cut
 1131 
 1132   sub rgrep (&@) {
 1133      barf 'Usage ($x,$y,...) = rgrep(sub, *HANDLE|"filename", [{OPTIONS}])'
 1134          if $#_ > 2;
 1135 
 1136      my (@ret,@v,$nret); my ($m,$n)=(-1,0); # Count/PDL size
 1137      my $pattern = shift;
 1138 
 1139      my $is_handle = _is_io_handle $_[0];
 1140      my $fh = $is_handle ? $_[0] : gensym;
 1141      open $fh, $_[0] or die "File $_[0] not found\n" unless $is_handle;
 1142 
 1143      if (ref($pattern) ne "CODE") {
 1144          die "Got a ".ref($pattern)." for rgrep?!";
 1145      }
 1146 
 1147     
 1148      # set up default options
 1149      my $opt = new PDL::Options( {
 1150          DEFTYPE => $deftype,
 1151          TYPES => [],
 1152          UNDEFINED => $PDL::undefval,
 1153      BUFFERSIZE => 10000
 1154          } );
 1155      # Check if the user specified options
 1156      my $u_opt = $_[1] || {};
 1157      $opt->options( $u_opt);
 1158 
 1159      my $options = $opt->current();   
 1160 
 1161      # If UNDEFINED is set to .*bad.* then undefined are set to
 1162      # bad - unless we have a Perl that is not compiled with Bad support
 1163      my $undef_is_bad = ($$options{UNDEFINED} =~ /bad/i);
 1164      barf "Unknown PDL type given for DEFTYPE.\n"
 1165         unless ref($$options{DEFTYPE}) eq "PDL::Type";
 1166 
 1167      while(<$fh>) {
 1168          next unless @v = &$pattern;
 1169 
 1170          $m++;  # Count got
 1171          if ($m==0) {
 1172            $nret = $#v;   # Last index of values to return
 1173 
 1174        # Handle various columns as in rcols - added 18/04/05
 1175            my @types = _handle_types( $nret, $$options{DEFTYPE}, $$options{TYPES} );    
 1176            for (0..$nret) {
 1177                 # Modified 18/04/05 to use specified precision.
 1178         $ret[$_] = [ PDL->zeroes($types[$_], 1), [] ];
 1179            }
 1180        } else { # perhaps should only carp once...
 1181            carp "Non-rectangular rgrep" if $nret != $#v;
 1182        }
 1183        if ($n<$m) {
 1184            for (0..$nret) {
 1185                _ext_lastD( $ret[$_]->[0], $$options{BUFFERSIZE} ); # Extend PDL in buffered manner
 1186            }
 1187            $n += $$options{BUFFERSIZE};
 1188       }
 1189        for(0..$nret) { 
 1190     # Set values - '1*' is to ensure numeric
 1191     # We now (JB - 18/04/05) also check for defined values or not
 1192     # Ideally this should include Badvalue support..
 1193     if ($v[$_] eq '') {
 1194        # Missing value - let us treat this specially
 1195        if ($undef_is_bad) {
 1196            set $ret[$_]->[0], $m, $$options{DEFTYPE}->badvalue();
 1197                # And set bad flag on $ref[$_]!
 1198                $ret[$_]->[0]->badflag(1);
 1199            } else {
 1200                set $ret[$_]->[0], $m, $$options{UNDEFINED};
 1201            } 
 1202     } else {
 1203            set $ret[$_]->[0], $m, 1*$v[$_];
 1204     }
 1205      } 
 1206    }
 1207                                  
 1208    close($fh) unless $is_handle;
 1209    for (@ret) { $_ = $_->[0]->slice("0:$m")->copy; }; # Truncate
 1210    wantarray ? return(@ret) : return $ret[0];
 1211 }
 1212 
 1213 =head2 isbigendian
 1214 
 1215 =for ref
 1216 
 1217   Determine endianness of machine - returns 0 or 1 accordingly
 1218 
 1219 =cut
 1220 #line 1221 "Misc.pm"
 1221 
 1222 
 1223 
 1224 #line 1180 "misc.pd"
 1225 
 1226 sub PDL::isbigendian { return 0; };
 1227 *isbigendian = \&PDL::isbigendian;
 1228 #line 1229 "Misc.pm"
 1229 
 1230 
 1231 
 1232 #line 1202 "misc.pd"
 1233 
 1234 
 1235 
 1236 =head2 rasc
 1237 
 1238 =for ref
 1239 
 1240   Simple function to slurp in ASCII numbers quite quickly,
 1241   although error handling is marginal (to nonexistent).
 1242 
 1243 =for usage
 1244 
 1245   $pdl->rasc("filename"|FILEHANDLE [,$noElements]);
 1246 
 1247       Where:
 1248         filename is the name of the ASCII file to read or open file handle
 1249         $noElements is the optional number of elements in the file to read.
 1250             (If not present, all of the file will be read to fill up $pdl).
 1251         $pdl can be of type float or double (for more precision).
 1252 
 1253 =for example
 1254 
 1255   #  (test.num is an ascii file with 20 numbers. One number per line.)
 1256   $in = PDL->null;
 1257   $num = 20;
 1258   $in->rasc('test.num',20);
 1259   $imm = zeroes(float,20,2);
 1260   $imm->rasc('test.num');
 1261 
 1262 =cut
 1263 
 1264 sub rasc {PDL->rasc(@_)}
 1265 sub PDL::rasc {
 1266   my ($pdl, $file, $num) = @_;
 1267   $num = -1 unless defined $num;
 1268   my $is_openhandle = defined fileno $file;
 1269   my $fi;
 1270   if ($is_openhandle) {
 1271     $fi = $file;
 1272   } else {
 1273     barf 'usage: rasc $pdl, "filename"|FILEHANDLE, [$num_to_read]'
 1274        if !defined $file || ref $file;
 1275     open $fi, "<", $file or barf "Can't open $file";
 1276   }
 1277   $pdl->_rasc(my $ierr=null,$num,$fi);
 1278   close $fi unless $is_openhandle;
 1279   return all $ierr > 0;
 1280 }
 1281 
 1282 # ----------------------------------------------------------
 1283 
 1284 =head2 rcube
 1285 
 1286 =for ref
 1287 
 1288  Read list of files directly into a large data cube (for efficiency)
 1289 
 1290 =for usage
 1291 
 1292  $cube = rcube \&reader_function, @files;
 1293 
 1294 =for example
 1295 
 1296  $cube = rcube \&rfits, glob("*.fits");
 1297 
 1298 This IO function allows direct reading of files into a large data cube,
 1299 Obviously one could use cat() but this is more memory efficient.
 1300 
 1301 The reading function (e.g. rfits, readfraw) (passed as a reference)
 1302 and files are the arguments.
 1303 
 1304 The cube is created as the same X,Y dims and datatype as the first
 1305 image specified. The Z dim is simply the number of images.
 1306 
 1307 =cut
 1308 
 1309 sub rcube {
 1310 
 1311     my $reader = shift;
 1312 
 1313     barf "Usage: blah" unless ref($reader) eq "CODE";
 1314 
 1315     my $k=0;
 1316     my ($im,$cube,$tmp,$nx,$ny);
 1317     my $nz = scalar(@_);
 1318 
 1319     for my $file (@_) {
 1320        print "Slice ($k) - reading file $file...\n" if $PDL::verbose;
 1321        $im = &$reader($file);
 1322        ($nx, $ny) = dims $im;
 1323        if ($k == 0) {
 1324           print "Creating $nx x $ny x $nz cube...\n" if $PDL::verbose;
 1325           $cube = $im->zeroes($im->type,$nx,$ny,$nz);
 1326         }
 1327         else {
 1328           barf "Dimensions do not match for file $file!\n" if
 1329              $im->getdim(0) != $nx or $im->getdim(1) != $ny ;
 1330 
 1331        }
 1332        $tmp = $cube->slice(":,:,($k)");
 1333        $tmp .= $im;
 1334        $k++;
 1335       }
 1336 
 1337       return $cube;
 1338 }
 1339 #line 1340 "Misc.pm"
 1340 
 1341 
 1342 
 1343 #line 950 "../../blib/lib/PDL/PP.pm"
 1344 
 1345 *_rasc = \&PDL::_rasc;
 1346 #line 1347 "Misc.pm"
 1347 
 1348 
 1349 
 1350 
 1351 
 1352 #line 27 "misc.pd"
 1353 
 1354 
 1355 =head1 AUTHOR
 1356 
 1357 Copyright (C) Karl Glazebrook 1997, Craig DeForest 2001,
 1358 2003, and Chris Marshall 2010. All rights reserved. There is
 1359 no warranty. You are allowed to redistribute this software
 1360 / documentation under certain conditions. For details, see
 1361 the file COPYING in the PDL distribution. If this file is
 1362 separated from the PDL distribution, the copyright notice
 1363 should be included in the file.
 1364 
 1365 =cut
 1366 #line 1367 "Misc.pm"
 1367 
 1368 
 1369 
 1370 
 1371 # Exit with OK status
 1372 
 1373 1;