# ------------------------------------------------------------------------------ # NAME # Fcm::Config # # DESCRIPTION # This is a class for reading and processing central and user configuration # settings for FCM. # # COPYRIGHT # (C) Crown copyright Met Office. All rights reserved. # For further details please refer to the file COPYRIGHT.txt # which you should have received as part of this distribution. # ------------------------------------------------------------------------------ package Fcm::Config; # Standard pragma use warnings; use strict; # Standard modules use File::Basename; use File::Spec::Functions; use FindBin; use POSIX qw/setlocale LC_ALL/; # FCM component modules use Fcm::CfgFile; # Other declarations: sub _get_hash_value; # Delimiter for setting and for list our $DELIMITER = '::'; our $DELIMITER_PATTERN = qr{::|/}; our $DELIMITER_LIST = ','; my $INSTANCE; # ------------------------------------------------------------------------------ # SYNOPSIS # $config = Fcm::Config->instance(); # # DESCRIPTION # Returns an instance of this class. # ------------------------------------------------------------------------------ sub instance { my ($class) = @_; if (!defined($INSTANCE)) { $INSTANCE = $class->new(); $INSTANCE->get_config(); $INSTANCE->is_initialising(0); } return $INSTANCE; } # ------------------------------------------------------------------------------ # SYNOPSIS # $obj = Fcm::Config->new (VERBOSE => $verbose); # # DESCRIPTION # This method constructs a new instance of the Fcm::Config class. # # ARGUMENTS # VERBOSE - Set the verbose level of diagnostic output # ------------------------------------------------------------------------------ sub new { my $this = shift; my %args = @_; my $class = ref $this || $this; # Ensure that all subsequent Subversion output is in UK English if (setlocale (LC_ALL, 'en_GB')) { $ENV{LANG} = 'en_GB'; } my $self = { initialising => 1, central_config => undef, user_config => undef, user_id => undef, verbose => exists $args{VERBOSE} ? $args{VERBOSE} : undef, variable => {}, # Primary settings setting => { # Current command FCM_COMMAND => &basename ($0), # Current FCM release identifier FCM_RELEASE => '1-5', # Location of file with the last changed revision of the FCM trunk FCM_REV_FILE => catfile (dirname ($FindBin::Bin), 'etc', 'fcm_rev'), # Fortran BLOCKDATA dependencies BLD_BLOCKDATA => {}, # Copy dummy target BLD_CPDUMMY => '$(FCM_DONEDIR)/FCM_CP.dummy', # No dependency check BLD_DEP_N => {}, # Additional (PP) dependencies BLD_DEP => {}, BLD_DEP_PP => {}, # Excluded dependency BLD_DEP_EXCL => { '' => [ # Fortran intrinsic modules 'USE' . $DELIMITER . 'ISO_C_BINDING', 'USE' . $DELIMITER . 'IEEE_EXCEPTIONS', 'USE' . $DELIMITER . 'IEEE_ARITHMETIC', 'USE' . $DELIMITER . 'IEEE_FEATURES', # Fortran intrinsic subroutines 'OBJ' . $DELIMITER . 'CPU_TIME', 'OBJ' . $DELIMITER . 'GET_COMMAND', 'OBJ' . $DELIMITER . 'GET_COMMAND_ARGUMENT', 'OBJ' . $DELIMITER . 'GET_ENVIRONMENT_VARIABLE', 'OBJ' . $DELIMITER . 'MOVE_ALLOC', 'OBJ' . $DELIMITER . 'MVBITS', 'OBJ' . $DELIMITER . 'RANDOM_NUMBER', 'OBJ' . $DELIMITER . 'RANDOM_SEED', 'OBJ' . $DELIMITER . 'SYSTEM_CLOCK', # Dummy statements 'OBJ' . $DELIMITER . 'NONE', 'EXE' . $DELIMITER . 'NONE', ], }, # Extra executable dependencies BLD_DEP_EXE => {}, # Dependency pattern for each type BLD_DEP_PATTERN => { H => q/^#\s*include\s*['"](\S+)['"]/, USE => q/^\s*use\s+(\w+)/, INTERFACE => q/^#?\s*include\s+['"](\S+##OUTFILE_EXT/ . $DELIMITER . q/INTERFACE##)['"]/, INC => q/^\s*include\s+['"](\S+)['"]/, OBJ => q#^\s*(?:/\*|!)\s*depends\s*on\s*:\s*(\S+)#, EXE => q/^\s*(?:#|;)\s*(?:calls|list|if|interface)\s*:\s*(\S+)/, }, # Rename main program targets BLD_EXE_NAME => {}, # Rename library targets BLD_LIB => {'' => 'fcm_default'}, # Name of Makefile and run environment shell script BLD_MISC => { 'BLDMAKEFILE' => 'Makefile', 'BLDRUNENVSH' => 'fcm_env.sh', }, # PP flags BLD_PP => {}, # Custom source file type BLD_TYPE => {}, # Types that always need to be built BLD_TYPE_ALWAYS_BUILD => 'PVWAVE' . $DELIMITER_LIST . 'GENLIST' . $DELIMITER_LIST . 'SQL', # Dependency scan types BLD_TYPE_DEP => { FORTRAN => 'USE' . $DELIMITER . 'INTERFACE' . $DELIMITER . 'INC' . $DELIMITER . 'OBJ', FPP => 'USE' . $DELIMITER . 'INTERFACE' . $DELIMITER . 'INC' . $DELIMITER . 'H' . $DELIMITER . 'OBJ', CPP => 'H' . $DELIMITER . 'OBJ', C => 'H' . $DELIMITER . 'OBJ', SCRIPT => 'EXE', }, # Dependency scan types for pre-processing BLD_TYPE_DEP_PP => { FPP => 'H', CPP => 'H', C => 'H', }, # Types that cannot have duplicated targets BLD_TYPE_NO_DUPLICATED_TARGET => '', # BLD_VPATH, each value must be a comma separate list # '' translates to % # 'FLAG' translates to {OUTFILE_EXT}{FLAG} BLD_VPATH => { BIN => q{}, ETC => 'ETC', DONE => join($DELIMITER_LIST, qw{DONE IDONE}), FLAGS => 'FLAGS', INC => q{}, LIB => 'LIB', OBJ => 'OBJ', }, # Cache basename CACHE => '.config', CACHE_DEP => '.config_dep', CACHE_DEP_PP => '.config_dep_pp', CACHE_FILE_SRC => '.config_file_src', # Types of "inc" statements expandable CFG files CFG_EXP_INC => 'BLD' . $DELIMITER_LIST . 'EXT' . $DELIMITER_LIST . 'FCM', # Configuration file labels that can be declared more than once CFG_KEYWORD => 'USE' . $DELIMITER_LIST . 'INC' . $DELIMITER_LIST . 'TARGET' . $DELIMITER_LIST . 'BLD_DEP_EXCL', # Labels for all types of FCM configuration files CFG_LABEL => { CFGFILE => 'CFG', # config file information INC => 'INC', # "include" from an configuration file # Labels for central/user internal config setting SETTING => 'SET', # Labels for systems that allow inheritance DEST => 'DEST', # destination USE => 'USE', # use (inherit) a previous configuration # Labels for bld and pck cfg TARGET => 'TARGET', # BLD: declare targets, PCK: target of source file # Labels for bld cfg BLD_BLOCKDATA => 'BLOCKDATA', # declare Fortran BLOCKDATA dependencies BLD_DEP => 'DEP', # additional dependencies BLD_DEP_N => 'NO_DEP', # no dependency check BLD_DEP_EXCL => 'EXCL_DEP', # exclude automatic dependencies BLD_DEP_EXE => 'EXE_DEP', # declare dependencies for program BLD_EXE_NAME => 'EXE_NAME', # rename a main program BLD_LIB => 'LIB', # rename library BLD_PP => 'PP', # sub-package needs pre-process? BLD_TYPE => 'SRC_TYPE', # custom source file type DIR => 'DIR', # DEPRECATED, same as DEST INFILE_EXT => 'INFILE_EXT', # change input file name extension type INHERIT => 'INHERIT', # inheritance flag NAME => 'NAME', # name the build OUTFILE_EXT => 'OUTFILE_EXT', # change output file type extension FILE => 'SRC', # declare a sub-package SEARCH_SRC => 'SEARCH_SRC', # search src/ sub-directory? TOOL => 'TOOL', # declare a tool # Labels for ext cfg BDECLARE => 'BLD', # build declaration CONFLICT => 'CONFLICT', # set conflict mode DIRS => 'SRC', # declare source directory EXPDIRS => 'EXPSRC', # declare expandable source directory MIRROR => 'MIRROR', # DEPRECATED, same as RDEST::MIRROR_CMD OVERRIDE => 'OVERRIDE', # DEPRECATED, replaced by CONFLICT RDEST => 'RDEST', # declare remote destionation REVISION => 'REVISION', # declare branch revision in a project REVMATCH => 'REVMATCH', # branch revision must match changed revision REPOS => 'REPOS', # declare branch in a project VERSION => 'VERSION', # DEPRECATED, same as REVISION }, # Default names of known FCM configuration files CFG_NAME => { BLD => 'bld.cfg', # build configuration file EXT => 'ext.cfg', # extract configuration file PARSED => 'parsed_', # as-parsed configuration file prefix }, # Latest version of known FCM configuration files CFG_VERSION => { BLD => '1.0', # bld cfg EXT => '1.0', # ext cfg }, # Standard sub-directories for extract/build DIR => { BIN => 'bin', # executable BLD => 'bld', # build CACHE => '.cache', # cache CFG => 'cfg', # configuration DONE => 'done', # "done" ETC => 'etc', # miscellaneous items FLAGS => 'flags', # "flags" INC => 'inc', # include LIB => 'lib', # library OBJ => 'obj', # object PPSRC => 'ppsrc', # pre-processed source SRC => 'src', # source TMP => 'tmp', # temporary directory }, # A flag to indicate whether the revision of a given branch for extract # must match with the revision of a changed revision of the branch EXT_REVMATCH => 0, # default is false (allow any revision) # Input file name extension and type # (may overlap with output (below) and vpath (above)) INFILE_EXT => { # General extensions 'f' => 'FORTRAN' . $DELIMITER . 'SOURCE', 'for' => 'FORTRAN' . $DELIMITER . 'SOURCE', 'ftn' => 'FORTRAN' . $DELIMITER . 'SOURCE', 'f77' => 'FORTRAN' . $DELIMITER . 'SOURCE', 'f90' => 'FORTRAN' . $DELIMITER . 'FORTRAN9X' . $DELIMITER . 'SOURCE', 'f95' => 'FORTRAN' . $DELIMITER . 'FORTRAN9X' . $DELIMITER . 'SOURCE', 'F' => 'FPP' . $DELIMITER . 'SOURCE', 'FOR' => 'FPP' . $DELIMITER . 'SOURCE', 'FTN' => 'FPP' . $DELIMITER . 'SOURCE', 'F77' => 'FPP' . $DELIMITER . 'SOURCE', 'F90' => 'FPP' . $DELIMITER . 'FPP9X' . $DELIMITER . 'SOURCE', 'F95' => 'FPP' . $DELIMITER . 'FPP9X' . $DELIMITER . 'SOURCE', 'c' => 'C' . $DELIMITER . 'SOURCE', 'cpp' => 'C' . $DELIMITER . 'C++' . $DELIMITER . 'SOURCE', 'h' => 'CPP' . $DELIMITER . 'INCLUDE', 'o' => 'BINARY' . $DELIMITER . 'OBJ', 'obj' => 'BINARY' . $DELIMITER . 'OBJ', 'exe' => 'BINARY' . $DELIMITER . 'EXE', 'a' => 'BINARY' . $DELIMITER . 'LIB', 'sh' => 'SCRIPT' . $DELIMITER . 'SHELL', 'ksh' => 'SCRIPT' . $DELIMITER . 'SHELL', 'bash' => 'SCRIPT' . $DELIMITER . 'SHELL', 'csh' => 'SCRIPT' . $DELIMITER . 'SHELL', 'pl' => 'SCRIPT' . $DELIMITER . 'PERL', 'pm' => 'SCRIPT' . $DELIMITER . 'PERL', 'py' => 'SCRIPT' . $DELIMITER . 'PYTHON', 'tcl' => 'SCRIPT' . $DELIMITER . 'TCL', 'pro' => 'SCRIPT' . $DELIMITER . 'PVWAVE', # Local extensions 'cfg' => 'CFGFILE', 'h90' => 'CPP' . $DELIMITER . 'INCLUDE', 'inc' => 'FORTRAN' . $DELIMITER . 'FORTRAN9X' . $DELIMITER . 'INCLUDE', 'interface' => 'FORTRAN' . $DELIMITER . 'FORTRAN9X' . $DELIMITER . 'INCLUDE' . $DELIMITER . 'INTERFACE', }, # Ignore input files matching the following names (comma-separated list) INFILE_IGNORE => 'fcm_env.ksh' . $DELIMITER_LIST . 'fcm_env.sh', # Input file name pattern and type INFILE_PAT => { '\w+Scr_\w+' => 'SCRIPT' . $DELIMITER . 'SHELL', '\w+Comp_\w+' => 'SCRIPT' . $DELIMITER . 'SHELL' . $DELIMITER . 'GENTASK', '\w+(?:IF|Interface)_\w+' => 'SCRIPT' . $DELIMITER . 'SHELL' . $DELIMITER . 'GENIF', '\w+Suite_\w+' => 'SCRIPT' . $DELIMITER . 'SHELL' . $DELIMITER . 'GENSUITE', '\w+List_\w+' => 'SCRIPT' . $DELIMITER . 'SHELL' . $DELIMITER . 'GENLIST', '\w+Sql_\w+' => 'SCRIPT' . $DELIMITER . 'SQL', }, # Input text file pattern and type INFILE_TXT => { '(?:[ck]|ba)?sh' => 'SCRIPT' . $DELIMITER . 'SHELL', 'perl' => 'SCRIPT' . $DELIMITER . 'PERL', 'python' => 'SCRIPT' . $DELIMITER . 'PYTHON', 'tcl(?:sh)?|wish' => 'SCRIPT' . $DELIMITER . 'TCL', }, # Lock file LOCK => { BLDLOCK => 'fcm.bld.lock', # build lock file EXTLOCK => 'fcm.ext.lock', # extract lock file }, # Output file type and extension # (may overlap with input and vpath (above)) OUTFILE_EXT => { CFG => '.cfg', # FCM configuration file DONE => '.done', # "done" files for compiled source ETC => '.etc', # "etc" dummy file EXE => '.exe', # binary executables FLAGS => '.flags', # "flags" files, compiler flags config IDONE => '.idone', # "done" files for included source INTERFACE => '.interface', # interface for F90 subroutines/functions LIB => '.a', # archive object library MOD => '.mod', # compiled Fortran module information files OBJ => '.o', # compiled object files PDONE => '.pdone', # "done" files for pre-processed files TAR => '.tar', # TAR archive }, # Build commands and options (i.e. tools) TOOL => { SHELL => '/bin/sh', # Default shell CPP => 'cpp', # C pre-processor CPPFLAGS => '-C', # CPP flags CPP_INCLUDE => '-I', # CPP flag, specify "include" path CPP_DEFINE => '-D', # CPP flag, define macro CPPKEYS => '', # CPP keys (definition macro) CC => 'cc', # C compiler CFLAGS => '', # CC flags CC_COMPILE => '-c', # CC flag, compile only CC_OUTPUT => '-o', # CC flag, specify output file name CC_INCLUDE => '-I', # CC flag, specify "include" path CC_DEFINE => '-D', # CC flag, define macro FPP => 'cpp', # Fortran pre-processor FPPFLAGS => '-P -traditional', # FPP flags FPP_INCLUDE => '-I', # FPP flag, specify "include" path FPP_DEFINE => '-D', # FPP flag, define macro FPPKEYS => '', # FPP keys (definition macro) FC => 'f90', # Fortran compiler FFLAGS => '', # FC flags FC_COMPILE => '-c', # FC flag, compile only FC_OUTPUT => '-o', # FC flag, specify output file name FC_INCLUDE => '-I', # FC flag, specify "include" path FC_MODSEARCH => '', # FC flag, specify "module" path FC_DEFINE => '-D', # FC flag, define macro LD => '', # linker LDFLAGS => '', # LD flags LD_OUTPUT => '-o', # LD flag, specify output file name LD_LIBSEARCH => '-L', # LD flag, specify "library" path LD_LIBLINK => '-l', # LD flag, specify link library AR => 'ar', # library archiver ARFLAGS => 'rs', # AR flags MAKE => 'make', # make command MAKEFLAGS => '', # make flags MAKE_FILE => '-f', # make flag, path to Makefile MAKE_SILENT => '-s', # make flag, silent diagnostic MAKE_JOB => '-j', # make flag, number of jobs INTERFACE => 'file', # name interface after file/program GENINTERFACE => '', # Fortran 9x interface generator DIFF3 => 'diff3', # extract diff3 merge DIFF3FLAGS => '-E -m', # DIFF3 flags GRAPHIC_DIFF => 'xxdiff', # graphical diff tool GRAPHIC_MERGE=> 'xxdiff', # graphical merge tool }, # List of tools that are local to FCM, (will not be exported to a Makefile) TOOL_LOCAL => 'CPP' . $DELIMITER_LIST . 'CPPFLAGS' . $DELIMITER_LIST . 'CPP_INCLUDE' . $DELIMITER_LIST . 'CPP_DEFINE' . $DELIMITER_LIST . 'DIFF3' . $DELIMITER_LIST . 'DIFF3_FLAGS' . $DELIMITER_LIST . 'FPP' . $DELIMITER_LIST . 'FPPFLAGS' . $DELIMITER_LIST . 'FPP_INCLUDE' . $DELIMITER_LIST . 'FPP_DEFINE' . $DELIMITER_LIST . 'GRAPHIC_DIFF' . $DELIMITER_LIST . 'GRAPHIC_MERGE' . $DELIMITER_LIST . 'MAKE' . $DELIMITER_LIST . 'MAKEFLAGS' . $DELIMITER_LIST . 'MAKE_FILE' . $DELIMITER_LIST . 'MAKE_SILENT' . $DELIMITER_LIST . 'MAKE_JOB' . $DELIMITER_LIST . 'INTERFACE' . $DELIMITER_LIST . 'GENINTERFACE' . $DELIMITER_LIST . 'MIRROR' . $DELIMITER_LIST . 'REMOTE_SHELL', # List of tools that allow sub-package declarations TOOL_PACKAGE => 'CPPFLAGS' . $DELIMITER_LIST . 'CPPKEYS' . $DELIMITER_LIST . 'CFLAGS' . $DELIMITER_LIST . 'FPPFLAGS' . $DELIMITER_LIST . 'FPPKEYS' . $DELIMITER_LIST . 'FFLAGS' . $DELIMITER_LIST . 'LD' . $DELIMITER_LIST . 'LDFLAGS' . $DELIMITER_LIST . 'INTERFACE' . $DELIMITER_LIST . 'GENINTERFACE', # Supported tools for compilable source TOOL_SRC_PP => { FPP => { COMMAND => 'FPP', FLAGS => 'FPPFLAGS', PPKEYS => 'FPPKEYS', INCLUDE => 'FPP_INCLUDE', DEFINE => 'FPP_DEFINE', }, C => { COMMAND => 'CPP', FLAGS => 'CPPFLAGS', PPKEYS => 'CPPKEYS', INCLUDE => 'CPP_INCLUDE', DEFINE => 'CPP_DEFINE', }, }, # Supported tools for compilable source TOOL_SRC => { FORTRAN => { COMMAND => 'FC', FLAGS => 'FFLAGS', OUTPUT => 'FC_OUTPUT', INCLUDE => 'FC_INCLUDE', }, FPP => { COMMAND => 'FC', FLAGS => 'FFLAGS', PPKEYS => 'FPPKEYS', OUTPUT => 'FC_OUTPUT', INCLUDE => 'FC_INCLUDE', DEFINE => 'FC_DEFINE', }, C => { COMMAND => 'CC', FLAGS => 'CFLAGS', PPKEYS => 'CPPKEYS', OUTPUT => 'CC_OUTPUT', INCLUDE => 'CC_INCLUDE', DEFINE => 'CC_DEFINE', }, }, # FCM URL keyword and prefix, FCM revision keyword, and FCM Trac URL URL => {}, URL_REVISION => {}, URL_BROWSER_MAPPING => {}, URL_BROWSER_MAPPING_DEFAULT => { LOCATION_COMPONENT_PATTERN => qr{\A // ([^/]+) /+ ([^/]+)_svn /+(.*) \z}xms, BROWSER_URL_TEMPLATE => 'http://{1}/projects/{2}/intertrac/source:{3}{4}', BROWSER_REV_TEMPLATE => '@{1}', }, # Default web browser WEB_BROWSER => 'firefox', }, }; # Backward compatibility: the REPOS setting is equivalent to the URL setting $self->{setting}{REPOS} = $self->{setting}{URL}; # Alias the REVISION and TRAC setting to URL_REVISION and URL_TRAC $self->{setting}{REVISION} = $self->{setting}{URL_REVISION}; bless $self, $class; return $self; } # ------------------------------------------------------------------------------ # SYNOPSIS # $value = $obj->X; # $obj->X ($value); # # DESCRIPTION # Details of these properties are explained in the "new" method. # ------------------------------------------------------------------------------ for my $name (qw/central_config user_config user_id verbose/) { no strict 'refs'; *$name = sub { my $self = shift; # Argument specified, set property to specified argument if (@_) { $self->{$name} = $_[0]; } # Default value for property if (not defined $self->{$name}) { if ($name eq 'central_config') { # Central configuration file if (-r catfile (dirname ($FindBin::Bin), 'etc', 'fcm.cfg')) { $self->{$name} = catfile ( dirname ($FindBin::Bin), 'etc', 'fcm.cfg' ); } elsif (-r catfile ($FindBin::Bin, 'fcm.cfg')) { $self->{$name} = catfile ($FindBin::Bin, 'fcm.cfg'); } } elsif ($name eq 'user_config') { # User configuration file my $home = (getpwuid ($<))[7]; $home = $ENV{HOME} if not defined $home; $self->{$name} = catfile ($home, '.fcm') if defined ($home) and -r catfile ($home, '.fcm'); } elsif ($name eq 'user_id') { # User ID of current process my $user = (getpwuid ($<))[0]; $user = $ENV{LOGNAME} if not defined $user; $user = $ENV{USER} if not defined $user; $self->{$name} = $user; } elsif ($name eq 'verbose') { # Verbose mode $self->{$name} = exists $ENV{FCM_VERBOSE} ? $ENV{FCM_VERBOSE} : 1; } } return $self->{$name}; } } # ------------------------------------------------------------------------------ # SYNOPSIS # $flag = $obj->is_initialising(); # # DESCRIPTION # Returns true if this object is initialising. # ------------------------------------------------------------------------------ sub is_initialising { my ($self, $value) = @_; if (defined($value)) { $self->{initialising} = $value; } return $self->{initialising}; } # ------------------------------------------------------------------------------ # SYNOPSIS # %hash = %{ $obj->X () }; # $obj->X (\%hash); # # $value = $obj->X ($index); # $obj->X ($index, $value); # # DESCRIPTION # Details of these properties are explained in the "new" method. # # If no argument is set, this method returns a hash containing a list of # objects. If an argument is set and it is a reference to a hash, the objects # are replaced by the the specified hash. # # If a scalar argument is specified, this method returns a reference to an # object, if the indexed object exists or undef if the indexed object does # not exist. If a second argument is set, the $index element of the hash will # be set to the value of the argument. # ------------------------------------------------------------------------------ for my $name (qw/variable/) { no strict 'refs'; *$name = sub { my ($self, $arg1, $arg2) = @_; # Ensure property is defined as a reference to a hash $self->{$name} = {} if not defined ($self->{$name}); # Argument 1 can be a reference to a hash or a scalar index my ($index, %hash); if (defined $arg1) { if (ref ($arg1) eq 'HASH') { %hash = %$arg1; } else { $index = $arg1; } } if (defined $index) { # A scalar index is defined, set and/or return the value of an element $self->{$name}{$index} = $arg2 if defined $arg2; return ( exists $self->{$name}{$index} ? $self->{$name}{$index} : undef ); } else { # A scalar index is not defined, set and/or return the hash $self->{$name} = \%hash if defined $arg1; return $self->{$name}; } } } # ------------------------------------------------------------------------------ # SYNOPSIS # $setting = $obj->setting (@labels); # $obj->setting (\@labels, $setting); # # DESCRIPTION # This method returns/sets an item under the setting hash table. The depth # within the hash table is given by the list of arguments @labels, which # should match with the keys in the multi-dimension setting hash table. # ------------------------------------------------------------------------------ sub setting { my $self = shift; if (@_) { my $arg1 = shift; my $s = $self->{setting}; if (ref ($arg1) eq 'ARRAY') { # Assign setting # ------------------------------------------------------------------------ my $value = shift; while (defined (my $label = shift @$arg1)) { if (exists $s->{$label}) { if (ref $s->{$label} eq 'HASH') { $s = $s->{$label}; } else { $s->{$label} = $value; last; } } else { if (@$arg1) { $s->{$label} = {}; $s = $s->{$label}; } else { $s->{$label} = $value; } } } } else { # Get setting # ------------------------------------------------------------------------ return _get_hash_value ($s->{$arg1}, @_) if exists $s->{$arg1}; } } return undef; } # ------------------------------------------------------------------------------ # SYNOPSIS # $obj->get_config (); # # DESCRIPTION # This method reads the configuration settings from the central and the user # configuration files. # ------------------------------------------------------------------------------ sub get_config { my $self = shift; $self->_read_config_file ($self->central_config); $self->_read_config_file ($self->user_config); return; } # ------------------------------------------------------------------------------ # SYNOPSIS # $obj->_read_config_file (); # # DESCRIPTION # This internal method reads a configuration file and assign values to the # attributes of the current instance. # ------------------------------------------------------------------------------ sub _read_config_file { my $self = shift; my $config_file = $_[0]; if (!$config_file || !-f $config_file || !-r $config_file) { return; } my $cfgfile = Fcm::CfgFile->new (SRC => $config_file, TYPE => 'FCM'); $cfgfile->read_cfg (); LINE: for my $line (@{ $cfgfile->lines }) { next unless $line->label; # "Environment variables" start with $ if ($line->label =~ /^\$([A-Za-z_]\w*)$/) { $ENV{$1} = $line->value; next LINE; } # "Settings variables" start with "set" if ($line->label_starts_with_cfg ('SETTING')) { my @tags = $line->label_fields; shift @tags; @tags = map {uc} @tags; $self->setting (\@tags, $line->value); next LINE; } # Not a standard setting variable, put in internal variable list (my $label = $line->label) =~ s/^\%//; $self->variable ($label, $line->value); } 1; } # ------------------------------------------------------------------------------ # SYNOPSIS # $ref = _get_hash_value (arg1, arg2, ...); # # DESCRIPTION # This internal method recursively gets a value from a multi-dimensional # hash. # ------------------------------------------------------------------------------ sub _get_hash_value { my $value = shift; while (defined (my $arg = shift)) { if (exists $value->{$arg}) { $value = $value->{$arg}; } else { return undef; } } return $value; } # ------------------------------------------------------------------------------ 1; __END__