inifiles.pm

支持全流程的Perl+MySQL电子商务系统。完全公开代码。

package IniFiles;
$IniFiles::VERSION = (qw($Revision: 2.19 $))[1];
use Carp;
use strict;
require 5.004;

@IniFiles::errors = ( );

#	$Header: /cvsroot/config-inifiles/config-inifiles/IniFiles.pm,v 2.19 2001/04/04 23:33:40 wadg Exp $

=head1 NAME

IniFiles - A module for reading .ini-style configuration files.

=head1 SYNOPSIS

  use IniFiles;
  my $cfg = new IniFiles( -file => "/path/configfile.ini" );
  print "We have parm " . $cfg->val( 'Section', 'Parameter' ) . "."
  	if $cfg->val( 'Section', 'Parameter' );

=head1 DESCRIPTION

IniFiles provides a way to have readable configuration files outside
your Perl script.  Configurations can be imported (inherited, stacked,...), 
sections can be grouped, and settings can be accessed from a tied hash.

=head1 FILE FORMAT

INI files consist of a number of sections, each preceded with the
section name in square brackets.  The first non-blank character of
the line indicating a section must be a left bracket and the last
nonblank character of a line indicating a section must be a right
bracket. The characters making up the section name can be any 
symbols at all. However section names must be unique.

Parameters are specified in each section as Name=Value.  Any spaces
around the equals sign will be ignored, and the value extends to the
end of the line. Parameter names are localized to the namespace of 
the section, but must be unique within a section.

  [section]
  Parameter=Value

