inifiles.pm

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

	    push(@val, $_);
	  }
	}
	if ($foundeot) {
	    if (exists $self->{v}{$sect}{$parm} && 
	        exists $loaded_params{$sect} && 
	        grep( /^$parm$/, @{$loaded_params{$sect}}) ) {
	      if (ref($self->{v}{$sect}{$parm}) eq "ARRAY") {
	        # Add to the array
	        push @{$self->{v}{$sect}{$parm}}, @val;
	      } else {
	        # Create array
	        my $old_value = $self->{v}{$sect}{$parm};
	        my @new_value = ($old_value, @val);
	        $self->{v}{$sect}{$parm} = \@new_value;
	      }
	    } else {
		$self->{v}{$sect}{$parm} = \@val;
		$loaded_params{$sect} = [] unless $loaded_params{$sect};
		push @{$loaded_params{$sect}}, $parm;
	    }
	    $self->{EOT}{$sect}{$parm} = $eotmark;
	} else {
	  push(@IniFiles::errors, sprintf('%d: %s', $startline,
			      qq#no end marker ("$eotmark") found#));
	}
      } else {
	if (exists $self->{v}{$sect}{$parm} &&
	    exists $loaded_params{$sect} && 
	    grep( /^$parm$/, @{$loaded_params{$sect}}) ) {
	    if (ref($self->{v}{$sect}{$parm}) eq "ARRAY") {
		# Add to the array
		push @{$self->{v}{$sect}{$parm}}, $val;
	    } else {
		# Create array
		my $old_value = $self->{v}{$sect}{$parm};
		my @new_value = ($old_value, $val);
		$self->{v}{$sect}{$parm} = \@new_value;
	    }
	} else {
	    $self->{v}{$sect}{$parm} = $val;
	    $loaded_params{$sect} = [] unless $loaded_params{$sect};
	    push @{$loaded_params{$sect}}, $parm;
	}
      }
      push(@{$self->{parms}{$sect}}, $parm) unless grep(/^\Q$parm\E$/, @{$self->{parms}{$sect}});
    }
    else {
      push(@IniFiles::errors, sprintf('%d: %s', $lineno, $_));
    }
  }

  #
  # Now convert all the parameter hashes into tied hashes.
  # This is in all uses, because it must be part of ReadConfig.
  #
  my %parms = %{$self->{startup_settings}};
  if( defined $parms{-default} ) {
    # If the default section doesn't exists, create it.
    unless( defined $self->{v}{$parms{-default}} ) {
      $self->{v}{$parms{-default}} = {};
      push(@{$self->{sects}}, $parms{-default}) unless (grep /^\Q$parms{-default}\E$/, @{$self->{sects}});
      $self->{parms}{$parms{-default}} = [];
    } # end unless
    $parms{-default} = $self->{v}{$parms{-default}};
  } # end if
  foreach( keys %{$self->{v}} ) {
    $parms{-_current_value} = $self->{v}{$_};
    $parms{-parms} = $self->{parms}{$_};
    $self->{v}{$_} = {};
    # Add a reference to our {parms} hash for each section
    tie %{$self->{v}{$_}}, 'IniFiles::_section', %parms
  } # end foreach

  @IniFiles::errors ? undef : 1;
}


=head2 Sections

Returns an array containing section names in the configuration file.
If the I<nocase> option was turned on when the config object was
created, the section names will be returned in lowercase.

=cut

sub Sections {
  my $self = shift;
  return @{$self->{sects}} if ref $self->{sects} eq 'ARRAY';
  return ();
}

=head2 Parameters ($section_name)

Returns an array containing the parameters contained in the specified
section.

=cut

sub Parameters {
  my $self = shift;
  my $sect = shift;
  return @{$self->{parms}{$sect}} if ref $self->{parms}{$sect} eq 'ARRAY';
  return ();
}

=head2 Groups

Returns an array containing the names of available groups.
  
Groups are specified in the config file as new sections of the form

  [GroupName MemberName]

This is useful for building up lists.  Note that parameters within a
"member" section are referenced normally (i.e., the section name is
still "Groupname Membername", including the space) - the concept of
Groups is to aid people building more complex configuration files.

=cut

sub Groups	{
  my $self = shift;
  return keys %{$self->{group}} if ref $self->{group} eq 'HASH';
  return ();
}

