File Coverage

/root/.cpan/build/PDL-CCS-1.23.13-0/blib/lib/PDL/CCS/IO/Common.pm
Criterion Covered Total %
statement 15 65 23.0
branch 0 36 0.0
condition 0 26 0.0
subroutine 5 14 35.7
pod n/a
total 20 141 14.1


line stmt bran cond sub pod time code
1             ## File: PDL::CCS::IO::Common.pm
2             ## Author: Bryan Jurish
3             ## Description: common routines for PDL::CCS::Nd I/O
4              
5             package PDL::CCS::IO::Common;
6 4     4   29 use PDL::CCS::Config qw(ccs_indx);
  4         7  
  4         200  
7 4     4   22 use PDL::CCS::Nd;
  4         8  
  4         71  
8 4     4   20 use PDL;
  4         6  
  4         29  
9 4     4   12379 use Carp qw(confess);
  4         9  
  4         256  
10 4     4   26 use strict;
  4         8  
  4         4926  
11              
12             our $VERSION = '1.23.13';
13             our @ISA = ('PDL::Exporter');
14             our @EXPORT_OK =
15             (
16             qw(_ccsio_open _ccsio_close),
17             qw(_ccsio_read_header _ccsio_parse_header),
18             qw(_ccsio_write_header _ccsio_header_lines),
19             qw(_ccsio_opts_ix _ccsio_opts_nz),
20             );
21             our %EXPORT_TAGS =
22             (
23             Func => [], ##-- respect PDL conventions (hopefully)
24             intern => [@EXPORT_OK],
25             );
26              
27              
28             ##======================================================================
29             ## pod: headers
30             =pod
31              
32             =head1 NAME
33              
34             PDL::CCS::IO::Common - Common pseudo-private routines for PDL::CCS::Nd I/O
35              
36             =head1 SYNOPSIS
37              
38             use PDL;
39             use PDL::CCS::Nd;
40             use PDL::CCS::IO::Common qw(:intern);
41              
42             #... stuff happens
43              
44             =cut
45              
46             ##======================================================================
47             ## private utilities
48              
49             ## \%ixOpts = _ccsio_opts_ix(\%opts)
50             ## \%ixOpts = _ccsio_opts_ix(\%opts,\%defaults)
51             ## + extracts 'ixX' options from \%opts as 'X' options in \%ixOpts
52             sub _ccsio_opts_ix {
53 0   0 0     my $opts = { map {s/^ix//; ($_=>$_[0]{$_})} grep {/^ix/} keys %{$_[0]//{}} };
  0            
  0            
  0            
  0            
54 0   0       $opts->{$_} //= $_[1]{$_} foreach (keys %{$_[1]//{}});
  0   0        
55 0           return $opts;
56             }
57              
58             ## \%nzOpts = _ccsio_opts_nz(\%opts)
59             ## \%nzOpts = _ccsio_opts_nz(\%opts,\%defaults)
60             ## + extracts 'nzX' options from \%opts as 'X' options in \%nzOpts
61             sub _ccsio_opts_nz {
62 0   0 0     my $opts = { map {s/^nz//; ($_=>$_[0]{$_})} grep {/^nz/} keys %{$_[0]//{}} };
  0            
  0            
  0            
  0            
63 0   0       $opts->{$_} //= $_[1]{$_} foreach (keys %{$_[1]//{}});
  0   0        
64 0           return $opts;
65             }
66              
67             ## $fh_or_undef = _ccsio_open($filename_or_handle,$mode)
68             sub _ccsio_open {
69 0     0     my ($file,$mode) = @_;
70 0 0         return $file if (ref($file));
71 0 0         $mode = '<' if (!defined($mode));
72 0           open(my $fh, $mode, $file);
73 0           return $fh;
74             }
75              
76             ## $fh_or_undef = _ccsio_close($filename_or_handle,$fh)
77             sub _ccsio_close {
78 0     0     my ($file,$fh) = @_;
79 0 0         return 1 if (ref($file)); ##-- don't close if we got a handle
80 0           return close($fh);
81             }
82              
83              
84             ## \%header = _ccsio_read_header( $hfile)
85             sub _ccsio_read_header {
86 0     0     my $hFile = shift;
87 0 0         my $hfh = _ccsio_open($hFile,'<')
88             or confess("_ccsio_read_header(): open failed for header-file $hFile: $!");
89 0           binmode($hfh,':raw');
90 0           my @hlines = <$hfh>;
91 0 0         _ccsio_close($hFile,$hfh)
92             or confess("_ccsio_read_header(): close failed for header-file $hFile: $!");
93 0           return _ccsio_parse_header(\@hlines);
94             }
95              
96             ## \%header = _ccsio_parse_header(\@hlines)
97             sub _ccsio_parse_header {
98 0     0     my $hlines = shift;
99 0           my ($magic,$pdims,$vdims,$flags,$iotype) = map {chomp;$_} @$hlines;
  0            
  0            
100             return {
101 0 0 0       magic=>$magic,
    0 0        
    0 0        
    0 0        
102             (defined($pdims) && $pdims ne '' ? (pdims=>pdl(ccs_indx(),[split(' ',$pdims)])) : qw()),
103             (defined($vdims) && $vdims ne '' ? (vdims=>pdl(ccs_indx(),[split(' ',$vdims)])) : qw()),
104             (defined($flags) && $flags ne '' ? (flags=>$flags) : qw()),
105             (defined($iotype) && $iotype ne '' ? (iotype=>$iotype) : qw()), ##-- added in v1.22.6
106             };
107             }
108              
109             ## $bool = _ccsio_write_header(\%header, $hfile)
110             ## $bool = _ccsio_write_header( $ccs, $hfile)
111             sub _ccsio_write_header {
112 0     0     my ($header,$hFile) = @_;
113 0 0         my $hfh = _ccsio_open($hFile,'>')
114             or confess("_ccsio_write_header(): open failed for header-file $hFile: $!");
115 0           binmode($hfh,':raw');
116 0           local $, = '';
117 0           print $hfh @{_ccsio_header_lines($header)};
  0            
118 0 0         _ccsio_close($hFile,$hfh)
119             or confess("_ccsio_write_header(): close failed for header-file $hFile: $!");
120 0           return 1;
121             }
122              
123             ## \@header_lines = _ccsio_header_lines(\%header)
124             ## \@header_lines = _ccsio_header_lines( $ccs)
125             sub _ccsio_header_lines {
126 0     0     my $header = shift;
127 0 0         $header = _ccsio_header($header) if (UNIVERSAL::isa($header,'PDL::CCS::Nd'));
128             return [
129 0           map {"$_\n"}
130             (defined($header->{magic}) ? $header->{magic} : ''),
131             (defined($header->{pdims}) ? (join(' ', $header->{pdims}->list)) : ''),
132             (defined($header->{vdims}) ? (join(' ', $header->{vdims}->list)) : ''),
133             (defined($header->{flags}) ? $header->{flags} : $PDL::CCS::Nd::CCSND_FLAGS_DEFAULT),
134 0 0         (defined($header->{iotype}) ? $header->{iotype} : $PDL::IO::Misc::deftype),
    0          
    0          
    0          
    0          
135             ];
136             }
137              
138             ## \%header = _ccsio_header( $ccs)
139             ## \%header = _ccsio_header(\%header)
140             sub _ccsio_header {
141 0     0     my $ccs = shift;
142 0 0         return $ccs if (!UNIVERSAL::isa($ccs,'PDL::CCS::Nd'));
143             return {
144 0           magic=>(ref($ccs)." $VERSION"),
145             pdims=>$ccs->pdims,
146             vdims=>$ccs->vdims,
147             flags=>$ccs->flags,
148             iotype=>$ccs->type,
149             };
150             }
151              
152              
153              
154             1; ##-- be happy
155              
156             ##======================================================================
157             ## POD: footer
158             =pod
159              
160             =head1 ACKNOWLEDGEMENTS
161              
162             Perl by Larry Wall.
163              
164             PDL by Karl Glazebrook, Tuomas J. Lukka, Christian Soeller, and others.
165              
166             =cut
167              
168              
169             ##---------------------------------------------------------------------
170             =pod
171              
172             =head1 AUTHOR
173              
174             Bryan Jurish Emoocow@cpan.orgE
175              
176             =head2 Copyright Policy
177              
178             Copyright (C) 2015-2018, Bryan Jurish. All rights reserved.
179              
180             This package is free software, and entirely without warranty.
181             You may redistribute it and/or modify it under the same terms
182             as Perl itself.
183              
184             =head1 SEE ALSO
185              
186             L,
187             L,
188             L,
189             L,
190             L,
191             L,
192             L,
193             ...
194              
195             =cut