Both the hash mark (#) and the semicolon (;) are comment characters.
Lines that begin with either of these characters will be ignored.  Any
amount of whitespace may preceed the comment character.

Multiline or multi-valued parameters may also be defined ala UNIX 
"here document" syntax:

  Parameter=<<EOT
  value/line 1
  value/line 2
  EOT

You may use any string you want in place of "EOT".  Note that what
follows the "<<" and what appears at the end of the text MUST match
exactly, including any trailing whitespace.

=head1 USAGE -- Object Interface

Get a new IniFiles object with the I<new> method:

  $cfg = IniFiles->new( -file => "/path/configfile.ini" );
  $cfg = new IniFiles -file => "/path/configfile.ini";

Optional named parameters may be specified after the configuration
file name.  See the I<new> in the B<METHODS> section, below.

Values from the config file are fetched with the val method:

  $value = $cfg->val('Section', 'Parameter');

If you want a multi-line/value field returned as an array, just
specify an array as the receiver:

  @values = $cfg->val('Section', 'Parameter');

=head1 METHODS

=head2 new ( [-option=>value ...] )

Returns a new configuration object (or "undef" if the configuration
file has an error).  One IniFiles object is required per configuration
file.  The following named parameters are available:

=over 10

=item I<-file>  filename

Specifies a file to load the parameters from. If this option is not specified, (ie:
you are creating a config file from scratch) you must specify a target file
using SetFileName in order to save the parameters.

=item I<-default> section

Specifies a section to be used for default values. For example, if you
look up the "permissions" parameter in the "users" section, but there
is none, IniFiles will look to your default section for a "permissions"
value before returning undef.

=item I<-reloadwarn> 0|1

Set -reloadwarn => 1 to enable a warning message (output to STDERR)
whenever the config file is reloaded.  The reload message is of the
form:

  PID <PID> reloading config file <file> at YYYY.MM.DD HH:MM:SS

Default behavior is to not warn (i.e. -reloadwarn => 0).

=item I<-nocase> 0|1

Set -nocase => 1 to handle the config file in a case-insensitive
manner (case in values is preserved, however).  By default, config
files are case-sensitive (i.e., a section named 'Test' is not the same
as a section named 'test').  Note that there is an added overhead for
turning off case sensitivity.

=item I<-import> object

This allows you to import or inherit existing setting from another 
IniFiles object. When importing settings from another object, 
sections with the same name will be merged and parameters that are 
defined in both the imported object and the I<-file> will take the 
value of given in the I<-file>. 

If a I<-default> section is also given on this call, and it does not 
coincide with the default of the imported object, the new default 
section will be used instead. If no I<-default> section is given, 
then the default of the imported object will be used.

=back

=cut

sub new {
  my $class = shift;
  my %parms = @_;

  my $errs = 0;
  my @groups = ( );

  my $self           = {};
  # Set config file to default value, which is nothing
  $self->{cf}        = '';
  if( ref($parms{-import}) && ($parms{-import}->isa('IniFiles')) ) {
    # Import from the import object by COPYing, so we
	# don't clobber the old object
    %{$self} = %{$parms{-import}};
  } else {
    $self->{firstload} = 1;
    $self->{default}   = '';
    $self->{imported}  = [];
    if( defined $parms{-import} ) {
      carp "Invalid -import value was ignored.";
      delete $parms{-import};
    } # end if
  } # end if

  # Parse options
  my($k, $v);
  local $_;
  while (($k, $v) = each %parms) {
    if( $k eq '-import' ) {
    	# Store the imported object's file parameter for reload
    	push( @{$self->{imported}}, $self->{cf} ) if $self->{cf};
    }
    elsif ($k eq '-file') {
      # Should we be pedantic and check that the file exists?
      $self->{cf} = $v;
    }
    elsif ($k eq '-default') {
      $self->{default} = $v;
    }
    elsif ($k eq '-nocase') {
      $self->{nocase} = $v ? 1 : 0;
    }
    elsif ($k eq '-reloadwarn') {
      $self->{reloadwarn} = $v ? 1 : 0;
    }
    else {
      carp "Unknown named parameter $k=>$v";
      $errs++;
    }
  }

  # Copy the original parameters so we 
  # can use them when we build new sections 
  %{$self->{startup_settings}} = %parms;

  return undef if $errs;

  bless $self, $class;

  # No config file specified, so everything's okay so far.
  if ($self->{cf} eq '') {
    return $self;
  }
  
  if ($self->ReadConfig) {
    return $self;
  } else {
    return undef;
  }
}

=head2 val ($section, $parameter)

Returns the value of the specified parameter (C<$parameter>) in section 
C<$section>, returns undef if no section or no parameter for the given section
section exists.

If you want a multi-line/value field returned as an array, just
specify an array as the receiver:

  @values = $cfg->val('Section', 'Parameter');

=cut

sub val {
  my ($self, $sect, $parm) = @_;

  if ($self->{nocase}) {
    $sect = lc($sect);
    $parm = lc($parm);
  }
  my $val = defined($self->{v}{$sect}{$parm}) ?
    $self->{v}{$sect}{$parm} :
    $self->{v}{$self->{default}}{$parm};
  if( defined ($/) && defined ($val) && $val =~ m#$/#) {
    return wantarray ? split( $/, $val ) : $val;
  } else {
    return $val;
  }
}

=head2 setval ($section, $parameter, $value, [ $value2, ... ])

Sets the value of parameter C<$parameter> in section C<$section> to 
C<$value> (or to a set of values).  See below for methods to write 
the new configuration back out to a file.

You may not set a parameter that didn't exist in the original
configuration file.  B<setval> will return I<undef> if this is
attempted. See B<newval> below to do this. Otherwise, it returns 1.

=cut

sub setval {
  my $self = shift;
  my $sect = shift;
  my $parm = shift;
  my @val  = @_;

# [e-mail] +
  if ($self->{nocase}) {
    $sect = lc($sect);
    $parm = lc($parm);
  }
# [e-mail] -

  if (defined($self->{v}{$sect}{$parm})) {
    if (@val > 1) {
      $self->{v}{$sect}{$parm} = \@val;
	  $self->{EOT}{$sect}{$parm} = 'EOT';
    } else {
      $self->{v}{$sect}{$parm} = shift @val;
    }
    return 1;
  } else {
    return undef;
  }
}

=head2 newval($setion, $parameter, $value [, $value2, ...])

Assignes a new value, C<$value> (or set of values) to the 
parameter C<$parameter> in section C<$section> in the configuration 
file.

=cut

sub newval {
  my $self = shift;
  my $sect = shift;
  my $parm = shift;
  my @val  = @_;

# [e-mail] +
  if ($self->{nocase}) {
    $sect = lc($sect);
    $parm = lc($parm);
  }
# [e-mail] -

    push(@{$self->{sects}}, $sect) unless (grep /^\Q$sect\E$/, @{$self->{sects}});
    $self->{v}{$sect} = {} unless ref $self->{v}{$sect} eq 'HASH';
    $self->{parms}{$sect} = [] unless ref($self->{parms}{$sect}) eq 'ARRAY';

    push(@{$self->{parms}{$sect}}, $parm) 
      unless (grep /^\Q$parm\E$/,@{$self->{parms}{$sect}} );

  if (@val > 1) {
    $self->{v}{$sect}{$parm} = \@val;
	$self->{EOT}{$sect}{$parm} = 'EOT' unless defined
				$self->{EOT}{$sect}{$parm};
  } else {
    $self->{v}{$sect}{$parm} = shift @val;
  }
  return 1
}

=head2 delval($section, $parameter)

Deletes the specified parameter from the configuration file

=cut

sub delval {
  my $self = shift;
  my $sect = shift;
  my $parm = shift;

# [e-mail] +
  if ($self->{nocase}) {
    $sect = lc($sect);
    $parm = lc($parm);
  }
# [e-mail] -

	@{$self->{parms}{$sect}} = grep !/^\Q$parm\E$/, @{$self->{parms}{$sect}};
	delete $self->{v}{$sect}{$parm};
	return 1
}

=head2 ReadConfig

Forces the configuration file to be re-read. Returns undef if the 
file can not be opened, no filename was defined (with the C<-file>
option) when the object was constructed, or an error occurred while 
reading.

If an error occurs while parsinf the INI file the @IniFiles::errors
array will contain messages that might help you figure out where the 
problem is in the file.

=cut

sub ReadConfig {
  my $self = shift;

  local *CF;
  my($lineno, $sect);
  my($group, $groupmem);
  my($parm, $val);
  my @cmts;
  my %loaded_params = ();			# A has to remember which params are loaded vs. imported
  @IniFiles::errors = ( );

  # Initialize (and clear out) storage hashes
  # unless we imported them from another file [JW]
  if( @{$self->{imported}} ) {
    #
    # Run up the import tree to the top, then reload coming
    # back down, maintaining the imported file names and our 
    # file name
    #
    my $cf = $self->{cf};
    $self->{cf} = pop @{$self->{imported}};
    $self->ReadConfig;
    push @{$self->{imported}}, $self->{cf};
    $self->{cf} = $cf;
  } else {
    $self->{sects}  = [];		# Sections
    $self->{group}  = {};		# Subsection lists
    $self->{v}      = {};		# Parameter values
    $self->{sCMT}   = {};		# Comments above section
  } # end if
  
  return undef if (
    (not exists $self->{cf}) or
    (not defined $self->{cf}) or
    ($self->{cf} eq '')
  );
  
  my $nocase = $self->{nocase};

  my ($ss, $mm, $hh, $DD, $MM, $YY) = (localtime(time))[0..5];
  printf STDERR
    "PID %d reloading config file %s at %d.%02d.%02d %02d:%02d:%02d\n",
    $$, $self->{cf}, $YY+1900, $MM+1, $DD, $hh, $mm, $ss
    unless $self->{firstload} || !$self->{reloadwarn};

  $self->{firstload} = 0;

  if (!open(CF, $self->{cf})) {
    carp "Failed to open $self->{cf}: $!";
    return undef;
  }
  my @stats = stat CF;
  $self->{file_mode} = sprintf "%04o", $stats[2];
  local $_;
  my @lines = split /[\015\012]+/, join( '', <CF>);
  close(CF);
  # Store what our line ending char was for output
  ($self->{line_ends}) = $lines[0] =~ /([\015\012]+)/;
  while ( @lines ) {
    $_ = shift @lines;

    s/[\015\012]+$//;				# remove line ending char(s)
    $lineno++;
    if (/^\s*$/) {				# ignore blank lines
      next;
    }
    elsif (/^\s*[\#\;]/) {			# collect comments
      push(@cmts, $_);
      next;
    }
    elsif (/^\s*\[\s*(\S|\S.*\S)\s*\]\s*$/) {		# New Section
      $sect = $1;
      $sect = lc($sect) if $nocase;
      push(@{$self->{sects}}, $sect) unless grep(/^\Q$sect\E$/, @{$self->{sects}});
      if ($sect =~ /(\S+)\s+\S+/) {		# New Group Member
	$group = $1;
	if (!defined($self->{group}{$group})) {
	  $self->{group}{$group} = [];
	}
	push(@{$self->{group}{$group}}, $sect) unless grep(/\Q$sect\E/, @{$self->{group}{$group}});
      }
      if (!defined($self->{v}{$sect})) {
	$self->{sCMT}{$sect} = [@cmts] if @cmts > 0;
	$self->{pCMT}{$sect} = {};		# Comments above parameters
	$self->{parms}{$sect} = [];
	@cmts = ( );
	$self->{v}{$sect} = {};
      }
    }
    elsif (($parm, $val) = /\s*([^=]+?)\s*=\s*(.*)/) {	# new parameter
      $parm = lc($parm) if $nocase;
      $self->{pCMT}{$sect}{$parm} = [@cmts];
      @cmts = ( );
      if ($val =~ /^<<(.*)/) {			# "here" value
	my $eotmark  = $1;
	my $foundeot = 0;
	my $startline = $lineno;
	my @val = ( );
	while ( @lines ) {
	  $_ = shift @lines;
	  s/[\015\012]+$//;				# remove line ending char(s)
	  $lineno++;
	  if ($_ eq $eotmark) {
	    $foundeot = 1;
	    last;
	  } else {