=head2 GroupMembers ($group)

Returns an array containing the members of specified $group. Each element
of the array is a section name. For example, given the sections

  [Group Element 1]
  ...

  [Group Element 2]
  ...

GroupMembers would return ("Group Element 1", "Group Element 2").

=cut

sub GroupMembers {
  my $self  = shift;
  my $group = shift;
  return @{$self->{group}{$group}} if ref $self->{group}{$group} eq 'ARRAY';
  return ();
}

=head2 WriteConfig ($filename)

Writes out a new copy of the configuration file.  A temporary file
(ending in .new) is written out and then renamed to the specified
filename.  Also see B<BUGS> below.

=cut

sub WriteConfig {
  my $self = shift;
  my $file = shift;

  local(*F);
  open(F, "> $file.new") || do {
    carp "Unable to write temp config file $file: $!";
    return undef;
  };
  my $oldfh = select(F);
  $self->OutputConfig;
  close(F);
  select($oldfh);
  rename "$file.new", $file || do {
    carp "Unable to rename temp config file to $file: $!";
    return undef;
  };
  if (exists $self->{file_mode}) {
    chmod oct($self->{file_mode}), $file;
  }
  return 1;
}

=head2 RewriteConfig

Same as WriteConfig, but specifies that the original configuration
file should be rewritten.

=cut

sub RewriteConfig {
  my $self = shift;
  
  return undef if (
    (not exists $self->{cf}) or
    (not defined $self->{cf}) or
    ($self->{cf} eq '')
  );
  
  # Return whatever WriteConfig returns :)
  $self->WriteConfig($self->{cf});
}

=head2 SetFileName ($filename)

If you created the IniFiles object without initialising from
a file, or if you just want to change the name of the file to use for
ReadConfig/RewriteConfig from now on, use this method.

Returns $filename if that was a valid name, undef otherwise.

=cut

sub SetFileName {
  my $self = shift;
  my $newfile = shift;
  if ((defined $newfile) and ($newfile ne "")) {
    $self->{cf} = $newfile;
    return $self->{cf};
  }
  return undef;
}

# OutputConfig
#
# Writes OutputConfig to STDOUT. Use select() to redirect STDOUT to
# the output target before calling this function

sub OutputConfig {
  my $self = shift;

  my($sect, $parm, @cmts);
  my $ors = $self->{line_ends} || $\ || "\n";		# $\ is normally unset, but use input by default
  my $notfirst = 0;
  local $_;
  foreach $sect (@{$self->{sects}}) {
    next unless defined $self->{v}{$sect};
    print $ors if $notfirst;
    $notfirst = 1;
    if ((ref($self->{sCMT}{$sect}) eq 'ARRAY') &&
	(@cmts = @{$self->{sCMT}{$sect}})) {
      foreach (@cmts) {
	print "$_$ors";
      }
    }
    print "[$sect]$ors";
    next unless ref $self->{v}{$sect} eq 'HASH';

    foreach $parm (@{$self->{parms}{$sect}}) {
      if ((ref($self->{pCMT}{$sect}{$parm}) eq 'ARRAY') &&
	  (@cmts = @{$self->{pCMT}{$sect}{$parm}})) {
	foreach (@cmts) {
	  print "$_$ors";
	}
      }

      my $val = $self->{v}{$sect}{$parm};
      next if ! defined ($val);	# No parameter exists !!
      if (ref($val) eq 'ARRAY') {
        my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT';
	print "$parm= <<$eotmark$ors";
	foreach (@{$val}) {
	  print "$_$ors";
	}
	print "$eotmark$ors";
      } elsif( $val =~ /[$ors]/ ) {
        # The FETCH of a tied hash is never called in 
        # an array context, so generate a EOT multiline
        # entry if the entry looks to be multiline
        my @val = split /[$ors]/, $val;
        if( @val > 1 ) {
          my $eotmark = $self->{EOT}{$sect}{$parm} || 'EOT';
          print "$parm= <<$eotmark$ors";
          print map "$_$ors", @val;
          print "$eotmark$ors";
        } else {
           print "$parm=$val[0]$ors";
        } # end if
      } else {
        print "$parm=$val$ors";
      }
    }
  }
  return 1;
}

=head2 SetSectionComment($section, @comment)

