123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894 |
- # ------------------------------------------------------------------------------
- # 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__
|