Context Navigation

Config.pm

Last change on this file was 1, checked in by fcm, 15 years ago
creation de larborescence
File size: 29.2 KB

Line
1	#!/usr/bin/perl
2	# ------------------------------------------------------------------------------
3	# NAME
4	# Fcm::Config
5	#
6	# DESCRIPTION
7	# This is a class for reading and processing central and user configuration
8	# settings for FCM.
9	#
10	# COPYRIGHT
11	# (C) Crown copyright Met Office. All rights reserved.
12	# For further details please refer to the file COPYRIGHT.txt
13	# which you should have received as part of this distribution.
14	# ------------------------------------------------------------------------------
15
16	package Fcm::Config;
17
18	# Standard pragma
19	use warnings;
20	use strict;
21
22	# Standard modules
23	use File::Basename;
24	use File::Spec::Functions;
25	use FindBin;
26	use POSIX qw/setlocale LC_ALL/;
27
28	# FCM component modules
29	use Fcm::CfgFile;
30
31	# Other declarations:
32	sub _get_hash_value;
33
34	# Delimiter for setting and for list
35	our $DELIMITER = '::';
36	our $DELIMITER_PATTERN = qr{::\|/};
37	our $DELIMITER_LIST = ',';
38
39	# ------------------------------------------------------------------------------
40	# SYNOPSIS
41	# $obj = Fcm::Config->new (VERBOSE => $verbose);
42	#
43	# DESCRIPTION
44	# This method constructs a new instance of the Fcm::Config class.
45	#
46	# ARGUMENTS
47	# VERBOSE - Set the verbose level of diagnostic output
48	# ------------------------------------------------------------------------------
49
50	sub new {
51	my $this = shift;
52	my %args = @_;
53	my $class = ref $this \|\| $this;
54
55	# Ensure that all subsequent Subversion output is in UK English
56	if (setlocale (LC_ALL, 'en_GB')) {
57	$ENV{LANG} = 'en_GB';
58	}
59
60	my $self = {
61	central_config => undef,
62	user_config => undef,
63	user_id => undef,
64	verbose => exists $args{VERBOSE} ? $args{VERBOSE} : undef,
65	variable => {},
66
67	# Primary settings
68	setting => {
69	# Current command
70	FCM_COMMAND => &basename ($0),
71
72	# Current FCM release identifier
73	FCM_RELEASE => '1.3',
74
75	# Location of file with the last changed revision of the FCM trunk
76	FCM_REV_FILE => catfile (dirname ($FindBin::Bin), 'etc', 'fcm_rev'),
77
78	# Fortran BLOCKDATA dependencies
79	BLD_BLOCKDATA => {},
80
81	# Copy dummy target
82	BLD_CPDUMMY => '$(FCM_DONEDIR)/FCM_CP.dummy',
83
84	# Additional (PP) dependencies
85	BLD_DEP => {},
86	BLD_DEP_PP => {},
87
88	# Excluded dependency
89	BLD_DEP_EXCL => {
90	'' => [
91	# Fortran intrinsic modules
92	'USE' . $DELIMITER . 'ISO_C_BINDING',
93	'USE' . $DELIMITER . 'IEEE_EXCEPTIONS',
94	'USE' . $DELIMITER . 'IEEE_ARITHMETIC',
95	'USE' . $DELIMITER . 'IEEE_FEATURES',
96
97	# Fortran intrinsic subroutines
98	'OBJ' . $DELIMITER . 'CPU_TIME',
99	'OBJ' . $DELIMITER . 'GET_COMMAND',
100	'OBJ' . $DELIMITER . 'GET_COMMAND_ARGUMENT',
101	'OBJ' . $DELIMITER . 'GET_ENVIRONMENT_VARIABLE',
102	'OBJ' . $DELIMITER . 'MOVE_ALLOC',
103	'OBJ' . $DELIMITER . 'MVBITS',
104	'OBJ' . $DELIMITER . 'RANDOM_NUMBER',
105	'OBJ' . $DELIMITER . 'RANDOM_SEED',
106	'OBJ' . $DELIMITER . 'SYSTEM_CLOCK',
107
108	# Dummy statements
109	'OBJ' . $DELIMITER . 'NONE',
110	'EXE' . $DELIMITER . 'NONE',
111	],
112	},
113
114	# Extra executable dependencies
115	BLD_DEP_EXE => {},
116
117	# Dependency pattern for each type
118	BLD_DEP_PATTERN => {
119	H => q/^#\sinclude\s['"](\S+)['"]/,
120	USE => q/^\s*use\s+(\w+)/,
121	INTERFACE => q/^#?\s*include\s+['"](\S+##OUTFILE_EXT/ . $DELIMITER .
122	q/INTERFACE##)['"]/,
123	INC => q/^\s*include\s+['"](\S+)['"]/,
124	OBJ => q#^\s(?:/\\|!)\sdepends\son\s:\s(\S+)#,
125	EXE => q/^\s(?:#\|;)\s(?:calls\|list\|if\|interface)\s:\s(\S+)/,
126	},
127
128	# Rename main program targets
129	BLD_EXE_NAME => {},
130
131	# Rename library targets
132	BLD_LIB => {'' => 'fcm_default'},
133
134	# Name of Makefile and run environment shell script
135	BLD_MISC => {
136	'BLDMAKEFILE' => 'Makefile',
137	'BLDRUNENVSH' => 'fcm_env.sh',
138	},
139
140	# PP flags
141	BLD_PP => {},
142
143	# Custom source file type
144	BLD_TYPE => {},
145
146	# Types that always need to be built
147	BLD_TYPE_ALWAYS_BUILD => 'PVWAVE' .
148	$DELIMITER_LIST . 'GENLIST' .
149	$DELIMITER_LIST . 'SQL',
150
151	# Dependency scan types
152	BLD_TYPE_DEP => {
153	FORTRAN => 'USE' .
154	$DELIMITER . 'INTERFACE' .
155	$DELIMITER . 'INC' .
156	$DELIMITER . 'OBJ',
157	FPP => 'USE' .
158	$DELIMITER . 'INTERFACE' .
159	$DELIMITER . 'INC' .
160	$DELIMITER . 'H' .
161	$DELIMITER . 'OBJ',
162	CPP => 'H' .
163	$DELIMITER . 'OBJ',
164	C => 'H' .
165	$DELIMITER . 'OBJ',
166	SCRIPT => 'EXE',
167	},
168
169	# Dependency scan types for pre-processing
170	BLD_TYPE_DEP_PP => {
171	FPP => 'H',
172	CPP => 'H',
173	C => 'H',
174	},
175
176	# Types that cannot have duplicated targets
177	BLD_TYPE_NO_DUPLICATED_TARGET => '',
178
179	# BLD_VPATH, each value must be a comma separate list
180	# EMPTY translates to %
181	# IN:<FLAG> translates to any key in {INFILE_EXT} if the value contains
182	# the word in <FLAG>
183	# OUT:<FLAG> translates to {OUTFILE_EXT}{<FLAG>}
184	BLD_VPATH => {
185	BIN => 'EMPTY' .
186	$DELIMITER_LIST . 'OUT:EXE' .
187	$DELIMITER_LIST . 'IN:SCRIPT',
188	ETC => 'OUT:ETC',
189	DONE => 'OUT:DONE' .
190	$DELIMITER_LIST . 'OUT:IDONE',
191	FLAGS => 'OUT:FLAGS',
192	INC => 'IN:INCLUDE',
193	LIB => 'OUT:LIB',
194	OBJ => 'OUT:OBJ',
195	},
196
197	# Cache basename
198	CACHE => '.config',
199	CACHE_DEP => '.config_dep',
200	CACHE_DEP_PP => '.config_dep_pp',
201	CACHE_FILE_SRC => '.config_file_src',
202
203	# Types of "inc" statements expandable CFG files
204	CFG_EXP_INC => 'BLD' .
205	$DELIMITER_LIST . 'EXT' .
206	$DELIMITER_LIST . 'FCM',
207
208	# Configuration file labels that can be declared more than once
209	CFG_KEYWORD => 'USE' .
210	$DELIMITER_LIST . 'INC' .
211	$DELIMITER_LIST . 'TARGET' .
212	$DELIMITER_LIST . 'BLD_DEP_EXCL',
213
214	# Labels for all types of FCM configuration files
215	CFG_LABEL => {
216	CFGFILE => 'CFG', # config file information
217	INC => 'INC', # "include" from an configuration file
218
219	# Labels for central/user internal config setting
220	SETTING => 'SET',
221
222	# Labels for systems that allow inheritance
223	DEST => 'DEST', # destination
224	USE => 'USE', # use (inherit) a previous configuration
225
226	# Labels for bld and pck cfg
227	TARGET => 'TARGET', # BLD: declare targets, PCK: target of source file
228
229	# Labels for bld cfg
230	BLD_BLOCKDATA => 'BLOCKDATA', # declare Fortran BLOCKDATA dependencies
231	BLD_DEP => 'SRC_DEP', # additional dependencies
232	BLD_DEP_PP => 'SRC_PPDEP', # additional PP dependencies
233	BLD_DEP_EXCL => 'EXCL_DEP', # exclude automatic dependencies
234	BLD_DEP_EXE => 'EXE_DEP', # declare dependencies for program
235	BLD_EXE_NAME => 'EXE_NAME', # rename a main program
236	BLD_LIB => 'LIB', # rename library
237	BLD_PP => 'PP', # sub-package needs pre-process?
238	BLD_TYPE => 'SRC_TYPE', # custom source file type
239	DIR => 'DIR', # DEPRECATED, same as DEST
240	INFILE_EXT => 'INFILE_EXT', # change input file name extension type
241	INHERIT => 'INHERIT', # inheritance flag
242	NAME => 'NAME', # name the build
243	OUTFILE_EXT => 'OUTFILE_EXT', # change output file type extension
244	FILE => 'SRC', # declare a sub-package
245	SEARCH_SRC => 'SEARCH_SRC', # search src/ sub-directory?
246	TOOL => 'TOOL', # declare a tool
247
248	# Labels for ext cfg
249	BDECLARE => 'BLD', # build declaration
250	CONFLICT => 'CONFLICT', # set conflict mode
251	DIRS => 'SRC', # declare source directory
252	EXPDIRS => 'EXPSRC', # declare expandable source directory
253	MIRROR => 'MIRROR', # DEPRECATED, same as RDEST::MIRROR_CMD
254	OVERRIDE => 'OVERRIDE', # DEPRECATED, replaced by CONFLICT
255	RDEST => 'RDEST', # declare remote destionation
256	REVISION => 'REVISION', # declare branch revision in a project
257	REVMATCH => 'REVMATCH', # branch revision must match changed revision
258	REPOS => 'REPOS', # declare branch in a project
259	VERSION => 'VERSION', # DEPRECATED, same as REVISION
260	},
261
262	# Default names of known FCM configuration files
263	CFG_NAME => {
264	BLD => 'bld.cfg', # build configuration file
265	EXT => 'ext.cfg', # extract configuration file
266	PARSED => 'parsed_', # as-parsed configuration file prefix
267	},
268
269	# Latest version of known FCM configuration files
270	CFG_VERSION => {
271	BLD => '1.0', # bld cfg
272	EXT => '1.0', # ext cfg
273	},
274
275	# Standard sub-directories for extract/build
276	DIR => {
277	BIN => 'bin', # executable
278	BLD => 'bld', # build
279	CACHE => '.cache', # cache
280	CFG => 'cfg', # configuration
281	DONE => 'done', # "done"
282	ETC => 'etc', # miscellaneous items
283	FLAGS => 'flags', # "flags"
284	INC => 'inc', # include
285	LIB => 'lib', # library
286	OBJ => 'obj', # object
287	PPSRC => 'ppsrc', # pre-processed source
288	SRC => 'src', # source
289	TMP => 'tmp', # temporary directory
290	},
291
292	# A flag to indicate whether the revision of a given branch for extract
293	# must match with the revision of a changed revision of the branch
294	EXT_REVMATCH => 0, # default is false (allow any revision)
295
296	# Input file name extension and type
297	# (may overlap with output (below) and vpath (above))
298	INFILE_EXT => {
299	# General extensions
300	'f' => 'FORTRAN' .
301	$DELIMITER . 'SOURCE',
302	'for' => 'FORTRAN' .
303	$DELIMITER . 'SOURCE',
304	'ftn' => 'FORTRAN' .
305	$DELIMITER . 'SOURCE',
306	'f77' => 'FORTRAN' .
307	$DELIMITER . 'SOURCE',
308	'f90' => 'FORTRAN' .
309	$DELIMITER . 'FORTRAN9X' .
310	$DELIMITER . 'SOURCE',
311	'f95' => 'FORTRAN' .
312	$DELIMITER . 'FORTRAN9X' .
313	$DELIMITER . 'SOURCE',
314	'F' => 'FPP' .
315	$DELIMITER . 'SOURCE',
316	'FOR' => 'FPP' .
317	$DELIMITER . 'SOURCE',
318	'FTN' => 'FPP' .
319	$DELIMITER . 'SOURCE',
320	'F77' => 'FPP' .
321	$DELIMITER . 'SOURCE',
322	'F90' => 'FPP' .
323	$DELIMITER . 'FPP9X' .
324	$DELIMITER . 'SOURCE',
325	'F95' => 'FPP' .
326	$DELIMITER . 'FPP9X' .
327	$DELIMITER . 'SOURCE',
328	'c' => 'C' .
329	$DELIMITER . 'SOURCE',
330	'cpp' => 'C' .
331	$DELIMITER . 'C++' .
332	$DELIMITER . 'SOURCE',
333	'h' => 'CPP' .
334	$DELIMITER . 'INCLUDE',
335	'o' => 'BINARY' .
336	$DELIMITER . 'OBJ',
337	'obj' => 'BINARY' .
338	$DELIMITER . 'OBJ',
339	'exe' => 'BINARY' .
340	$DELIMITER . 'EXE',
341	'a' => 'BINARY' .
342	$DELIMITER . 'LIB',
343	'sh' => 'SCRIPT' .
344	$DELIMITER . 'SHELL',
345	'ksh' => 'SCRIPT' .
346	$DELIMITER . 'SHELL',
347	'bash' => 'SCRIPT' .
348	$DELIMITER . 'SHELL',
349	'csh' => 'SCRIPT' .
350	$DELIMITER . 'SHELL',
351	'pl' => 'SCRIPT' .
352	$DELIMITER . 'PERL',
353	'pm' => 'SCRIPT' .
354	$DELIMITER . 'PERL',
355	'py' => 'SCRIPT' .
356	$DELIMITER . 'PYTHON',
357	'tcl' => 'SCRIPT' .
358	$DELIMITER . 'TCL',
359	'pro' => 'SCRIPT' .
360	$DELIMITER . 'PVWAVE',
361
362	# Local extensions
363	'cfg' => 'CFGFILE',
364	'h90' => 'CPP' .
365	$DELIMITER . 'INCLUDE',
366	'inc' => 'FORTRAN' .
367	$DELIMITER . 'FORTRAN9X' .
368	$DELIMITER . 'INCLUDE',
369	'interface' => 'FORTRAN' .
370	$DELIMITER . 'FORTRAN9X' .
371	$DELIMITER . 'INCLUDE' .
372	$DELIMITER . 'INTERFACE',
373	},
374
375	# Ignore input files matching the following names (comma-separated list)
376	INFILE_IGNORE => 'fcm_env.ksh' .
377	$DELIMITER_LIST . 'fcm_env.sh',
378
379	# Input file name pattern and type
380	INFILE_PAT => {
381	'\w+Scr_\w+' => 'SCRIPT' .
382	$DELIMITER . 'SHELL',
383	'\w+Comp_\w+' => 'SCRIPT' .
384	$DELIMITER . 'SHELL' .
385	$DELIMITER . 'GENTASK',
386	'\w+(?:IF\|Interface)_\w+' => 'SCRIPT' .
387	$DELIMITER . 'SHELL' .
388	$DELIMITER . 'GENIF',
389	'\w+Suite_\w+' => 'SCRIPT' .
390	$DELIMITER . 'SHELL' .
391	$DELIMITER . 'GENSUITE',
392	'\w+List_\w+' => 'SCRIPT' .
393	$DELIMITER . 'SHELL' .
394	$DELIMITER . 'GENLIST',
395	'\w+Sql_\w+' => 'SCRIPT' .
396	$DELIMITER . 'SQL',
397	},
398
399	# Input text file pattern and type
400	INFILE_TXT => {
401	'(?:[ck]\|ba)?sh' => 'SCRIPT' .
402	$DELIMITER . 'SHELL',
403	'perl' => 'SCRIPT' .
404	$DELIMITER . 'PERL',
405	'python' => 'SCRIPT' .
406	$DELIMITER . 'PYTHON',
407	'tcl(?:sh)?\|wish' => 'SCRIPT' .
408	$DELIMITER . 'TCL',
409	},
410
411	# Lock file
412	LOCK => {
413	BLDLOCK => 'fcm.bld.lock', # build lock file
414	EXTLOCK => 'fcm.ext.lock', # extract lock file
415	},
416
417	# Output file type and extension
418	# (may overlap with input and vpath (above))
419	OUTFILE_EXT => {
420	CFG => '.cfg', # FCM configuration file
421	DONE => '.done', # "done" files for compiled source
422	ETC => '.etc', # "etc" dummy file
423	EXE => '.exe', # binary executables
424	FLAGS => '.flags', # "flags" files, compiler flags config
425	IDONE => '.idone', # "done" files for included source
426	INTERFACE => '.interface', # interface for F90 subroutines/functions
427	LIB => '.a', # archive object library
428	MOD => '.mod', # compiled Fortran module information files
429	OBJ => '.o', # compiled object files
430	PDONE => '.pdone', # "done" files for pre-processed files
431	TAR => '.tar', # TAR archive
432	},
433
434	# Build commands and options (i.e. tools)
435	TOOL => {
436	SHELL => '/bin/sh', # Default shell
437
438	CPP => 'cpp', # C pre-processor
439	CPPFLAGS => '-C', # CPP flags
440	CPP_INCLUDE => '-I', # CPP flag, specify "include" path
441	CPP_DEFINE => '-D', # CPP flag, define macro
442	CPPKEYS => '', # CPP keys (definition macro)
443
444	CC => 'cc', # C compiler
445	CFLAGS => '', # CC flags
446	CC_COMPILE => '-c', # CC flag, compile only
447	CC_OUTPUT => '-o', # CC flag, specify output file name
448	CC_INCLUDE => '-I', # CC flag, specify "include" path
449	CC_DEFINE => '-D', # CC flag, define macro
450
451	FPP => 'cpp', # Fortran pre-processor
452	FPPFLAGS => '-P -traditional', # FPP flags
453	FPP_INCLUDE => '-I', # FPP flag, specify "include" path
454	FPP_DEFINE => '-D', # FPP flag, define macro
455	FPPKEYS => '', # FPP keys (definition macro)
456
457	FC => 'f90', # Fortran compiler
458	FFLAGS => '', # FC flags
459	FC_COMPILE => '-c', # FC flag, compile only
460	FC_OUTPUT => '-o', # FC flag, specify output file name
461	FC_INCLUDE => '-I', # FC flag, specify "include" path
462	FC_DEFINE => '-D', # FC flag, define macro
463
464	LD => '', # linker
465	LDFLAGS => '', # LD flags
466	LD_OUTPUT => '-o', # LD flag, specify output file name
467	LD_LIBSEARCH => '-L', # LD flag, specify "library" path
468	LD_LIBLINK => '-l', # LD flag, specify link library
469
470	AR => 'ar', # library archiver
471	ARFLAGS => 'rs', # AR flags
472
473	MAKE => 'make', # make command
474	MAKEFLAGS => '', # make flags
475	MAKE_SILENT => '-s', # make flag, silent diagnostic
476	MAKE_JOB => '-j', # make flag, number of jobs
477
478	INTERFACE => 'file', # name interface after file/program
479	GENINTERFACE => 'ECMWF', # Fortran 9x interface generator
480
481	DIFF3 => 'diff3', # extract diff3 merge
482	DIFF3FLAGS => '-E -m', # DIFF3 flags
483	MIRROR => 'rsync', # extract mirroring tool
484	REMOTE_SHELL => 'remsh', # command to invoke the remote shell
485	GRAPHIC_DIFF => 'xxdiff', # graphical diff tool
486	GRAPHIC_MERGE=> 'xxdiff', # graphical merge tool
487	},
488
489	# List of tools that are local to FCM, (will not be exported to a Makefile)
490	TOOL_LOCAL => 'CPP' .
491	$DELIMITER_LIST . 'CPPFLAGS' .
492	$DELIMITER_LIST . 'CPP_INCLUDE' .
493	$DELIMITER_LIST . 'CPP_DEFINE' .
494	$DELIMITER_LIST . 'DIFF3' .
495	$DELIMITER_LIST . 'DIFF3_FLAGS' .
496	$DELIMITER_LIST . 'FPP' .
497	$DELIMITER_LIST . 'FPPFLAGS' .
498	$DELIMITER_LIST . 'FPP_INCLUDE' .
499	$DELIMITER_LIST . 'FPP_DEFINE' .
500	$DELIMITER_LIST . 'GRAPHIC_DIFF' .
501	$DELIMITER_LIST . 'GRAPHIC_MERGE' .
502	$DELIMITER_LIST . 'MAKE' .
503	$DELIMITER_LIST . 'MAKEFLAGS' .
504	$DELIMITER_LIST . 'MAKE_SILENT' .
505	$DELIMITER_LIST . 'MAKE_JOB' .
506	$DELIMITER_LIST . 'INTERFACE' .
507	$DELIMITER_LIST . 'GENINTERFACE' .
508	$DELIMITER_LIST . 'MIRROR' .
509	$DELIMITER_LIST . 'REMOTE_SHELL',
510
511	# List of tools that allow sub-package declarations
512	TOOL_PACKAGE => 'CPPFLAGS' .
513	$DELIMITER_LIST . 'CPPKEYS' .
514	$DELIMITER_LIST . 'CFLAGS' .
515	$DELIMITER_LIST . 'FPPFLAGS' .
516	$DELIMITER_LIST . 'FPPKEYS' .
517	$DELIMITER_LIST . 'FFLAGS' .
518	$DELIMITER_LIST . 'LD' .
519	$DELIMITER_LIST . 'LDFLAGS' .
520	$DELIMITER_LIST . 'INTERFACE' .
521	$DELIMITER_LIST . 'GENINTERFACE',
522
523	# Supported tools for compilable source
524	TOOL_SRC_PP => {
525	FPP => {
526	COMMAND => 'FPP',
527	FLAGS => 'FPPFLAGS',
528	PPKEYS => 'FPPKEYS',
529	INCLUDE => 'FPP_INCLUDE',
530	DEFINE => 'FPP_DEFINE',
531	},
532
533	C => {
534	COMMAND => 'CPP',
535	FLAGS => 'CPPFLAGS',
536	PPKEYS => 'CPPKEYS',
537	INCLUDE => 'CPP_INCLUDE',
538	DEFINE => 'CPP_DEFINE',
539	},
540	},
541
542	# Supported tools for compilable source
543	TOOL_SRC => {
544	FORTRAN => {
545	COMMAND => 'FC',
546	FLAGS => 'FFLAGS',
547	OUTPUT => 'FC_OUTPUT',
548	INCLUDE => 'FC_INCLUDE',
549	},
550
551	FPP => {
552	COMMAND => 'FC',
553	FLAGS => 'FFLAGS',
554	PPKEYS => 'FPPKEYS',
555	OUTPUT => 'FC_OUTPUT',
556	INCLUDE => 'FC_INCLUDE',
557	DEFINE => 'FC_DEFINE',
558	},
559
560	C => {
561	COMMAND => 'CC',
562	FLAGS => 'CFLAGS',
563	PPKEYS => 'CPPKEYS',
564	OUTPUT => 'CC_OUTPUT',
565	INCLUDE => 'CC_INCLUDE',
566	DEFINE => 'CC_DEFINE',
567	},
568	},
569
570	# FCM URL keyword and prefix, FCM revision keyword, and FCM Trac URL
571	URL => {},
572	URL_PREFIX => 'fcm:',
573	URL_REVISION => {},
574	URL_TRAC => {},
575
576	# Default web browser
577	WEB_BROWSER => 'firefox',
578	},
579	};
580
581	# Backward compatibility: the REPOS setting is equivalent to the URL setting
582	$self->{setting}{REPOS} = $self->{setting}{URL};
583
584	# Alias the REVISION and TRAC setting to URL_REVISION and URL_TRAC
585	$self->{setting}{REVISION} = $self->{setting}{URL_REVISION};
586	$self->{setting}{TRAC} = $self->{setting}{URL_TRAC};
587
588	bless $self, $class;
589	return $self;
590	}
591
592	# ------------------------------------------------------------------------------
593	# SYNOPSIS
594	# $value = $obj->X;
595	# $obj->X ($value);
596	#
597	# DESCRIPTION
598	# Details of these properties are explained in the "new" method.
599	# ------------------------------------------------------------------------------
600
601	for my $name (qw/central_config user_config user_id verbose/) {
602	no strict 'refs';
603
604	*$name = sub {
605	my $self = shift;
606
607	# Argument specified, set property to specified argument
608	if (@_) {
609	$self->{$name} = $_[0];
610	}
611
612	# Default value for property
613	if (not defined $self->{$name}) {
614	if ($name eq 'central_config') {
615	# Central configuration file
616	if (-r catfile (dirname ($FindBin::Bin), 'etc', 'fcm.cfg')) {
617	$self->{$name} = catfile (
618	dirname ($FindBin::Bin), 'etc', 'fcm.cfg'
619	);
620
621	} elsif (-r catfile ($FindBin::Bin, 'fcm.cfg')) {
622	$self->{$name} = catfile ($FindBin::Bin, 'fcm.cfg');
623	}
624
625	} elsif ($name eq 'user_config') {
626	# User configuration file
627	my $home = (getpwuid ($<))[7];
628	$home = $ENV{HOME} if not defined $home;
629	$self->{$name} = catfile ($home, '.fcm')
630	if defined ($home) and -r catfile ($home, '.fcm');
631
632	} elsif ($name eq 'user_id') {
633	# User ID of current process
634	my $user = (getpwuid ($<))[0];
635	$user = $ENV{LOGNAME} if not defined $user;
636	$user = $ENV{USER} if not defined $user;
637	$self->{$name} = $user;
638
639	} elsif ($name eq 'verbose') {
640	# Verbose mode
641	$self->{$name} = exists $ENV{FCM_VERBOSE} ? $ENV{FCM_VERBOSE} : 1;
642	}
643	}
644
645	return $self->{$name};
646	}
647	}
648
649	# ------------------------------------------------------------------------------
650	# SYNOPSIS
651	# %hash = %{ $obj->X () };
652	# $obj->X (\%hash);
653	#
654	# $value = $obj->X ($index);
655	# $obj->X ($index, $value);
656	#
657	# DESCRIPTION
658	# Details of these properties are explained in the "new" method.
659	#
660	# If no argument is set, this method returns a hash containing a list of
661	# objects. If an argument is set and it is a reference to a hash, the objects
662	# are replaced by the the specified hash.
663	#
664	# If a scalar argument is specified, this method returns a reference to an
665	# object, if the indexed object exists or undef if the indexed object does
666	# not exist. If a second argument is set, the $index element of the hash will
667	# be set to the value of the argument.
668	# ------------------------------------------------------------------------------
669
670	for my $name (qw/variable/) {
671	no strict 'refs';
672
673	*$name = sub {
674	my ($self, $arg1, $arg2) = @_;
675
676	# Ensure property is defined as a reference to a hash
677	$self->{$name} = {} if not defined ($self->{$name});
678
679	# Argument 1 can be a reference to a hash or a scalar index
680	my ($index, %hash);
681
682	if (defined $arg1) {
683	if (ref ($arg1) eq 'HASH') {
684	%hash = %$arg1;
685
686	} else {
687	$index = $arg1;
688	}
689	}
690
691	if (defined $index) {
692	# A scalar index is defined, set and/or return the value of an element
693	$self->{$name}{$index} = $arg2 if defined $arg2;
694
695	return (
696	exists $self->{$name}{$index} ? $self->{$name}{$index} : undef
697	);
698
699	} else {
700	# A scalar index is not defined, set and/or return the hash
701	$self->{$name} = \%hash if defined $arg1;
702	return $self->{$name};
703	}
704	}
705	}
706
707	# ------------------------------------------------------------------------------
708	# SYNOPSIS
709	# $setting = $obj->setting (@labels);
710	# $obj->setting (\@labels, $setting);
711	#
712	# DESCRIPTION
713	# This method returns/sets an item under the setting hash table. The depth
714	# within the hash table is given by the list of arguments @labels, which
715	# should match with the keys in the multi-dimension setting hash table.
716	# ------------------------------------------------------------------------------
717
718	sub setting {
719	my $self = shift;
720
721	if (@_) {
722	my $arg1 = shift;
723	my $s = $self->{setting};
724
725	if (ref ($arg1) eq 'ARRAY') {
726	# Assign setting
727	# ------------------------------------------------------------------------
728	my $value = shift;
729
730	while (defined (my $label = shift @$arg1)) {
731	if (exists $s->{$label}) {
732	if (ref $s->{$label} eq 'HASH') {
733	$s = $s->{$label};
734
735	} else {
736	$s->{$label} = $value;
737	last;
738	}
739
740	} else {
741	if (@$arg1) {
742	$s->{$label} = {};
743	$s = $s->{$label};
744
745	} else {
746	$s->{$label} = $value;
747	}
748	}
749	}
750
751	} else {
752	# Get setting
753	# ------------------------------------------------------------------------
754	return _get_hash_value ($s->{$arg1}, @_) if exists $s->{$arg1};
755	}
756	}
757
758	return undef;
759	}
760
761	# ------------------------------------------------------------------------------
762	# SYNOPSIS
763	# $obj->get_config ();
764	#
765	# DESCRIPTION
766	# This method reads the configuration settings from the central and the user
767	# configuration files.
768	# ------------------------------------------------------------------------------
769
770	sub get_config {
771	my $self = shift;
772
773	$self->_read_config_file ($self->central_config);
774	$self->_read_config_file ($self->user_config);
775
776	return;
777	}
778
779	# ------------------------------------------------------------------------------
780	# SYNOPSIS
781	# $obj->_read_config_file ();
782	#
783	# DESCRIPTION
784	# This internal method reads a configuration file and assign values to the
785	# attributes of the current instance.
786	# ------------------------------------------------------------------------------
787
788	sub _read_config_file {
789	my $self = shift;
790	my $config_file = $_[0];
791
792	return unless $config_file and -r $config_file;
793
794	my $cfgfile = Fcm::CfgFile->new (SRC => $config_file, TYPE => 'FCM');
795	$cfgfile->read_cfg ();
796
797	LINE: for my $line (@{ $cfgfile->lines }) {
798	next unless $line->label;
799
800	# "Environment variables" start with $
801	if ($line->label =~ /^\$([A-Za-z_]\w*)$/) {
802	$ENV{$1} = $line->value;
803	next LINE;
804	}
805
806	# "Settings variables" start with "set"
807	if ($line->label_starts_with_cfg ('SETTING')) {
808	my @tags = $line->label_fields;
809	shift @tags;
810	@tags = map {uc} @tags;
811	$self->setting (\@tags, $line->value);
812	next LINE;
813	}
814
815	# Not a standard setting variable, put in internal variable list
816	(my $label = $line->label) =~ s/^\%//;
817	$self->variable ($label, $line->value);
818	}
819
820	1;
821	}
822
823	# ------------------------------------------------------------------------------
824	# SYNOPSIS
825	# $ref = _get_hash_value (arg1, arg2, ...);
826	#
827	# DESCRIPTION
828	# This internal method recursively gets a value from a multi-dimensional
829	# hash.
830	# ------------------------------------------------------------------------------
831
832	sub _get_hash_value {
833	my $value = shift;
834
835	while (defined (my $arg = shift)) {
836	if (exists $value->{$arg}) {
837	$value = $value->{$arg};
838
839	} else {
840	return undef;
841	}
842	}
843
844	return $value;
845	}
846
847	# ------------------------------------------------------------------------------
848
849	1;
850
851	__END__

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: OFFICIAL/FCM_V1.3/lib/Fcm/Config.pm

Download in other formats: