lib/GetConfig.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: GetConfig.pm,v $
   4
   5 Simple config file parsing
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@DeFaria.com>
  14
  15 =item Revision
  16
  17 $Revision: 1.19 $
  18
  19 =item Created
  20
  21 Tue Feb 14 11:03:18 PST 2006
  22
  23 =item Modified
  24
  25 $Date: 2013/01/17 01:08:34 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  31 Parse config files.
  32
  33  # Comment lines are skipped - white space is eliminated...
  34  app:                   MyApp
  35  nbr_iterrations:       10
  36  major_version:         1
  37  release:               2
  38  version:               $major_version.$release
  39
  40  my %opts = GetConfig "myconfig.cfg";
  41  print "Application Name:\t" . $opts {app}              . "(" . $opts {version} . )\n";
  42  print "Iterrations:\t\t"    . $opts {nbr_iterrations}  . "\n";
  43
  44 yields
  45
  46  Application Name:      MyApp (1.2)
  47  Iterrations:           10
  48
  49 =head1 DESCRIPTION
  50
  51 This module is a simple interface to reading config files. Config file
  52 format is roughly like .XDefaults format - <name>:<value> pairs. A
  53 hash of the name/value pairs are returned. Variable interpolation is
  54 supported such that env(1) variables will be interpolated as well as
  55 previously defined values. Thus:
  56
  57  temp_files: tmp
  58  temp_dir:   $HOME/$temp_files
  59  temp_dir2:  $HOME/$foo/$temp_files
  60
  61 would return:
  62
  63  $conf{temp_files} => "tmp"
  64  $conf{temp_dir}   => "~/tmp"
  65  $conf{temp_dir2}  => "~/$foo/tmp"
  66
  67 In other word, $HOME would be expanded because it's set in your
  68 environment and $temp_files would be expanded because you set it in
  69 the first line. Finally $foo would not be expanded because it was not
  70 set in the first place. This is useful if other processing wants to
  71 provide further interpolation.
  72
  73 =head1 ROUTINES
  74
  75 The following routines are exported:
  76
  77 =cut
  78
  79 package GetConfig;
  80
  81 use strict;
  82 use warnings;
  83
  84 use base 'Exporter';
  85 use File::Spec;
  86 use Carp;
  87
  88 our @EXPORT = qw (
  89   GetConfig
  90 );
  91
  92 # Interpolate variable in str (if any) from %opts
  93 sub interpolate ($%) {
  94   my ($str, %opts) = @_;
  95
  96   # Since we wish to leave undefined $var references in tact the following while
  97   # loop would loop indefinitely if we don't change the variable. So we work
  98   # with a copy of $str changing it always, but only changing the original $str
  99   # for proper interpolations.
 100   my $copyStr = $str;
 101
 102   while ($copyStr =~ /\$(\w+)/) {
 103     my $var = $1;
 104
 105     if (exists $opts{$var}) {
 106       $str     =~ s/\$$var/$opts{$var}/;
 107       $copyStr =~ s/\$$var/$opts{$var}/;
 108     } elsif (exists $ENV{$var}) {
 109       $str     =~ s/\$$var/$ENV{$var}/;
 110       $copyStr =~ s/\$$var/$ENV{$var}/;
 111     } else {
 112      $copyStr =~ s/\$$var//;
 113   } # if
 114  } # while
 115
 116  return $str;
 117 } # interpolate
 118
 119 sub _processFile ($%) {
 120   my ($configFile, %opts) = @_;
 121
 122   while (<$configFile>) {
 123     chomp;
 124
 125     next if /^\s*[\#|\!]/;    # Skip comments
 126
 127     if (/\s*(\w*)\s*:\s*(.*)\s*$/) {
 128       my $key   = $1;
 129       my $value = $2;
 130
 131       # Strip trailing spaces
 132       $value =~ s/\s+$//;
 133
 134       # Interpolate
 135       $value = interpolate $value, %opts;
 136
 137       if ($opts{$key}) {
 138         # If the key exists already then we have a case of multiple values for
 139         # the same key. Since we support this we need to replace the scalar
 140         # value with an array of values...
 141         if (ref $opts{$key} eq "ARRAY") {
 142           # It's already an array, just add to it!
 143           push @{$opts{$key}}, $value;
 144         } else {
 145           # It's not an array so make it one
 146           my @a;
 147
 148           push @a, $opts{$key};
 149           push @a, $value;
 150           $opts{$key} = \@a;
 151         } # if
 152       } else {
 153         # It's a simple value
 154         $opts{$key} = $value;
 155       }  # if
 156     } # if
 157   } # while
 158
 159   return %opts;
 160 } # _processFile
 161
 162 sub GetConfig ($) {
 163   my ($filename) = @_;
 164
 165 =pod
 166
 167 =head2 GetConfig ($conf)
 168
 169 Reads $filename looking for .XDefaults style name/value pairs and
 170 returns a hash.
 171
 172 Parameters:
 173
 174 =begin html
 175
 176 <blockquote>
 177
 178 =end html
 179
 180 =over
 181
 182 =item $conf
 183
 184 Name of configuration file
 185
 186 =back
 187
 188 =begin html
 189
 190 </blockquote>
 191
 192 =end html
 193
 194 Returns:
 195
 196 =begin html
 197
 198 <blockquote>
 199
 200 =end html
 201
 202 =over
 203
 204 =item Hash of name/value pairs
 205
 206 =back
 207
 208 =begin html
 209
 210 </blockquote>
 211
 212 =end html
 213
 214 =cut
 215
 216   my %opts;
 217
 218   open my $configFile, '<', $filename
 219     or carp "Unable to open config file $filename";
 220
 221   %opts = _processFile $configFile;
 222
 223   close $configFile;
 224
 225   return %opts;
 226 } # GetConfig
 227
 228 1;
 229
 230 =pod
 231
 232 =head1 DEPENDENCIES
 233
 234 =head2 Perl Modules
 235
 236 L<File::Spec>
 237
 238 =head1 INCOMPATABILITIES
 239
 240 None yet...
 241
 242 =head1 BUGS AND LIMITATIONS
 243
 244 There are no known bugs in this module.
 245
 246 Please report problems to Andrew DeFaria (Andrew@DeFaria.com).
 247
 248 =head1 AUTHOR
 249
 250 Andrew DeFaria (Andrew@DeFaria.com)
 251
 252 =head1 LICENSE AND COPYRIGHT
 253
 254 This Perl Module is freely available; you can redistribute it and/or
 255 modify it under the terms of the GNU General Public License as
 256 published by the Free Software Foundation; either version 2 of the
 257 License, or (at your option) any later version.
 258
 259 This Perl Module is distributed in the hope that it will be useful,
 260 but WITHOUT ANY WARRANTY; without even the implied warranty of
 261 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
 262 General Public License (L<http://www.gnu.org/copyleft/gpl.html>) for more
 263 details.
 264
 265 You should have received a copy of the GNU General Public License
 266 along with this Perl Module; if not, write to the Free Software Foundation,
 267 Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 268 reserved.
 269
 270 =cut