File Coverage

blib/lib/DiaColloDB/Utils.pm
Criterion Covered Total %
statement 79 551 14.3
branch 0 436 0.0
condition 0 161 0.0
subroutine 31 114 27.1
pod 63 75 84.0
total 173 1337 12.9


line stmt bran cond sub pod time code
1             ## -*- Mode: CPerl -*-
2             ##
3             ## File: DiaColloDB::Utils.pm
4             ## Author: Bryan Jurish <moocow@cpan.org>
5             ## Description: generic DiaColloDB utilities
6              
7             package DiaColloDB::Utils;
8 2     2   16 use DiaColloDB::Logger;
  2         4  
  2         62  
9 2     2   10 use Exporter;
  2         4  
  2         88  
10 2     2   2402 use JSON;
  2         25506  
  2         12  
11 2     2   1370 use IO::Handle;
  2         12000  
  2         90  
12 2     2   964 use IO::File;
  2         3714  
  2         236  
13 2     2   4188 use IPC::Run;
  2         61614  
  2         104  
14 2     2   20 use File::Basename qw(basename dirname);
  2         6  
  2         158  
15 2     2   16 use File::Path qw(make_path);
  2         48  
  2         148  
16 2     2   1114 use File::Copy qw();
  2         4852  
  2         54  
17 2     2   16 use File::Spec qw(); ##-- for tmpdir()
  2         8  
  2         32  
18 2     2   1532 use File::Temp qw(); ##-- for tempdir(), tempfile()
  2         19902  
  2         70  
19 2     2   20 use Fcntl qw(:DEFAULT SEEK_SET SEEK_CUR SEEK_END);
  2         4  
  2         872  
20 2     2   14 use Time::HiRes qw(gettimeofday tv_interval);
  2         4  
  2         18  
21 2     2   368 use POSIX qw(strftime);
  2         4  
  2         20  
22 2     2   3520 use Carp;
  2         6  
  2         132  
23 2     2   12 use strict;
  2         4  
  2         2856  