Sets the comment for section $section to the lines contained in @comment.
Each comment line will be prepended with "#" if it doesn't already have
a comment character (ie: if $line !~ m/^\s*[#;]/)

To clear a section comment, use DeleteSectionComment ($section)

=cut

sub SetSectionComment
{
	my $self = shift;
	my $section = shift;
	my @comment = @_;

	defined($section) || return undef;
	@comment || return undef;
	
	$self->{sCMT}{$section} = [];
	# At this point it's possible to have a comment for a section that
	# doesn't exist. This comment will not get written to the INI file.
	
	foreach my $comment_line (@comment) {
		($comment_line =~ m/^\s*[#;]/) or ($comment_line = "# $comment_line");
		push @{$self->{sCMT}{$section}}, $comment_line;
	}
	return scalar @comment;
}

=head2 GetSectionComment ($section)

Returns a list of lines, being the comment attached to section $section. In 
scalar context, returns a string containing the lines of the comment separated
by newlines.

The lines are presented as-is, with whatever comment character was originally
used on that line.

=cut

sub GetSectionComment
{
	my $self = shift;
	my $section = shift;

	if (exists $self->{sCMT}{$section}) {
		return @{$self->{sCMT}{$section}};
	} else {
		return undef;
	}
}

=head2 DeleteSectionComment ($section)

Removes the comment for the specified section.

=cut

sub DeleteSectionComment
{
	my $self = shift;
	my $section = shift;
	
	delete $self->{sCMT}{$section};
}

=head2 SetParameterComment ($section, $parameter, @comment)

Sets the comment attached to a particular parameter.

Any line of @comment that does not have a comment character will be
prepended with "#".

=cut

sub SetParameterComment
{
	my $self = shift;
	my $section = shift;
	my $parameter = shift;
	my @comment = @_;

	defined($section) || return undef;
	defined($parameter) || return undef;
	@comment || return undef;
	
	if (not exists $self->{pCMT}{$section}) {
		$self->{pCMT}{$section} = {};
	}
	
	$self->{pCMT}{$section}{$parameter} = [];
	# Note that at this point, it's possible to have a comment for a parameter,
	# without that parameter actually existing in the INI file.
	
	foreach my $comment_line (@comment) {
		($comment_line =~ m/^\s*[#;]/) or ($comment_line = "# $comment_line");
		push @{$self->{pCMT}{$section}{$parameter}}, $comment_line;
	}
	return scalar @comment;
}

=head2 GetParameterComment ($section, $parameter)

Gets the comment attached to a parameter.

=cut

sub GetParameterComment
{
	my $self = shift;
	my $section = shift;
	my $parameter = shift;
	
	defined($section) || return undef;
	defined($parameter) || return undef;
	
	exists($self->{pCMT}{$section}) || return undef;
	exists($self->{pCMT}{$section}{$parameter}) || return undef;
	
	my @comment = @{$self->{pCMT}{$section}{$parameter}};
	return (wantarray)?@comment:join " ", @comment;
}

=head2 DeleteParameterComment ($section, $parameter)

Deletes the comment attached to a parameter.

=cut

sub DeleteParameterComment
{
	my $self = shift;
	my $section = shift;
	my $parameter = shift;
	
	defined($section) || return undef;
	defined($parameter) || return undef;
	
	# If the parameter doesn't exist, our goal has already been achieved
	exists($self->{pCMT}{$section}) || return 1;
	exists($self->{pCMT}{$section}{$parameter}) || return 1;
	
	delete $self->{pCMT}{$section}{$parameter};
	return 1;
}

=head2 GetParameterEOT ($section, $parameter)

Accessor method for the EOT text (in fact, style) of the specified parameter. If any text is used as an EOT mark, this will be returned. If the parameter was not recorded using HERE style multiple lines, GetParameterEOT returns undef.

=cut

sub GetParameterEOT
{
	my $self = shift;
	my $section = shift;
	my $parameter = shift;

	defined($section) || return undef;
	defined($parameter) || return undef;

	if (not exists $self->{EOT}{$section}) {
		$self->{EOT}{$section} = {};
	}

	if (not exists $self->{EOT}{$section}{$parameter}) {
		return undef;
	}
	return $self->{EOT}{$section}{$parameter};
}

=head2 SetParameterEOT ($section, $EOT)