#!/usr/bin/env perl #----------------------------------------------------------------------------------------------- # # xml2env # # This utility converts env_*xml files to shell environment variable files that are then # sourced. # #----------------------------------------------------------------------------------------------- use strict; #use warnings; #use diagnostics; use Cwd; use English; use Getopt::Long; use IO::File; use IO::Handle; #----------------------------------------------------------------------------------------------- sub usage { die <). Any value that contains white-space must be quoted. Long option names may be supplied with either single or double leading dashes. A consequence of this is that single letter options may NOT be bundled. -help [or -h] Print usage to STDOUT. -silent [or -s] Turns on silent mode - only fatal messages issued. -verbose [or -v] Turn on verbose echoing of settings EOF } #----------------------------------------------------------------------------------------------- # Setting autoflush (an IO::Handle method) on STDOUT helps in debugging. It forces the test # descriptions to be printed to STDOUT before the error messages start. *STDOUT->autoflush(); #----------------------------------------------------------------------------------------------- # Set the directory that contains the scripts. If the create_newcase command was # issued using a relative or absolute path, that path is in $ProgDir. Otherwise assume the # command was issued from the current working directory. (my $ProgName = $0) =~ s!(.*)/!!; # name of this script my $ProgDir = $1; # name of directory containing this script -- may be a # relative or absolute path, or null if the script is in # the user's PATH my $cwd = getcwd(); # current working directory my $cfgdir; # absolute pathname of directory that contains this script if ($ProgDir) { $cfgdir = absolute_path($ProgDir); } else { $cfgdir = $cwd; } #----------------------------------------------------------------------------------------------- # Parse command-line options. my %opts = ( cache => "config_cache.xml", ); GetOptions( "h|help" => \$opts{'help'}, "s|silent" => \$opts{'silent'}, "v|verbose" => \$opts{'verbose'}, ) or usage(); # Give usage message. usage() if $opts{'help'}; # Check for unparsed argumentss if (@ARGV) { print "ERROR: unrecognized arguments: @ARGV\n"; usage(); } (-f "env_case.xml") or die <<"EOF"; ** Cannot find env_case.xml ** EOF # Define 3 print levels: # 0 - only issue fatal error messages # 1 - only informs what files are created (default) # 2 - verbose my $print = 1; if ($opts{'silent'}) { $print = 0; } if ($opts{'verbose'}) { $print = 2; } my $eol = "\n"; my %cfg = (); # build configuration #----------------------------------------------------------------------------------------------- # Make sure we can find required perl modules and configuration files. # Check for the configuration definition file. my $config_def_file = "config_definition.xml"; (-f "$cfgdir/$config_def_file") or die <<"EOF"; ** Cannot find configuration definition file \"$config_def_file\" in directory ./Tools ** EOF # The XML::Lite module is required to parse the XML configuration files. (-f "$cfgdir/XML/Lite.pm") or die <<"EOF"; ** Cannot find perl module \"XML/Lite.pm\" in directory ./Tools ** EOF # The ConfigCase module provides utilities to store and manipulate the configuration. (-f "$cfgdir/ConfigCase.pm") or die <<"EOF"; ** Cannot find perl module \"ConfigCase.pm\" in directory ./Tools ** EOF if ($print>=2) { print "Setting configuration directory to $cfgdir$eol"; } #----------------------------------------------------------------------------------------------- # Add $cfgdir/perl5lib to the list of paths that Perl searches for modules my @dirs = ( $cfgdir, "$cfgdir/Tools"); unshift @INC, @dirs; require XML::Lite; require ConfigCase; my $config_file = "$cfgdir/$config_def_file"; my $cfg_ref = ConfigCase->new("$config_file", "env_case.xml"); $cfg_ref->reset_setup("env_build.xml"); $cfg_ref->reset_setup("env_run.xml"); $cfg_ref->reset_setup("env_mach_pes.xml"); if(-e "env_test.xml"){ $cfg_ref->reset_setup("env_test.xml"); $cfg_ref->write_file("env_test", "env"); } $cfg_ref->write_file("env_case" , "env"); $cfg_ref->write_file("env_build" , "env" ); $cfg_ref->write_file("env_run" , "env"); $cfg_ref->write_file("env_mach_pes", "env"); if ($print>=2) { print "xml2env done.\n"; } exit; #----------------------------------------------------------------------------------------------- # FINNISHED #################################################################################### #----------------------------------------------------------------------------------------------- sub absolute_path { # # Convert a pathname into an absolute pathname, expanding any . or .. characters. # Assumes pathnames refer to a local filesystem. # Assumes the directory separator is "/". # my $path = shift; my $cwd = getcwd(); # current working directory my $abspath; # resulting absolute pathname # Strip off any leading or trailing whitespace. (This pattern won't match if # there's embedded whitespace. $path =~ s!^\s*(\S*)\s*$!$1!; # Convert relative to absolute path. if ($path =~ m!^\.$!) { # path is "." return $cwd; } elsif ($path =~ m!^\./!) { # path starts with "./" $path =~ s!^\.!$cwd!; } elsif ($path =~ m!^\.\.$!) { # path is ".." $path = "$cwd/.."; } elsif ($path =~ m!^\.\./!) { # path starts with "../" $path = "$cwd/$path"; } elsif ($path =~ m!^[^/]!) { # path starts with non-slash character $path = "$cwd/$path"; } my ($dir, @dirs2); my @dirs = split "/", $path, -1; # The -1 prevents split from stripping trailing nulls # This enables correct processing of the input "/". # Remove any "" that are not leading. for (my $i=0; $i<=$#dirs; ++$i) { if ($i == 0 or $dirs[$i] ne "") { push @dirs2, $dirs[$i]; } } @dirs = (); # Remove any "." foreach $dir (@dirs2) { unless ($dir eq ".") { push @dirs, $dir; } } @dirs2 = (); # Remove the "subdir/.." parts. foreach $dir (@dirs) { if ( $dir !~ /^\.\.$/ ) { push @dirs2, $dir; } else { pop @dirs2; # remove previous dir when current dir is .. } } if ($#dirs2 == 0 and $dirs2[0] eq "") { return "/"; } $abspath = join '/', @dirs2; return( $abspath ); } #------------------------------------------------------------------------------- sub subst_env_path { # # Substitute for any environment variables contained in a pathname. # Assumes the directory separator is "/". # my $path = shift; my $newpath; # resulting pathname # Strip off any leading or trailing whitespace. (This pattern won't match if # there's embedded whitespace. $path =~ s!^\s*(\S*)\s*$!$1!; my ($dir, @dirs2); my @dirs = split "/", $path, -1; # The -1 prevents split from stripping trailing nulls # This enables correct processing of the input "/". foreach $dir (@dirs) { if ( $dir =~ /^\$(.+)$/ ) { push @dirs2, $ENV{$1}; } else { push @dirs2, $dir; } } $newpath = join '/', @dirs2; return( $newpath ); } #------------------------------------------------------------------------------- sub get_option { my ($mes, @expect) = @_; my ($ans, $expect, $max_tries); $max_tries = 5; print $mes; while ($max_tries) { $ans = <>; chomp $ans; --$max_tries; $ans =~ s/^\s+//; $ans =~ s/\s+$//; # Check for null response which indicates that default is accepted. unless ($ans) { return ""; } foreach $expect (@expect) { if ($ans =~ /^$expect$/i) { return $expect; } } if ($max_tries > 1) { print "$ans does not match any of the expected values: @expect\n"; print "Please try again: "; } elsif ($max_tries == 1) { print "$ans does not match any of the expected values: @expect\n"; print "Last chance! "; } } die "Failed to get answer to question: $mes\n"; } #------------------------------------------------------------------------------- sub print_hash { my %h = @_; my ($k, $v); while ( ($k,$v) = each %h ) { print "$k => $v\n"; } }