← 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:47 2010

File/wise/base/deliv/dev/lib/perl/WISE/UtilsLight.pm
Statements Executed427
Total Time0.018891 seconds

Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
2220.004930.01316WISE::UtilsLight::banner
7420.000310.00077WISE::UtilsLight::normalizepath
2110.000150.00064WISE::UtilsLight::whichami
4218.9e-50.00093WISE::UtilsLight::mytime
2112.6e-52.6e-5WISE::UtilsLight::mystatus
1111.1e-51.1e-5WISE::UtilsLight::logging
00000WISE::UtilsLight::OO::AUTOLOAD
00000WISE::UtilsLight::OO::BEGIN
00000WISE::UtilsLight::OO::new
00000WISE::UtilsLight::__ANON__[:1225]
00000WISE::UtilsLight::__ANON__[:601]
00000WISE::UtilsLight::__ANON__[:611]
00000WISE::UtilsLight::aryhash_keys
00000WISE::UtilsLight::aryhash_vals
00000WISE::UtilsLight::bannerlines
00000WISE::UtilsLight::closelog
00000WISE::UtilsLight::device_from_df
00000WISE::UtilsLight::fpre
00000WISE::UtilsLight::get_self_command
00000WISE::UtilsLight::mymkpath
00000WISE::UtilsLight::mysymlink
00000WISE::UtilsLight::openlog
00000WISE::UtilsLight::pathcomp
00000WISE::UtilsLight::pathdecomp
00000WISE::UtilsLight::resolvepath
00000WISE::UtilsLight::restorestderr
00000WISE::UtilsLight::restorestdout
00000WISE::UtilsLight::safe_eval
00000WISE::UtilsLight::samefile
00000WISE::UtilsLight::savestderr
00000WISE::UtilsLight::savestdout
00000WISE::UtilsLight::teetofile
00000WISE::UtilsLight::tempfile
00000WISE::UtilsLight::thishost
00000WISE::UtilsLight::whoiam
00000WISE::UtilsLight::wrapup

