← Index
Performance Profile   « block view • line view • sub view »
For /wise/base/deliv/dev/bin/getfix
  Run on Thu May 20 15:30:03 2010
Reported on Thu May 20 16:25:19 2010

File/wise/base/deliv/dev/lib/perl/WISE/Utils.pm
Statements Executed108
Total Time0.014228 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1116.8e-56.8e-5WISE::Utils::expandlist
00000WISE::Utils::BEGIN
00000WISE::Utils::GETLK
00000WISE::Utils::LKTMPL8
00000WISE::Utils::OO::AUTOLOAD
00000WISE::Utils::OO::BEGIN
00000WISE::Utils::OO::new
00000WISE::Utils::RDLCK
00000WISE::Utils::SETLK
00000WISE::Utils::SETLKW
00000WISE::Utils::UNLCK
00000WISE::Utils::WRLCK
00000WISE::Utils::__ANON__[:109]
00000WISE::Utils::__ANON__[:1876]
00000WISE::Utils::__ANON__[:371]
00000WISE::Utils::__ANON__[:372]
00000WISE::Utils::alertbell
00000WISE::Utils::angdiff
00000WISE::Utils::angnorm
00000WISE::Utils::angsum
00000WISE::Utils::area_2circle_overlap
00000WISE::Utils::array_cmpr
00000WISE::Utils::array_copy
00000WISE::Utils::calc_stats
00000WISE::Utils::chgrp
00000WISE::Utils::clearout
00000WISE::Utils::collapselist
00000WISE::Utils::copy_glob
00000WISE::Utils::current_version
00000WISE::Utils::deep_cmpr
00000WISE::Utils::deep_copy
00000WISE::Utils::def
00000WISE::Utils::derivexform
00000WISE::Utils::disambiguate
00000WISE::Utils::evalpoly
00000WISE::Utils::filedescriptortest
00000WISE::Utils::first
00000WISE::Utils::first_def
00000WISE::Utils::fixup_paths
00000WISE::Utils::foreground
00000WISE::Utils::gather_stats
00000WISE::Utils::get_hdr_data
00000WISE::Utils::getfitshdr
00000WISE::Utils::goodseed
00000WISE::Utils::hash_cmpr
00000WISE::Utils::hash_copy
00000WISE::Utils::interval_overlap_2
00000WISE::Utils::invalidate_nfs_cache
00000WISE::Utils::lockgetr
00000WISE::Utils::lockgetrw
00000WISE::Utils::lockgetw
00000WISE::Utils::lockit
00000WISE::Utils::lockr
00000WISE::Utils::lockrnb
00000WISE::Utils::lockrw
00000WISE::Utils::lockrwb
00000WISE::Utils::lockrwnb
00000WISE::Utils::lockun
00000WISE::Utils::lockw
00000WISE::Utils::lockwnb
00000WISE::Utils::makerelative
00000WISE::Utils::max
00000WISE::Utils::min
00000WISE::Utils::new_version
00000WISE::Utils::nrandgaus
00000WISE::Utils::option_validate
00000WISE::Utils::poly_inv
00000WISE::Utils::prefixpath
00000WISE::Utils::print_stats
00000WISE::Utils::printable
00000WISE::Utils::push_handler
00000WISE::Utils::qpat
00000WISE::Utils::randgaus
00000WISE::Utils::ref_cmpr
00000WISE::Utils::ref_copy
00000WISE::Utils::rot1
00000WISE::Utils::rot3
00000WISE::Utils::rss
00000WISE::Utils::rsseq1p
00000WISE::Utils::safe_copy
00000WISE::Utils::scalar_cmpr
00000WISE::Utils::scalar_copy
00000WISE::Utils::skydraw
00000WISE::Utils::spliceix
00000WISE::Utils::splicere
00000WISE::Utils::srandgaus
00000WISE::Utils::unbless
00000WISE::Utils::undefize
00000WISE::Utils::undefizejoin
00000WISE::Utils::uniqueify
00000WISE::Utils::unlinkifexists
00000WISE::Utils::unquote
00000WISE::Utils::unzombie
00000WISE::Utils::uqindex
00000WISE::Utils::uqsplit

