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