|
BASIS
r3148
|
Utilities.pm
Go to the documentation of this file.
00001 ############################################################################## 00002 # @file Utilities.pm 00003 # @brief Main module of project-independent BASIS utilities. 00004 # 00005 # This module defines the BASIS utility functions. It uses the BASIS::Sub::Exporter 00006 # module to enable the generation of these functions customized to the request 00007 # of the particular project they are used in. This is, for example, used by 00008 # the BASIS::Basis module. The default utility functions defined by 00009 # this module, i.e., without any customizaton are intended for use in Perl 00010 # scripts that are not build as part of a particular package. In case of a 00011 # BASIS package, the already customized project-specific implementations should 00012 # be used instead, i.e., those defined by the BASIS::Basis module of 00013 # the project. 00014 # 00015 # @note This module exports also all other BASIS utility functions that are 00016 # defined in other Perl modules. Therefore, only this or the 00017 # BASIS::Basis module should be used. 00018 # 00019 # Copyright (c) 2011, 2012 University of Pennsylvania. All rights reserved.<br /> 00020 # See https://www.cbica.upenn.edu/sbia/software/license.html or COPYING file. 00021 # 00022 # Contact: SBIA Group <sbia-software at uphs.upenn.edu> 00023 # 00024 # @ingroup BasisPerlUtilities 00025 ############################################################################## 00026 00027 use strict; 00028 use warnings; 00029 00030 package BASIS::Utilities; 00031 { 00032 $BASIS::Utilities::VERSION = 0.00_00; 00033 } 00034 00035 00036 use Cwd qw(realpath); 00037 use File::Basename qw(dirname basename); 00038 use File::Spec::Functions qw(catfile); 00039 use BASIS::File::Which qw(which); 00040 00041 00042 ## @addtogroup BasisPerlUtilities 00043 # @{ 00044 00045 00046 # ============================================================================ 00047 # constants 00048 # ============================================================================ 00049 00050 ## @brief Default copyright of executables. 00051 use constant COPYRIGHT => "2011, 2012, 2013 University of Pennsylvania"; 00052 ## @brief Default license of executables. 00053 use constant LICENSE => "See https://www.cbica.upenn.edu/sbia/software/license.html or COPYING file."; 00054 ## @brief Default contact to use for help output of executables. 00055 use constant CONTACT => "SBIA Group <sbia-software at uphs.upenn.edu>"; 00056 00057 # ============================================================================ 00058 # exports 00059 # ============================================================================ 00060 00061 # Note: The generators are defined at the end of this file. 00062 00063 use BASIS::Sub::Exporter -setup => { 00064 exports => [ 00065 qw(tostring qsplit), 00066 print_contact => \&_build_print_contact, 00067 print_version => \&_build_print_version, 00068 targetuid => \&_build_executabletargetinfo_function, 00069 istarget => \&_build_executabletargetinfo_function, 00070 exepath => \&_build_executabletargetinfo_function, 00071 exename => \&_build_executabletargetinfo_function, 00072 exedir => \&_build_executabletargetinfo_function, 00073 execute => \&_build_execute], 00074 groups => { 00075 default => [qw(print_contact print_version exepath exename exedir execute)], 00076 everything => [qw(print_contact print_version targetuid istarget exepath 00077 exename exedir tostring qsplit execute)] 00078 } 00079 }; 00080 00081 # ============================================================================ 00082 # executable information 00083 # ============================================================================ 00084 00085 # ---------------------------------------------------------------------------- 00086 ## @brief Print contact information. 00087 # 00088 # @param [in] $contact Name of contact. If @c undef, the default contact is used. 00089 sub print_contact 00090 { 00091 my $contact = shift; 00092 $contact = CONTACT unless $contact; 00093 print "Contact:\n $contact\n"; 00094 } 00095 00096 # ---------------------------------------------------------------------------- 00097 ## @brief Print version information including copyright and license notices. 00098 # 00099 # @note This function can be customized when importing it in order to set 00100 # default values for its parameters, which is in particular done by 00101 # the Basis module. 00102 # 00103 # Example: 00104 # @code 00105 # use BASIS::Utilities qw(print_version); 00106 # print_version('foo', '1.0'); 00107 # print_version('foo', version => '1.0'); 00108 # print_version(name => 'foo', version => '1.0'); 00109 # @endcode 00110 # 00111 # Example: 00112 # @code 00113 # use BASIS::Utilities 00114 # print_version => {project => 'FooBar', 00115 # version => '1.0', 00116 # copyright => '2012 Andreas Schuh', 00117 # license => 'Licensed under the Apache License, Version 2.0'}; 00118 # print_version('foo'); 00119 # @endcode 00120 # which results in the output 00121 # @verbatim 00122 # foo (FooBar) 1.0 00123 # Copyright (c) 2012 Andreas Schuh. All rights reserved. 00124 # Licensed under the Apache License, Version 2.0 00125 # @endverbatim 00126 # 00127 # @param [in] $name Name of executable. Should not be set programmatically 00128 # to the first argument of the main script, but a string 00129 # literal instead. This argument is required if no default 00130 # has been set during customization. The argument can be 00131 # either given as first argument or as keyword argument 00132 # as in "name => 'foo'". 00133 # @param [in] $version Version of executable, e.g., release of project this 00134 # executable belongs to. This argument is required if no 00135 # default has been set during customization. The argument 00136 # can be either given as second argument or as keyword 00137 # argument as in "version => '1.0'". 00138 # @param [in] $project Name of project this executable belongs to. 00139 # If @c undef or an empty string is given, no project 00140 # information is included in output. 00141 # @param [in] $copyright The copyright notice. If @c undef, the default copyright 00142 # is used. If an empty string is given, no copyright notice 00143 # is printed. 00144 # @param [in] $license Information regarding licensing. If @c undef, the default 00145 # software license is used. If an empty string is given, 00146 # no license information is printed. 00147 sub print_version 00148 { 00149 my $name = undef; 00150 my $version = undef; 00151 if (@_ != 0 and (not defined $_[0] or $_[0] !~ /^(name|version|project|copyright|license)$/)) { 00152 $name = $_[0]; 00153 shift; 00154 } 00155 if (@_ != 0 and (not defined $_[0] or $_[0] !~ /^(name|version|project|copyright|license)$/)) { 00156 $version = $_[0]; 00157 shift; 00158 } 00159 die "print_version(): Invalid number of arguments" if scalar(@_) % 2 == 1; 00160 my %defaults = (name => undef, version => undef, project => undef, copyright => COPYRIGHT, license => LICENSE); 00161 my %options = (%defaults, @_); 00162 die "print_version(): Name argument given twice" if defined $options{'name'} and defined $name; 00163 die "print_version(): Version argument given twice" if defined $options{'version'} and defined $version; 00164 $name = $options{'name'} unless $name; 00165 $version = $options{'version'} unless $version; 00166 die "print_version(): Missing name argument" unless $name; 00167 die "print_version(): Missing version argument" unless $version; 00168 # program identification 00169 print $name; 00170 print " ($options{'project'})" if $options{'project'}; 00171 print " ", $version, "\n"; 00172 # copyright notice 00173 print "Copyright (c) ", $options{'copyright'}, ". All rights reserved.\n" if $options{'copyright'}; 00174 # license information 00175 print $options{'license'}, "\n" if $options{'license'}; 00176 } 00177 00178 # ---------------------------------------------------------------------------- 00179 ## @brief Get UID of build target. 00180 # 00181 # @note This function can be customized when importing it in order to set 00182 # default values for @p prefix and @p targets, which is in particular 00183 # done by the Basis module. 00184 # 00185 # This function prepends the default namespace used for targets build as 00186 # part of the project this module belongs to if the given target name is yet 00187 # neither known nor fully-qualified, i.e., in the form "<namespace>::<target>". 00188 # 00189 # @param [in] $target Name of build target. 00190 # @param [in] $prefix Common target name prefix. If @c undef, the given 00191 # target name must match excactly. Otherwise, targets 00192 # within the specified namespace are considered. 00193 # @param [in] %$targets Reference to hash which maps known build targets to 00194 # executable file paths. If not specified, this function 00195 # always returns the input target name unchanged. 00196 # 00197 # @returns Fully-qualified build target name or @c undef if @p target is 00198 # @c undef or an empty string. 00199 sub targetuid 00200 { 00201 my $target = shift; 00202 my $prefix = shift; 00203 my $targets = shift; 00204 # handle invalid arguments 00205 return undef unless defined $target and length($target) > 0; 00206 # in case of a leading namespace separator or if no lookup table 00207 # of executable build target is provided, do not modify target name 00208 return $target if $target =~ /^\./ or not defined $targets; 00209 # project namespace 00210 $prefix = '' unless defined $prefix; 00211 $prefix = $prefix . '.DUMMY'; # simplifies while loop 00212 # try prepending namespace or parts of it until target is known 00213 while ($prefix =~ s/(.*)\.[^.]*/$1/) { 00214 if (exists $targets->{$prefix . '.' . $target}) { 00215 return $prefix . '.' . $target; 00216 } 00217 } 00218 # otherwise, return target name unchanged 00219 return $target; 00220 } 00221 00222 # ---------------------------------------------------------------------------- 00223 ## @brief Determine whether a given target is known. 00224 # 00225 # @note This function can be customized when importing it in order to set 00226 # default values for @p prefix and @p targets, which is in particular 00227 # done by the Basis module. 00228 # 00229 # @param [in] $target Name of build target. 00230 # @param [in] $prefix Common target name prefix. If @c undef, the given 00231 # target name must match excactly. Otherwise, targets 00232 # within the specified namespace are considered. 00233 # @param [in] %$targets Reference to hash which maps known build targets to 00234 # executable file paths. If not specified, this function 00235 # always returns false. 00236 # 00237 # @returns Whether the given build target is known by this module. 00238 sub istarget 00239 { 00240 my $target = shift; 00241 my $prefix = shift; 00242 my $targets = shift; 00243 if (defined $targets) { 00244 my $uid = targetuid($target, $prefix, $targets); 00245 defined $uid or return 0; 00246 $uid =~ s/^[.]?(.*)/$1/; 00247 exists $targets->{$uid}; 00248 } else { 00249 return 0; 00250 } 00251 } 00252 00253 # ---------------------------------------------------------------------------- 00254 ## @brief Get absolute path of executable file. 00255 # 00256 # @note This function can be customized when importing it in order to set 00257 # default values for @p prefix and @p targets, which is in particular 00258 # done by the Basis module. 00259 # 00260 # This function determines the absolute file path of an executable. If no 00261 # arguments are given, the absolute path of this executable is returned. 00262 # Otherwise, the named command is searched in the system PATH and its 00263 # absolute path returned if found. If the executable is not found, @c undef 00264 # is returned. 00265 # 00266 # @param [in] $name Name of command or @c undef. 00267 # @param [in] $prefix Common target name prefix. If @c undef, the given 00268 # target name must match excactly. Otherwise, targets 00269 # within the specified namespace are considered. 00270 # @param [in] %$targets Reference to hash which maps known build targets to 00271 # executable file paths. If not specified, this function 00272 # always returns false. 00273 # @param [in] $base Base directory used for relative paths in @p %$targets. 00274 # 00275 # @returns Absolute path of executable or @c undef if not found. 00276 # If @p name is @c undef, the path of this executable is returned. 00277 sub exepath 00278 { 00279 my $name = shift; 00280 my $prefix = shift; 00281 my $targets = shift; 00282 my $base = shift || '.'; 00283 my $path = undef; 00284 if (not defined $name) { 00285 $path = realpath($0); 00286 } elsif (defined $targets) { 00287 my $uid = targetuid($name, $prefix, $targets); 00288 defined $uid and $uid =~ s/^[.]?(.*)/$1/; 00289 if (defined $uid and exists $targets->{$uid}) { 00290 $path = $targets->{$uid}; 00291 if ($path =~ m/\$\(IntDir\)/) { 00292 my $tmppath = ''; 00293 my $intdir = ''; 00294 foreach $intdir ('Release', 'Debug', 'RelWithDebInfo', 'MinSizeRel') { 00295 $tmppath = $path; 00296 $tmppath =~ s/\$\(IntDir\)/$intdir/g; 00297 if (-e $tmppath) { 00298 $path = $tmppath; 00299 last; 00300 } 00301 } 00302 $path =~ s/\$\(IntDir\)//g; 00303 } 00304 $path = File::Spec->rel2abs($path, File::Spec->rel2abs($base, dirname(__FILE__))); 00305 # the realpath() function only works for existing paths 00306 $path = realpath($path) if -e $path; 00307 } 00308 } 00309 $path = which($name) unless defined $path; 00310 return $path; 00311 } 00312 00313 # ---------------------------------------------------------------------------- 00314 ## @brief Get name of executable file. 00315 # 00316 # @note This function can be customized when importing it in order to set 00317 # default values for @p prefix and @p targets, which is in particular 00318 # done by the Basis module. 00319 # 00320 # @param [in] $name Name of command or @c undef. 00321 # @param [in] $prefix Common target name prefix. If @c undef, the given 00322 # target name must match excactly. Otherwise, targets 00323 # within the specified namespace are considered. 00324 # @param [in] %$targets Reference to hash which maps known build targets to 00325 # executable file paths. If not specified, this function 00326 # always returns false. 00327 # @param [in] $base Base directory used for relative paths in @p %$targets. 00328 # 00329 # @returns Name of executable file or @c undef if not found. 00330 # If @p name is @c undef, the path of this executable is returned. 00331 sub exename 00332 { 00333 my $path = exepath(@_); 00334 defined $path or return undef; 00335 return basename($path); 00336 } 00337 00338 # ---------------------------------------------------------------------------- 00339 ## @brief Get directory of executable file. 00340 # 00341 # @note This function can be customized when importing it in order to set 00342 # default values for @p prefix and @p targets, which is in particular 00343 # done by the Basis module. 00344 # 00345 # @param [in] $name Name of command or @c undef. 00346 # @param [in] $prefix Common target name prefix. If @c undef, the given 00347 # target name must match excactly. Otherwise, targets 00348 # within the specified namespace are considered. 00349 # @param [in] %$targets Reference to hash which maps known build targets to 00350 # executable file paths. If not specified, this function 00351 # always returns false. 00352 # @param [in] $base Base directory used for relative paths in @p %$targets. 00353 # 00354 # @returns Absolute path of directory containing executable or @c undef if not found. 00355 # If @p name is @c undef, the directory of this executable is returned. 00356 sub exedir 00357 { 00358 my $path = exepath(@_); 00359 defined $path or return undef; 00360 return dirname($path); 00361 } 00362 00363 # ============================================================================ 00364 # command execution 00365 # ============================================================================ 00366 00367 # ---------------------------------------------------------------------------- 00368 ## @brief Convert list to double quoted string. 00369 # 00370 # @param [in] @$args Array of arguments. 00371 # 00372 # @returns Double quoted string, i.e., string where array elements are separated 00373 # by a space character and surrounded by double quotes if necessary. 00374 # Double quotes within an array element are escaped with a backslash. 00375 sub tostring 00376 { 00377 my $str = ''; 00378 if (ref($_[0]) eq 'ARRAY') { 00379 foreach my $arg (@{$_[0]}) { 00380 $arg =~ s/"/\\"/g; # escape double quotes 00381 $arg = '"' . $arg . '"' if $arg =~ m/'|\s|^$/; # quote if necessary 00382 $str .= ' ' if $str ne ''; 00383 $str .= $arg; 00384 } 00385 } else { 00386 $str = $_[0]; 00387 $str =~ s/"/\\"/g; # escape double quotes 00388 $str = '"' . $str . '"' if $str =~ m/'|\s|^$/; # quote if necessary 00389 } 00390 return $str; 00391 } 00392 00393 # ---------------------------------------------------------------------------- 00394 ## @brief Split quoted string. 00395 # 00396 # @param [in] $str Quoted string. 00397 sub qsplit 00398 { 00399 my $str = shift; 00400 my $max = shift; 00401 my $arg = ''; 00402 my @args = (); 00403 LOOP: { 00404 while ($str =~ /[ ]*('([^']|\\\')*[^\\]'|\"([^\"]|\\\")*[^\\]\"|[^ ]+)(.*)/) { 00405 $arg = $1; # matched element including quotes 00406 $str = $4; # continue with residual command-line 00407 $arg =~ s/^['\"]|(^|[^\\])['\"]$//g; # remove quotes 00408 $arg =~ s/[\\]('|\")/$1/g; # unescape quotes 00409 push @args, $arg; # add to resulting array 00410 last LOOP if defined $max and scalar(@args) >= $max; 00411 } 00412 } 00413 if (defined $max) { 00414 if ($max eq 1) { return ($args[0], $str); } 00415 else { return (@args, $str); } 00416 } else { return @args; } 00417 } 00418 00419 # ---------------------------------------------------------------------------- 00420 # @brief Split/Convert quoted string or array of arguments into command name 00421 # and quoted string of command arguments. 00422 # 00423 # @param [in] @$args Array of command name and arguments or quoted string. 00424 # 00425 # @returns Tuple of command name and quoted string of command arguments. 00426 sub _split_command_and_arguments 00427 { 00428 my $args = $_[0]; 00429 my $command = ''; 00430 my $arguments = ''; 00431 if (ref($args) eq 'ARRAY') { 00432 my @argv = @$args; # otherwise input is modified 00433 $command = shift @argv or die "execute(): No command specified for execution"; 00434 $arguments = tostring(\@argv); 00435 } elsif (ref($args) eq '') { 00436 ($command, $arguments) = qsplit($args, 1); 00437 } else { 00438 die "Argument must be either array reference or string"; 00439 } 00440 return ($command, $arguments); 00441 } 00442 00443 # ---------------------------------------------------------------------------- 00444 ## @brief Execute command as subprocess. 00445 # 00446 # @note This function can be customized when importing it in order to set 00447 # default values for @p prefix and @p targets, which is in particular 00448 # done by the Basis module. 00449 # 00450 # This command takes either an array reference or a string as first argument. 00451 # All other arguments are keyword arguments using hash notation. 00452 # 00453 # Example: 00454 # @code 00455 # # only returns exit code of command but does not output anything 00456 # my $status = execute(['ls', '/'], quiet => 1); 00457 # # returns exit code of command and returns command output w/o printing to stdout 00458 # my ($status, $stdout) = execute('ls /', quiet => 1, stdout => 1); 00459 # @endcode 00460 # 00461 # @param [in] $args Command with arguments given either as single quoted 00462 # string or array of command name and arguments. 00463 # @param [in] $quiet Turns off output of @c stdout of child process to 00464 # @c stdout of parent process. 00465 # @param [in] $stdout Whether to return the command output. 00466 # @param [in] $allow_fail If true, does not raise an exception if return 00467 # value is non-zero. Otherwise, an exception is 00468 # raised by this function using die. 00469 # @param [in] $verbose Verbosity of output messages. 00470 # Does not affect verbosity of executed command. 00471 # @param [in] $simulate Whether to simulate command execution only. 00472 # @param [in] $prefix Common target name prefix. If @c undef, the given 00473 # target name must match excactly. Otherwise, targets 00474 # within the specified namespace are considered. 00475 # @param [in] %$targets Reference to hash which maps known build targets to 00476 # executable file paths. If not specified, this function 00477 # always returns false. 00478 # @param [in] $base Base directory used for relative paths in @p %$targets. 00479 # 00480 # @returns The exit code of the subprocess if @p stdout is false (the default). 00481 # Otherwise, if @p stdout is true, a tuple consisting of exit code 00482 # command output is returned. Note that if @p allow_fail is false, 00483 # the returned exit code will always be 0. 00484 # 00485 # @throws die If command execution failed. This exception is not raised 00486 # if the command executed with non-zero exit code but 00487 # @p allow_fail is true. 00488 sub execute 00489 { 00490 # arguments 00491 my $args = shift or die "execute(): No command specified for execution"; 00492 if ($args =~ m/^(quiet|stdout|allow_fail|verbose|simulate|prefix|targets|base)$/) { 00493 warn "First argument matches option name. Missing args argument?"; 00494 } 00495 my %defaults = (quiet => 0, stdout => 0, allow_fail => 0, 00496 verbose => 0, simulate => 0, 00497 prefix => undef, targets => undef, base => '.'); 00498 my %options = (%defaults, @_); 00499 # get absolute path of executable 00500 my ($command, $arguments) = _split_command_and_arguments($args); 00501 my $exec_path = exepath($command, $options{'prefix'}, $options{'targets'}, $options{'base'}); 00502 defined $exec_path or die "$command: Command not found"; 00503 $exec_path = '"' . $exec_path . '"' if $exec_path =~ m/'|\s/; # quote if necessary 00504 $args = "$exec_path $arguments"; 00505 # some verbose output 00506 if ($options{'verbose'} gt 0 or $options{'simulate'}) { 00507 print "\$ ", $args; 00508 $options{'simulate'} and print " (simulated)"; 00509 print "\n"; 00510 } 00511 # execute command 00512 my $status = 0; 00513 my $output = ''; 00514 if (not $options{'simulate'}) { 00515 open CMD, "$args |" or die "$command: Failed to open subprocess"; 00516 my $ofh = select STDOUT; 00517 $|++; 00518 while (<CMD>) { 00519 print $_ unless $options{'quiet'}; 00520 $output .= $_ if $options{'stdout'}; 00521 } 00522 $|--; 00523 select $ofh; 00524 close CMD; 00525 $status = $?; 00526 } 00527 # if command failed, throw an exception 00528 if ($status != 0 and not $options{'allow_fail'}) { 00529 die "Command $args failed"; 00530 } 00531 # return 00532 if ($options{'stdout'}) { return ($status, $output); } 00533 else { return $status; } 00534 } 00535 00536 00537 ## @} 00538 # end of Doxygen group 00539 00540 00541 # ============================================================================ 00542 # exports 00543 # ============================================================================ 00544 00545 # ---------------------------------------------------------------------------- 00546 # builder of customized print_contact() 00547 sub _build_print_contact 00548 { 00549 my ($class, $fn, $args) = @_; 00550 return sub { 00551 my $contact = shift || $args->{contact}; 00552 print_contact($contact); 00553 } 00554 } 00555 00556 # ---------------------------------------------------------------------------- 00557 # builder of customized print_version() 00558 sub _build_print_version 00559 { 00560 my ($class, $fn, $args) = @_; 00561 return sub { 00562 my $name = undef || $args->{name}; 00563 my $version = undef || $args->{version}; 00564 if (@_ != 0 and (not defined $_[0] or $_[0] !~ /^(name|version|project|copyright|license)$/)) { 00565 $name = $_[0]; 00566 shift; 00567 } 00568 if (@_ != 0 and (not defined $_[0] or $_[0] !~ /^(name|version|project|copyright|license)$/)) { 00569 $version = $_[0]; 00570 shift; 00571 } 00572 die "print_version(): Invalid number of arguments" if scalar(@_) % 2 == 1; 00573 my %defaults = (name => $args->{name}, 00574 version => $args->{version}, 00575 project => $args->{project}, 00576 copyright => $args->{copyright}, 00577 license => $args->{license}); 00578 my %options = (%defaults, @_); 00579 die "print_version(): Name argument given twice" if defined $options{'name'} and defined $name; 00580 die "print_version(): Version argument given twice" if defined $options{'version'} and defined $version; 00581 $options{'name'} = $name if $name; 00582 $options{'version'} = $version if $version; 00583 print_version(%options); 00584 } 00585 } 00586 00587 # ---------------------------------------------------------------------------- 00588 # builder of customized functions related to executable target information 00589 sub _build_executabletargetinfo_function 00590 { 00591 my ($class, $fn, $args) = @_; 00592 return sub { 00593 my $target = shift; 00594 my $prefix = shift || $args->{prefix}; 00595 my $targets = shift || $args->{targets}; 00596 my $base = shift || $args->{base}; 00597 eval "$fn(\$target, \$prefix, \$targets, \$base)"; 00598 } 00599 } 00600 00601 # ---------------------------------------------------------------------------- 00602 # builder of customized execute() 00603 sub _build_execute 00604 { 00605 my ($class, $fn, $args) = @_; 00606 return sub { 00607 my $argv = shift; 00608 my %defaults = (quiet => $args->{quiet} || 0, 00609 stdout => $args->{stdout} || 0, 00610 allow_fail => $args->{allow_fail} || 0, 00611 verbose => $args->{verbose} || 0, 00612 simulate => $args->{simulate} || 0, 00613 prefix => $args->{prefix}, 00614 targets => $args->{targets}, 00615 base => $args->{base}); 00616 my %options = (%defaults, @_); 00617 execute($argv, %options); 00618 } 00619 } 00620 00621 00622 1; # indicate success of module loading