LineStmts.Exclusive
Time		Avg.Code
1#! /usr/bin/env perl
2
335.3e-51.8e-5use strict;
# spent 22µs making 1 call to strict::import
433.3e-51.1e-5use warnings;
# spent 33µs making 1 call to warnings::import
5
633.3e-51.1e-5use WISE::Env (cfglib=>'/wise/base/deliv/dev/lib/perl');
# spent 506µs making 1 call to WISE::Env::import, max recursion depth 1
7
834.0e-51.3e-5use vars qw(*LOG);
# spent 28µs making 1 call to vars::import
9
10# $Id: Utils.pm 6301 2009-11-06 02:40:41Z tim $
11
12package WISE::Utils;
13
1433.0e-51.0e-5use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
# spent 68µs making 1 call to vars::import
15
1636.1e-52.0e-5use Exporter;
# spent 31µs making 1 call to Exporter::import
1711.0e-61.0e-6$VERSION = 1.00;
1819.0e-69.0e-6@ISA = qw(Exporter);
19
2011.0e-61.0e-6@EXPORT = ();
21
2211.0e-61.0e-6my @bandstuff;
23
24BEGIN {
2513.0e-63.0e-6 @bandstuff = qw(bandfwhm bandpixsz bandnum bandstr);
2610.000150.00015}
27
2814.0e-54.0e-5%EXPORT_TAGS = (file => [qw(unlinkifexists uniqueify whoiam samefile
29 mysymlink mymkpath chgrp clearout getfitshdr
30 safe_copy copy_glob disambiguate
31 pathcomp pathdecomp get_hdr_info)],
32 proc => [qw(whichami unzombie)],
33 text => [qw(uqindex uqsplit unquote fpre qpat printable
34 spliceix splicere)],
35 math => [qw(rot1 rot3 evalpoly poly_inv
36 rss area_2circle_overlap
37 rsseq1p goodseed randgaus nrandgaus
38 gather_stats calc_stats print_stats
39 skydraw angsum angnorm angdiff)],
40 pos => [qw(skydraw angsum angnorm angdiff)],
41 lock => [qw(lockit lockw lockr lockun lockwnb lockrnb
42 lockgetw lockgetr)],
43 stats=> [qw(gather_stats calc_stats print_stats)],
44 band=>\@bandstuff,
45 common=>[qw(whichami
46 first def banner normalizepath makerelative
47 prefixpath
48 openlog logging expandlist collapselist
49 undefize undefizejoin anymax anymin
50 deep_cmpr deep_copy
51 foreground
52 thishost safe_eval
53 pathcomp pathdecomp get_hdr_info
54 paramval
55 ),
56 @bandstuff],
57 );
58
5918.4e-58.4e-5@EXPORT_OK = ( map { @$_ } values %EXPORT_TAGS );
60
6111.0e-61.0e-6my $version = '$Id: Utils.pm 6301 2009-11-06 02:40:41Z tim $ ';
62
63# Extension modules
6430.000960.00032use Text::ParseWords;
# spent 67µs making 1 call to Exporter::import
6533.2e-51.1e-5use Fcntl qw/:DEFAULT :flock :seek/;
# spent 718µs making 1 call to Exporter::import
6633.2e-51.1e-5use File::Spec;
# spent 4µs making 1 call to import
6733.0e-51.0e-5use Cwd;
# spent 55µs making 1 call to Exporter::import
6835.1e-51.7e-5use Cwd 'fast_abs_path';
# spent 53µs making 1 call to Exporter::import
6930.000279.1e-5use Text::Tabs;
# spent 117µs making 1 call to Exporter::import
7032.9e-59.7e-6use Carp qw/:DEFAULT cluck confess/;
# spent 173µs making 1 call to Exporter::import
7132.9e-59.7e-6use File::Basename;
# spent 54µs making 1 call to Exporter::import
7233.3e-51.1e-5use IO::Handle '_IOLBF';
# spent 119µs making 1 call to Exporter::import
7333.4e-51.1e-5use POSIX qw(:errno_h);
# spent 643µs making 1 call to POSIX::import
74#use Params::Validate ();
75
7631.8e-56.0e-6use WISE::Release ();
7732.8e-59.3e-6use WISE::Time ();
7836.0e-52.0e-5use WISE::BandUtils (@bandstuff);
# spent 99µs making 1 call to Exporter::Lite::import
79use WISE::UtilsLight qw(banner bannerlines mystatus logging thishost samefile
# spent 416µs making 1 call to Exporter::Lite::import
80 openlog closelog teetofile savestdout savestderr
81 restorestdout restorestderr whoiam whichami
82 resolvepath normalizepath wrapup fpre
83 aryhash_keys aryhash_vals pathdecomp pathcomp
84 safe_eval mysymlink mymkpath tempfile
8533.4e-51.1e-5 $logwidth $__LOG__);
86
8730.007110.00237use WISE::Spawn;
# spent 22µs making 1 call to Exporter::Lite::import
88
89# Get delivery bin directory
9011.0e-61.0e-6$main::Execpath = "/wise/base/deliv/dev/bin";
91# Normalize and add trailing '/' IF we've had a proper path substituted in.
9211.8e-51.8e-5$main::Execpath = normalizepath($main::Execpath,1)
# spent 169µs making 1 call to WISE::UtilsLight::normalizepath
93 if $main::Execpath =~ m|/[^/]+$|;
94
95# File-local definitions
96100my $PI = atan2(1.0,1.0) * 4.0;
9713.0e-63.0e-6my $R2D = 180.0 / $PI;
9811.0e-61.0e-6my $S2 = sqrt(2.0);
99
100# Return value of first expression evaluating to true.
101# The search for truth does NOT shortcircuit.
102# This is the first time I've written a piece of code using prototypes.
103# Use of the & prototype is the only reason I see for doing so.
104sub first (&@) { my $sub=shift; $sub->($_) and return $_ for @_; return undef; }
105
106# Using the above, create the much needed first_defined "operator".
107# It would be real nice if it could short circuit, but perl doesn'
108# have that bit of sugar in its syntax.
109sub first_def { first { defined } @_ };
110
111# Synonym
112sub def { &first_def; }
113
114# Unlink a list of files, but only try to do so on each file if it exists.
115sub unlinkifexists {
116 my(@files) = @_;
117 local $^W = 0; # The -e test below screws up -w; so turn off warnings
118 my($n) = 0;
119
120 for my $f (@files) {
121
122 if(-e $f) {
123 $n += unlink $f
124 or
125 warn "=== $0/UNLINKIF: Failed to unlink $f; $!\n";
126 }
127 }
128
129 return $n;
130}
131
132# If a filename we wish to use exists, add a uniquifying letter sequence. The
133# added letters go before any trailing '.suffix'.
134sub uniqueify {
135 my $file = shift; # File name
136 my $unq = shift; # Suffix to use to uniquify (optional)
137 my $sufre= shift; # Regular expression (RE) for matching a file suffix
138 my($base,$path,$suf,@fileslike,$nxt,@sofar,$force,$opts);
139
140 if(ref($unq) =~ /hash/i) { $opts = $unq; $unq = undef; }
141 else { $opts = {}; }
142 $unq ||= $opts->{suffix};
143 $sufre ||= $opts->{suffixre} || '(\.[^.]+)+';
144 $force = $opts->{force}; # Always apply a suffix, even if the base is unique.
145
146 if(! -e $file && ! $force) {
147 # File is unique and $force is not set. Just return the given name.
148 return wantarray ? ($file,"") : $file;
149 }
150
151 # Split the file into dir. path, basename and suffix.
152 ($base,$path,$suf) = fileparse($file,$sufre);
153
154 # In case this is a case of serial uniquification, remove any previous
155 # uniquifying letters from the file name.
156 $base =~ s/_\w\w//;
157
158 if(! defined $unq) {
159 # We must figure out our own unique letter suffix.
160
161 # Start by getting all similar previously uniquified files.
162 opendir(DIR,$path) or confess "$0/UNIQ: Can't open $path; $!\n";
163 @fileslike = map { "$path/$_" } grep(/^${base}_\w\w$suf$/,<DIR>);
164 close DIR or confess "$0/UNIQ: Bad close(read) of $path; $!\n";
165
166 if(@fileslike) {
167 # If there are any, extract all used suffixes.
168 @sofar = "@fileslike" =~ /_(\w\w)\.$suf (?: \s|$ ) /xg;
169 # Pop off the lexigraphically last one (sorted by the glob).
170 $nxt = (sort @sofar)[-1];
171 # The self-increment operator in Perl is magical and will return
172 # the lexigraphcally "next" letter sequence.
173 ++$nxt;
174 } else {
175 # No other previously uniquified files of this name exist, so
176 # initialize the process.
177 $nxt = "aa";
178 }
179 } else {
180 $nxt = $unq;
181 }
182
183 return wantarray ? ("$path${base}_$nxt$suf",$nxt) : "$path${base}_$nxt$suf";
184}
185
186# Search @dirs for files with the same basename and allow disabiguation by
187# returning a single character after the basename. This is different from
188# uniqueify above in that it disambiguates differently and works based on
189# base name rather than suffix. They could probably be made equivalent,
190# or at least to use the same underlying mecahnism.
191sub disambiguate {
192 my $opts = ref $_[-1] ? pop : {};
193 my $base = shift;
194 my @dirs = @_;
195 my $sep = $opts->{sep} || "_";
196 my $chars = $opts->{chars} || ['A'..'Z'];
197 my $verbose = $opts->{verbose};
198 my $err = "*** $0/disambig";
199 my $warn = "=== $0/disambig";
200 my ($add,@found,%found,$got,$char);
201
202 for my $dir (@dirs) {
203
204 next if ! -d $dir;
205
206 # Search for duplicates and increment the final letter as required
207 opendir(my $dh,$dir)
208 or warn("$err: Can't open directory '$dir'; $!"), return;
209
210 # Look for files (or dirs) like $base, $base_*, $base-*, $base.*, or
211 # those possibilities with an optional '_a' disambiguator present.
212 for my $d ( grep(/^(\Q$base\E(?:${sep}[a-zA-Z])?)(?:[-_.]|$)/
213 && ! $found{$1}++,
214 readdir($dh)) ) {
215 my ($got) = $d =~ /^(\Q$base\E(?:${sep}[a-zA-Z])?)(?:[-_.]|$)/;
216 $got =~ s/\Q${base}\E${sep}?//; # Reduce to any disambiguators
217 push @found,$got; # Save just the disambiguators we find
218 }
219
220 close $dh;
221 }
222
223 if (@found) {
224 # Get the last disambiguation character (lexically sorted last).
225 my $add = (sort {$found[$a] cmp $found[$b]} 0..$#found)[-1];
226 if (! defined $add) { $add = 0; } # Initialize disambiguation
227 else { ++$add; } # Next character
228 # Warn user of the file name conflict.
229 warn "$warn: Found ".@found." existing names like ".
230 "'$base'. Disambiguate with '$chars->[$add]'.\n".
231 " Searched for $base in @dirs"
232 if $verbose;
233 # Check the range
234 warn("$err: Found ".@found." existing names like ".
235 "'$base'. Disambiguation would exceed ".@$chars.
236 " available characters.\n".
237 " Searched for $base in @dirs"), return
238 if $add > $#{$chars};
239 $char = $chars->[$add];
240 } else {
241 $char = ''; # No disambiguation required
242 }
243
244 return $char;
245}
246
247
248# Take an ASCII string like '1,8..12,6,89..112' and interpolate the ranges.
249# Will also work in limited cases using letters instead of digits.
250
# spent 68µs within WISE::Utils::expandlist which was called # once (68µs+0) at line 374 of /wise/base/deliv/dev/bin/getfix
sub expandlist {
251185.9e-53.3e-6 my $str = shift; # Can be a ref to a set of strings or just a scalar string
252 my $nouniq = shift; # Don't uniquify the list
253 my $nosort = shift; # Don't sort the list
254 my $min = shift; # Minimum if the bottom of a range is not given
255 my $max = shift; # Maximum if the top of a range is not given
256 my $sep = shift || '[,\s]+'; # RE for number or range separators
257 my $run = shift || '\.\.+'; # A range indicator
258 my (@bits,$alpha,$opts); # "$bits" as in "bits and pieces"
259
260 if(ref($nouniq) =~ /hash/i) {
261 $opts = $nouniq;
262 $nouniq = $opts->{nounique} || $opts->{nouniq};
263 $nosort = $opts->{nosort};
264 $min = $opts->{min};
265 $max = $opts->{max};
266 $sep = $opts->{separator} || $opts->{sep} || '[,\s]+';
267 $run = $opts->{range} || $opts->{run} || '\.\.+';
268 }
269
270 $alpha = $str =~ /[a-zA-Z]/; # Warn us if an alphbetic range is included
271
272 # Step through list from split string or as passed in the ref
273 for my $s ( ref $str ? (@$str) : (split(/$sep/,$str)) ) {
274 # A full range
275 if($s=~/([+-]?\w+)$run([+-]?\w+)/) { push @bits, $1..$2; }
276 # Start of a range; ok if max is defined
277 elsif($s=~/([+-]?\w+)$run/ ) {
278 if(defined $max) { push @bits, $1..$max; }
279 else { die "*** $0/EXPAND: Dangling range fragment: '$s'\n"; }
280 # End of a range; ok if min is defined
281 } elsif($s=~/$run([+-]?\w+)/) {
282 if(defined $min) { push @bits, $min..$1; }
283 else { die "*** $0/EXPAND: Dangling range fragment: '$s'\n"; }
284 # No range; copy as is
285 } else { push @bits, $s; }
286 }
287
288 # Uniquify; common perl idiom to remove dup.s in a list.
289 if(! $nouniq) {
290 my %n;
291 @bits = grep(!$n{$_}++,@bits);
292 }
293 # Sor
294 if(! $nosort) {
295 @bits = sort {$a <=> $b} @bits if ! $alpha; # Numeric sor
296 @bits = sort {$a cmp $b} @bits if $alpha; # Lexical sor
297 }
298
299 wantarray ? @bits : scalar(@bits);
300
301}
302
303# Reverse the above operation.
304# Parameters can be:
305# List of integers
306# Ref. to a list of int.s, followed by
307# Positional arg.s
308# An option hash
309sub collapselist {
310 my @list = @_;
311 my ($str,$i,$n,$x,$y,$start,$end,$alpha,$nexty);
312 my ($list,$uniq,$opts);
313
314 if(ref $list[0]) {
315 $list = shift @list; # Lis
316 @list = @$list; # Local copy
317 # Other arg.s.
318 if(ref($list[0]) !~ /hash/i) {
319 # Positional
320 ($uniq) = @list; # Uniquify
321 } else {
322 # Named options
323 $opts = $list[0];
324 $uniq = $opts->{unique} || $opts->{uniq};
325 }
326
327 }
328
329 $alpha = grep(/[a-zA-Z]/,@list);
330
331 if($uniq) {
332 my %n;
333 @list = grep(!$n{$_}++,@list);
334 }
335
336 # There's no "nosort" option because we must sort the list to collapse i
337 @list = sort {$a <=> $b} @list if ! $alpha;
338 @list = sort {$a cmp $b} @list if $alpha;
339
340 $n = @list;
341 $str = "";
342 $start = undef;
343 $end = undef;
344 # Nothing perl-ish here.
345 for ($i=0; $i<$n; ++$i, $y = $x) {
346 $x = $list[$i];
347 if($i == 0) { $str = "$x"; next; }
348 $nexty = $y;
349 $nexty++;
350 if((! $alpha && $x == $nexty) ||
351 ( $alpha && $x eq $nexty)) {
352 if(! defined $start) { $start = $y; }
353 $end = $x;
354 } else {
355 if(defined $start) { $str .= "..$end"; }
356 $start = $end = undef;
357 $str .= ",$x";
358 }
359 }
360 if(defined $start) { $str .= "..$end"; }
361
362 return wantarray ? ($str,$alpha) : $str;
363}
364
365sub push_handler {
366 my $new = shift;
367 my $sig = shift || "__DIE__";
368 my $top = shift;
369 my $old = $SIG{$sig};
370 if(ref($old) eq "CODE" && ref($new) eq "CODE") {
371 if($top) { $new = sub { &$new; &$old; }; }
372 else { $new = sub { &$old; &$new; }; }
373 }
374 $SIG{$sig} = $new;
375 return $old;
376}
377
378# Make an absolute path as relative as possible.
379# Only works as one might expect for directories below or above $file's
380# directory, not for "cousins". I.e. the reulsting path will be absolute
381# rather than contain '..'.
382sub makerelative {
383 my $file= shift;
384 my $cwd = shift || getcwd(); # Avoid fd leak; don't call 'cwd()'
385
386 $cwd = normalizepath($cwd, 1,1);
387 $file = normalizepath($file,1,1);
388 $file =~ s!^$cwd(/|$)!!;
389
390 # Do *not* try to normalize or resolve this relative path. There's
391 # code out there that depends on getting "" (empty string) if
392 # the path reduces to the cwd. And, dammit, we *want* a relative path!
393 return $file;
394}
395
396sub prefixpath {
397 my $path = shift || "";
398 my $file = shift;
399
400 if($file) {
401 $path = normalizepath($path,1);
402 $file = $path.$file if $file !~ m|^.?/|;
403 }
404
405 return $file;
406}
407
408# Update paths IN PLACE by prepending $root if appropriate and normalizing them.
409sub fixup_paths {
410 # cheap way to exclude vvvvv blessed objects
411 my $opts = ref($_[-1]) eq 'HASH' ? pop : {};
412 my $pars = shift; # WISE::Pars object instance
413 my $root = normalizepath(shift,1); # Root directory
414 my $verbose = $opts->{verbose};
415 my $name;
416
417 while (@_) {
418 $name = shift;
419 # Take './' or '/' to be absolute paths, others are relative to $root.
420 $_[0] = $root and next if ! $_[0];
421 $_[0] = $root.$_[0] if $_[0] !~ m|^\.?/|;
422 $_[0] = normalizepath($_[0],1);
423 } continue {
424 print ucfirst($name)." resolves to '$_[0]'.\n" if $verbose;
425 if($pars) {
426 $pars->set($name,$_[0],{missingok=>1});
427 }
428 shift;
429 }
430
431 return @_;
432}
433
434# Check to see what the next allocated file descrriptor is.
435# I used this to chase down a filehandle leak in perl. Shouldn't be necessary
436# now.
437sub filedescriptortest {
438 require "usedfilenos.pl";
439 my $verbose = shift;
440 my $fno;
441 if(! open(_FNOTST_,">/dev/null")) {
442 warn "*** $0/FNOTEST: Couldn't open /dev/null; $!\n";
443 return;
444 }
445 $fno = fileno(_FNOTST_);
446 close(_FNOTST_);
447 warn "=== $0/FNOTEST: Next file descriptor = ".undefize($fno).
448 ". Used = ".collapselist(usedfilenos())."\n"
449 if $verbose;
450 return $fno;
451}
452
453# Do a double fork/exec to cause a process to disconnect from the parent and
454# be inherited by init. This will prevent it from becoming a zombie upon death.
455sub unzombie {
456 my $daemon = shift;
457 my $close = shift;
458 my($rc,$pid);
459 require POSIX;
460 POSIX->import("setsid");
461
462 if($pid=fork) {
463 # Parent; reap and exit
464 $rc = waitpid($pid,0);
465 if($rc < 0 || $? != 0) { die "$0: Parent wait failed: $rc/$?\n." }
466 exit 0;
467 } elsif (! defined $pid) {
468 confess "*** $0/UNZOMBIE: Parent can't fork: $!.\n";
469 } else {
470 # Child; set new process group, fork again and be reaped.
471 setsid();
472 $SIG{HUP} = "IGNORE" if $daemon;
473 if($pid=fork) { exit 0; }
474 elsif (! defined $pid) {
475 confess "*** $0/UNZOMBIE: Child can't fork: $!.\n";
476 }
477 if($daemon) {
478 chdir "/" or confess "*** $0/UNZOMBIE: Can't cd to /: $!.\n";
479 #umask(0);
480 if($close) {
481 open(STDIN, "</dev/null");
482 open(STDOUT,"+>/dev/null");
483 open(STDERR,"+>/dev/null");
484 }
485 }
486 # Carry on with calling program ...
487 }
488
489 return 1;
490}
491
492# Intricate regular expression for finding characters only when not
493# within a paired quote and not escaped with a backslash.
494
495# This RE will find paired double quotes even if escaped quotes (\") are
496# embedded. It handles double escapes correctly.
497sub qpat {
498 q@((?<!\\\\)(?:\\\\{2})*)("(?:(?:(?<!\\\\)(?:\\\\{2})*\\\\")|[^"])*")@;
499}
500
501sub uqindex {
502
503 # Return the index to the first unquoted and unescaped occurrence of $c in $s
504 my ($s,$c,$j) = @_;
505 my ($i);
506 my $qpat = &parqpat;
507
508# $s = q{aaa"a'a\"dda"a's\'dds"'ax"pppp\\\\"gg"xx'c"xddx"zddz}; #"
509
510# print "\n\n**input=/$s/, **search=$c\n";
511
512# print "\nLooking for $c\n";
513
514 # Get rid of double backslashes
515 # (Use a null as a blank-out char.)
516 $s =~ s|\\\\|\000\000|g;
517
518 # Blank out quoted parts of $s
519 while($s =~ m/$qpat/og) {
520# print "\tmatched=$&\n";
521 $s = $`.$1.("\000"x length($2)).$'; #'
522 }
523
524 # Blank out escaped occurances of $c
525 $s =~ s/\\\Q$c\E/\000\000/g;
526
527# print "$s\n";
528 # Do the indexing
529 return index($s,$c,$j||0);
530
531
532}
533
534sub uqsplit {
535 my ($s,$c) = @_;
536 my (@parts,$i,$l);
537 my $lc = length($c);
538 # Split string on $c (not an RE) except where escaped or quoted
539 while($l=length($s)) {
540 $i = uqindex($s,$c);
541 push @parts,substr($s,0,($i>=0?$i:$l));
542 $s = $i>=0 ? substr($s,$i+$lc) : "";
543 }
544 return @parts;
545}
546
547# Remove quotes and un-escape the test
548sub unquote {
549
550 my $s = shift;
551 my ($t);
552 my $qpat = &qpat;
553
554 return $s if ! $s;
555
556 while($s =~ m/$qpat/o) {
557 # print "\n\tMatched = /$1/$2/\n";
558 $t = $2;
559 $t = substr($t,1,-1);
560 $s = $`.$1.$t.$';
561 # print "\tresult = /$s/\n";
562 }
563
564 if($s =~ m|\\+|) { $s =~ s|(\\+)|'\\'x(int(length($1)/2))|eg; }
565
566 return $s;
567}
568
569# Do a single rotation wrt a selectable pivot poin
570sub rot1 {
571 my ($x,$y,$theta,$xc,$yc) = (shift,shift,shift,
572 def(shift(),0),def(shift(),0));
573 my ($xp,$yp,$thetar);
574
575 $x -= $xc;
576 $y -= $yc;
577 $thetar = $theta/$R2D;
578 $xp = $x*cos($thetar) + $y*sin($thetar);
579 $yp = -$x*sin($thetar) + $y*cos($thetar);
580
581 return ($xp+$xc,$yp+$yc);
582}
583
584# Do a rotation and offset wrt a selectable pivot point.
585sub rot3 {
586 my ($x,$y,$theta,$dx,$dy,$xc,$yc) = (shift,shift,shift,shift,shift,
587 def(shift(),0),def(shift(),0));
588 my ($xp,$yp);
589
590 ($xp,$yp) = rot1($x,$y,$theta,$xc,$yc);
591
592 return ($xp+$dx, $yp+$dy);
593}
594
595# Normalize an angle to [0-360].
596sub angnorm {
597 my $a = shift;
598 require POSIX;
599 POSIX->import(qw/fmod/);
600
601 $a = fmod($a,360);
602 if($a < 0) { $a += 360; }
603
604 return $a;
605}
606
607# Take the difference between two angles producing a result in [-180,180]
608sub angdiff {
609 my ($a,$b) = @_;
610 require POSIX;
611 POSIX->import(qw/fmod/);
612
613 $a = angnorm($a);
614 $b = angnorm($b);
615
616 $a = fmod($a - $b,360);
617 if(abs($a) > 180) { $a = $a < 0 ? 360 + $a : $a - 360; }
618
619 return $a
620}
621
622# Sum two angles producing a positive result in [0-360]
623sub angsum {
624 my ($a,$b) = @_;
625
626 $a = angnorm($a);
627 $b = angnorm($b);
628
629 $a = fmod($a + $b,360);
630 if($a > 180) { $a -= 360; }
631
632 return $a
633}
634
635sub derivexform {
636# Calculate the (theta,dx,dy) needed to rotate x,y to xp,yp
637# given two data points and an initial theta guess that is
638# only a few tenths of a degree off.
639# (Derived equations using a reversed angle sense, so some superfluous
640# minus signs appear on theta and gamma.)
641 my ($x1i,$y1i,$xp1,$yp1,$x2i,$y2i,$xp2,$yp2,
642 $theta0,$xc,$yc,$noiter) = @_;
643 my ($ct,$st) = (cos($theta0/$R2D),sin($theta0/$R2D));
644 my ($x1,$x2,$y1,$y2);
645 my ($a1,$a2,$b1,$b2);
646 my ($gamx,$gamy,$gam);
647 my ($theta,$gamma,$alpha,$beta);
648 my ($maxiter,$maxdtheta) = (10,.005);
649 my $niter = 0;
650
651 $xc = def($xc,0);
652 $yc = def($yc,0);
653 ($x1,$x2,$y1,$y2) = ($x1i-$xc,$x2i-$xc,$y1i-$yc,$y2i-$yc);
654
655 $b1 = $x1*$ct + $y1*$st;
656 $b2 = $x2*$ct + $y2*$st;
657 $a1 = -$x1*$st + $y1*$ct;
658 $a2 = -$x2*$st + $y2*$ct;
659
660 $gamx = (($xp1 - $xp2) - ($b1 - $b2))/($a1 - $a2);
661 $gamy = (($yp1 - $yp2) - ($a1 - $a2))/($b2 - $b1);
662
663 $alpha = $xp1 - $b1 - $a1*$gamx - $xc;
664 $beta = $yp1 - $a1 + $b1*$gamy - $yc;
665 $gamma = ($gamx + $gamy)/2.*$R2D;
666
667 $theta = angsum($gamma,$theta0);
668
669 if(! $noiter && abs($gamma) > $maxdtheta) {
670 for my $i (1..$maxiter) {
671 ($theta,$alpha,$beta,$gam) =
672 derivexform($x1i,$y1i,$xp1,$yp1,$x2i,$y2i,$xp2,$yp2,$theta,
673 $xc,$yc,1);
674 $gamma = angdiff($theta,$theta0);
675 ++$niter;
676 if(abs($gam) <= $maxdtheta) { last; }
677 }
678 }
679
680 return wantarray ? ($theta,$alpha,$beta,$gamma,$niter) : $gamma;
681}
682
683# Evaluate a polynomial at value $x.
684# arg.s: x,c0,c1,... in c0*x^0+c1*x^1+...
685sub evalpoly {
686 my $x = shift;
687 my $y = 0;
688
689 $y = pop(@_) + $x*$y while(@_);
690
691 return $y;
692}
693
694# Approximate coefficients b* for the inverse of polynomial a*.
695# No constant term is supplied. $a1 MUST be non-zero.
696# This is from
697# An analysis on the inversion of polynomials
698# M.F. Gonzalez-Cardel and R. Diaz-Uribe,
699# REVISTA MEXICANA DE FISICA E52 (2) (2006) 163-171
700# At the moment this doesn't appear to work well enough for doing
701# inversion of distortion coeff.s since errors are too large 500
702# pixels out from the distortion center. On the other hand, it may
703# work well enough if the distortion is small enough.
704sub poly_inv {
705 my ($a1,$a2,$a3,$a4,$a5,$a6,$a7) = @_;
706 ($a1,$a2,$a3,$a4,$a5,$a6,$a7) = map {$_||0} ($a1,$a2,$a3,$a4,$a5,$a6,$a7);
707 my $b1 = $a1**-1;
708 my $b2 = $a1**-3*-$a2;
709 my $b3 = $a1**-5*(2*$a2**2 - $a3*$a1);
710 my $b4 = $a1**-7*(5*$a1*$a2*$a3 - $a1**2*$a4 - 5*$a2**3);
711 my $b5 = $a1**-9*(6*$a1**2*$a2*$a4 + 3*$a1**2*$a3**2 + 14*$a2**4 -
712 $a1**3*$a5 - 21*$a1*$a2**2*$a3);
713 my $b6 = $a1**-11*(7*$a1**3*$a2*$a5 + 7*$a1**3*$a3*$a4 +
714 84*$a1*$a2**3*$a3 - $a1**4*$a6 -
715 28*$a1**2*$a2**2*$a4 - 28*$a1**2*$a2*$a3**2 -
716 42*$a2**5);
717 my $b7 = $a1**-13*(8*$a1**4*$a2*$a6 + 8*$a1**4*$a3*$a5 +
718 4*$a1**4*$a4**2 +
719 120*$a1**2*$a2**3*$a4 + 180*$a1**2*$a2**2*$a3**2 +
720 132*$a2**6 - $a1**5*$a7 - 36*$a1**3*$a2**2*$a5 -
721 72*$a1**3*$a2*$a3*$a4 - 12*$a1**3*$a3**3 -
722 330*$a1*$a2**4*$a3);
723 # They give two more terms after this I don't have the patience to
724 # transcribe
725 return ($b1,$b2,$b3,$b4,$b5,$b6,$b7);
726}
727
728# Return the max of a list
729sub max {
730 my $v=ref($_[0]) ? $_[0] : \@_;
731 my $i=$#{$v};
732 my $m=$v->[$i];
733 while (--$i >= 0) { if ($v->[$i] > $m) { $m=$v->[$i]; }}
734 return $m;
735}
736
737# Return the min of a list
738sub min {
739 my $v=ref($_[0]) ? $_[0] : \@_;
740 my $i=$#{$v};
741 my $m=$v->[$i];
742 while (--$i >= 0) { if ($v->[$i] < $m) { $m=$v->[$i]; }}
743 return $m;
744}
745
746# Make undefined values visible/printable
747sub undefize {
748 my @x = map {defined $_ ? $_ : "<undef>"} @_;
749 return wantarray ? @x : $x[0];
750}
751
752# Join the results of undefizing into a single string
753sub undefizejoin {
754 my $sep = shift;
755 return join($sep,undefize(@_));
756}
757
758# Print a string that may have embedded non-printable char.s by substituting
759# their hex value. Also stringify any undefined elements of @_.
760sub printable {
761 my (@s) = undefize @_;
762
763 s/([\001-\037\042\177-\377])/sprintf("<%02x>",unpack("C",$1))/eg for @s;
764
765 return @s;
766}
767
768# Splice in place from an array elements given by their unique, sorted indices
769sub spliceix {
770 my $list = shift;
771 my $ix = shift;
772 my $n=0;
773 my @ret;
774 push @ret, splice @$list,$_-$n++,1 for (@$ix);
775 return @ret;
776}
777
778# Splice in place from an array elements that match any of a set of regexes
779sub splicere {
780 my $list = shift;
781 my $REs = shift;
782 my $eq = shift; # Demand string equality, not a pattern match
783 my @REs = ref($REs) ? @$REs : ($REs);
784 @REs = map { '\A'."\Q$_".'\Z' } @REs if $eq;
785 my $re = "(".join(")|(",@REs).")";
786 my $n=0;
787 my @ret;
788 push @ret, splice @$list,$_-$n++,1 for grep($list->[$_]=~/$re/,0..$#{$list});
789 return @ret;
790}
791
792# Ring an terminal bell
793sub alertbell {
794 my $n = shift || 1; # Number of beeps
795 my $sp = shift || 0; # Time interval between each beep in real sec.s
796 my $l = shift || 1; # Duration of each beep in number of char.s
797 my $ring = "\a"x$l;
798 while ($n--) {
799 print $ring;
800 # Use select as a way of timing between beeps
801 select(undef,undef,undef,$sp) if $n;
802 }
803
804 return 1;
805}
806
807# Defunct routine for peeling off a primary FITS header
808sub getfitshdr {
809 my $fits_file = shift;
810 my ($card,$retval,%hdr,$key,$val,$comment);
811 my $err = "*** $0/GETFITSHDR";
812
813 sysopen FITS,$fits_file,0
814 or (carp("$err: $fits_file inaccessible; $!"),return);
815 while($retval=sysread(FITS,$card,80)) {
816 (carp("$err: Premature EOF on $fits_file"),$retval=-1,last)
817 if $retval<80;
818 (carp("$err: Off the header of $fits_file"),$retval=-1,last)
819 if $card =~ /[^ -~]/; # Non-printing character found
820 last if $card =~ /^END +$/; # End of header
821 next if substr($card,8,1) ne "="; # Not a key=value pair
822 ($key,$val,$comment) = $card =~ m/^(\S+)\s*=\s*(\S.*?)\s*\/\s*(.*)?$/;
823 $hdr{$key} = $val;
824 }
825 carp "$err: IO error on $fits_file; $!" if ! defined $retval;
826 carp "$err: EOF before END card on $fits_file" if $retval == 0;
827 close FITS or carp "$err IO error on close of $fits_file; $!";
828
829 return $retval == 80 ? %hdr : ();
830}
831
832#
833# =====================================================================
834# Move or copy a file in a safe manner.
835#
836
837sub safe_copy {
838 my $from = shift;
839 my $to = shift;
840 my $opts = shift || {};
841 my $err = "*** $0/safecp";
842 my $warn = "=== $0/safecp";
843 my $verbose = $opts->{verbose};
844 my $move = $opts->{move};
845 my $clobber = $opts->{clobber};
846 my $syscp = $opts->{syscp};
847 my $linkok = $opts->{linkok};
848 my $invalidate = $opts->{invalidate_nfs_cache};
849
850 cluck("$err: Bad arguments"),return
851 if ! defined $from || ! defined $to;
852
853 $from = normalizepath($from,1,1);
854 $to = normalizepath($to,1,1);
855
856 cluck("$err: File $from does not exist"),return
857 if ! -e $from;
858
859 cluck("$err: File $from is not a plain file"),return
860 if ! -f _;
861
862 cluck("$err: File $from is not readable"),return
863 if ! -r _;
864
865 cluck("$err: Source file $from and target $to are the same"),return
866 if $to eq $from;
867
868 cluck("$err: File $to already exists"),return
869 if ! $clobber && -e $to;
870
871 cluck("$err: Target $to is a directory"),return
872 if -d $to;
873
874 my $todir = dirname($to);
875
876 cluck("$err: Target directory $todir does not exist"),return
877 if ! -e $todir;
878
879 cluck("$err: Target directory $todir has bad permissions"),return
880 if ! -w $todir || ! -x $todir;
881
882 my $todev = (stat($todir))[0];
883 my $fromdev = (stat($from))[0];
884
885 # Do the actual copy/move
886
887 if($move && $todev == $fromdev) {
888 # If we're unlinking and the target is on the same device as
889 # the input, we can just do a rename.
890 print "Renaming '$from' to '$to'.\n" if $verbose;
891 my $rc = system("/bin/mv",$verbose?("-v"):(),$from,$to);
892 cluck("$err: Archiving by 'mv' of $from to $to failed; RC=$rc"),
893 return
894 if $rc;
895 #rename($from, $to) or
896 # cluck("$err: Archiving by rename of $from to $to failed; $!"),
897 # return
898 } else {
899 # Copy the target.
900 # As an optimization, if we're on the same device (and not unlinking)
901 # we can do a hardlink instead of an actual copy.
902 my $link = $linkok && $todev == $fromdev;
903 my @link = $link ? ("-l") : ();
904 my @force = $clobber ? ("-f") : ();
905 # If we're not hard linking, make the copy pseudo-atomic by
906 # by copying to a temp name, then renaming.
907 my $tmp = $to.".copying.$$.".time();
908 my $targ = @link ? $to : $tmp;
909 if($syscp || $link) {
910 # Use the system copy command
911
912 my @cpcmd = ('/bin/cp', '-p', $verbose?("-v"):(), @link, @force,
913 $from, $targ );
914 print "Executing archiving command '@cpcmd' ...\n" if $verbose;
915 my $rc = system(@cpcmd);
916 cluck("$err: Cp command '@cpcmd' failed with RC=$rc"), return
917 if $rc;
918 } else { INTERNAL: {
919 # Use internal copy code
920
921 # Code shamelessly cribbed from File::Copy. We don't just
922 # use File::Copy because I may want to start injecting
923 # kluges to work around various problems.
924
925 print "Executing internal copy loop from '$from' to '$targ' ...\n"
926 if $verbose;
927
928 my($fr,$to,$where);
929 $where = "";
930 open($to, ">$targ") or $where="open(to)", $to=undef, goto BAIL;
931 open($fr, "<$from") or $where="open(from)", $fr=undef, goto BAIL;
932
933 $! = 0;
934 my $bufsz = 2*1024*1024;
935 IO: for (;;) {
936 my ($r, $w, $t, $buf);
937 my $nlostfile = 0;
938 READ: {
939 $r = sysread($fr, $buf, $bufsz);
940 if(! defined $r) {
941 # Error
942 if($! =~ /^no such file/i && $nlostfile < 10) {
943 # !!! Special work-around to try and deal with
944 # strange network problem where a file
945 # "disappears" while being copied.
946 ++$nlostfile;
947 warn "$warn: \"Lost\" '$from' on sysread ($!); ".
948 "pause and retry ".(10-$nlostfile).
949 " more times.\n";
950 sleep 2;
951 redo READ;
952 } else {
953 # Some other error we can't work around.
954 $where="sysread(from)";
955 goto BAIL;
956 }
957 } # defined $r
958 } # READ
959 last IO unless $r; # EOF
960 WRITE: for ($w = 0; $w < $r; $w += $t) {
961 $t = syswrite($to, $buf, $r - $w, $w)
962 or $where="syswrite(to)", goto BAIL;
963 }
964 } # IO
965
966 BAIL:
967 my $status = $!;
968 $! = 0;
969 close($to) or $where.='close(to)' if $to;
970 close($fr) or $where.='close(from)' if $fr;
971 $! = $status unless ! $status && $!;
972
973 cluck("$err: Internal copy of '$from' to '$targ' failed in ".
974 "$where; $!"),
975 return
976 if $!;
977
978 } } # INTERNAL
979 if(! $link) {
980 # Rename from the temp file if not hard linking
981 my $rc = system("/bin/mv",$verbose?("-v"):(),@force,$targ,$to);
982 cluck("$err: System 'mv' of $targ to $to failed; RC=$rc"),
983 return
984 if $rc;
985 #rename($tmp, $to) or
986 # cluck("$err: Renaming '$tmp' to '$to' failed; $!"), return;
987 }
988 if($move) {
989 # Unlink after doing a size check
990 cluck("$err: Size comparison failed"),return
991 if -s $from != -s $to;
992 print "Unlinking $from ...\n" if $verbose;
993 unlink($from)
994 or warn "$err: Unable to unlink '$from'; $!\n".
995 "$err: Continue after failed unlink";
996 }
997 }
998
999 invalidate_nfs_cache($todir) if $invalidate;
1000
1001 return 1;
1002}
1003
1004# This just delets then writes an empty file to make NFS update its
1005# attribute cache
1006sub invalidate_nfs_cache {
1007 my $dir = shift || ".";
1008 my $file = shift || ".invalidate";
1009 unlink("$dir/$file");
1010 return open(S,">$dir/$file") && close(S);
1011}
1012
1013# Move/copy files matching $glob from $from to $to, creating $to if need be.
1014sub copy_glob {
1015 my $from = shift;
1016 my $to = shift;
1017 my $glob = shift;
1018 my $opts = shift || {};
1019 my $verbose = $opts->{verbose};
1020 my $move = $opts->{move};
1021 my $clobber = $opts->{clobber};
1022 my $tag = $opts->{tag};
1023 my $create = $opts->{create};
1024 my $umask = $opts->{umask} || umask();
1025 my $err = "$0/cpglob";
1026
1027 $tag .= " " if defined $tag;
1028 $tag ||= "";
1029
1030 my $svumask = umask();
1031
1032 umask($umask);
1033
1034 if(! samefile($to,$from)) {
1035 if($create && ! -d $to) {
1036 mymkpath($to,{unmask=>$umask, verbose=>$verbose})
1037 or warn("$err: Error creating path $to"),
1038 umask($svumask),
1039 return;
1040 }
1041 my @glob = glob($from.$glob);
1042 print "Copying ".@glob." ${tag}files ($glob) from $from to $to ...\n"
1043 if $verbose;
1044 for my $file (@glob) {
1045 my $target = $to.basename($file);
1046 safe_copy($file,$target,{verbose=>$verbose,move=>$move,
1047 clobber=>$clobber})
1048 or warn("$err: Couldn't move $file to $target"),
1049 umask($svumask),
1050 return;
1051 }
1052 } else {
1053 print "Paths $from and $to are the same; no copy of ${tag}files done.\n"
1054 if $verbose;
1055 }
1056
1057 umask($svumask);
1058
1059 return 1;
1060
1061}
1062
1063# Front-end for arcane calls required to change the group id of a file
1064# and set the SETGID bit and the sticky/inherit bit. Nothing perl-ish here;
1065# This would look pretty simnilar if written in C. It's the same system calls.
1066sub chgrp {
1067 my $file = shift;
1068 my $grpname = shift;
1069 my $setgid = shift;
1070 my $sticky = shift;
1071 # v = current permit mode
1072 my $mode = $setgid || $sticky ? (stat($file))[2] : "0 but true";
1073 if(! defined $mode) {
1074 warn "*** $0/CHGRP: Stat failed for $file; $!\n";
1075 return;
1076 }
1077 my $grpid = $grpname=~/^\s*[-+]?\d+\s*$/ ? $grpname : getgrnam($grpname);
1078 if(! defined $grpid) {
1079 warn "*** $0/CHGRP: getgrname failed on $grpname; $!\n";
1080
1081 return;
1082 }
1083 # If it's a real group ID, change the file or directory group ID
1084 # but not the owner by setting uid to -1.
1085 # Note that this call will change the group of the file pointed to
1086 # by a symbolic link, not the group of the symbolic link itself.
1087 if($grpid>=0) {
1088 if(! chown(-1,$grpid,$file)) {
1089 warn "*** $0/CHGRP: Chown (to change group) failed on $file, ".
1090 "group $grpname/$grpid; $!\n";
1091 return;
1092 }
1093 }
1094 # Setting the sticky bit on a directory restricts the conditions
1095 # under which a file may be removed or renamed in a directory
1096 if($sticky) {
1097 if(! chmod(($mode|01000),$file)) {
1098 warn "*** $0/CHGRP: Chmod(sticky) failed on $file; $!\n";
1099 return;
1100 }
1101 $mode |= 01000;
1102 }
1103 # Set the inhert-group-ID bit for directories, or the setgid bi
1104 # for non-dir.s . For directories, this causes files created in the
1105 # dir to inherit the dir's group ID.
1106 if($setgid) {
1107 if(! chmod(($mode|02000|010),$file)) {
1108 warn "*** $0/CHGRP: Chmod(setgid) failed on $file; $!\n";
1109 return;
1110 }
1111 $mode |= 02000|010;
1112 }
1113
1114 return $mode;
1115}
1116
1117# Clear out all files in a directory except those matching (one of) the
1118# globs in $not.
1119sub clearout {
1120 my $dir = shift;
1121 my $opts= shift || {};
1122 my $not = $opts->{not};
1123 my $isre = $opts->{re};
1124 my $list = $opts->{list};
1125 my $do = $opts->{do};
1126 my $keepsyms= $opts->{keepsyms}; # Keep symlinks
1127 my $recurse = $opts->{recurse}; # Not implemented yet
1128 my $verbose = $opts->{verbose};
1129 my (@files,$n,$dh);
1130
1131
1132 if($recurse) {
1133 warn "*** $0/CLEAR: RECURSE option not implemented.\n";
1134 return;
1135 }
1136
1137 if(! defined $dir) {
1138 warn "*** $0/CLEAR: No directory specified.\n";
1139 return;
1140 }
1141
1142 if(! $do && ! $not) { # Demand the user specify something
1143 warn "*** $0/CLEAR: Neither DO nor NOT specified.\n";
1144 return;
1145 }
1146
1147 $dir .= '/' if $dir !~ m|/$|;
1148
1149 if(! opendir($dh,$dir)) {
1150 warn "*** $0/CLEAR: Unable to open $dir: $!\n"; return; }
1151 if(! (@files = readdir($dh))) {
1152 warn "*** $0/CLEAR: Unable to read $dir: $!\n";
1153 return;
1154 }
1155 closedir($dh);
1156
1157 # Strip off "." and "..", prepend directory name,
1158 # and mark directories with a trailing slash
1159 @files = map { $_ eq '.' || $_ eq '..' ? () :
1160 -d $_ ? $dir.$_."/" : $dir.$_ } @files;
1161 if(! @files) { return $list ? [] : 1; }
1162
1163 #print "--- @files\n";
1164
1165 if($do) {
1166 # Files to clear out
1167 my @thesedos;
1168 my @tmp;
1169 my $do = ref($do) ? $do : [$do];
1170 for my $yup (@$do) {
1171 next if ! $yup && $yup ne '0'; # not defined or empty string
1172 @thesedos = glob($dir.$yup) if ! $isre;
1173 @thesedos = grep(m|/.*?$yup$|,@files) if $isre;
1174 #print "---- '$yup'($isre) found '@thesedos'\n";
1175 push @tmp,@thesedos;
1176 }
1177 @files = @tmp;
1178 }
1179
1180 if($not) {
1181 # Files to NOT clear out
1182 my @thesenots;
1183 my $not = ref($not) ? $not : [$not];
1184 for my $nope (@$not) {
1185 next if ! $nope && $nope ne '0'; # not defined or empty string
1186 @thesenots = glob($dir.$nope) if ! $isre;
1187 @thesenots = grep(m|/.*?$nope$|,@files) if $isre;
1188 #print "---- '$nope'($isre) avoiding '@thesenots'\n";
1189 for my $nope1 (@thesenots) {
1190 @files = grep($_ ne $nope1,@files);
1191 }
1192 }
1193 }
1194
1195 # Just plain files and links please
1196 @files = grep(-f $_ || (! $keepsyms && -l $_), @files);
1197
1198 # Really just return a list (or count)?
1199 if($list) { return \@files; }
1200
1201 if(! @files) { return 1; }
1202
1203 # Do the unlinking
1204 for my $f (@files) {
1205 print "Unlinking $f ...\n" if $verbose;
1206 if(! unlink($f)) {
1207 warn "*** $0/CLEAR: Unable to unlink $f: $!\n";
1208 ++$n;
1209 }
1210 }
1211
1212 return if $n; # Oops. Some files wouldn't unlink
1213 return 1; # All is well
1214}
1215
1216# Cartesian sum
1217sub rss {
1218 my $sum=0;
1219 return sqrt( scalar((map { $sum+=(($_?$_:0)**2) } @_), $sum) );
1220}
1221
1222# Test for unity of a cartesian sum
1223sub rsseq1p {
1224 my $rss=rss;
1225 return abs($rss-1) < .0000001;
1226}
1227
1228 # Pretty decent random generator seed.
1229sub goodseed { return time() ^ ($$ + ($$<<15)); }
1230
1231 # Normally distributed random numbers good to +- 6 sigma
1232sub srandgaus { my $seed = shift || goodseed(); srand($seed); return $seed; }
1233sub randgaus {
1234 my $u = shift;
1235 my $s = shift;
1236 $u = defined $u ? $u : 0;
1237 $s = defined $s ? $s : 1;
1238 my $samp = rand() + rand() + rand()
1239 + rand() + rand() + rand()
1240 + rand() + rand() + rand()
1241 + rand() + rand() + rand() - 6;
1242 return $samp*$s + $u;
1243}
1244sub nrandgaus { my $n=shift; return map {randgaus(@_)} 1..$n; }
1245
1246 # Sky positions uniformly covering the sphere
1247sub skydraw {
1248 my ($alpha,$delta);
1249 require POSIX;
1250 POSIX->import(qw/asin/);
1251
1252 $alpha = rand()*360;
1253 $delta = $R2D*asin(rand()*2 - 1);
1254
1255 return ($alpha,$delta);
1256}
1257
1258 # Area of overlap of two circles of different radii
1259 # From http://www.biozoek.nl/venn/theory.html
1260sub area_2circle_overlap {
1261
126230.001800.00060 use POSIX qw/acos/;
# spent 85µs making 1 call to POSIX::import
1263
1264 my ($R,$r,$d) = @_;
1265
1266 return if grep {! defined} ($d, $R, $r);
1267 return if $d < 0 || $R <= 0 || $r <= 0;
1268
1269 ($r,$R) = sort {$a<=>$b} ($r,$R);
1270
1271 return $PI*$r**2 if $d <= $R-$r;
1272 return 0 if $d >= $R+$r;
1273
1274 my $A = $r**2*acos(($d**2+$r**2-$R**2)/(2*$d*$r)) +
1275 $R**2*acos(($d**2+$R**2-$r**2)/(2*$d*$R)) -
1276 0.5*sqrt((-$d+$r+$R)*($d+$r-$R)*($d-$r+$R)*($d+$r+$R));
1277
1278 return $A;
1279}
1280
1281# Check to see if this session is interactive or background
1282sub foreground {
1283 require POSIX;
1284 POSIX->import(qw/getpgrp tcgetpgrp/);
1285 open(TTY, "/dev/tty") or return;
1286 my $tpgrp = tcgetpgrp(fileno(*TTY));
1287 my $pgrp = getpgrp();
1288 if ($tpgrp == $pgrp) {
1289 return 1;
1290 } else {
1291 return 0;
1292 }
1293}
1294
1295# Deep comparison
1296
1297sub deep_cmpr { &scalar_cmpr; }
1298
1299sub hash_cmpr {
1300 my ($h1,$h2) = @_;
1301 for my $k (keys %$h1,keys %$h2) {
1302 return unless exists $h1->{$k} && exists $h2->{$k} &&
1303 scalar_cmpr($h1->{$k},$h2->{$k});
1304 }
1305 return 1;
1306}
1307
1308sub array_cmpr {
1309 my ($a1,$a2) = @_;
1310 return if @$a1 != @$a2;
1311 for my $i (0..$#$a1) { return unless scalar_cmpr($a1->[$i],$a2->[$i]); }
1312 return 1;
1313}
1314
1315sub ref_cmpr {
1316 my ($r1,$r2) = @_;
1317 return unless scalar_cmpr(ref($r1),ref($r2));
1318 if( ref($r1) eq "ARRAY") {
1319 return unless array_cmpr($r1,$r2);
1320 } elsif(ref($r1) eq "HASH") {
1321 return unless hash_cmpr($r1,$r2);
1322 } elsif(ref($r1) eq "SCALAR") {
1323 return unless scalar_cmpr($$r1,$$r2);
1324 } elsif(ref($r1) eq "REF") {
1325 return unless ref_cmpr($$r1,$$r2);
1326 } elsif("$r1" =~ /=(array|hash|scalar|ref)\([0-9xa-f]+\)$/i) {
1327 return unless ref($r1) eq ref($r2);
1328 # Is there a more compact way to unbless?
1329 if( $1 eq "HASH") {
1330 return unless hash_cmpr({%$r1},{%$r2});
1331 } elsif($1 eq "ARRAY") {
1332 return unless array_cmpr([@$r1],[@$r2]);
1333 } elsif($1 eq "REF") {
1334 return unless ref_cmpr($$r1,$$r2);
1335 } else { # SCALAR
1336 return unless scalar_cmpr($$r1,$$r2);
1337 }
1338 } else { # GLOB, CODE, LVALUE, or odd object. No can handle.
1339 carp "*** $0/deep_cmpr: Can't handle a $r1";
1340 return;
1341 }
1342
1343 return 1;
1344}
1345
1346sub scalar_cmpr {
1347 my ($s1,$s2) = @_;
1348 return if defined $s1 xor defined $s2;
1349 return 1 if not defined $s1;
1350 return if ref $s1 xor ref $s2;
1351 return $s1 eq $s2 unless ref $s1;
1352 return ref_cmpr($s1,$s2);
1353}
1354
1355
1356# Deep copying
1357
1358sub deep_copy {
1359 my @res;
1360 push @res,scalar_copy($_) for (@_);
1361 return wantarray ? @res : $res[0];
1362}
1363
1364sub unbless {
1365 my $r1 = shift;
1366 return unless "$r1" =~ /=(array|hash|scalar|ref)\([0-9xa-f]+\)$/i;
1367 if( $1 eq "HASH") {
1368 return hash_copy({%$r1});
1369 } elsif($1 eq "ARRAY") {
1370 return array_copy([@$r1]);
1371 } elsif($1 eq "REF") {
1372 return \ ref_copy($$r1);
1373 } else { # SCALAR
1374 return \ scalar_copy($$r1);
1375 }
1376}
1377
1378sub hash_copy {
1379 my ($h1,$h2) = (shift,{});
1380 return unless "$h1" =~ /hash/i;
1381 for my $k (keys %$h1) {
1382 $h2->{$k} = scalar_copy($h1->{$k});
1383 }
1384 return $h2;
1385}
1386
1387sub array_copy {
1388 my ($a1,$a2) = (shift,[]);
1389 return unless "$a1" =~ /array/i;
1390 for my $i (0..$#$a1) { $a2->[$i] = scalar_copy($a1->[$i]); }
1391 return $a2;
1392}
1393
1394sub scalar_copy {
1395 my $s1 = shift;
1396 return $s1 unless ref $s1;
1397 return ref_copy($s1);
1398}
1399
1400sub ref_copy {
1401 my $r1 = shift;
1402 return unless ref $r1;
1403 if( ref($r1) eq "ARRAY") {
1404 return array_copy($r1);
1405 } elsif(ref($r1) eq "HASH") {
1406 return hash_copy($r1);
1407 } elsif(ref($r1) eq "SCALAR") {
1408 return \ scalar_copy($$r1);
1409 } elsif(ref($r1) eq "REF") {
1410 return \ ref_copy($$r1);
1411 } elsif("$r1" =~ /(.+)=(array|hash|scalar|ref)\([0-9xa-f]+\)$/i) {
1412 return bless unbless($r1),$1;
1413 } else { # GLOB, CODE, LVALUE, or odd object. No can handle.
1414 carp "*** $0/deep_copy: Can't handle a $r1";
1415 return;
1416 }
1417
1418 return 1;
1419}
1420
1421
1422#
1423# fcntl-based file locking control code. Works for recent linux versions.
1424#
1425
1426# !!! Should probably use File::NFSLock instead these days.
1427
1428# The file lock structure on linux with the large file (64 bit) kernel
1429#
1430# struct flock {
1431# short l_type;
1432# short l_whence;
1433# off64_t l_start; ... or off_t l_start
1434# off64_t l_len; ... or off_t l_len
1435# pid_t l_pid;
1436# };
1437#
1438# Auxilliary routines for providing the structure above with constants
1439# set to lock/unlock whole files.
1440
1441# These first routines are not exported
1442
1443# Need 64 bit start and len values? vvvvv 64 vvv 32
1444sub LKTMPL8 () { &F_SETLK==&F_SETLK64 ? "S S LL LL i" : "S S L L i"; }
1445sub WRLCK () { pack(LKTMPL8,&F_WRLCK,&SEEK_SET,0,0,0,0,0); }
1446sub RDLCK () { pack(LKTMPL8,&F_RDLCK,&SEEK_SET,0,0,0,0,0); }
1447sub UNLCK () { pack(LKTMPL8,&F_UNLCK,&SEEK_SET,0,0,0,0,0); }
1448sub SETLK () { &F_SETLK; }
1449sub SETLKW () { &F_SETLKW; }
1450sub GETLK () { &F_GETLK; }
1451
1452sub lockrwnb {
1453 # General lock or unlock code.
1454 my($FOO,$type) = @_;
1455 my($rc);
1456
1457 $rc = fcntl($FOO,SETLK,$type);
1458
1459 return $rc ? 1 # Lock succeeded
1460 : $!==&EAGAIN || $!==&EACCES ? 0 # Locked elsewhere
1461 : undef; # Error
1462
1463}
1464
1465sub lockrwb {
1466 # General lock or unlock code.
1467 my($FOO,$type) = @_;
1468 my($rc);
1469
1470 $rc = fcntl($FOO,SETLKW,$type);
1471
1472 return $rc ? 1 : undef;
1473}
1474
1475sub lockgetrw {
1476 # Get info on other processes that would block a read or write lock
1477 my($FOO,$type) = @_;
1478 my($state,$pid);
1479
1480 fcntl($FOO,GETLK,$type)
1481 or (carp("*** $0/LOCKGETRW: fcntl failed; (errno=",$!+0,") $!"),
1482 return);
1483 ($state,$pid) = (unpack(LKTMPL8,$type))[0,-1];
1484
1485 return $state == &F_UNLCK ? 0 : $pid;
1486}
1487
1488sub lockrw {
1489 # Request a blocking read or write lock on filehandle FOO.
1490 my $FOO = shift;
1491 my $type = shift;
1492 my $ntry = shift;
1493 my $retry= shift;
1494 my($rc,$wait);
1495
1496 $wait = ! $ntry;
1497
1498 REP: {
1499 if($wait) {
1500 # Unbounded, continuous blocking wait
1501 $rc = lockrwb($FOO,$type);
1502 if(! $rc && $! == &EINTR) {
1503 # Interrupted. Now what?
1504 redo REP if $retry; # Try again ...
1505 $rc = 0; # ... or show failure, but a "non-fatal" failure
1506 }
1507 } else {
1508 # Bounded, periodic, non-blocking wait
1509 $rc = lockrwnb($FOO,$type);
1510 # print "$ntry -- $rc -- $!\n";
1511 (sleep(1),redo REP) if defined $rc && $rc==0 && $ntry--;
1512 }
1513 }
1514 carp "*** $0/LOCKRW: fcntl failed; (errno=",$!+0,") $!"
1515 if ! defined $rc; # Be silent if out of time or interrupted
1516
1517 return $rc;
1518}
1519
1520# Exported routines
1521
1522# By name ...
1523sub lockit {
1524 my $file = shift; # Name or filehandle
1525 my $type = shift || "w"; # w, r ,wbn, rnb, un
1526 my ($rc,$fh);
1527
1528 if(! ref $file) {
1529 open($fh, "+<$file")
1530 or (carp("*** $0/lockname: Unable to open $file; $!"),return);
1531 } else {
1532 $fh = $file;
1533 }
1534 {
153530.002710.00090 no strict 'refs';
# spent 26µs making 1 call to strict::unimport
1536 #print "$type $file $fh\n";
1537 #$SIG{__DIE__} = sub {confess @_};
1538 $rc = &{"lock$type"}($fh);
1539 }
1540
1541 close $fh if ! wantarray;
1542
1543 return wantarray ? ($rc,$fh) : $rc;
1544}
1545
1546# By file handle ...
1547sub lockwnb {
1548 # Request a non-blocking write lock on filehandle FOO.
1549 return lockrwnb(shift,WRLCK);
1550}
1551
1552
1553sub lockw {
1554 # Request a blocking write lock on filehandle FOO.
1555 return lockrw(shift,WRLCK,@_);
1556}
1557
1558
1559sub lockrnb {
1560 # Request a non-blocking read lock on filehandle FOO.
1561 return lockrwnb(shift,RDLCK);
1562}
1563
1564
1565sub lockr {
1566 # Request a blocking read lock on filehandle FOO.
1567 return lockrw(shift,RDLCK,@_);
1568}
1569
1570sub lockun {
1571 # Unlocks filehandle FOO.
1572 lockrwnb(shift,UNLCK)
1573 or (carp("*** $0/LOCKUN: fcntl failed; (errno=",$!+0,") $!"),return);
1574
1575 return 1;
1576}
1577
1578sub lockgetw {
1579 # Get write lock info
1580 return lockgetrw(shift,WRLCK);
1581}
1582
1583sub lockgetr {
1584 # Get read lock info
1585 return lockgetrw(shift,RDLCK);
1586}
1587
1588#
1589####### Statistical computation and display
1590#
1591
1592sub gather_stats {
1593 my $what = shift;
1594 my $state = shift || {};
1595 my $opts = shift || {};
1596 my $extend= $opts->{extend};
1597
1598 while(my ($who,$val) = each %$what) {
1599 next if ! defined $val;
1600 $state->{$who}{n}++;
1601 $state->{$who}{sum} += $val;
1602 $state->{$who}{sumsq} += $val**2;
1603 $state->{$who}{min} = $val if ! defined $state->{$who}{min};
1604 $state->{$who}{min} = $val < $state->{$who}{min} ? $val
1605 : $state->{$who}{min};
1606 $state->{$who}{max} = $val if ! defined $state->{$who}{max};
1607 $state->{$who}{max} = $val > $state->{$who}{max} ? $val
1608 : $state->{$who}{max};
1609 if($extend) {
1610 push @{$state->{$who}{set}}, $val;
1611 }
1612 }
1613
1614 return $state;
1615}
1616
1617sub calc_stats {
1618 my $which = shift; # [ $who1, ..., $whoN]
1619 my $state = shift;
1620 my $opts = shift || {};
1621
1622 if(! $which || $which eq 'all') { $which = [sort keys %$state]; }
1623 elsif(! ref $which) { $which = [$which]; }
1624 elsif(! @$which) { $which = [sort keys %$state]; }
1625
1626 for my $who (@$which) {
1627 next if ! $state->{$who} || ! defined $state->{$who}{n};
1628 my $n = $state->{$who}{n};
1629 if($n > 0) {
1630 $state->{$who}{mean} = $state->{$who}{sum} / $n;
1631 if($state->{$who}{set} && @{$state->{$who}{set}}) {
1632 my ($lo,$hi) = (int($n/2)-(($n+1)%2), int($n/2));
1633 @{$state->{$who}{set}} = sort {$a<=>$b} @{$state->{$who}{set}};
1634 $state->{$who}{median} = ($state->{$who}{set}[$lo] +
1635 $state->{$who}{set}[$hi] )/2;
1636 }
1637 } else {
1638 $state->{$who}{mean} = undef;
1639 if($state->{set} && @{$state->{set}}) {
1640 $state->{$who}{median} = undef;
1641 }
1642 }
1643 if($n > 1) {
1644 my $d = $state->{$who}{sumsq}/$n - $state->{$who}{mean}**2;
1645 $state->{$who}{popsd} = sqrt(($d>0?$d:0) * $n/($n-1));
1646 $state->{$who}{meansd} = $state->{$who}{popsd} / sqrt($n);
1647 if($state->{$who}{set} && @{$state->{$who}{set}}) {
1648 $state->{$who}{sigpop} = ($state->{$who}{set}[int($n*0.84)] -
1649 $state->{$who}{set}[int($n*0.16)]) / 2;
1650 }
1651 } else {
1652 $state->{$who}{popsd} = $state->{$who}{meansd} = -1;
1653 if($state->{$who}{set} && @{$state->{$who}{set}}) {
1654 $state->{$who}{sigpop} = -1;
1655 }
1656 }
1657 }
1658
1659 return $state;
1660}
1661
1662sub print_stats {
1663 my $which = shift; # [$id,...] or [... [$id=>$label] ... ]
1664 my $state = shift;
1665 if(! $state && ref($which) =~ /hash/i) { $state = $which; $which=undef; }
1666 my $opts = shift || {};
1667
1668 if(! $which || $which eq 'all') { $which = [sort keys %$state]; }
1669 elsif(! ref $which) { $which = [$which]; }
1670 elsif(! @$which) { $which = [sort keys %$state]; }
1671 else {
1672 if(ref($which->[0]) =~ /hash/i) {
1673 # Turn into array refs
1674 $_ = [@{$_}{qw/who label unit fmt/}] for @$which;
1675 } else {
1676 # All is in proper order already
1677 }
1678 }
1679
1680 my $outfh = $opts->{outfh} || \*STDOUT;
1681
1682 # Create id=>label hash, even if that means copying the id as the label
1683 my %which = map { ref($_) ? ($_->[0]=>$_) : ($_=>[$_]) } @$which;
1684 ref($_) and $_ = $_->[0] for @$which;
1685
1686 my $str = "";
1687
1688 for my $who (@$which) {
1689 my $unit = "";
1690 my $formatdef = $opts->{format} || "%8.3f";
1691 my $format2;
1692 my $format = $formatdef;
1693 if(! defined $which{$who} || ! defined $state->{$who}) {
1694 $str .= "[No data for '$who']\n";
1695 next;
1696 }
1697 my $label = $which{$who};
1698 if(ref $label) { ($label,$unit,$format) =
1699 ($label->[1]||$who, $label->[2]||"",
1700 $label->[3]||$formatdef) ; }
1701 if(! defined $state->{$who}{mean} &&
1702 defined $state->{$who}{n} && $state->{$who}{n} > 0) {
1703 calc_stats($who,$state);
1704 }
1705 ($format2 = $format) =~ s/%(\d*)\.(\d*)/%$1.0/;
1706 $unit = $unit ? "($unit)" : "";
1707 $str .= sprintf
1708 "$label$unit:\n".
1709 "\tMean = $format +/- $format\n".
1710 ($state->{$who}{set} && @{$state->{$who}{set}}
1711 ? "\tMedian = $format, PopSig = $format\n" : "").
1712 "\tStdDev = $format, N = $format2\n".
1713 "\tMin = $format, Max = $format\n",
1714 $state->{$who}{mean}, $state->{$who}{meansd},
1715 ($state->{$who}{set} && @{$state->{$who}{set}}
1716 ? ($state->{$who}{median},$state->{$who}{sigpop}) : ()),
1717 $state->{$who}{popsd},$state->{$who}{n},
1718 $state->{$who}{min}, $state->{$who}{max};
1719 }
1720
1721 if(! $opts->{str}) {
1722 print $outfh $str;
1723 }
1724
1725 return $str;
1726}
1727
1728#
1729####### New WISE file/band/header resoltuion stuff
1730#
1731
1732sub get_hdr_data {
1733 my $files = shift || [];
1734 # Pairwise key=>scalar ref, or [key1,key2,...]=>scalar ref
1735 # key can be {key=>key, low=>min value, high=>max value}
1736 my @want = @_;
1737 my $n = 0;
1738 my @files = ref($files) ? @$files : ($files);
1739 my $err = "*** $0/GetHdr";
1740
1741 return if ! @want;
1742 return if ! @files;
1743
1744 die "$err: \@want parameter misconfigured.\n" if @want%2;
1745
1746 my $npairs = @want/2;
1747
1748 FILE: for my $file (@files) { # Look for values in each file in turn
1749 next FILE if ! $file;
1750
1751 my ($hdr,$close);
1752
1753 if(ref $file) {
1754 $hdr = $file;
1755 } else {
1756 eval "use WISE::FITSIO (); 1;"
1757 or die "$err: Can't load WISE::FITSIO.\n$@";
1758 $hdr = WISE::FITSIO->new($file,{silent=>1}) or next;
1759 $close = 1;
1760 }
1761
1762 my $gotone;
1763 WANT: for my $i (0..@want/2-1) { # Step through desired values
1764 my ($keys,$ref) = ($want[2*$i],$want[2*$i+1]);
1765 my ($min,$max,$verbose);
1766 if(ref($keys) =~ /HASH/) {
1767 ($keys,$min,$max,$verbose) = @{$keys}{qw/key low high verbose/};
1768 }
1769 $keys = [$keys] if ! ref($keys);
1770 die "$err: \@want parameter pair $i misconfigured(1).\n"
1771 if ref($keys) !~ /ARRAY/ || ! @$keys || ref($ref) !~ /SCALAR/;
1772 # Already got it?
1773 next WANT if defined $$ref &&
1774 (! defined $min || $$ref >= $min) &&
1775 (! defined $max || $$ref <= $max);
1776 my $tmp;
1777 KEY: for my $key (@$keys) { # Step through key aliases
1778 die "$err: \@want parameter pair $i misconfigured(2).\n"
1779 if ! $key;
1780 $tmp = $hdr->key($key,{hdunum=>1});
1781 next KEY if ! defined $tmp ||
1782 (defined $min && $tmp < $min) ||
1783 (defined $max && $tmp > $max);
1784 $$ref = $tmp;
1785 print "Got $key=$tmp from FITS header in '".$hdr->file."'.\n"
1786 if $verbose;
1787 ++$n;
1788 $gotone = 1;
1789 last KEY;
1790 } # KEY
1791 } # WANT
1792
1793 $hdr->end if $close;
1794
1795 last FILE if ! $gotone; # End if all desired values are in hand
1796 } # FILE
1797
1798 return $n;
1799}
1800
1801sub new_version {
1802 my $dir = shift;
1803 my $iam = "$0/new_version";
1804 my $err = "*** $iam";
1805 my $warn = "=== $iam";
1806
1807 # first we need read/write in/on the directory to be versioned
1808 require File::CheckTree; File::CheckTree->import();
1809 my $warnings = validate( $dir.q{ -rw || warn "***$0/make_new_version: failed permission checks\n"});
1810 return if($warnings);
1811
1812 # we can find the input directory in one of the following states:
1813 # 1. files exist, but no versions ( warning & assume current is v1)
1814 # 2. both files and versions exist (normal, make next)
1815 # 3. versions exist but no files (normal, make next)
1816 # 4. neither files nor versions exist (normal, make v1)
1817
1818 unless( opendir IN, $dir) {
1819 warn "$err: Could not open $dir: $!\n";
1820 return;
1821 }
1822 my @files = readdir IN;
1823 closedir IN;
1824
1825 my $version = 0;
1826 my @movers;
1827 foreach my $entry (@files) {
1828 # we will move a regular file, symlink, or directory (not v\d+) into the new versioned directory
1829 # otherwise, ignore non-regular files, and do version arithmetic on a directory matching /^v\d+$/
1830 if( ($entry !~ /^v\d+$/) &&
1831 (-f "$dir/$entry" || -d _ || -l "$dir/$entry" ) &&
1832 ($entry !~ /(?:^\.+)|(?:-0\.(?:fits|tbl)$)/ ) ) {
1833 push @movers, $entry;
1834 } elsif( (-l "$dir/$entry") && ($entry =~ /^v\d+$/) && (readlink("$dir/$entry") eq '.') ) {
1835 ($version = $entry) =~ s/v//;
1836 }
1837 }
1838
1839 # if we didn't find a version, but we have files, assume a missing v1 link to current
1840 # that's state 1. above, for those following at home
1841 if(@movers && (! $version) ) {
1842 warn "$warn: Files found but no current version link. Assuming current version is 1.\n";
1843 $version = 1;
1844 }
1845
1846 # now, the following should be completed atomically or rolled back.
1847 # no promises; errors in the die handler are ignored
1848 my $ver = eval {
1849
1850 # implement the rollback in a handler for perl's internal die()
1851 # i'll ingore error during clean up; something is wrong & i tried my best
1852 local $SIG{'__DIE__'} = sub {
1853 # reset ourselves back to standard die
1854 local $SIG{'__DIE__'};
1855 # remove the new version link if it exists
1856 if(-e "$dir/v".($version+1)) {
1857 unlink "$dir/v".($version+1);
1858 }
1859
1860 # move everything in $dir/v$version back into $dir
1861 foreach (@movers) {
1862 rename "$dir/v$version/$_", "$dir/$_";
1863 }
1864
1865 # remove any directory hanging off current version
1866 if(-d "$dir/v$version") {
1867 unlink "$dir/v$version";
1868 }
1869
1870 if($version) {
1871 # replace the current version link to .
1872 # TODO: the link now has the wrong creation/mod time. fix this
1873 symlink '.', "$dir/v$version";
1874 }
1875 # don't need to rethrow the die
1876 };
1877
1878 if($version) {
1879 # removed the old version symlink
1880 if(-e $dir.'/v'.$version) {
1881 unlink $dir.'/v'.$version or die "$!";
1882 }
1883
1884 # make a directory for the old version files
1885 mkdir $dir.'/v'.$version or die "$!";
1886 }
1887
1888 foreach (@movers) {
1889 # won't work across filesystem boundaries
1890 rename "$dir/$_", "$dir/v$version/$_" or die "$!";
1891 }
1892
1893 # set the symlink for the new version
1894 symlink '.', $dir.'/v'.($version+1) or die "$!";
1895
1896 return $version+1;
1897
1898 };
1899
1900 if($@) {
1901 warn "***$0/make_new_version: Failed to make new version.\n";
1902 print "***$0/make_new_version: $@\n";
1903 return;
1904 }
1905
1906 return $ver;
1907}
1908
1909
1910sub current_version {
1911 my $dir = shift;
1912 opendir IN, "$dir";
1913 my @entries = readdir IN;
1914 close IN;
1915 foreach (@entries) {
1916 if( ($_ =~ m/^v\d+$/ ) && (-l "$dir/$_") && (readlink "$dir/$_" eq '.') ) {
1917 (my $ver = $_) =~ s/^v//;
1918 return $ver;
1919 }
1920 }
1921 return;
1922}
1923
1924#
1925####### Stndard parameter validation
1926#
1927
1928sub option_validate {
1929 my $opts = shift || {};
1930 my $spec = shift || {};
1931 #Params::Validate::validate(%$opts,
1932 # $spec)
1933}
1934
1935#
1936####### Other misc crap
1937#
1938
1939# Check if two intervals overlap, given some slop.
1940sub interval_overlap_2 {
1941 my $exc = shift || 0; # Exclusive of endpoints
1942 my $slop = shift || 0;
1943 my ($a0,$a1,$b0,$b1) = @_;
1944 my $a2 = ($a0+$a1)/2.; # Need to check midpoints too.
1945 my $b2 = ($b0+$b1)/2.;
1946 my $rc = 0;
1947 if($exc) {
1948 $rc |= 1 if $a0> $b0+$slop && $a0< $b1-$slop;
1949 $rc |= 2 if $a1> $b0+$slop && $a1< $b1-$slop;
1950 $rc |= 4 if $a2> $b0+$slop && $a2< $b1-$slop;
1951 $rc |= 8 if $b0> $a0+$slop && $b0< $a1-$slop;
1952 $rc |= 16 if $b1> $a0+$slop && $b1< $a1-$slop;
1953 $rc |= 32 if $b2> $a0+$slop && $b2< $a1-$slop;
1954 } else {
1955 $rc |= 1 if $a0>=$b0+$slop && $a0<=$b1-$slop;
1956 $rc |= 2 if $a1>=$b0+$slop && $a1<=$b1-$slop;
1957 $rc |= 4 if $a2>=$b0+$slop && $a2<=$b1-$slop;
1958 $rc |= 8 if $b0>=$a0+$slop && $b0<=$a1-$slop;
1959 $rc |= 16 if $b1>=$a0+$slop && $b1<=$a1-$slop;
1960 $rc |= 32 if $b2>=$a0+$slop && $b2<=$a1-$slop;
1961 }
1962 return $rc;
1963}
1964
1965
1966#######################
1967
1968package WISE::Utils::OO;
1969
197030.000196.5e-5use vars qw/$AUTOLOAD/;
# spent 43µs making 1 call to vars::import
1971
1972sub new {
1973 my $this = shift;
1974 my $class = ref($this) || $this;
1975 return bless {},$class;
1976}
1977
1978# Auto-gen methods
1979sub AUTOLOAD {
1980 my $self = shift;
1981 my $err = "*** $0/".__PACKAGE__."/AUTOLOAD";
1982 my $this = ref($self)
1983 or die "$err: '$self' is not an object.\n";
1984 return if ($AUTOLOAD =~ /::DESTROY$/);
1985 # Separate package qualifier from desired sub name
1986 my ($pkg,$sub) = $AUTOLOAD =~ m/(.*:)(.*)/;
1987 #print "'$AUTOLOAD'/'$pkg'/'$sub'/@_\n";
1988 # Strip off OO trailer
1989 $pkg =~ s/::OO//;
1990 # Get sub ref (do not store in namespace)
1991 my $subref;
1992 {
199330.000124.0e-5 no strict qw{refs};
# spent 20µs making 1 call to strict::unimport
1994 $subref = eval "\\&$pkg$sub";
1995 die "$err: Can't eval '$subref'.\n$@" if $@;
1996 }
1997 # Call
1998 goto &$subref;
1999}
2000
200113.0e-53.0e-51;
2002

Report produced by the NYTProf 2.07 Perl profiler, developed by Tim Bunce and Adam Kaplan.