LineStmts.Exclusive
Time		Avg.Code
1#! /usr/bin/env perl
2
335.1e-51.7e-5use strict;
# spent 13µs making 1 call to strict::import
433.8e-51.3e-5use warnings;
# spent 35µs making 1 call to warnings::import
5
669.7e-51.6e-5use 5.010;
# spent 59µs making 1 call to feature::import
7
830.000227.3e-5use WISE::Env (cfglib=>'/wise/base/deliv/dev/lib/perl', import=>[qw/$hostname/]);
# spent 5.06ms making 1 call to WISE::Env::import, max recursion depth 1
9
10100our $hostname;
11
12# $Id: UtilsLight.pm 7890 2010-05-13 18:25:15Z tim $
13
14package WISE::UtilsLight;
15
1635.9e-52.0e-5use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);
# spent 120µs making 1 call to vars::import
17
1830.000103.4e-5use Exporter::Lite;
# spent 70µs making 1 call to Exporter::Lite::import
1911.0e-61.0e-6$VERSION = 1.00;
20
2111.0e-61.0e-6@EXPORT = ();
2219.0e-69.0e-6@EXPORT_OK = qw(banner bannerlines mystatus logging thishost samefile
23 openlog closelog teetofile savestdout savestderr
24 restorestdout restorestderr whoiam whichami
25 resolvepath normalizepath wrapup fpre
26 aryhash_keys aryhash_vals pathdecomp pathcomp
27 safe_eval mysymlink mymkpath tempfile
28 $logwidth $__LOG__);
29
30#use File::Spec;
31#use Carp;
3234.5e-51.5e-5use Cwd;
# spent 114µs making 1 call to Exporter::import
3330.000980.00033use File::Basename ();
3433.8e-51.3e-5use Fcntl qw/:DEFAULT :flock :seek/;
# spent 857µs making 1 call to Exporter::import
3530.000237.6e-5use File::Path;
# spent 47µs making 1 call to Exporter::import
36
3731.8e-56.0e-6use WISE::Release ();
3830.000700.00023use WISE::BandUtils ();
39
4033.0e-51.0e-5use vars qw($logwidth $__LOG__);
# spent 34µs making 1 call to vars::import
4132.8e-59.3e-6use vars qw(*LOG);
# spent 22µs making 1 call to vars::import
4230.009810.00327use vars qw(*at_end);
# spent 27µs making 1 call to vars::import
43
44100$logwidth = 130;
4511.0e-61.0e-6$__LOG__ = undef;
46
47
48# Print a program startup banner with name, version, time, cpu times,
49# command line param.s, exec. file update time. Optionally echo to
50# LOG file. All the parameters are optional. Can be called simply as
51# 'banner;'
52
# spent 13.2ms (4.93+8.23) within WISE::UtilsLight::banner which was called 2 times, avg 6.58ms/call: # once (1.12ms+7.33ms) at line 278 of /wise/base/deliv/dev/bin/getfix # once (3.81ms+902µs) by WISE::UtilsLight::END at line 4 of (eval 199)[/wise/base/deliv/dev/lib/perl/WISE/UtilsLight.pm:196] at line 196
sub banner {
53 # Passed parameters. Each 'shift' returns one parameter.
5421.6e-58.0e-6 my $savestat = mystatus();
# spent 26µs making 2 calls to WISE::UtilsLight::mystatus, avg 13µs/call
5524.0e-62.0e-6 my $iam = shift; # Program name. Just 'end' if end of execution
5624.0e-62.0e-6 my $version = shift; # Version ID (from CVS?), or status if $iam=~/^end/
5722.0e-61.0e-6 my $update = shift; # Update time of exec file
5822.0e-61.0e-6 my $opts = shift; # Options hash
5922.0e-61.0e-6 my $defs; # Command line parameter definition structure
6021.0e-65.0e-7 my $log; # Log file filehandle.
61 # Locally used var.s
6224.0e-62.0e-6 my $t = time; # Clock time
6326.0e-63.0e-6 my ($user,$lines,$l,$vrsnorstat,$end,$elapsed,$noop,$cwd,
64 $logcmdln,$outparms,$parmlines,$arglines,$to,$prefix,$cmd,$width,
65 $nobannerfutz,$endopts,$noparams,$from,$status,$flush,$release,
66 $os,$slim,$nochildfutz,$mypid);
6722.0e-61.0e-6 $mypid = $$;
68 # This is a bit goofy, allowing the options hash to masquerade in *either*
69 # version or update, but c'est la vie. One must be backward compatible.
7023.0e-61.5e-6 if(ref $version) {
71100 $opts = $version;
7212.0e-62.0e-6 $version = $opts->{version};
7311.0e-61.0e-6 $update = $opts->{update};
74 }
7522.0e-61.0e-6 if(ref $update) {
7611.0e-61.0e-6 $opts = $update;
7712.0e-62.0e-6 $update = $opts->{update};
78 }
7922.0e-61.0e-6 $opts ||= {};
80 # Arg.s that can come only from $opts
8121.1e-55.5e-6 $log = exists $opts->{logfh} ? $opts->{logfh} : logging(1);
# spent 11µs making 1 call to WISE::UtilsLight::logging
8221.0e-65.0e-7 $user = $opts->{user};
8322.0e-61.0e-6 $end = $opts->{end};
8421.0e-65.0e-7 $cwd = $opts->{'cwd'};
8521.0e-65.0e-7 $to = $opts->{to};
8623.0e-61.5e-6 $noop = exists $opts->{to} && ! defined $opts->{to};
8722.0e-61.0e-6 $logcmdln = $opts->{logcmdln};
8823.0e-61.5e-6 $prefix = $opts->{prefix};
8922.0e-61.0e-6 $nobannerfutz = $opts->{noendbanner} || $opts->{noend};
9021.0e-65.0e-7 $nochildfutz = $opts->{noendbannerchild} || $opts->{noendchild};
9123.0e-61.5e-6 $endopts = $opts->{endopts} || {};
9221.0e-65.0e-7 $noparams = $opts->{noparams};
9323.0e-61.5e-6 $cmd = $opts->{cmd} || $0;
9422.0e-61.0e-6 $status = $opts->{status};
9522.0e-61.0e-6 $slim = $opts->{slim} // 1; # Make default
9622.0e-61.0e-6 $width = $opts->{width} || $logwidth;
9722.0e-61.0e-6 $flush = exists $opts->{flush} ? $opts->{flush} : 1;
98
9925.0e-52.5e-5 $release = WISE::Release->new()->release($opts->{release}) || '-';
# spent 118µs making 2 calls to WISE::Release::new, avg 59µs/call # spent 22µs making 2 calls to WISE::Release::release, avg 11µs/call
10020.001530.00077 if(open(my $osfh,"/etc/redhat-release")) {
101 chomp(($os) = <$osfh>);
102 } else {
103 $os = "";
104 }
105
10621.0e-65.0e-7 if($flush) {
10722.0e-61.0e-6 my $old;
10821.4e-57.0e-6 $old=select(STDOUT), $|=1, select($old) if ! ref $flush || $flush->[0];
10927.0e-63.5e-6 $old=select(STDERR), $|=1, select($old) if ! ref $flush || $flush->[1];
110 }
111
112 # Apply defaults
11322.0e-61.0e-6 $iam ||= whoiam();
11423.0e-61.5e-6 $end ||= $iam =~ /^end\s/i; # Does $iam indicate a termination banner?
115 # "version" is really status for ending
11627.0e-63.5e-6 $version = $end
117 ? $status
118 : (defined $version?"'$version'":"NONE").", release=$release";
11920.002200.00110 $update ||= -e $0 ? mytime((stat($0))[9]) : undef;
# spent 722µs making 2 calls to WISE::UtilsLight::mytime, avg 361µs/call
12021.5e-57.5e-6 $user ||= $slim ? $< : (getpwuid($<))[0]; # Expensive in memory!!!
12124.6e-52.3e-5 $cwd ||= normalizepath(Cwd::fastcwd());
# spent 77µs making 2 calls to WISE::UtilsLight::normalizepath, avg 38µs/call # spent 27µs making 2 calls to Cwd::fastcwd, avg 14µs/call
12224.0e-62.0e-6 $defs ||= $opts->{defs};
12323.0e-61.5e-6 $to = ! $noop ? ($to||\*STDOUT) : undef;
12422.0e-61.0e-6 $prefix ||= "";
125
12622.8e-51.4e-5 $from = normalizepath(scalar(whichami($cmd)),1,1);
# spent 639µs making 2 calls to WISE::UtilsLight::whichami, avg 320µs/call # spent 104µs making 2 calls to WISE::UtilsLight::normalizepath, avg 52µs/call
12727.0e-63.5e-6 $from .= $main::Execpath ? " ($main::Execpath)" : "";
128
129 # Report status at end, otherwise it is really a version
13021.5e-57.5e-6 $vrsnorstat = defined $version ? ($end ? "status=$version"
131 : "version=$version")
132 : "";
13325.0e-62.5e-6 $lines = "$prefix<< $iam >> $vrsnorstat".
134 # ... and the exec. file update time, if given, and pid and userid.
135 (defined $update && ! $end ? ", moddate=$update":"").
136 "\n";
137
13826.0e-63.0e-6 $elapsed = $t - $^T; # Elapsed time since startup
139 {
14041.8e-54.5e-6 my ($usert,$system,$cuser,$csystem) = times; # CPU times
14125.0e-62.5e-6 my $tot = $usert+$system+$cuser+$csystem;
14224.0e-62.0e-6 $tot = 1 if $tot == 0;
14327.9e-53.9e-5 $lines .= "${prefix}Date/time: ".mytime($t)." ".
# spent 213µs making 2 calls to WISE::UtilsLight::mytime, avg 106µs/call
144 sprintf("PCPU: U=%-.4g,S=%-.4g CCPU: U=%-.4g,S=%-.4g ".
145 "UTIL: %-.0f%% ".
146 "ELAP: %-.4g \n",
147 $usert,$system,$cuser,$csystem,
148 ($usert+$cuser)/$tot*100,
149 $elapsed);
150 }
15122.5e-51.2e-5 my $rgrpid = (split " ","$(")[0];
15228.0e-64.0e-6 my $egrpid = (split " ","$)")[0];
15322.0e-61.0e-6 my $rgrp = $slim ? $rgrpid : (getgrgid($rgrpid))[0];
15422.0e-61.0e-6 my $egrp = $slim ? $egrpid : (getgrgid($egrpid))[0];
15521.5e-57.5e-6 $lines .= "${prefix}HOST: $hostname PID: $$ USER: $user GRP: $rgrp/$egrp ".
156 "CFG: ".($ENV{WISE_CONFIG}?"'$ENV{WISE_CONFIG}'":"-")." ".
157 "OS: '$os'".
158 "\n";
159
16022.0e-61.0e-6 if(! $end) {
16117.0e-67.0e-6 $lines .= "${prefix}CWD: $cwd (ENV: ".($ENV{PWD}//'').")\n";
16212.0e-62.0e-6 $lines .= "${prefix}EXEC: $from "; # Print fully qualified exec
16312.0e-62.0e-6 $lines .= "PERL: $^X (v$])\n"; # Print perl exec and version
164 # Echo command line parm.s to log file, iff parameter handling is done.
165 # The eval protects from failure if the printparams subroutine isn't
166 # available.
16711.0e-61.0e-6 if(! $noparams) {
16810.000110.00011 eval "use WISE::Params; 1;" or die $@;
# spent 40µs making 1 call to Exporter::Lite::import
169 $parmlines =
17015.0e-65.0e-6 eval {
17112.0e-52.0e-5 (ref($defs) && @{$defs->{_meta}{parnames} || []}
# spent 6.23ms making 1 call to WISE::Params::Param_print
172 ? &WISE::Params::Param_print({to=>undef,extra=>1,
173 width=>$width,
174 prefix=>$prefix, banner=>0,
175 defs=>$defs, iam=>$iam})
176 : undef);
177 };
17811.0e-61.0e-6 warn "=== $0/banner: Couldn't print params\n$@\n" if $@;
17916.0e-66.0e-6 $lines .= $parmlines||"";
180 }
18111.0e-61.0e-6 $arglines = "${prefix}ARGS=\\".
182 join("\\ \\",
183 ($defs ? $defs->{_meta}{argv_orig} : @ARGV)
184 ). "\\\n"
185 if $logcmdln;
186 }
187
18820.000360.00018 print $to "\n\n$lines\n\n" if $to; # Print line to STDOUT
18922.0e-61.0e-6 $lines .= $arglines||""; # Add extra stuff going in logfile
190 #print $log "\n$lines\n" if $log; # Copy to log file
191
192 # Add an automatic call to "banner" at the end of the program run.
193 # This will allow the printing of a termination status number.
19423.0e-61.5e-6 if(! $nobannerfutz && ! $end) {
195
19610.000280.00028 eval <<'EOT';
# spent 4.71ms making 1 call to WISE::UtilsLight::banner
197
198END {
199 my $save = $?;
200 if(! $nochildfutz || $$ == $mypid) {
201 # Protect $? from mysterious modification in banner ...
202 banner("End of $iam",{to=>$to,logfh=>$log,status=>$?,
203 end=>1,%$endopts,prefix=>$prefix});
204 # ... so it will have the correct value here.
205 }
206 $? = $save;
207 }
208
209EOT
210
21111.0e-61.0e-6 if($@) { die "*** $0/BANNER: Error setting up END block.\n$@"; }
212 }
213
21424.0e-52.0e-5 return $lines;
215}
216
217# Front end for the above, but only returns text to be printed.; no o/p is done.
218sub bannerlines {
219 my ($iam,$version,$update,$prefix,$parms) = @_;
220 my $opts;
221
222 $opts = ref($update)=~/hash/i ? $update :
223 { update=>$update, prefix=>$prefix, params=>$parms };
224 $opts->{to} = undef;
225
226 return banner($iam,$version,$opts);
227}
228
22921.6e-58.0e-6
# spent 26µs within WISE::UtilsLight::mystatus which was called 2 times, avg 13µs/call: # 2 times (26µs+0) by WISE::UtilsLight::banner at line 54, avg 13µs/call
sub mystatus { $? || ($!+0) }
230
231
# spent 935µs (89+846) within WISE::UtilsLight::mytime which was called 4 times, avg 234µs/call: # 2 times (60µs+662µs) by WISE::UtilsLight::banner at line 119, avg 361µs/call # 2 times (29µs+184µs) by WISE::UtilsLight::banner at line 143, avg 106µs/call
sub mytime {
23245.0e-61.2e-6 my $t = shift || time();
23344.0e-61.0e-6 my $compact = shift;
23484.2e-55.2e-6 require POSIX; POSIX->import('strftime');
# spent 350µs making 4 calls to POSIX::import, avg 88µs/call
23543.0e-67.5e-7 if($compact) {
236 return strftime("%y%m%d_%H%M%S",gmtime($t));
237 } else {
23840.000520.00013 return strftime("%y/%m/%d_%TZ",gmtime($t));
# spent 496µs making 4 calls to POSIX::strftime, avg 124µs/call
239 }
240}
241
242# Terminate logging
243sub closelog {
244 return if ! logging();
245 require PerlIO::Util;
246 my @layers;
247 @layers = *STDERR->get_layers(output=>1);
248 *STDERR->pop_layer() if @layers && $layers[-1] =~ /^tee/;
249 @layers = *STDOUT->get_layers(output=>1);
250 *STDOUT->pop_layer() if @layers && $layers[-1] =~ /^tee/;
251 close $__LOG__;
252 undef $__LOG__;
253 return;
254}
255
256# Test if a log file is defined and open
257
# spent 11µs within WISE::UtilsLight::logging which was called # once (11µs+0) by WISE::UtilsLight::banner at line 81
sub logging {
25811.0e-61.0e-6 my $nostd = shift; # Return false if logging to stdout/err
25911.0e-61.0e-6 my $logfh = defined $__LOG__ ? fileno $__LOG__ : undef;
26013.0e-63.0e-6 return if ! defined $logfh;
261 if($nostd) {
262 my $outfh = eval { fileno(STDOUT) } || -1; # .. in case it's tee'd
263 my $errfh = eval { fileno(STDERR) } || -1; # .. in case it's tee'd
264 return if $logfh == $outfh || $logfh == $errfh;
265 }
266 return $__LOG__;
267}
268
269sub thishost { $hostname; }
270
271# This is a pretty complicated series of steps for handling log file opening,
272# inheriting, appending, etc.
273# Inheriting means appending to a log file a parent process opened,
274# the filehandle to which is passed along in the environment.
275# name = undef => inherit if possible, but do *not* initiate a new log file
276# name = 1 => inherit if possible, or overwrite the standard name %iam%.log
277# name = =1 => same
278# name = +1 => same but append if the log file already exists
279# name = '0' or 'none' => no logging. Don't inherit either.
280# name = other => overwrite to the named file
281# name = =other => same
282# name = +other => append to the named file
283# The name may consist of these substitution markers:
284# %iam% = the current app name as given in $iam or whoiam()
285# %host% = the current host
286# %date% = the current date/time
287# %pid% = the current process ID
288sub openlog {
289 my $iam = shift; # Name of program; may be default log file name
290 my $name = shift; # Log file name (much magic)
291 my $LOG = shift; # LOG file filehandle to use
292 my $verbose = shift; # Verbose o/p
293 my $duperr = shift; # Dup stderr to log
294 my ($user,$cwd); # Other user settable options, from $opts.
295 my ($dummy,$line,$me,$rc,$fno,$fh,$i,$inherited,$opts,$logpath,$slim);
296 my ($lead,$trap,$errtag,$outtag,$dupout,$append,$noinherit,$nameonly);
297 my ($monitor);
298
299 # In case it's not already done, line-buffer stdout/err
300 {
301 my $old;
302 $old=select(STDOUT), $|=1, select($old);
303 $old=select(STDERR), $|=1, select($old);
304 }
305
306 if(ref($name) =~ /hash/i) {
307 # Options are in an option hash
308 $opts = { %$name };
309 } else {
310 # Options are in @_
311 $opts = {};
312 $opts->{name} = $name;
313 $opts->{logfh} = $LOG;
314 $opts->{verbose} = $verbose;
315 $opts->{duperr} = $duperr;
316 }
317 # Arguments in $opts only.
318 # $name is weird.
319 # .*/ = path supplied, strip and save it
320 # undef = inherit log file or do nothing if there's nothing to inherit
321 # "" = need to get log acces through logfh param ($name is disabled)
322 # 0,none= no logging
323 # else = some indication of how to log
324 # $name can also have further parameters embedded in matching {/}
325 $name = $opts->{name};
326 $name =~ s|^([=+:]*)(.*/)|$1| and $logpath=$2 if $name;
327 # Derive some options directly from the name
328 if(defined $name) {
329 # Hash-ref command-line options after name?
330 if($name =~ s/\s*(\{.*\})\s*$//) {
331 # Do a safe eval.
332 my $cmdlnopts = $1;
333 my $newopts = safe_eval($cmdlnopts);
334 die "*** $0/OPENLOG: Unable to parse cmd line options ".
335 "'$cmdlnopts'.\n$@"
336 if $@;
337 $opts = { %$opts, %$newopts };
338 }
339 while($name =~ s|^([=+:])||) { # Option prefix
340 $append = 1 if $1 eq '+'; # Append to extant file, or start new
341 $append = 0 if $1 eq '='; # Overwrite file; now the default
342 $noinherit = 1 if $1 eq ':'; # Don't inherit a log file
343 $name = 1 if $name =~ /^\s*$/; # Assume default is now empty
344 }
345 }
346 $LOG = $opts->{logfh};
347 $verbose= $opts->{verbose} || $opts->{v};
348 $duperr = $opts->{dupouterr} || $opts->{duperr};
349 $user = $opts->{user};
350 $cwd = $opts->{'cwd'};
351 $lead = $opts->{lead}; # Become process lead
352 $trap = $opts->{trap}; # Trap a set of signals
353 $append ||= $opts->{append} || $opts->{add};
354 $errtag = $opts->{errtag};
355 $outtag = $opts->{outtag};
356 $slim = $opts->{slim} // 1;
357 $dupout = $opts->{dupstdout} || $opts->{dupout};
358 $noinherit ||= $opts->{noinherit};
359 $logpath ||= $opts->{logdir} || "."; # 0 and "" not allowed
360 $nameonly=$opts->{nameonly}; # Get the propective log file name and return
361 $monitor= $opts->{monitor}; # Monitor memory and I/O and report in log
362 $monitor ||= $ENV{__LOGMONITOR};
363 # Defaults
364 $iam ||= whoiam();
365 $user ||= $slim ? $< : (getpwuid($<))[0];
366 $cwd ||= Cwd::fastcwd();
367
368 $_ ||= 0 for ($append,$noinherit);
369
370 # print "fileno STDOUT = ",fileno(STDOUT),
371 # " fileno STDERR = ",fileno(STDERR),"\n";
372
373 die "*** $0/OPENLOG: Both a LOG filehandle and a log name '$name' defined."
374 if defined $LOG && defined $name && length $name;
375
376 # Only one may be used. For $name, value "" will disable its use, leaving
377 # $fh to do the job.
378 $fh = $LOG ? fileno $LOG : undef;
379 $name = $fh ? "" : $name;
380 $inherited = 0;
381
382 # If neither an explicit log file name nor an open filehandle have been
383 # passed, we hope to inherit.
384 if(! defined $name || $name =~ m&(^|/)(1|default)$&) {
385 # Default action; either inherit or use a default name.
386 # Try to inherit: Check for a log file handle in the environment
387 if(! $noinherit && defined($ENV{__LOGFH}) && length($ENV{__LOGFH})) {
388 # Inherit
389 $name = $ENV{__LOGFH};
390 $inherited = 1;
391 } elsif (defined $name) { # Name must be '1' or 'default'.
392 # Use a default name
393 $name =~ s&(1|default)$&"%iam%.log"&e;
394 } else { # Name not defined and we couldn't inherit.
395 # No logging.
396 $name = 'none';
397 }
398 }
399
400 # If both are *still* without meaningful values it means
401 # inheritance failed or the user specifed "" for the name without
402 # an open log file handle; return an error.
403 if(! $fh && ! length $name){
404 die "*** $0/OPENLOG: One of 'logfh' or 'name' must be given.\n";
405 }
406
407 # Look for a name indicating a desire for NO logging
408 if(defined $name && (lc($name) eq 'none' || $name eq "0")) {
409 # Terminate inheritance
410 $ENV{__LOGFH} = 'NONE';
411 $ENV{__LOGNAME} = '';
412 # Return no log name, but no error either
413 return "";
414 }
415
416 my $rundatime = mytime(time,1);
417
418 if($name) {
419 # Handle requests for special values in the log file name
420 # If stdout/err requested, just define LOG straight off.
421 if($name eq '-') {
422 $LOG = \*STDOUT;
423 $fh = fileno(STDOUT);
424 $name = "&STDOUT";
425 } elsif($name eq '-&' || $name eq '&-') {
426 $LOG = \*STDERR;
427 $fh = fileno(STDERR);
428 $name = "&STDERR";
429 } else {
430 $name =~ s/%iam%/$iam/g;
431 $name =~ s/%pid%/$$/g;
432 $name =~ s/%date%/$rundatime/g;
433 $name =~ s/%host%/$hostname/g;
434 # Override $logpath with one prefixing the name, if any.
435 ($name,$logpath) = File::Basename::fileparse($name)
436 if $name =~ m|/|;
437 $logpath = normalizepath($logpath,1);
438 }
439 }
440
441 # Three possibilites:
442 # log file is in $fh and we have no name {$name is ""}
443 # log file is inherited and the name is in the environment
444 # log file is named in $name and $logpath
445
446 my $realname = ($fh
447 ? "&$fh"
448 : ($inherited
449 ? $ENV{__LOGNAME}||""
450 : "$logpath$name"
451 )
452 );
453
454 if($nameonly) {
455 return $realname;
456 }
457
458 setpgrp(0,0) if $lead; # Become process group leader
459
460 # Take action requested to open or inherit, and use, the log file
461
462 if (defined $fh) {
463 # A log file is already opened on $LOG. No open required.
464 # If the name was not passed, use the file handle number as the name
465 # (for printout purposes).
466 $name = "&$fh";
467 } elsif ($inherited) {
468 # The "name" is an inherited file handle number
469 my $fd = $name;
470 open($LOG,">>&=$fd") # Re-open; i.e. assign a perl filehandle
471 or die "*** $0/OPENLOG: Can't fdopen $fd: $!\n";
472 $name = $ENV{__LOGNAME}; # For p/o
473 ($name,$logpath) = File::Basename::fileparse($name) if $name =~ m|/|;
474 $logpath = normalizepath($logpath,1);
475 print "Re-opening log file handle $logpath$name (fd=$fd) ".
476 "(LOG=".(defined$LOG?$LOG:"<undef>").
477 ",flags=$append,$noinherit,$inherited) ...\n"
478 if $verbose;
479 } else {
480 # The file name of the log file has been given (maybe implicitly)
481 # Make the dir if it doesn't exist
482 if(! -d $logpath) {
483 mymkpath($logpath,{verbose=>$verbose})
484 or die "*** $0/OPENLOG: Unable to make log directory ".
485 "'$logpath'; $!.\n";
486 }
487 # Open uniquely named log file if new. If not new, open existing file.
488 # Always open in append mode (>>) to make sure other functions
489 # can add to the file at will w/o stepping on buffers.
490 my $file = "$logpath$name";
491 my $uniq = $file;
492 my $mode = ">>";
493 my $uniqfh;
494 if(! $append) {
495 # Create and open unique name
496 require File::Temp;
497 my ($tmp,$suf);
498 (my $short = $name) =~ s|\.([^.]*)$|| and $suf = $1;
499 $suf = ".save_$suf" if defined $suf;
500 $suf = ".save" if ! defined $suf;
501 my $tmpl = "${short}_${rundatime}_XXXX";
502 ($uniqfh,$tmp) = File::Temp::tempfile($tmpl,
503 SUFFIX=>$suf,
504 DIR=>$logpath);
505 die "*** $0/OPENLOG: Unable to create unique file based on ".
506 "'$tmpl' in '$logpath'; $!.\n"
507 if ! $uniqfh;
508 chmod(0777&(~umask()),$uniqfh);
509 # Arrange for open below to reopen same file handle for append
510 $uniq = $tmp;
511 }
512 print "Opening log file >>$uniq ".(! $append?"(AKA $file) ":"").
513 "(LOG=".(defined$LOG?$LOG:"<undef>").", mode=$mode, ".
514 "flags=$append,$noinherit,$inherited) ...\n"
515 if $verbose;
516 open($LOG,$mode,$uniq)
517 or die "*** $0/OPENLOG: Can't open new log file ".
518 "$mode$uniq: $!\n";
519 if(! $append) {
520 # Link unique file name to standard, public name
521 if(-e $file) {
522 # Get rid of old link, if any
523 unlink($file)
524 or die "*** $0/OPENLOG: Unable to unlink '$file'; $!.\n";
525 }
526 link($uniq,$file)
527 or die "*** $0/OPENLOG: Unable to make link '$file' ".
528 "to '$uniq'; $!.\n";
529 close $uniqfh;
530 }
531 }
532
533 # Make log file handle inheritable across an 'exec'.
534 $rc = fcntl($LOG,F_SETFD,0)
535 or die "*** $0/OPENLOG: Can't fcntl name/append/fh=".
536 "'$name'/'$append'/",fileno($LOG),": $!\n";
537
538 # Un-buffer log file o/p
539 select((select($LOG), $|=1)[0]);
540 # Get file number for log file
541 $fno = fileno($LOG);
542 # Set environment for inheritance so child processes can send log i/o here
543 $ENV{__LOGFH} = $fno;
544 $ENV{__LOGNAME} = $realname;
545 $ENV{__LOGMONITOR} = $monitor || 0;
546 if($verbose) {
547 print "Now logging $$ to file $name, GETFD=",
548 fcntl($LOG,F_GETFD,$dummy=0), ", FH=$fno/$LOG, ".
549 "flags=$append,$noinherit,$inherited.\n";
550 # ,join("/",stat $LOG),"\n";
551 }
552
553 # Package global internal log filehandle; used by internal routines to see
554 # if data is being logged.
555 $__LOG__ = $LOG;
556
557 # Get a fully qualified name for the running program
558 $me = whichami($0);
559
560 my $t = time;
561 my $startt = mytime($t);
562 my $host = $hostname;
563 my $id = "iam=>'$iam', host=>'$host', pid=>$$, starttime=>'$startt'";
564
565 my ($sys);
566 if($monitor) {
567 require WISE::SysStat;
568 $sys = WISE::SysStat->new();
569 }
570
571 $line =
572 join("",
573 "START $id, ",
574 "ppid=>",getppid,", pgrpid=>",getpgrp,", ",
575 "user=>'$user', cwd=>'$cwd', exec=>'$me', ",
576 );
577
578# print "\n\n".wrapup($logwidth,">>>> ",">>>>+ ",1,$line) or
579 print $LOG "\n\n".wrapup($logwidth,">>>> ",">>>>+ ",1,$line)."\n",
580 ">>>>+ Command_line=>'".get_self_command()."'\n\n"
581 or die "*** $0/OPENLOG: Printing START tag to LOG ".
582 "$logpath$name failed(1): $!\n";
583
584 my $atend = sub {
585 return if ! logging();
586 my $rc = @_ ? shift||0 : $?;
587 my $et = time();
588 my $endtime = mytime($et);
589 my $stats = $sys ? $sys->get() : undef;
590 print $LOG "\n\n".
591 wrapup($logwidth,">>>> ",">>>>+ ",1,
592 "END $id, endtime=>'$endtime', ".
593 "status=>$rc, signal=>".($rc&255).", ".
594 "retcode=>".($rc>>8).", ".
595 ($stats ? $stats->statstr().", " : (""))
596 ).
597 "\n\n"
598 or die "*** $0/OPENLOG: Printing END tag to LOG ".
599 "$logpath$name failed(2): $!\n";
600 closelog();
601 };
602
603 *at_end = $atend;
604
605 eval "END { my \$save = \$?; WISE::UtilsLight::at_end(\$?); \$? = \$save }";
606
607 if($trap) {
608 # Set up signal handlers. This allows the proper END block to be called
609 # for these signals to write out the end tag in the log file and
610 # allows signals to be non-fatal in eval blocks.
611 my $handler= sub { die "*** $0/openlog/TRAP: Caught signal $_[0].\n"; };
612 $SIG{HUP} = $handler;
613 $SIG{INT} = $handler;
614 $SIG{TERM} = $handler;
615 }
616
617# if($verbose) { print "LOG has fileno $fno.\n"; }
618
619 # Tee o/p to log? Not if we've inherited a filehandle, since presumably
620 # a higher, calling process is capturing o/p and doing it.
621 if(! $inherited) {
622 # Tee o/p (duplicate it) to real STDERR/OUT and the log file
623 if($duperr) {
624 # my $itag = ! defined $errtag ? ')-: ' : $errtag;
625 my $itag = ! defined $errtag ? ')-' : $errtag;
626 my $mytag = $itag ? "-t '${itag}'" : "";
627 print "Dup'ing STDERR=".\*STDERR." to LOG=$LOG ...\n"
628 if $verbose;
629 # The new way
630 require PerlIO::Util;
631 *STDERR->push_layer(tee => $LOG);
632 # The old way
633 #savestderr($noinherit);
634 #teetofile($fno,\*STDERR,2,1,"-a -s $mytag");
635 }
636
637 if($dupout) {
638 # my $itag = ! defined $outtag ? '(-: ' : $outtag;
639 my $itag = ! defined $outtag ? '(-' : $outtag;
640 my $mytag = $itag ? "-t '${itag}'" : "";
641 print "Dup'ing STDOUT=".\*STDOUT." to LOG=$LOG ...\n"
642 if $verbose;
643 # The new way
644 require PerlIO::Util;
645 *STDOUT->push_layer(tee => $LOG);
646 # The old way
647 #savestdout($noinherit);
648 #teetofile($fno,\*STDOUT,1,1,"-a -s $mytag");
649 }
650 } # inherited?
651
652 return wantarray ? ($LOG, $realname) : $LOG;
653}
654
655sub get_self_command {
656 my $self_cmd_file = shift || "/proc/self/cmdline";
657 open(my $selffh, "<", $self_cmd_file) or return;
658 my @command = split /\000/, scalar(<$selffh>);
659 close $selffh;
660 my $command = join(" ",
661 map { my $word = $_;
662 $word =~ s/([\s'"\$\*&;?\\{}\[\]<>()])/\\$1/g;
663 $word;
664 }
665 @command
666 );
667 return wantarray ? @command : $command;
668}
669
670sub device_from_df {
671 my $path = shift || ".";
672 # Get the first field in the 2nd line of df output for this path's device
673 return (split(" ",(`df $path 2>/dev/null`)[1]//""))[0];
674}
675
676# Execute etee as an o/p duplicator. 'etee' ia like 'tee' but o/p goes
677# to stderr instead of stdout, plus it does a few other things. Etee is
678# in the ..../perl/misc directory.
679sub teetofile {
680 my $name = shift; # File name or handle to tee to
681 my $OUT = shift; # Glob of filehandle we wish to tee on.
682 my $std = shift; # One of stdout/err? 1==out, 2==err
683 my $restore = shift; # Restore saved stderr/out in child before etee execs
684 my $args = shift || "-a -s"; # Arg.s for tee
685 my $teedir = shift || ""; # Path to etee program
686 my $tee = 'etee';
687 my ($pid);
688
689 # Ripe for named options, but this is pretty much only used internally
690 # and I'm feeling lazy.
691
692# print "TEETOFL: '$name' '$OUT' '$std' '$restore' '$tee' '$args' \n";
693
694 $tee = "$teedir$tee $args";
695
696 if($restore) {
697 # Tell etee to restore stderr/out to a saved filehandle
698 if(($std == 1 && ! defined fileno SAVESTDOUT) ||
699 ($std == 2 && ! defined fileno SAVESTDERR)) {
700 warn "=== $0/TEETOFL: ".
701 "Can't dup fh $std without original saved fh.\n";
702 return;
703 }
704 if($std == 1 || $std == 2) {
705 $restore = (fileno(SAVESTDOUT),fileno(SAVESTDERR))[$std-1];
706 }
707 $tee = "$tee -r $restore";
708 }
709 if($std == 1) { $tee = "$tee -o"; } # Direct etee at stdout.
710# print "ETEE exec = '$tee'\n";
711 if(! ($pid=open($OUT,"| $tee $name")) ) {
712 print "*** $0/TEETOFL: Error etee'ing $OUT to $name: $!.\n".
713 " (Tried '$tee $name')\n";
714 die "*** $0/TEETOFL: Error etee'ing $OUT to $name: $!.\n".
715 " (Tried '$tee $name')\n";
716 }
717 # Reap etee parent to avoid zombie. (Grandchild will carry on etee function.)
718 waitpid($pid,0);
719 if($?) {
720 print "*** $0/TEETOFL: Error reaping etee parent: RC=$?.\n";
721 die "*** $0/TEETOFL: Error reaping etee parent: RC=$?.\n";
722 }
723 select +(select($OUT), $| = 1)[0];
724
725 return 1;
726}
727
728# Save the stdout file handle and set the saved fh up to be inherited.
729# A saved stdout filehandle may already exist in the environment. If so
730# use it.
731sub savestdout {
732 my $noinherit = shift;
733 my ($outfh);
734
735 # Already saved; return.
736 if(defined fileno SAVESTDOUT) { return 1; }
737 if($noinherit || ! defined ($outfh=$ENV{SAVED_STDOUT}) ) {
738 # No environment variable to inherit saved stdout from
739 open(SAVESTDOUT,">&STDOUT") or
740 die "*** $0/SVSTDOUT: Can't dup STDOUT: $!\n";
741 $ENV{SAVED_STDOUT} = $outfh = fileno(SAVESTDOUT);
742 } else {
743 # We inherited a saved stdout filehandle. Do an fdopen on it.
744 open(SAVESTDOUT,">&=$outfh") or
745 die "*** $0/SVSTDOUT: Can't fdopen SAVESTDOUT on $outfh: $!\n";
746 }
747 # Mark this filehandle as inheritable across an 'exec'.
748 fcntl(SAVESTDOUT,F_SETFD,0) or
749 die "*** $0/SVSTDOUT: Can't fcntl SAVESTDOUT on $outfh: $!\n";
750
751 select +(select(SAVESTDOUT), $| = 1)[0];
752
753 return 1;
754}
755
756 # Save the stderr file handle and set the saved fh up to be inherited.
757sub savestderr {
758 my $noinherit = shift;
759 my ($errfh);
760
761 if(defined fileno SAVESTDERR) { return 1; }
762 if($noinherit || ! defined ($errfh=$ENV{SAVED_STDERR}) ) {
763 open(SAVESTDERR,">&STDERR") or
764 die "*** $0/SVSTDERR: Can't dup STDERR: $!\n";
765 $ENV{SAVED_STDERR} = $errfh = fileno(SAVESTDERR);
766 } else {
767 open(SAVESTDERR,">&=$errfh") or
768 die "*** $0/SVSTDERR: Can't fdopen SAVESTDERR on $errfh: $!\n";
769 }
770 fcntl(SAVESTDERR,F_SETFD,0) or
771 die "*** $0/SVSTDERR: Can't fcntl SAVESTDERR on $errfh: $!\n";
772
773 select +(select(SAVESTDERR), $| = 1)[0];
774
775 return 1;
776}
777
778# Reverse the above two routines, assuming openlog has alread fdopen'd
779# the saved file handles, if necessary.
780# Error messages are sent to stdout, or both stdout and stderr sometimes
781# because it isn't clear which, if either, is available.
782sub restorestdout {
783 my ($f1,$f2);
784 if(defined ($f1 = fileno SAVESTDOUT)) {
785 if(defined ($f2 = fileno STDOUT) && $f2 != $f1) { close STDOUT; }
786 open(STDOUT,">&SAVESTDOUT") or
787 die "*** $0/RSTSTDOUT: Can't restore STDOUT: $!\n";
788 } else {
789 print "=== $0/RSTSTDOUT: No saved STDOUT to restore.\n";
790 warn "=== $0/RSTSTDOUT: No saved STDOUT to restore.\n";
791 }
792}
793
794sub restorestderr {
795 my ($f1,$f2);
796 if(defined ($f1 = fileno SAVESTDERR)) {
797 if(defined ($f2 = fileno STDERR) && $f2 != $f1) { close STDERR; }
798 open(STDERR,">&SAVESTDERR") or
799 die "*** $0/RSTSTDERR: Can't restore STDOUT: $!\n";
800 } else {
801 print "=== $0/RSTSTDERR: No saved STDERR to restore.\n";
802 warn "=== $0/RSTSTDERR: No saved STDERR to restore.\n";
803 }
804}
805
806# My name, capitalized. I.e. the name of the running program.
807sub whoiam {
808 my $nopretty = shift;
809 my $iam;
810 if($0 eq "-e") { $iam = "perl-e"; }
811 else { $iam = File::Basename::basename($0); }
812 if(! $nopretty) { $iam = ucfirst $iam; $iam =~ s/[-.]/_/g; }
813 return $iam;
814}
815
816# Find the executable path for a given program, by default the currently
817# executing one.
818
# spent 639µs (145+494) within WISE::UtilsLight::whichami which was called 2 times, avg 320µs/call: # 2 times (145µs+494µs) by WISE::UtilsLight::banner at line 126, avg 320µs/call
sub whichami {
81925.0e-62.5e-6 my ($iam) = shift||$0;
82029.4e-54.7e-5 my (@path) = @_ ? (@_) : split(/[:\s]+/,$ENV{'PATH'});
82122.0e-61.0e-6 my ($me,$base,$path);
822
82322.0e-61.0e-6 if($iam eq '-e' || $iam eq 'perl-e') { $iam = $^X; }
824
82522.6e-51.3e-5 if($iam =~ m|/|) {
# spent 73µs making 2 calls to File::Basename::fileparse, avg 36µs/call
826 ($base,$path) = File::Basename::fileparse($iam);
827 } else {
828 $path = "";
829 $base = $iam;
830 }
831
83222.0e-61.0e-6 if ($path eq "") {
833 for my $p (@path) {
834 if(-x "$p/$base" && ! -d _) { $path = "$p/"; last; }
835 }
836 }
83721.3e-56.5e-6 $path = normalizepath($path,1) if $path ne "";
# spent 421µs making 2 calls to WISE::UtilsLight::normalizepath, avg 210µs/call
838
83922.0e-61.0e-6 $me = $path.$base;
840
84128.0e-64.0e-6 return wantarray ? ($base,$path) : $me;
842}
843
844# Make a relative path absolute. It's probably better to do this through
845# 'normalizepath' below.
846sub resolvepath {
847 my ($path,$cwd) = @_;
848
849 if($path !~ m|^/|) {
850 # Avoid fd leak; don't call 'cwd()'
851 if(! defined $cwd) { $cwd = Cwd::fastcwd(); }
852 $path = $cwd."/".$path;
853 }
854
855 $path =~ s!/\./!/!g;
856
857 return $path;
858}
859
860# Take a pathname and "normalize" it by removing ugly UNIX-ish constructs
861# and optionally resolving it to an absolute path. By default paths have
862# '/' at the end, but this can be suppressed.
863
# spent 771µs (314+457) within WISE::UtilsLight::normalizepath which was called 7 times, avg 110µs/call: # 2 times (79µs+342µs) by WISE::UtilsLight::whichami at line 837, avg 210µs/call # 2 times (86µs+18µs) by WISE::UtilsLight::banner at line 126, avg 52µs/call # 2 times (77µs+0) by WISE::UtilsLight::banner at line 121, avg 38µs/call # once (72µs+97µs) at line 92 of /wise/base/deliv/dev/lib/perl/WISE/Utils.pm
sub normalizepath {
86479.0e-61.3e-6 my $path = shift;
86574.0e-65.7e-7 my $resolve = shift;
86674.0e-65.7e-7 my $notrail = shift;
86777.0e-61.0e-6 my $cwd = shift; # Will be determined here if not passed.
86874.0e-65.7e-7 my ($where,$base,$default,$opts);
86972.2e-53.1e-6 my $err = "*** $0/NORM";
87071.1e-51.6e-6 my $warn= "=== $0/NORM";
871
87274.0e-65.7e-7 if(ref $resolve) {
873 $opts = $resolve;
874 $resolve = $opts->{resolve};
875 $notrail = $opts->{noslash} || $opts->{notrail} || $opts->{isfile};
876 }
877
878 # If no path, return '.'
87977.0e-61.0e-6 if(! defined $path || $path eq "") { $path = '.'; }
880
881 # Magic: The characters '@/' at the start of a path are magical. There're
882 # replaced with the path of whatever is currently executing or whatever
883 # is in $default.
88476.0e-68.6e-7 if($path =~ m|^@/|) {
885 ($base,$where) = File::Basename::fileparse(scalar(whichami()),'');
886 if($where eq ".") { $where = "./"; }
887 $path =~ s|^\@/?|$where|;
888 }
889
890 # Fully resolve a path
89171.7e-52.4e-6 if($resolve) {
89255.1e-51.0e-5 if(-d $path) {
893 # Resolve to an absolute name, because the dir exists
89432.0e-66.7e-7 my $ntries = 0;
89531.0e-63.3e-7 my $abs;
896 RETRY: {
89793.7e-54.1e-6 $abs = eval { Cwd::fast_abs_path($path); };
# spent 439µs making 3 calls to Cwd::fast_abs_path, avg 146µs/call
89832.0e-66.7e-7 if(! defined $abs) {
899 die "$err: Unable to resolve path from '$path'; $!.\n$@"
900 if ++$ntries > 10;
901 warn "$warn: Unable to resolve path from '$path'; $!.\n$@";
902 sleep(1);
903 redo RETRY;
904 }
905 }
90633.0e-61.0e-6 $path = $abs;
907 } else {
908 # Avoid fd leak; don't call 'cwd()'.
909 # (Probably fixed in recent perl releases.)
91022.4e-51.2e-5 if(! defined $cwd) { $cwd = Cwd::fastcwd(); }
# spent 18µs making 2 calls to Cwd::fastcwd, avg 9µs/call
91123.0e-61.5e-6 if(! defined $cwd) {
912 die "$err: Unable to get CWD for '$path'. ".
913 "Dunno why.\n".
914 " Stat of '.' = (".join(",",stat(".")).")\n";
915 } else {
91621.5e-57.5e-6 $path = "$cwd/$path" if $path !~ m|^/|;
917 }
918 }
919 }
920
921 # Remove multiple ///
92271.0e-51.4e-6 $path =~ s%//+%/%g;
923 # Remove superfluous ..././.... constructs
92476.0e-68.6e-7 $path =~ s%/\./%/%g; # a/./b => a/b
92577.0e-61.0e-6 $path =~ s%/^\./(.)%$1%g; # ./a... => a...
92676.0e-68.6e-7 $path =~ s%(.)/\.$%$1%g; # ...a/. => ...a
927 # (This must be done before ...)
928 # Remove superfluous '..' constructs. E.g. /zzz/xxx/yyy/../.. == /zzz
92971.3e-51.9e-6 1 while($path =~ s%[^/]+/\.\.($|/)%%);
930 # Replace common constructs with usual symlink
93174.0e-65.7e-7 $path =~ s%^/exports?/wise(?=$|/)%/wise%;
932
933 # Add or remove a trailing slash
93471.2e-51.7e-6 if(! $notrail && $path !~ m|/$|) { $path .= '/'; }
93575.0e-67.1e-7 if($notrail && $path =~ m|/$|) { $path =~ s|/$||; }
936
93771.6e-52.3e-6 return $path;
938}
939
940
941# Wrap text to given # column's.
942# $ip = prefix text on first line.
943# $xp = prefix text for subsequent lines.
944# $resplit = split all text on whitespace.
945# This can be called in any of these forms:
946# wrapup(80,"\t","",1,"text...",...) -- for backward compatability
947# wrapup(["text...",...],{columns=>80,initpfx=>"\t"})
948# wrapup("text (not just digits!) ...",{columns=>80,initpfx=>"\t"})
949# The latter is the most natural form. The others are for compatability
950# with old code or as simple variants to allow flexibility.
951sub wrapup {
952 my ($columns, $ip, $xp, $resplit) =
953 (shift||80,shift,shift,shift);
954 # The rest of @_ is the text to split.
955 my ($opts,@t,$text);
956
957 if (ref($columns) =~ /array/i || $columns !~ /^\d+$/) {
958 # An array reference as the first element is taken as
959 # the string(s) to wrap. Likewise if it's just a scalar
960 # but not a numeric scalar. The *second* argument is
961 # then the options. No other arg.s are allowed.
962 $text = [$columns];
963 die "*** $0/wrapup: Non-hash options passed"
964 if defined $ip && ref($ip) ne "HASH";
965 $opts = $ip || {}; # Options, processed below.
966 die "*** $0/wrapup: Extra arg.s detected."
967 if defined $xp || defined $resplit || @_;
968 } else {
969 $text = [@_];
970 }
971 if($opts) {
972 $columns = $opts->{columns} || $opts->{width} || 80;
973 $ip = $opts->{initial_prefix} || $opts->{ip} || "";
974 $xp = $opts->{rest_prefix} || $opts->{xp} || $ip;
975 $resplit = ! ($opts->{no_resplit} || $opts->{no_split} ||
976 $opts->{nosplit});
977 }
978
979 # Get rid of undefined elements in the strings and expand references.
980 @t = map {defined $_ ? (ref($_) ? @$_ : $_) : ""} @$text;
981 if(! @t) { return ""; }
982
983 my ($r,$s) = ("","");
984 my $lead1 = defined $ip ? $ip : "";
985 my $lead2 = defined $xp ? $xp : "";
986 my ($lead,$ll,$ll1,$ll2);
987
988 # Split all text in each list element on white space
989 if($resplit) { @t = split(" ",join(" ",@t)); }
990 $ll1 = ($columns) - length($lead1) - 1;
991 $ll2 = ($columns) - length($lead2) - 1;
992
993 $ll = $ll1;
994 $lead = $lead1;
995 for my $t (@t) {
996 $t =~ s/\s*(.*?)\s*/$1/;
997 if(length($r)+length($t) >= $ll) {
998 if(length $r > 0) { $s .= "$lead$r\n"; }
999 $r = "";
1000 $ll = $ll2;
1001 $lead = $lead2;
1002 }
1003 $r .= "$t ";
1004
1005 }
1006
1007 if(length $r > 0) { $s .= "$lead$r\n"; }
1008
1009 return $s;
1010}
1011
1012
1013# Return the RE to use to match to any legal C floating point number.
1014# This should be a fully embeddable pattern. The user must supply
1015# a boundary, e.g. /^$fpre$/.
1016sub fpre {
1017 my $d = shift || "";
1018 $d = 'dD' if $d; # Is 'd' allowed instead of 'e' in the exponent?
1019 my $re =
1020 "(?:
1021 [-+]? (?#_Optional_sign)
1022 (?:
1023 (?:(?:\\d*\\.?\\d+|\\d+\\.)(?:[eE$d][+-]?\\d+)?) | (?#_Normal_number)
1024 (?:nanq?|inf(?:inity)) (?#_Special_values)
1025 )
1026 )
1027 ";
1028 $re =~ s/[\s\n]//g; # Ensure readability without using (?x)
1029 $re =~ s/nanq/[Nn][Aa][Nn][Qq]/; # Ensure case insenstivity w/o using (?i)
1030 $re =~ s/inf/[Ii][Nn][Ff]/;
1031 $re =~ s/inity/[Ii][Nn][Ii][Tt][Yy]/;
1032 return $re;
1033}
1034
1035# Get keys from an array-hash (a hash stored in an array, usually to
1036# preserve key order)
1037sub aryhash_keys {
1038 return map {$_[$_]} grep {! ($_%2)} 0..$#_;
1039}
1040# Get values
1041sub aryhash_vals {
1042 return map {$_[$_]} grep { ($_%2)} 0..$#_;
1043}
1044
1045sub pathdecomp {
1046 my $path = shift || '';
1047 my $opts = shift || {};
1048 my $sep = $opts->{sep} || '-';
1049 my %parts;
1050 return wantarray ? %parts : \%parts if ! $path;
1051 if(! $opts->{isdir}) {
1052 ($parts{file},$parts{dir}) = File::Basename::fileparse($path);
1053 } else {
1054 ($parts{file},$parts{dir}) = ('', $path);
1055 }
1056 if($parts{dir} || $opts->{abs}) {
1057 $parts{dir} = normalizepath($parts{dir},
1058 {resolve=>!$opts->{asis},
1059 notrail=>1});
1060 }
1061 $parts{dir} ||= '';
1062 $parts{dir} =~ s|/*$||; # Standardize on no trailing slash
1063 die "*** $0/PathDecomp: Can't find directory '$parts{dir}'.\n"
1064 if $parts{dir} && $opts->{require_dir} && ! -e $parts{dir};
1065 return wantarray ? %parts : \%parts if ! $parts{file};
1066 @parts{'root','form'} = $parts{file} =~ /([^.]*)\.(.*?)$/;
1067 $parts{root} ||= $parts{file};
1068 @parts{'base','band','type','vsn'} = split /$sep/, $parts{root}, 4;
1069 if($parts{band} && $parts{band} =~ /^\d+$/) {
1070 # Special case: allow basenames with a single trailing negative integer
1071 $parts{base} .= $sep.$parts{band};
1072 $parts{band} = $parts{type};
1073 @parts{'type','vsn'} = split /$sep/, $parts{vsn}, 2;
1074 }
1075 if($parts{band} && $parts{band}!~/^w?%[^%]+%$/ &&
1076 ! WISE::BandUtils::bandnum($parts{band})) {
1077 # Not really a band; reparse
1078 @parts{'base','type','vsn'} = split /$sep/, $parts{root}, 3;
1079 $parts{band} = '';
1080 }
1081 @parts{'base','band','type','vsn','form'} =
1082 (
1083 map { defined $_ && /%[^%]+%/ ? undef : $_ }
1084 @parts{'base','band','type','vsn','form'}
1085 );
1086 $parts{bandnum} = WISE::BandUtils::bandnum($parts{band})
1087 if $parts{band};
1088 return wantarray ? %parts : \%parts;
1089}
1090
1091sub pathcomp {
1092 my $model = shift;
1093 my $parts;
1094 if(ref($model)=~/hash/i) {
1095 $parts = $model;
1096 $model = '';
1097 } else {
1098 $parts = shift || {};
1099 }
1100 my $opts = shift || {};
1101 my $sep = $opts->{sep} || '-';
1102 my %in = %{ pathdecomp($model,$opts) } if $model;
1103 my @parts = ref($parts)=~/hash/i ? ($parts) : @$parts;
1104 my @paths;
1105 for my $parts (@parts) {
1106 my %parts = %$parts;
1107 if(defined $parts{spec} &&
1108 length($parts{spec}) && # Non-empty
1109 $parts{spec} ne '1' # Literal '1' means do the usual thing
1110 ) {
1111 push @paths, $parts{spec};
1112 next;
1113 }
1114 $parts{base} =~ s/$sep(?!\d).*// if $parts{base};
1115 $parts{vsn} //= $parts{var}; # Transparent alias
1116 $parts{addvsn} //= $parts{addvar}; # Transparent alias
1117 my %out = (%in,
1118 (map { ($_ => $parts{$_}) }
1119 grep {defined $parts{$_} &&
1120 $parts{$_} !~ /^%[^%]+%$/} # not a tag}
1121 keys %$parts)
1122 );
1123 # { use WISE; print Dumper(\%in,\%out); }
1124 $out{dir} = pathdecomp($out{dir},{%$opts,isdir=>1})->{dir};
1125 $out{band} = WISE::BandUtils::bandstr($out{band}) || '' # Normalize
1126 if $out{band} && # If defined ...
1127 $out{band}!~/[][*{}?%]/; # and not a glob and has no tags
1128 # Simple addition to extant components.
1129 # Careful using these.
1130 $out{type} .= ($out{addtype}
1131 ? ($out{addtype} !~ /^[-~^+._=]/ ? "_" : '').
1132 $out{addtype}
1133 : '');
1134 $out{base} .= ($out{addbase}
1135 ? ($out{addbase} !~ /^[-~^+._=]/ ? "_" : '').
1136 $out{addbase}
1137 : '');
1138 if($out{vsn} || $out{addvsn}) {
1139 my @vsn = split /-/,$out{vsn}//'';
1140 $vsn[0] .= ($out{addvsn}
1141 ? (length($vsn[0]//'') &&
1142 $out{addvsn} !~ /^[-~^+._=]/
1143 ? "_" : '').
1144 $out{addvsn}
1145 : '');
1146 $out{vsn} = join("-",@vsn);
1147 }
1148 my $path = ($out{dir} ? $out{dir}."/" : '').
1149 $out{base}.
1150 (($out{band}//'') ? $sep.$out{band} : '').
1151 ((length($out{type}//'')) ? $sep.$out{type} : '').
1152 ((length($out{vsn} //'')) ? $sep.$out{vsn} : '').
1153 ($out{form} ? ".".$out{form} : '').
1154 ($out{z} ? ".".$out{z} : '');
1155 push @paths,$path;
1156 }
1157 if(! wantarray && @paths > 1) {
1158 warn "***$0/PathComp: Multiple path return in scalar context.\n";
1159 return;
1160 }
1161 return wantarray || @paths==0 ? @paths : $paths[0];
1162}
1163
1164sub samefile {
1165 my $f1 = shift;
1166 my $f2 = shift;
1167 my $opts = shift || {};
1168
1169 return 0 if ! -e $f1 || ! -e $f2;
1170
1171 my ($dev1,$ind1) = stat($f1);
1172 my ($dev2,$ind2) = stat($f2);
1173
1174 return if $dev1!=$dev2 || $ind1 != $ind2;
1175
1176 return 1;
1177}
1178
1179
1180# Provide a (fairly) safe compartment for eval'ing external code.
1181# (Still not safe against %SIG hijacking.)
1182sub safe_eval {
1183 my $code = shift;
1184 my $opts = shift || {};
1185 my $share_from = $opts->{share_from};
1186 my $permit = $opts->{permit};
1187 warn("*** $0/safe_eval: share_from is not an array ref.\n"), return
1188 if $share_from && ref($share_from) !~ /array/i;
1189 if($code=~/( # Disallow package manipulation
1190 \w\s*\}?:: | \bpackage\b |
1191 # Disallow signal manipulation
1192 [\$%] \s* \{? \s* SIG \s* \}? \b |
1193 # Disallow call stack manipulation
1194 \@ \s* \{? \s* _ \s* \}? \b |
1195 \$ \s* \{? \s* _ \s* \}? \s* \[
1196 )/x) {
1197 $@ = "*** $0/Safe_eval: string contains unsafe words/symbols '$1'.\n".
1198 " code='$code'\n";
1199 return;
1200 }
1201 {
1202 require Safe;
1203 Safe->import;
1204
1205 my $safe = Safe->new;
1206 $safe->permit_only(qw/:base_core :base_mem :base_orig :base_math/);
1207 $safe->deny(qw/:sys_db warn die dbmopen tie untie sselect select
1208 pipe_op sockpair/);
1209 $safe->share_from(@$share_from) if $share_from;
1210 $safe->permit(@$permit) if $permit;
1211 return $safe->reval($code,1);
1212 }
1213}
1214
1215# Create a symbolic link with added functionality and error checking
1216sub mysymlink {
1217 my $targ = shift; # Target. A scalar path or a ref to an array of them
1218 my $link = shift; # Symlink name. Must be a dir. if $targ is a ref.
1219 my $replace = shift; # First remove an extant symlink (and only a symlink)
1220 my $opts = {};
1221 if(ref $replace) { $opts = $replace; $replace = $opts->{replace}; }
1222 my $serious = $opts->{serious}; # Errors are serious and result in death
1223 my $verbose = $opts->{verbose}; # Make noise
1224 my $test = $opts->{test}; # Don't really do it
1225 my $fail = $serious ? sub { die @_ } : sub { warn @_ };
1226
1227 $verbose ||= $test;
1228
1229 &$fail("*** $0/SYMLINK: Missing source or target"), return
1230 if ! defined $link || ! defined $targ;
1231
1232 if(ref $targ) {
1233 my $failed = 0;
1234 &$fail("*** $0/SYMLINK: Symlink location '$link' for multiple links ".
1235 "not a dir.\n"), return
1236 if ! -d $link;
1237 $link = normalizepath($link,{resolve=>1});
1238 for my $this (@$targ) {
1239 # Iterative call
1240 if(! mysymlink($this,$link.File::Basename::basename($this),
1241 {replace=>$replace,serious=>$serious})) {
1242 ++$failed;
1243 }
1244 }
1245 if($failed) { return; }
1246 else { return 1; }
1247 }
1248
1249 print "Creating symlink '$link' to target '$targ' ...\n" if $verbose;
1250
1251 &$fail("*** $0/SYMLINK: Replacement requested for '$link', ".
1252 "but it isn't a symlink.\n"), return
1253 if -e $link && ! -l $link;
1254
1255 my ($tmplink);
1256
1257 if($replace) {
1258 $tmplink = tempfile($link);
1259 } else {
1260 $tmplink = $link;
1261 }
1262
1263 if(! $test) {
1264 print " Creating symlink '$tmplink' ...\n" if $verbose;
1265
1266 unlink $tmplink if $replace;
1267 symlink($targ,$tmplink)
1268 or &$fail("*** $0/SYMLINK: Link from $targ to ".
1269 "$tmplink failed: $!\n"),
1270 return;
1271
1272 if($replace) {
1273 print " Renaming temporary symlink to '$link' ...\n"
1274 if $verbose;
1275 rename($tmplink,$link)
1276 or &$fail("*** $0/SYMLINK: Couldn't rename ".
1277 "'$tmplink' to '$link': $!\n");
1278 }
1279 }
1280
1281 return 1;
1282}
1283
1284sub tempfile {
1285 my $file = shift || 'temp$$';
1286 my $opts = shift || {};
1287 require File::Temp;
1288 my ($fh,$tmp);
1289 my ($base,$dir) = File::Basename::fileparse($file);
1290 $dir = $opts->{dir} || $dir;
1291 ($fh,$tmp) = File::Temp::tempfile("$base.tmp_XXXX",DIR=>$dir,
1292 UNLINK=>$opts->{unlink});
1293 my $umask = umask() // 2;
1294 my $mode = $opts->{mode} || (0666 & (~$umask));
1295 chmod($mode,$fh);
1296 if(! wantarray) {
1297 # Just want the file name string, so close the file
1298 close($fh);
1299 # Also unlink it. This just anticipates the UNLINK option
1300 # above, removing the file immediately instead of after the
1301 # job ends
1302 unlink($tmp);
1303 }
1304 return wantarray ? ($tmp,$fh) : $tmp;
1305}
1306
1307# Simple wrapper for the File::Path::mkpath utility
1308sub mymkpath {
1309 my $dir = shift; # Path name to create
1310 my $opts = shift || {};
1311
1312 my $verbose = $opts->{verbose};
1313 my $test = $opts->{test};
1314 my $umask = $opts->{umask} // umask() // 02;
1315 my $mode = $opts->{mode} // 0775;
1316 my $maxretries = $opts->{retries} // 5;
1317 my $err = "*** $0/MKPATH";
1318 my $warn= "=== $0/MKPATH";
1319
1320 $verbose ||= $test;
1321
1322 warn("$err: No path to create defined"), return if ! defined $dir;
1323
1324 # Make sure no trailing slashes mess up mkpath
1325 $dir =~ s|/+$||;
1326
1327 $mode ||= (0777 & (~$umask)); # mode='0' never allowed; use umask
1328 $mode |= 0111; # Turn on search permissions for all
1329 printf "Creating path '".$dir."' with mode 0%o (umask=0%o) ...\n",
1330 $mode,$umask
1331 if $verbose || $test;
1332
1333 return 1 if $test;
1334
1335 my $nretries = 0;
1336 RETRY: {
1337 File::Path::mkpath($dir,{verbose=>$verbose,mode=>$mode,error=>\ my $error});
1338 my $msg;
1339 $msg .= ($_->{''}//$_->{$dir}//'').' ' for @$error;
1340 if($msg) {
1341 # Error encountered
1342 if($msg =~ /no such file/i && ++$nretries <= $maxretries) {
1343 # Perhaps hit a race condition trying to create the
1344 # directory or a parent
1345 warn "$warn: Failed to create 'dir'; $msg\n",
1346 "$warn: Retry #$nretries ...\n";
1347 sleep 1 + int(rand()*5);
1348 redo RETRY;
1349 }
1350 warn "$err: Error creating '$dir'; $msg\n";
1351 $@ = $msg; # Error msg out-of-band return
1352 return;
1353 }
1354 }
1355
1356 return 1;
1357}
1358
1359
1360#######################
1361
1362package WISE::UtilsLight::OO;
1363
136430.000196.4e-5use vars qw/$AUTOLOAD/;
# spent 59µs making 1 call to vars::import
1365
1366sub new {
1367 my $this = shift;
1368 my $class = ref($this) || $this;
1369 return bless {},$class;
1370}
1371
1372# Auto-gen methods
1373sub AUTOLOAD {
1374 my $self = shift;
1375 my $err = "*** $0/".__PACKAGE__."/AUTOLOAD";
1376 my $this = ref($self)
1377 or die "$err: '$self' is not an object.\n";
1378 return if ($AUTOLOAD =~ /::DESTROY$/);
1379 # Separate package qualifier from desired sub name
1380 my ($pkg,$sub) = $AUTOLOAD =~ m/(.*:)(.*)/;
1381 #print "'$AUTOLOAD'/'$pkg'/'$sub'/@_\n";
1382 # Strip off OO trailer
1383 $pkg =~ s/::OO//;
1384 # Get sub ref (do not store in namespace)
1385 my $subref;
1386 {
138730.000134.3e-5 no strict qw{refs};
# spent 30µs making 1 call to strict::unimport
1388 $subref = eval "\\&$pkg$sub";
1389 die "$err: Can't eval '$subref'.\n$@" if $@;
1390 }
1391 # Call
1392 goto &$subref;
1393}
1394
139511.4e-51.4e-51;

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