lib/Onis/Config.pm

   1 package Onis::Config;
   2
   3 use strict;
   4 use warnings;
   5 use Exporter;
   6
   7 @Onis::Config::EXPORT_OK = qw/get_config parse_argv read_config get_checksum/;
   8
   9 @Onis::Config::ISA = ('Exporter');
  10
  11 =head1 NAME
  12
  13 Onis::Config - Parsing of configuration files and query method.
  14
  15 =head1 USAGE
  16
  17   use Config qw#get_config read_config#;
  18
  19   read_config ("filename");
  20   read_config ($filehandle);
  21
  22   get_config ("key");
  23
  24   get_checksum ();
  25
  26 =head1 SYNTAX
  27
  28 Here are the syntax rules:
  29
  30 =over 4
  31
  32 =item *
  33
  34 An option starts with a keyword, followed by a colon, then the value for
  35 that key and is ended with a semi-colon. Example:
  36
  37   keyword: value;
  38
  39 =item *
  40
  41 Text in single- or souble quotes is taken literaly. Quotes can not be
  42 escaped. However, singlequotes enclosed in double quotes (and vice versa)
  43 are perfectly ok. Examples:
  44
  45   teststring: "Yay, it's a string!";
  46   html: '<span style="color: #fe0000;">';
  47
  48 =item *
  49
  50 Hashes are start comments and are ignored to the end of the line. Hashes
  51 enclosed in quotes are B<not> interpreted as comments.. See html-example
  52 above..
  53
  54 =item *
  55
  56 Linebreaks and spaces (unless when in quotes..) are ignored. Strings may
  57 not span multiple lines. Use something along this lines instead:
  58
  59   multiplelineoption: "This is a very very long"
  60     "string that continues in the next line";
  61
  62 =item *
  63
  64 Any key may occur more than once. You can separate two or more values with
  65 commas:
  66
  67   key: value1, value2, "This, is ONE value..";
  68   key: value4;
  69
  70 =back
  71
  72 =cut
  73
  74 our $config = {};
  75
  76 my $VERSION = '$Id: Config.pm,v 1.10 2004/09/16 10:30:00 octo Exp $';
  77 print STDERR $/, __FILE__, ": $VERSION" if ($::DEBUG);
  78
  79 return (1);
  80
  81 =head1 EXPORTED FUNCTIONS
  82
  83 =over 4
  84
  85 =item B<get_config> (I<$key>)
  86
  87 Queries the config structure for the given key and returns the value(s). In
  88 list context all values are returned, in scalar context only the most recent
  89 one.
  90
  91 =cut
  92
  93 sub get_config
  94 {
  95         my $key = shift;
  96         my $val;
  97
  98         if (!defined ($config->{$key}))
  99         {
 100                 return (wantarray () ? () : '');
 101         }
 102
 103         $val = $config->{$key};
 104
 105         if (wantarray ())
 106         {
 107                 return (@$val);
 108         }
 109         else
 110         {
 111                 return ($val->[0]);
 112         }
 113 }
 114
 115 =item B<parse_argv> (I<@argv>)
 116
 117 Parses ARGV and adds command-line options to the internal config structure.
 118
 119 =cut
 120
 121 sub parse_argv
 122 {
 123         my @argv = @_;
 124
 125         while (@argv)
 126         {
 127                 my $item = shift (@argv);
 128
 129                 if ($item =~ m/^--?(\S+)/)
 130                 {
 131                         my $key = lc ($1);
 132
 133                         if (!@argv)
 134                         {
 135                                 print STDERR $/, __FILE__, ": No value for key '$key'",
 136                                         'present.';
 137                                 next;
 138                         }
 139
 140                         my $val = shift (@argv);
 141
 142                         push (@{$config->{$key}}, $val);
 143                 }
 144                 elsif ($item)
 145                 {
 146                         push (@{$config->{'input'}}, $item);
 147                 }
 148                 else
 149                 {
 150                         print STDERR $/, __FILE__, ': Ignoring empty argument.';
 151                 }
 152         }
 153
 154         return (1);
 155 }
 156
 157 sub parse_config
 158 {
 159         my $text = shift;
 160         my $tmp = '';
 161         my @rep;
 162         my $rep = 0;
 163
 164         local ($/) = "\n";
 165
 166         $text =~ s/\r//sg;
 167
 168         for (split (m/\n+/s, $text))
 169         {
 170                 my $line = $_;
 171                 chomp ($line);
 172
 173                 # escape quoted text
 174                 while ($line =~ m/^[^#]*(['"]).*?\1/)
 175                 {
 176                         $line =~ s/(['"])(.*?)\1/<:$rep:>/;
 177                         push (@rep, $2);
 178                         $rep++;
 179                 }
 180
 181                 $line =~ s/#.*$//;
 182                 $line =~ s/\s*//g;
 183
 184                 $tmp .= $line;
 185         }
 186
 187         $text = lc ($tmp);
 188
 189         while ($text =~ m/(\w+):([^;]+);/g)
 190         {
 191                 my $key = $1;
 192                 my @val = split (m/,/, $2);
 193
 194                 s/<:(\d+):>/$rep[$1]/eg for (@val);
 195
 196                 push (@{$config->{$key}}, @val);
 197         }
 198
 199         return (1);
 200 }
 201
 202 =item B<read_config> (I<$file>)
 203
 204 Reads the configuration file. $file must either be a filename, a reference to
 205 one or a reference to a filehandle. Complains, is file does not exist.
 206
 207 =cut
 208
 209 sub read_config
 210 {
 211         my $arg = shift;
 212         my $fh;
 213         my $text;
 214         my $need_close = 0;
 215         local ($/) = undef; # slurp mode ;)
 216
 217         if (ref ($arg) eq 'GLOB')
 218         {
 219                 $fh = $arg->{'IO'};
 220         }
 221         elsif (!ref ($arg) || ref ($arg) eq 'SCALAR')
 222         {
 223                 my $scalar_arg;
 224                 if (ref ($arg)) { $scalar_arg = $$arg; }
 225                 else { $scalar_arg = $arg; }
 226
 227                 if (!-e $scalar_arg)
 228                 {
 229                         print STDERR $/, __FILE__, ': Configuration file ',
 230                                 "'$scalar_arg' does not exist";
 231                         return (0);
 232                 }
 233
 234                 unless (open ($fh, "< $scalar_arg"))
 235                 {
 236                         print STDERR $/, __FILE__, ': Unable to open ',
 237                                 "'$scalar_arg': $!";
 238                         return (0);
 239                 }
 240
 241                 $need_close++;
 242         }
 243         else
 244         {
 245                 my $type = ref ($arg);
 246
 247                 print STDERR $/, __FILE__, ": Reference type $type not ",
 248                         'valid';
 249                 return (0);
 250         }
 251
 252         # By now we should have a valid filehandle in $fh
 253
 254         $text = <$fh>;
 255
 256         close ($fh) if ($need_close);
 257
 258         parse_config ($text);
 259
 260         return (1);
 261 }
 262
 263 =back
 264
 265 =head1 AUTHOR
 266
 267 Florian octo Forster E<lt>octo at verplant.orgE<gt>