24              
25             ##==============================================================================
26             ## Globals
27              
28             our @ISA = qw(Exporter DiaColloDB::Logger);
29             our @EXPORT = qw();
30             our %EXPORT_TAGS =
31             (
32             fcntl => [qw(fcflags fcread fcwrite fctrunc fccreat fcperl fcopen fcgetfl)],
33             json => [qw(jsonxs loadJsonString loadJsonFile saveJsonString saveJsonFile)],
34             sort => [qw(csort_to csortuc_to)],
35             run => [qw(crun opencmd runcmd)],
36             env => [qw(env_set env_push env_pop)],
37             pack => [qw(packsize packsingle packeq packFilterFetch packFilterStore)],
38             math => [qw(isNan isInf isFinite $LOG2 log2 min2 max2 lmax lmin lsum)],
39             list => [qw(luniq sluniq xluniq lcounts)],
40             regex => [qw(regex)],
41             html => [qw(htmlesc)],
42             ddc => [qw(ddc_escape)],
43             time => [qw(s2hms s2timestr timestamp)],
44             file => [qw(file_mtime file_timestamp du_file du_glob copyto moveto copyto_a cp_a fh_flush fh_reopen)],
45             si => [qw(si_str)],
46             pdl => [qw(_intersect_p _union_p _complement_p _setdiff_p),
47             qw(readPdlFile writePdlFile writePdlHeader writeCcsHeader mmzeroes mmtemp),
48             qw(maxval mintype),
49             ],
50             temp => [qw($TMPDIR tmpdir tmpfh tmpfile tmparray tmparrayp tmphash)],
51             jobs => [qw(nCores nJobs sortJobs)],
52             );
53             our @EXPORT_OK = map {@$_} values(%EXPORT_TAGS);
54             $EXPORT_TAGS{all} = [@EXPORT_OK];
55              
56             ##==============================================================================
57             ## Functions: Fcntl
58              
59             ## $flags = PACKAGE::fcflags($flags)
60             ## + returns Fcntl flags for symbolic string $flags
61             sub fcflags {
62 0     0 1   my $flags = shift;
63 0   0       $flags //= 'r';
64 0 0         return $flags if ($flags =~ /^[0-9]+$/); ##-- numeric flags are interpreted as Fcntl bitmask
65 0           my $fread = $flags =~ /[r<]/;
66 0           my $fwrite = $flags =~ /[wa>\+]/;
67 0   0       my $fappend = ($flags =~ /[a]/ || $flags =~ />>/);
68 0 0         my $iflags = ($fread
    0          
    0          
69             ? ($fwrite ? (O_RDWR|O_CREAT) : O_RDONLY)
70             : ($fwrite ? (O_WRONLY|O_CREAT) : 0)
71             );
72 0 0 0       $iflags |= O_TRUNC if ($fwrite && !$fappend);
73 0           return $iflags;
74             }
75              
76             ## $fcflags = fcgetfl($fh)
77             ## + returns Fcntl flags for filehandle $fh
78             sub fcgetfl {
79 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
80 0           my $fh = shift;
81 0           return CORE::fcntl($fh,F_GETFL,0);
82             }
83              
84             ## $bool = fcread($flags)
85             ## + returns true if any read-bits are set for $flags
86             sub fcread {
87 0     0 1   my $flags = fcflags(shift);
88 0   0       return ($flags&O_RDONLY)==O_RDONLY || ($flags&O_RDWR)==O_RDWR;
89             }
90              
91             ## $bool = fcwrite($flags)
92             ## + returns true if any write-bits are set for $flags
93             sub fcwrite {
94 0     0 1   my $flags = fcflags(shift);
95 0   0       return ($flags&O_WRONLY)==O_WRONLY || ($flags&O_RDWR)==O_RDWR;
96             }
97              
98             ## $bool = fctrunc($flags)
99             ## + returns true if truncate-bits are set for $flags
100             sub fctrunc {
101 0     0 1   my $flags = fcflags(shift);
102 0           return ($flags&O_TRUNC)==O_TRUNC;
103             }
104              
105             ## $bool = fccreat($flags)
106             sub fccreat {
107 0     0 1   my $flags = fcflags(shift);
108 0           return ($flags&O_CREAT)==O_CREAT;
109             }
110              
111             ## $str = fcperl($flags)
112             ## + return perl mode-string for $flags
113             sub fcperl {
114 0     0 1   my $flags = fcflags(shift);
115 0 0         return (fcread($flags)
    0          
    0          
    0          
    0          
116             ? (fcwrite($flags) ##-- +read
117             ? (fctrunc($flags) ##-- +read,+write
118             ? '+>' : '+<') ##-- +read,+write,+/-trunc
119             : '<')
120             : (fcwrite($flags) ##-- -read
121             ? (fctrunc($flags) ##-- -read,+write
122             ? '>' : '>>') ##-- -read,+write,+/-trunc
123             : '<') ##-- -read,-write : default
124             );
125             }
126              
127             ## $fh_or_undef = fcopen($file,$flags)
128             ## $fh_or_undef = fcopen($file,$flags,$mode,$perms)
129             ## + opens $file with fcntl-style flags $flags
130             sub fcopen {
131 0     0 1   my ($file,$flags,$perms) = @_;
132 0           $flags = fcflags($flags);
133 0   0       $perms //= (0666 & ~umask);
134 0           my $mode = fcperl($flags);
135              
136 0           my ($sysfh);
137 0 0         if (ref($file)) {
138             ##-- dup an existing filehandle
139 0           $sysfh = $file;
140             }
141             else {
142             ##-- use sysopen() to honor O_CREAT and O_TRUNC
143 0 0         sysopen($sysfh, $file, $flags, $perms) or return undef;
144             }
145              
146             ##-- now open perl-fh from system fh
147 0 0         open(my $fh, "${mode}&=", fileno($sysfh)) or return undef;
148 0 0 0       if (fcwrite($flags) && !fctrunc($flags)) {
149             ##-- append mode: seek to end of file
150 0 0         seek($fh, 0, SEEK_END) or return undef;
151             }
152 0           return $fh;
153             }
154              
155             ##==============================================================================
156             ## Functions: JSON
157              
158             ##--------------------------------------------------------------
159             ## JSON: load
160              
161             ## $data = PACKAGE::loadJsonString( $string,%opts)
162             ## $data = PACKAGE::loadJsonString(\$string,%opts)
163             ## + %opts passed to JSON::from_json(), e.g. (relaxed=>0)
164             ## + supports $opts{json} = $json_obj
165             sub loadJsonString {
166 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
167 0 0         my $bufr = ref($_[0]) ? $_[0] : \$_[0];
168 0           my %opts = @_[1..$#_];
169 0 0         return $opts{json}->decode($$bufr) if ($opts{json});
170 0           return from_json($$bufr, {utf8=>!utf8::is_utf8($$bufr), relaxed=>1, allow_nonref=>1, %opts});
171             }
172              
173             ## $data = PACKAGE::loadJsonFile($filename_or_handle,%opts)
174             sub loadJsonFile {
175 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
176 0           my $file = shift;
177 0 0         my $fh = ref($file) ? $file : IO::File->new("<$file");
178 0 0         return undef if (!$fh);
179 0           binmode($fh,':raw');
180 0           local $/=undef;
181 0           my $buf = <$fh>;
182 0 0         close($fh) if (!ref($file));
183 0           return $that->loadJsonString(\$buf,@_);
184             }
185              
186             ##--------------------------------------------------------------
187             ## JSON: save
188              
189             ## $str = PACKAGE::saveJsonString($data)
190             ## $str = PACKAGE::saveJsonString($data,%opts)
191             ## + %opts passed to JSON::to_json(), e.g. (pretty=>0, canonical=>0)'
192             ## + supports $opts{json} = $json_obj
193             sub saveJsonString {
194 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
195 0           my $data = shift;
196 0           my %opts = @_;
197 0 0         return $opts{json}->encode($data) if ($opts{json});
198 0           return to_json($data, {utf8=>1, allow_nonref=>1, allow_unknown=>1, allow_blessed=>1, convert_blessed=>1, pretty=>1, canonical=>1, %opts});
199             }
200              
201             ## $bool = PACKAGE::saveJsonFile($data,$filename_or_handle,%opts)
202             sub saveJsonFile {
203 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
204 0           my $data = shift;
205 0           my $file = shift;
206 0 0         my $fh = ref($file) ? $file : IO::File->new(">$file");
207 0 0         $that->logconfess("saveJsonFile() failed to open file '$file': $!") if (!$fh);
208 0           binmode($fh,':raw');
209 0 0         $fh->print($that->saveJsonString($data,@_)) or return undef;
210 0 0         if (!ref($file)) { close($fh) || return undef; }
  0 0          
211 0           return 1;
212             }
213              
214             ##--------------------------------------------------------------
215             ## JSON: object
216              
217             ## $json = jsonxs()
218             ## $json = jsonxs(%opts)
219             ## $json = jsonxs(\%opts)
220             sub jsonxs {
221 0 0   0 0   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
222             my %opts = (
223             utf8=>1, relaxed=>1, allow_nonref=>1, allow_unknown=>1, allow_blessed=>1, convert_blessed=>1, pretty=>1, canonical=>1,
224 0 0         (@_==1 ? %{$_[0]} : @_),
  0            
225             );
226 0           my $jxs = JSON->new;
227 0           foreach (grep {$jxs->can($_)} keys %opts) {
  0            
228 0           $jxs->can($_)->($jxs,$opts{$_});
229             }
230 0           return $jxs;
231             }
232              
233 2     2   1600 BEGIN { *json = \&jsonxs; }
234              
235             ##==============================================================================
236             ## Functions: env
237              
238              
239             ## \%setenv = PACKAGE::env_set(%setenv)
240             sub env_set {
241 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
242 0           my %setenv = @_;
243 0           my ($key,$val);
244 0           while (($key,$val)=each(%setenv)) {
245 0 0         if (!defined($val)) {
246             #$that->trace("ENV_UNSET $key");
247 0           delete($ENV{$key});
248             } else {
249             #$that->trace("ENV_SET $key=$val");
250 0           $ENV{$key} = $val;
251             }
252             }
253 0           return \%setenv;
254             }
255              
256             ## \%oldvals = PACKAGE::env_push(%setenv)
257             our @env_stack = qw();
258             sub env_push {
259 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
260 0           my %setenv = @_;
261 0           my %oldenv = map {($_=>$ENV{$_})} keys %setenv;
  0            
262 0           push(@env_stack, \%oldenv);
263 0           $that->env_set(%setenv);
264 0           return \%oldenv;
265             }
266              
267             ## \%restored = PACKAGE::env_pop(%setenv)
268             sub env_pop {
269 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
270 0           my $oldvals = pop(@env_stack);
271 0 0         $that->env_set(%$oldvals) if ($oldvals);
272 0           return $oldvals;
273             }
274              
275              
276             ##==============================================================================
277             ## Functions: run
278              
279             ## $rc = PACKAGE::runcmd($cmd)
280             ## $rc = PACKAGE::runcmd(@cmd)
281             ## + does log trace at level $TRACE_RUNCMD
282             sub runcmd {
283 0 0   0 0   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
284 0           $that->trace("CMD ", join(' ',@_));
285 0           return system(@_);
286             }
287              
288             ## $fh_or_undef = PACKAGE::opencmd($cmd)
289             ## $fh_or_undef = PACKAGE::opencmd($mode,@argv)
290             ## + does log trace at level $TRACE_RUNCMD
291             sub opencmd {
292 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
293 0           $that->trace("CMD ", join(' ',@_));
294 0           my $fh = IO::Handle->new();
295 0 0         if ($#_ > 0) {
296 0           open($fh,$_[0],$_[1],@_[2..$#_])
297             } else {
298 0           open($fh,$_[0]);
299             }
300 0 0         $that->logconfess("opencmd() failed for \`", join(' ',@_), "': $!") if (!$fh);
301 0           return $fh;
302             }
303              
304             ## $bool = crun(@IPC_Run_args)
305             ## + wrapper for IPC::Run::run(@IPC_Run_args) with $ENV{LC_ALL}='C'
306             sub crun {
307 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
308             $that->trace("RUN ", join(' ',
309             map {
310 0 0         (ref($_)
  0 0          
311             ? (ref($_) eq 'ARRAY'
312             ? join(' ', @$_)
313             : ref($_))
314             : $_)
315             } @_));
316 0           $that->env_push(LC_ALL=>'C');
317 0           my $rc = IPC::Run::run(@_);
318 0           $that->env_pop();
319 0           return $rc;
320             }
321              
322             ## $bool = csort_to(\@sortargs, \&catcher)
323             ## + runs system sort and feeds resulting lines to \&catcher
324             sub csort_to {
325 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
326 0           my ($sortargs,$catcher) = @_;
327 0           return crun(['sort',@$sortargs], '>', IPC::Run::new_chunker("\n"), $catcher);
328             }
329              
330             ## $bool = csortuc_to(\@sortargs, \&catcher)
331             ## + runs system sort | uniq -c and feeds resulting lines to \&catcher
332             sub csortuc_to {
333 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
334 0           my ($sortargs,$catcher) = @_;
335 0           return crun(['sort',@$sortargs], '|', [qw(uniq -c)], '>', IPC::Run::new_chunker("\n"), $catcher);
336             }
337              
338              
339             ##==============================================================================
340             ## Functions: pack filters
341              
342             ## $len = PACKAGE::packsize($packfmt)
343             ## $len = PACKAGE::packsize($packfmt,@args)
344             ## + get pack-size for $packfmt with args @args
345             sub packsize {
346 2     2   18 use bytes; #use bytes; ##-- deprecated in perl v5.18.2
  2         4  
  2         18  
347 2     2   112 no warnings;
  2         6  
  2         1250  
348 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
349 0           return bytes::length(pack($_[0],@_[1..$#_]));
350             }
351              
352             ## $bool = PACKAGE::packsingle($packfmt)
353             ## $bool = PACKAGE::packsingle($packfmt,@args)
354             ## + guess whether $packfmt is a single-element (scalar) format
355             sub packsingle {
356 0 0   0 0   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
357 0   0       return (packsize($_[0],0)==packsize($_[0],0,0)
358             && $_[0] !~ m{\*|(?:\[(?:[2-9]|[0-9]{2,})\])|(?:[[:alpha:]].*[[:alpha:]])});
359             }
360              
361             ## $bool = PACKAGE::packeq($packfmt1,$packfmt2,$val=0x123456789abcdef)
362             ## + returns true iff $packfmt1 and $packfmt2 are equivalent for $val
363             sub packeq {
364 0 0   0 0   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
365 0           my ($fmt1,$fmt2,$val) = @_;
366 0   0       $val //= 0x12345678;
367 0           return pack($fmt1,$val) eq pack($fmt2,$val);
368             }
369              
370             ## \&filter_sub = PACKAGE::packFilterStore($pack_template)
371             ## \&filter_sub = PACKAGE::packFilterStore([$pack_template_store, $pack_template_fetch])
372             ## \&filter_sub = PACKAGE::packFilterStore([\&pack_code_store, \&pack_code_fetch])
373             ## + returns a DB_File-style STORE-filter sub for transparent packing of data to $pack_template
374             sub packFilterStore {
375 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
376 0           my $packas = shift;
377 0 0         $packas = $packas->[0] if (UNIVERSAL::isa($packas,'ARRAY'));
378 0 0         return $packas if (UNIVERSAL::isa($packas,'CODE'));
379 0 0 0       return undef if (!$packas || $packas eq 'raw');
380 0 0         if ($that->packsingle($packas)) {
381             return sub {
382 0 0   0     $_ = pack($packas,$_) if (defined($_));
383 0           };
384             } else {
385             return sub {
386 0 0   0     $_ = pack($packas, ref($_) ? @$_ : split(/\t/,$_)) if (defined($_));
    0          
387 0           };
388             }
389             }
390              
391             ## \&filter_sub = PACKAGE::packFilterFetch($pack_template)
392             ## \&filter_sub = PACKAGE::packFilterFetch([$pack_template_store, $pack_template_fetch])
393             ## \&filter_sub = PACKAGE::packFilterFetch([\&pack_code_store, \&pack_code_fetch])
394             ## + returns a DB_File-style FETCH-filter sub for transparent unpacking of data from $pack_template
395             sub packFilterFetch {
396 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
397 0           my $packas = shift;
398 0 0         $packas = $packas->[1] if (UNIVERSAL::isa($packas,'ARRAY'));
399 0 0         return $packas if (UNIVERSAL::isa($packas,'CODE'));
400 0 0 0       return undef if (!$packas || $packas eq 'raw');
401 0 0         if ($that->packsingle($packas)) {
402             return sub {
403 0     0     $_ = unpack($packas,$_);
404 0           };
405             } else {
406             return sub {
407 0     0     $_ = [unpack($packas,$_)];
408             }
409 0           }
410             }
411              
412             ##==============================================================================
413             ## Math stuff
414              
415             sub isNan {
416 2     2   16 no warnings qw(uninitialized numeric);
  2         4  
  2         146  
417 0   0 0 0   return !($_[0]<=0||$_[0]>=0);
418             }
419             sub isInf {
420 2     2   14 no warnings qw(uninitialized numeric);
  2         4  
  2         248  
421 0   0 0 0   return !($_[0]<=0||$_[0]>=0) || ($_[0]==+"INF") || ($_[0]==-"INF");
422             }
423             sub isFinite {
424 2     2   14 no warnings qw(uninitialized numeric);
  2         4  
  2         204  
425 0   0 0 0   return ($_[0]<=0||$_[0]>=0) && ($_[0]!=+"INF") && ($_[0]!=-"INF");
426             }
427              
428             our ($LOG2);
429             BEGIN {
430 2     2   5846 $LOG2 = log(2.0);
431             }
432              
433             ## $log2 = log2($x)
434             sub log2 {
435 0 0   0 1   return $_[0]==0 ? -inf : log($_[0])/$LOG2;
436             }
437              
438             ## $max2 = max2($x,$y)
439             sub max2 {
440 0 0   0 1   return $_[0] > $_[1] ? $_[0] : $_[1];
441             }
442              
443             ## $min2 = min2($x,$y)
444             sub min2 {
445 0 0   0 1   return $_[0] < $_[1] ? $_[0] : $_[1];
446             }
447              
448             ## $max = lmax(@vals)
449             sub lmax {
450 0     0 0   my $max = undef;
451 0           foreach (@_) {
452 0 0 0       $max = $_ if (!defined($max) || (defined($_) && $_ > $max));
      0        
453             }
454 0           return $max;
455             }
456              
457             ## $min = lmin(@vals)
458             sub lmin {
459 0     0 0   my $min = undef;
460 0           foreach (@_) {
461 0 0 0       $min = $_ if (!defined($min) || (defined($_) && $_ < $min));
      0        
462             }
463 0           return $min;
464             }
465              
466             ## $sum = lsum(@vals)
467             sub lsum {
468 0     0 0   my $sum = 0;
469 0           $sum += $_ foreach (grep {defined($_)} @_);
  0            
470 0           return $sum;
471             }
472              
473             ##==============================================================================
474             ## Functions: lists
475              
476             ## \@l_uniq = luniq(\@l)
477             ## + returns unique defined elements of @l; @l need not be sorted
478             sub luniq {
479 0     0 1   my ($tmp);
480 0 0 0       return [map {defined($tmp) && $tmp eq $_ ? qw() : ($tmp=$_)} sort grep {defined($_)} @{$_[0]//[]}];
  0   0        
  0            
  0            
481             }
482              
483             ## \@l_sorted_uniq = sluniq(\@l_sorted)
484             ## + returns unique defined elements of pre-sorted @l
485             sub sluniq {
486 0     0 1   my ($tmp);
487 0 0 0       return [map {defined($tmp) && $tmp eq $_ ? qw() : ($tmp=$_)} grep {defined($_)} @{$_[0]//[]}];
  0   0        
  0            
  0            
488             }
489              
490             ## \@l_uniq = xluniq(\@l,\&keyfunc)
491             ## + returns elements of @l with unique defined keys according to \&keyfunc (default=\&overload::StrVal)
492             sub xluniq {
493 0     0 1   my ($l,$keyfunc) = @_;
494 0   0       $keyfunc //= \&overload::StrVal;
495 0           my $tmp;
496             return [
497 0           map {$_->[1]}
498 0 0 0       map {defined($tmp) && $tmp->[0] eq $_->[0] ? qw() : ($tmp=$_)}
499 0           sort {$a->[0] cmp $b->[0]}
500 0           grep {defined($_->[0])}
501 0           map {[$keyfunc->($_),$_]}
502 0   0       @{$l//[]}
  0            
503             ];
504             }
505              
506             ## \%l_counts = lcounts(\@l)
507             ## + return occurrence counts for elements of @l
508             sub lcounts {
509 0     0 0   my %counts = qw();
510 0   0       ++$counts{$_} foreach (grep {defined($_)} @{$_[0]//[]});
  0            
  0            
511 0           return \%counts;
512             }
513              
514             ##==============================================================================
515             ## Functions: regexes
516              
517             ## $re = regex($re_str)
518             ## + parses "/"-quoted regex $re_str
519             ## + parses modifiers /[gimsadlu] a la ddc
520             sub regex {
521 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
522 0           my $re = shift;
523 0 0         return $re if (ref($re));
524 0           $re =~ s/^\s*\///;
525              
526 0 0         my $mods = ($re =~ s/\/([gimsadlux]*)\s*$// ? $1 : '');
527 0 0         if ($mods =~ s/g//g) {
    0          
528 0           $re = "^(?${mods}:${re})\$"; ##-- parse /g modifier a la ddc
529             } elsif ($mods) {
530 0           $re = "(?${mods}:$re)";
531             }
532              
533 0           return qr{$re};
534             }
535              
536             ##==============================================================================
537             ## Functions: html
538              
539             ## $escaped = htmlesc($str)
540             sub htmlesc {
541             ##-- html escapes
542 0     0 1   my $str = shift;
543 0           $str =~ s/\&/\&amp;/sg;
544 0           $str =~ s/\'/\&#39;/sg;
545 0           $str =~ s/\"/\&quot;/sg;
546 0           $str =~ s/\</\&lt;/sg;
547 0           $str =~ s/\>/\&gt;/sg;
548 0           return $str;
549             }
550              
551             ##==============================================================================
552             ## Functions: ddc
553              
554             ## $escaped_str = ddc_escape($str)
555             ## $escaped_str = ddc_escape($str, $addQuotes=1)
556             sub ddc_escape {
557 0 0   0 0   shift(@_) if (UNIVERSAL::isa($_[0],__PACKAGE__));
558 0 0         return $_[0] if ($_[0] =~ /^[a-zA-Z][a-zA-Z0-9]*$/s); ##-- bareword ok
559 0           my $s = shift;
560 0           $s =~ s/\\/\\\\/g;
561 0           $s =~ s/\'/\\'/g;
562 0 0 0       return !exists($_[1]) || $_[1] ? "'$s'" : $s;
563             }
564              
565             ##==============================================================================
566             ## Functions: time
567              
568             ## $hms = PACKAGE::s2hms($seconds,$sfmt="%06.3f")
569             ## ($h,$m,$s) = PACKAGE::s2hms($seconds,$sfmt="%06.3f")
570             sub s2hms {
571 0 0   0 1   shift(@_) if (UNIVERSAL::isa($_[0],__PACKAGE__));
572 0           my ($secs,$sfmt) = @_;
573 0   0       $sfmt ||= '%06.3f';
574 0           my $h = int($secs/(60*60));
575 0           $secs -= $h*60*60;
576 0           my $m = int($secs/60);
577 0           $secs -= $m*60;
578 0           my $s = sprintf($sfmt, $secs);
579 0 0         return wantarray ? ($h,$m,$s) : sprintf("%02d:%02d:%s", $h,$m,$s);
580             }
581              
582             ## $timestr = PACKAGE::s2timestr($seconds,$sfmt="%f")
583             sub s2timestr {
584 0 0   0 1   shift(@_) if (UNIVERSAL::isa($_[0],__PACKAGE__));
585 0           my ($h,$m,$s) = s2hms(@_);
586 0 0 0       if ($h==0 && $m==0) {
    0          
587 0           $s =~ s/^0+(?!\.)//;
588 0           return "${s}s";
589             }
590             elsif ($h==0) {
591 0           return sprintf("%2dm%ss",$m,$s)
592             }
593 0           return sprintf("%dh%02dm%ss",$h,$m,$s);
594             }
595              
596             ## $rfc_timestamp = PACAKGE->timestamp()
597             ## $rfc_timestamp = PACAKGE->timestamp($time)
598             sub timestamp {
599 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
600 0 0         return POSIX::strftime("%Y-%m-%dT%H:%M:%SZ", (@_ ? gmtime($_[0]) : gmtime()));
601             }
602              
603             ##==============================================================================
604             ## Functions: file
605              
606             ## $mtime = PACKAGE->file_mtime($file_or_fh)
607             sub file_mtime {
608 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
609 0   0       return (stat($_[0]))[9] // 0;
610             }
611              
612             ## $timestamp = PACKAGE->file_timestamp($file_or_fh)
613             sub file_timestamp {
614 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
615 0           return timestamp(file_mtime(@_));
616             }
617              
618             ## $nbytes = du_file(@filenames_or_dirnames_or_fhs)
619             sub du_file {
620 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
621 0           my $du = 0;
622 0           foreach (@_) {
623 0 0 0       $du += (!ref($_) && -d $_ ? du_glob("$_/*") : (-s $_))//0;
      0        
624             }
625 0           return $du;
626             }
627              
628             ## $nbytes = du_glob(@globs)
629             sub du_glob {
630 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
631 0           return du_file(map {glob($_)} @_);
  0            
632             }
633              
634             ## $bool = PACKAGE->copyto($srcfile, $dstdir, %opts)
635             ## $bool = PACKAGE->copyto(\@srcfiles, $dstdir, %opts)
636             ## + copies file(s) $srcfile (first form) or @srcfiles (second form) to $dstdir, creating $dstdir if it doesn't already exist;
637             ## options %opts:
638             ## (
639             ## from => $from, ##-- replace prefix $from in file(s) with $todir; default=undef: flat copy to $todir
640             ## method => \&method, ##-- use CODE-ref \&method as underlying copy routing; default=\&File::Copy::copy
641             ## label => $label, ##-- report errors as '$label'; (default='copyto()')
642             ## )
643             sub copyto {
644 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
645 0           my ($srcfiles,$todir,%opts) = @_;
646 0   0       my $method = $opts{method} || \&File::Copy::copy;
647 0   0       my $label = $opts{label} || 'copyto()';
648 0           my $from = $opts{from};
649 0           my ($src,$dst,$dstdir);
650 0 0         foreach $src (UNIVERSAL::isa($srcfiles,'ARRAY') ? @$srcfiles : $srcfiles) {
651 0 0         if (defined($from)) {
652 0           ($dst = $src) =~ s{^\Q$from\E}{$todir};
653             } else {
654 0           $dst = "$todir/".basename($src);
655             }
656 0           $dstdir = dirname($dst);
657 0 0 0       -d $dstdir
658             or make_path($dstdir)
659             or $that->logconfess("$label: failed to create target directory '$dstdir': $!");
660 0 0         $method->($src,$dst)
661             or $that->logconfess("$label: failed to transfer file '$src' to to '$dst': $!");
662             }
663 0           return 1;
664             }
665              
666             ## $bool = PACKAGE->copyto_a($src,$dstdir,%opts)
667             ## + wrapper for PACKAGE->copyto($src,$dstdir, %opts,method=>PACKAGE->can('cp_a'),label=>'copyto_a()')
668             sub copyto_a {
669 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
670 0           return $that->copyto(@_, method=>\&cp_a, label=>'copyto_a()');
671             }
672              
673             ## $bool = PACKAGE->moveto($src,$dstdir, %opts)
674             ## + wrapper for PACKAGE->copyto($src,$dstdir, %opts,method=>\&File::Copy::move,label=>'moveto()')
675             sub moveto {
676 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
677 0           return $that->copyto(@_, method=>\&File::Copy::move, label=>'moveto()');
678             }
679              
680             ## $bool = PACKAGE->cp_a($src,$dst)
681             ## $bool = PACKAGE->cp_a($src,$dstdir)
682             ## + copies file $src to $dst, propagating ownership, permissions, and timestamps
683             sub cp_a {
684 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
685 0           my ($src,$dst) = @_;
686 0 0 0       if (File::Copy->can('syscopy') && File::Copy->can('syscopy') ne File::Copy->can('copy')) {
687             ##-- use File::copy::syscopy() if available
688 0           return File::Copy::syscopy($src,$dst,3);
689             }
690             ##-- copy and then manually propagate file attributes
691 0 0         my $rc = File::Copy::copy($src,$dst) or return undef;
692 0 0         $dst = "$dst/".basename($src) if (-d $dst);
693 0           my @stat = stat($src);
694 0           my ($perm,$gid,$atime,$mtime) = @stat[2,5,8,9];
695 0 0         my $uid = $>==0 ? $stat[4] : $>; ##-- don't try to set uid unless we're running as root
696 0 0 0       $rc &&= CORE::chown($uid,$gid,$dst)
697             or $that->warn("cp_a(): failed to propagate ownership from '$src' to '$dst': $!");
698 0 0 0       $rc &&= CORE::chmod(($perm & 07777), $dst)
699             or $that->warn("cp_a(): failed to propagate persmissions from '$src' to '$dst': $!");
700 0 0 0       $rc &&= CORE::utime($atime,$mtime,$dst)
701             or $that->warn("cp_a(): failed to propagate timestamps from '$src' to '$dst': $!");
702 0           return $rc;
703             }
704              
705             ## $fh_or_undef = PACKAGE->fh_flush($fh)
706             ## + flushes filehandle $fh using its flush() method if available
707             sub fh_flush {
708 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
709 0           my $fh = shift;
710 0 0         return UNIVERSAL::can($fh,'flush') ? $fh->flush() : $fh;
711             }
712              
713             ## $fh_or_undef = PACKAGE->fh_reopen($fh,$file)
714             ## + closes and re-opens filehandle $fh
715             sub fh_reopen {
716 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
717 0           my ($fh,$file) = @_;
718 0           my $flags = fcgetfl($fh) & (~O_TRUNC);
719 0           my @layers0 = PerlIO::get_layers($fh);
720 0 0         CORE::close($fh) || return undef;
721 0 0         CORE::open($fh, fcperl($flags), $file) or return undef;
722 0           my @layers1 = PerlIO::get_layers($fh);
723 0   0       while (@layers0 && @layers1 && $layers0[0] eq $layers1[0]) {
      0        
724 0           shift(@layers0);
725 0           shift(@layers1);
726             }
727 0           binmode($fh,":$_") foreach (@layers1);
728 0           return $fh;
729             }
730              
731              
732              
733             ##==============================================================================
734             ## Utils: SI
735              
736             ## $str = si_str($float)
737             sub si_str {
738 0 0   0 1   shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
739 0           my $x = shift;
740 0 0         return sprintf("%.2fY", $x/10**24) if ($x >= 10**24); ##-- yotta
741 0 0         return sprintf("%.2fZ", $x/10**21) if ($x >= 10**21); ##-- zetta
742 0 0         return sprintf("%.2fE", $x/10**18) if ($x >= 10**18); ##-- exa
743 0 0         return sprintf("%.2fP", $x/10**15) if ($x >= 10**15); ##-- peta
744 0 0         return sprintf("%.2fT", $x/10**12) if ($x >= 10**12); ##-- tera
745 0 0         return sprintf("%.2fG", $x/10**9) if ($x >= 10**9); ##-- giga
746 0 0         return sprintf("%.2fM", $x/10**6) if ($x >= 10**6); ##-- mega
747 0 0         return sprintf("%.2fk", $x/10**3) if ($x >= 10**3); ##-- kilo
748 0 0         return sprintf("%.2f", $x) if ($x >= 1); ##-- (natural units)
749 0 0         return sprintf("%.2fm", $x*10**3) if ($x >= 10**-3); ##-- milli
750 0 0         return sprintf("%.2fu", $x*10**6) if ($x >= 10**-6); ##-- micro
751 0 0         return sprintf("%.2fn", $x*10**9) if ($x >= 10**-9); ##-- nano
752 0 0         return sprintf("%.2fp", $x*10**12) if ($x >= 10**-12); ##-- pico
753 0 0         return sprintf("%.2ff", $x*10**15) if ($x >= 10**-15); ##-- femto
754 0 0         return sprintf("%.2fa", $x*10**18) if ($x >= 10**-18); ##-- atto
755 0 0         return sprintf("%.2fz", $x*10**21) if ($x >= 10**-21); ##-- zepto
756 0 0         return sprintf("%.2fy", $x*10**24) if ($x >= 10**-24); ##-- yocto
757 0           return sprintf("%.2g", $x); ##-- default
758             }
759              
760             ##==============================================================================
761             ## Functions: pdl: setops
762              
763             ## $pi = CLASS::_intersect_p($p1,$p2)
764             ## $pi = CLASS->_intersect_p($p1,$p2)
765             ## + intersection of 2 piddles; undef is treated as the universal set
766             ## + argument piddles MUST be sorted in ascending order
767             sub _intersect_p {
768 0 0   0     shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
769 0 0         return (defined($_[0])
    0          
770             ? (defined($_[1])
771             ? $_[0]->v_intersect($_[1]) ##-- v_intersect is 1.5-3x faster than PDL::Primitive::intersect()
772             : $_[0])
773             : $_[1]);
774             }
775             ## $pu = CLASS::_union_p($p1,$p2)
776             ## $pi = CLASS->_intersect_p($p1,$p2)
777             ## + union of 2 piddles; undef is treated as the universal set
778             ## + argument piddles MUST be sorted in ascending order
779             sub _union_p {
780 0 0   0     shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
781 0 0         return (defined($_[0])
    0          
782             ? (defined($_[1])
783             ? $_[0]->v_union($_[1]) ##-- v_union is 1.5-3x faster than PDL::Primitive::setops($a,'OR',$b)
784             : $_[0])
785             : $_[1]);
786             }
787              
788             ## $pneg = CLASS::_complement_p($p,$N)
789             ## $pneg = CLASS->_complement_p($p,$N)
790             ## + index-piddle negation; undef is treated as the universal set
791             ## + $N is the total number of elements in the index-universe
792 2     2   208 BEGIN { *_not_p = *_negate_p = \&_complement_p; }
793             sub _complement_p {
794 0 0   0     shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
795 0           my ($p,$N) = @_;
796 0 0         if (!defined($p)) {
    0          
797             ##-- neg(\universe) = \emptyset
798 0           return PDL->null->long;
799             }
800             elsif ($p->nelem==0) {
801             ##-- neg(\emptyset) = \universe
802 0           return undef;
803             }
804             else {
805             ##-- non-trivial negation
806             ##
807             ##-- mask: ca. 2.2x faster than v_setdiff
808 2     2   16 no strict 'subs';
  2         4  
  2         2726  
809 0           my $mask = PDL->ones(PDL::byte(),$N);
810 0           (my $tmp=$mask->index($p)) .= 0;
811 0           return $mask->which;
812             ##
813             ##-- v_setdiff: ca. 68% slower than mask
814             #my $U = sequence($p->type, $N);
815             #return scalar($U->v_setdiff($p));
816             }
817             }
818              
819              
820             ## $pdiff = CLASS::_setdiff_p($a,$b,$N)
821             ## $pdiff = CLASS->_setdiff_p($a,$b,$N)
822             ## + index-piddle difference; undef is treated as the universal set
823             ## + $N is the total number of elements in the index-universe
824             sub _setdiff_p {
825 0 0   0     shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
826 0           my ($a,$b,$N) = @_;
827 0 0         if (!defined($a)) {
    0          
    0          
    0          
828             ##-- \universe - b = \neg(b)
829 0           return _complement_p($b,$N);
830             }
831             elsif (!defined($b)) {
832             ##-- a - \universe = \emptyset
833 0           return PDL->null->long;
834             }
835             elsif ($a->nelem==0) {
836             ##-- \empyset - b = \emptyset
837 0           return $a;
838             }
839             elsif ($b->nelem==0) {
840             ##-- a - \emptyset = a
841 0           return $a;
842             }
843             else {
844             ##-- non-trivial setdiff
845 0           return scalar($a->v_setdiff($b));
846             }
847             }
848              
849             ##==============================================================================
850             ## Functions: pdl: I/O
851              
852             ## $pdl_or_undef = CLASS->readPdlFile($basename, %opts)
853             ## + %opts:
854             ## class=>$class, # one of qw(PDL PDL::CCS::Nd)
855             ## mmap =>$bool, # use mapfraw() (default=1)
856             ## log=>$level, # log-level (default=undef: off)
857             ## ... # other keys passed to CLASS->mapfraw() rsp. CLASS->readfraw()
858             sub readPdlFile {
859             #require PDL::IO::FastRaw;
860 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
861 0           my ($file,%opts) = @_;
862 0   0       my $class = $opts{class} // 'PDL';
863 0   0       my $mmap = $opts{mmap} // 1;
864 0   0       my $ro = (!$mmap || (exists($opts{ReadOnly}) ? $opts{ReadOnly} : (!-w "$file.hdr"))) || 0;
865 0           $that->vlog($opts{log}, "readPdlFile($file) [class=$class,mmap=$mmap,ReadOnly=$ro]");
866 0           delete @opts{qw(class mmap ReadOnly verboseIO)};
867 0 0         return undef if (!-e "$file.hdr");
868 0 0         return $mmap ? $class->mapfraw($file,{%opts,ReadOnly=>$ro}) : $class->readfraw($file,\%opts);
869             }
870              
871             ## $bool = CLASS->writePdlFile($pdl_or_undef, $basename, %opts)
872             ## + unlinks target file(s) if $pdl is not defined
873             ## + %opts:
874             ## log => $bool, # log-level (default=undef: off)
875             ## ... # other keys passed to $pdl->writefraw()
876             sub writePdlFile {
877             #require PDL::IO::FastRaw;
878 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
879 0           my ($pdl,$file,%opts) = @_;
880 0 0         if (defined($pdl)) {
881             ##-- write: raw
882 0           $that->vlog($opts{log}, "writePdlFile($file)");
883 0           delete($opts{verboseIO});
884 0           return $pdl->writefraw($file,\%opts);
885             }
886             else {
887             ##-- write: undef: unlink
888 0           $that->vlog($opts{log}, "writePdlFile($file): unlink");
889 0           foreach (grep {-e "file$_"} ('','.hdr','.ix','.ix.hdr','.nz','.nz.hdr','.fits')) {
  0            
890 0 0         unlink("file$_") or $that->logconfess(__PACKAGE__, "::writePdlFile(): failed to unlink '$file$_': $!");
891             }
892             }
893 0           return 1;
894             }
895              
896             ## $bool = CLASS->writePdlHeader($filename, $type, $ndims, @dims)
897             ## + writes a PDL::IO::FastRaw-style header $filename (e.g. "pdl.hdr")
898             ## + adapted from PDL::IO::FastRaw::_writefrawhdr()
899             ## + arguments
900             ## $type ##-- PDL::Type or integer
901             ## $ndims ##-- number of piddle dimensions
902             ## @dims ##-- dimension size list, piddle, or ARRAY-ref
903             sub writePdlHeader {
904 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
905 0           my ($file,$type,$ndims,@dims) = @_;
906 0 0         $that->logconfess("writePdlHeader(): missing required parameter (FILE,TYPE,NDIMS,DIMS...)") if (@_ < 3);
907 0 0         $type = $type->enum if (UNIVERSAL::isa($type,'PDL::Type'));
908 0 0         @dims = map {UNIVERSAL::isa($_,'PDL') ? $_->list : (UNIVERSAL::isa($_,'ARRAY') ? @$_ : $_)} @dims;
  0 0          
909 0 0         open(my $fh, ">$file")
910             or return undef;
911             #$that->logconfess("writePdlHeader(): open failed for '$file': $!");
912 0           print $fh join("\n", $type, $ndims, join(' ', @dims), '');
913 0           close($fh);
914             }
915              
916             ## $bool = CLASS->writeCcsHeader($filename, $itype, $vtype, $pdims, %opts)
917             ## + writes a PDL::CCS::IO::FastRaw-style header $filename (e.g. "pdl.hdr")
918             ## + arguments:
919             ## $itype, ##-- PDL::Type for index (default: PDL::CCS::Utils::ccs_indx())
920             ## $vtype, ##-- PDL::Type for values (default: $PDL::IO::Misc::deftype)
921             ## $pdims, ##-- dimension piddle or ARRAY-ref
922             ## + %opts: ##-- passed to PDL::CCS::Nd->newFromWich
923             sub writeCcsHeader {
924 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
925 0 0         $that->logconfess("writeCcsFile(): missing required parameter (FILE,ITYPE,VTYPE,DIMS...)") if (@_ < 3);
926 0           my ($file,$itype,$vtype,$pdims,%opts) = @_;
927 0 0         $itype = PDL::CCS::Utils::ccs_indx() if (!defined($itype));
928 0 0         $vtype = $PDL::IO::Misc::deftype if (!defined($vtype));
929 0 0         $pdims = PDL->pdl($itype, $pdims) if (!UNIVERSAL::isa($pdims,'PDL'));
930 0           my $ccs = PDL::CCS::Nd->newFromWhich(PDL->zeroes($itype,$pdims->nelem,1),
931             PDL->zeroes($vtype,2),
932             pdims=>$pdims, sorted=>1, steal=>1, %opts);
933 0           return PDL::CCS::IO::Common::_ccsio_write_header($ccs, $file);
934             }
935              
936             ##==============================================================================
937             ## Functions: pdl: mmap temporaries
938              
939             ## $pdl = mmzeroes($file?, $type?, @dims, \%opts?)
940             ## $pdl = $pdl->mmzeroes($file?, $type?, \%opts?)
941             ## + create a temporary mmap()ed pdl using DiaColloDB::PDL::MM; %opts:
942             ## (
943             ## file => $template, ##-- file basename or File::Temp template; default='pdlXXXX'
944             ## suffix => $suffix, ##-- File::Temp::tempfile() suffix (default='.pdl')
945             ## log => $level, ##-- logging verbosity (default=undef: off)
946             ## temp => $bool, ##-- delete on END (default: $file =~ /X{4}/)
947             ## )
948             sub mmzeroes {
949 0     0 1   require DiaColloDB::PDL::MM;
950 0 0         shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
951 0           return DiaColloDB::PDL::MM::new(@_);
952             }
953             sub mmtemp {
954 0     0 1   require DiaColloDB::PDL::MM;
955 0 0         shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
956 0           return DiaColloDB::PDL::MM::mmtemp(@_);
957             }
958              
959             ## $bool = mmunlink(@mmfiles)
960             ## $bool = mmunlink($mmpdl,@mmfiles)
961             ## + unlinkes file(s) generated by mmzeroes($basename)
962             sub mmunlink {
963 0     0 1   require DiaColloDB::PDL::MM;
964 0 0         shift if (UNIVERSAL::isa($_[0],__PACKAGE__));
965 0           return DiaColloDB::PDL::MM::unlink(@_);
966             }
967              
968             ##==============================================================================
969             ## Functions: pdl: misc
970              
971             ## $type = CLASS->mintype($pdl, @types)
972             ## $type = CLASS->mintype($maxval, @types)
973             ## + returns minimum PDL::Types type from @types required for representing $maxval ($pdl->max if passed as a PDL)
974             ## + @types defaults to all known PDL types
975             sub mintype {
976 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
977 0           my ($arg,@types) = @_;
978 0 0         $arg = $arg->max if (UNIVERSAL::isa($arg,'PDL'));
979 0 0         @types = map {$_->{ioname}} values(%PDL::Types::typehash) if (!@types);
  0            
980 0 0         @types = sort {$a->enum <=> $b->enum} map {ref($_) ? $_ : (PDL->can($_) ? PDL->can($_)->() : qw())} @types;
  0 0          
  0            
981 0           foreach my $type (@types) {
982 0 0         return $type if (maxval($type) >= $arg);
983             }
984 0           return PDL::float(); ##-- float is enough to represent anything, in principle
985             }
986             BEGIN {
987 2     2   96 *PDL::mintype = \&mintype;
988             }
989              
990             ## $maxval = $type->maxval()
991             ## $maxval = CLASS::maxval($type_or_name)
992             sub maxval {
993 2     2   14 no warnings 'pack';
  2         4  
  2         372  
994 0     0 1   my $type = shift;
995 0 0 0       $type = PDL->can($type)->() if (!ref($type) && PDL->can($type));
996 0 0         return 'inf' if ($type >= PDL::float());
997 0           my $nbits = 8*length(pack($PDL::Types::pack[$type->enum],0));
998 0           return (PDL->pdl($type,2)->pow(PDL->sequence($type,$nbits+1))-1)->double->max;
999             }
1000             BEGIN {
1001 2     2   206 *PDL::Type::maxval = \&maxval;
1002             }
1003              
1004              
1005             ## ($vals,$counts) = $pdl->valcounts()
1006             ## + wrapper for $pdl->flat->qsort->rle() with masking lifted from MUDL::PDL::Smooth
1007             sub valcounts {
1008 0     0 1   my $pdl = shift;
1009 0           my ($counts,$vals) = $pdl->flat->qsort->rle;
1010 0           my $mask = ($counts > 0);
1011 0           return ($vals->where($mask), $counts->where($mask));
1012             }
1013             BEGIN {
1014 2     2   16 no warnings 'redefine'; ##-- avoid irritating "PDL::valcounts redefined" messages when running together with (legacy) MUDL & DocClassify code
  2         4  
  2         74  
1015 2     2   3096 *PDL::valcounts = \&valcounts;
1016             }
1017              
1018             ##==============================================================================
1019             ## Functions: temporaries
1020              
1021             ## $TMPDIR : global temp directory to use
1022             our $TMPDIR = undef;
1023              
1024             ## TMPFILES : temporary files to be unlinked on END
1025             our @TMPFILES = qw();
1026             END {
1027 2     2   1198513 foreach (@TMPFILES) {
1028 0 0 0       !-e $_
1029             or CORE::unlink($_)
1030             or __PACKAGE__->logwarn("failed to unlink temporary file $_ in final cleanup");
1031             }
1032             }
1033              
1034             ## $tmpdir = CLASS->tmpdir()
1035             ## $tmpdir = CLASS_>tmpdir($template, %opts)
1036             ## + in first form, get name of global tempdir ($TMPDIR || File::Spec::tmpdir())
1037             ## + in second form, create and return a new temporary directory via File::Temp::tempdir()
1038             sub tmpdir {
1039 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1040 0   0       my $tmpdir = $TMPDIR || File::Spec->tmpdir();
1041 0 0         return @_ ? File::Temp::tempdir($_[0], DIR=>$tmpdir, @_[1..$#_]) : $tmpdir;
1042             }
1043              
1044             ## $fh = CLASS->tmpfh()
1045             ## $fh = CLASS->tmpfh($template_or_filename, %opts)
1046             ## + get a new temporary filehandle or undef on error
1047             ## + in list context, returns ($fh,$filename) or empty list on error
1048             sub tmpfh {
1049 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1050 0   0       my $template = shift // 'tmpXXXXX';
1051 0           my ($fh,$filename);
1052 0 0         if ($template =~ /X{4}/) {
1053             ##-- use File::Temp::tempfile()
1054 0 0         ($fh,$filename) = File::Temp::tempfile($template, DIR=>$that->tmpdir(), @_) or return qw();
1055             } else {
1056             ##-- use literal filename, honoring DIR, TMPDIR, and SUFFIX options
1057 0           my %opts = @_;
1058 0           $filename = $template;
1059 0 0 0       do { $opts{DIR} =~ s{/$}{}; $filename = "$opts{DIR}/$filename"; } if ($filename !~ m{^/} && defined($opts{DIR}));
  0            
  0            
1060 0 0 0       $filename = $that->tmpdir."/".$filename if ($filename !~ m{^/} && $opts{TMPDIR});
1061 0 0         $filename .= $opts{SUFFIX} if (defined($opts{SUFFIX}));
1062 0 0         CORE::open($fh, ($opts{APPEND} ? '+<' : '+>'), $filename)
    0          
1063             or $that->logconfess("tmpfh(): open failed for file '$filename': $!");
1064 0 0         push(@TMPFILES, $filename) if ($opts{UNLINK});
1065             }
1066 0 0         return wantarray ? ($fh,$filename) : $fh;
1067             }
1068              
1069             ## $filename = CLASS->tmpfile()
1070             ## $filename = CLASS->tmpfile($template, %opts)
1071             sub tmpfile {
1072 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1073 0 0         my ($fh,$filename) = $that->tmpfh(@_) or return undef;
1074 0           $fh->close();
1075 0           return $filename;
1076             }
1077              
1078             ## \@tmparray = CLASS->tmparray($template, %opts)
1079             ## + ties a new temporary array via $class (default='Tie::File::Indexed::JSON')
1080             ## + calls tie(my @tmparray, 'DiaColloDB::Temp::Array', $tmpfilename, %opts)
1081             sub tmparray {
1082 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1083 0           my ($template,%opts) = @_;
1084              
1085             ##-- load target module
1086 0 0         eval { require "DiaColloDB/Temp/Array.pm" }
  0            
1087             or $that->logconfess("tmparray(): failed to load class DiaColloDB::Temp::Array: $@");
1088              
1089             ##-- default options
1090 0   0       $template //= 'dcdbXXXXXX';
1091 0   0       $opts{SUFFIX} //= '.tmpa';
1092 0 0         $opts{UNLINK} = 1 if (!exists($opts{UNLINK}));
1093 0 0         $opts{APPEND} = 0 if (!exists($opts{APPEND}));
1094              
1095             ##-- tie it up
1096 0           my $tmpfile = $that->tmpfile($template, %opts);
1097 0 0         tie(my @tmparray, 'DiaColloDB::Temp::Array', $tmpfile, %opts)
1098             or $that->logconfess("tmparray(): failed to tie file '$tmpfile' via DiaColloDB::Temp::Array: $@");
1099 0           return \@tmparray;
1100             }
1101              
1102             ## \@tmparrayp = CLASS->tmparrayp($template, $packas, %opts)
1103             ## + ties a new temporary integer-array via DiaColloDB::PackedFile)
1104             ## + calls tie(my @tmparray, 'DiaColloDB::PackedFile', $tmpfilename, %opts)
1105             sub tmparrayp {
1106 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1107 0           my ($template,$packas,%opts) = @_;
1108              
1109             ##-- load target module
1110 0 0         eval { require "DiaColloDB/PackedFile.pm" }
  0            
1111             or $that->logconfess("tmparrayp(): failed to load class DiaColloDB::PackedFile: $@");
1112              
1113             ##-- default options
1114 0   0       $template //= 'dcdbXXXXXX';
1115 0   0       $opts{SUFFIX} //= '.pf';
1116 0 0         $opts{UNLINK} = 1 if (!exists($opts{UNLINK}));
1117 0 0         $opts{APPEND} = 0 if (!exists($opts{APPEND}));
1118              
1119             ##-- tie it up
1120 0           my $tmpfile = $that->tmpfile($template, %opts);
1121 0 0         my $mode = 'rw'.($opts{APPEND} ? 'a' : '');
1122 0 0         tie(my @tmparray, 'DiaColloDB::PackedFile', $tmpfile, $mode, packas=>$packas, temp=>$opts{UNLINK}, %opts)
1123             or $that->logconfess("tmparrayp(): failed to tie file '$tmpfile' via DiaColloDB::PackedFile: $@");
1124 0           return \@tmparray;
1125             }
1126              
1127             ## \%tmphash = CLASS->tmphash($template, %opts)
1128             ## + ties a new temporary hash via $class (default='DB_File')
1129             ## + calls tie(my @tmparray, $class, $tmpfilename, temp=>1, %opts)
1130             sub tmphash {
1131 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1132 0           my ($template,%opts) = @_;
1133              
1134             ##-- load target module
1135 0 0         eval { require "DiaColloDB/Temp/Hash.pm" }
  0            
1136             or $that->logconfess("tmparray(): failed to load class DiaColloDB::Temp::Hash: $@");
1137              
1138             ##-- default options
1139 0   0       $template //= 'dcdbXXXXXX';
1140 0   0       $opts{SUFFIX} //= '.tmph';
1141 0 0         $opts{UNLINK} = 1 if (!exists($opts{UNLINK}));
1142 0 0         $opts{APPEND} = 0 if (!exists($opts{APPEND}));
1143 0 0 0       $opts{flags} //= fcflags('rw'.($opts{APPEND} ? 'a' : ''));
1144              
1145             ##-- tie it up
1146 0           my $tmpfile = $that->tmpfile($template, %opts);
1147 0 0         tie(my %tmphash, 'DiaColloDB::Temp::Hash', $tmpfile, %opts)
1148             or $that->logconfess("tmphash(): failed to tie file '$tmpfile' via DiaColloDB::Temp::Hash: $@");
1149 0           return \%tmphash;
1150             }
1151              
1152             ##==============================================================================
1153             ## Functions: jobs: parallelization
1154              
1155             ## %NCORES : cache for nCores() utility ($cpuinfo_file=>$n, ...)
1156             our %NCORES = qw();
1157              
1158             ## $ncores = PACKAGE::nCores()
1159             ## $ncores = PACKAGE::nCores($proc_cpuinfo_filename)
1160             ## + returns the number of CPU cores on the system according to /proc/cpuinfo, or zero if unavailable
1161             ## + caches result in %NCORES
1162             sub nCores {
1163 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1164 0   0       my $filename = shift || '/proc/cpuinfo';
1165 0 0         return $NCORES{$filename} if (exists($NCORES{$filename}));
1166              
1167 0 0         if (CORE::open(my $fh, "<$filename")) {
    0          
1168 0           my $ncores = 0;
1169 0           while (defined($_=<$fh>)) {
1170 0 0         ++$ncores if (/^processor\s*:/);
1171             }
1172 0           close($fh);
1173 0           $NCORES{$filename} = $ncores;
1174             }
1175             elsif (CORE::open(my $pipefh, "nproc|")) {
1176 0           my $ncores = <$pipefh>;
1177 0           chomp $ncores;
1178 0           close($pipefh);
1179 0 0         $NCORES{$filename} = $NCORES{'nproc|'} = $ncores if ($ncores);
1180             }
1181 0   0       return ($NCORES{$filename} //= 0);
1182             }
1183              
1184             ## $njobs = PACKAGE::nJobs($njobs=$DiaColloDB::NJOBS)
1185             ## + gets non-negative number of jobs for user request $njobs (default=-1)
1186             ## + returns nCores() if $njobs is negative
1187             ## + returns int($njobs*nCores()) if (0 < $njobs < 1)
1188             ## + otherwise returns $njobs+0
1189             sub nJobs {
1190 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1191 0 0         my $njobs = @_ ? shift : $DiaColloDB::NJOBS;
1192 0   0       $njobs //= -1;
1193 0 0         return $that->nCores() if ($njobs < 0);
1194 0 0 0       return $njobs*$that->nCores if (0 < $njobs && $njobs < 1);
1195 0           return int($njobs+0);
1196             }
1197              
1198             ## $sort_parallel_option = sortJobs($njobs=$DiaColloDB::NJOBS)
1199             ## + returns --parallel option for 'sort' calls to use $njobs jobs
1200             sub sortJobs {
1201 0 0   0 1   my $that = UNIVERSAL::isa($_[0],__PACKAGE__) ? shift : __PACKAGE__;
1202 0 0         my $njobs = @_ ? shift : $DiaColloDB::NJOBS;
1203 0 0 0       my $args = (!$njobs || $njobs < 1 ? '' : ("--parallel=".nJobs($njobs)));
1204 0 0         return $args ? ($args) : qw() if (wantarray);
    0          
1205 0           return $args;
1206             }
1207              
1208             ##==============================================================================
1209             ## Footer
1210             1; ##-- be happy