Prima::IniFile - support of Windows-like initialization files

Prima documentation Contained in the Prima distribution.

Index

Code Index:

NAME

Top

Prima::IniFile - support of Windows-like initialization files

DESCRIPTION

Top

The module contains a class, that provides mapping of text initialization file to a two-level hash structure. The first level is called sections, which groups the second level hashes, called items. Sections must have unique keys. The items hashes values are arrays of text strings. The methods, operated on these arrays are get_values, set_values, add_values and replace_values.

SYNOPSIS

Top

	use Prima::IniFile;

	my $ini = create Prima::IniFile;
	my $ini = create Prima::IniFile FILENAME;
	my $ini = create Prima::IniFile FILENAME,
					default => HASHREF_OR_ARRAYREF;
	my $ini = create Prima::IniFile file => FILENAME,
					default => HASHREF_OR_ARRAYREF;

	my @sections = $ini->sections;
	my @items = $ini->items(SECTION);
	my @items = $ini->items(SECTION, 1);
	my @items = $ini->items(SECTION, all => 1);

	my $value = $ini-> get_values(SECTION, ITEM);
	my @vals = $ini-> get_values(SECTION, ITEM);
	my $nvals = $ini-> nvalues(SECTION, ITEM);

	$ini-> set_values(SECTION, ITEM, LIST);
	$ini-> add_values(SECTION, ITEM, LIST);
	$ini-> replace_values(SECTION, ITEM, LIST);

	$ini-> write;
	$ini-> clean;
	$ini-> read( FILENAME);
	$ini-> read( FILENAME, default => HASHREF_OR_ARRAYREF);

	my $sec = $ini->section(SECTION);
	$sec->{ITEM} = VALUE;
	my $val = $sec->{ITEM};
	delete $sec->{ITEM};
	my %everything = %$sec;
	%$sec = ();
	for ( keys %$sec) { ... }
	while ( my ($k,$v) = each %$sec) { ... }

METHODS

Top

add_values SECTION, ITEM, @LIST

Adds LIST of string values to the ITEM in SECTION.

clean

Cleans all internal data in the object, including the name of the file.

create PROFILE

Creates an instance of the class. The PROFILE is treated partly as an array, partly as a hash. If PROFILE consists of a single item, the item is treated as a filename. Otherwise, PROFILE is treated as a hash, where the following keys are allowed:

file FILENAME

Selects name of file.

default %VALUES

Selects the initial values for the file, where VALUES is a two-level hash of sections and items. It is passed to read, where it is merged with the file data.

get_values SECTION, ITEM

Returns array of values for ITEM in SECTION. If called in scalar context, and there is more than one value, the first value in list is returned.

items SECTION [ HINTS ]

Returns items in SECTION. HINTS parameters is used to tell if a multiple-valued item must be returned as several items of the same name; HINTS can be supplied in the following forms:

items( $section, 1 ) items( $section, all => 1);

new PROFILE

Same as create.

nvalues SECTION, ITEM

Returns number of values in ITEM in SECTION.

read FILENAME, %PROFILE

Flushes the old content and opens new file. FILENAME is a text string, PROFILE is a two-level hash of default values for the new file. PROFILE is merged with the data from file, and the latter keep the precedence. Does not return any success values but, warns if any error is occurred.

replace_values SECTION, ITEM, @VALUES

Removes all values form ITEM in SECTION and assigns it to the new list of VALUES.

section SECTION

Returns a tied hash for SECTION. All its read and write operations are reflected in the caller object, which allows the following syntax:

	my $section = $inifile-> section( 'Sample section');
	$section-> {Item1} = 'Value1';

which is identical to

	$inifile-> set_items( 'Sample section', 'Item1', 'Value1');
sections

Returns array of section names.

set_values SECTION, ITEM, @VALUES

Assigns VALUES to ITEM in SECTION. If number of new values are equal or greater than the number of the old, the method is same as replace_values. Otherwise, the values with indices higher than the number of new values are not touched.

write

Rewrites the file with the object content. The object keeps an internal modification flag under name {changed}; in case it is undef, no actual write is performed.

AUTHORS

Top

Anton Berezin, <tobez@plab.ku.dk>

Dmitry Karasik <dmitry@karasik.eu.org>

Prima documentation Contained in the Prima distribution. 
#
#  Copyright (c) 1997-2002 The Protein Laboratory, University of Copenhagen
#  All rights reserved.
#
#  Redistribution and use in source and binary forms, with or without
#  modification, are permitted provided that the following conditions
#  are met:
#  1. Redistributions of source code must retain the above copyright
#     notice, this list of conditions and the following disclaimer.
#  2. Redistributions in binary form must reproduce the above copyright
#     notice, this list of conditions and the following disclaimer in the
#     documentation and/or other materials provided with the distribution.
#
#  THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
#  ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
#  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
#  ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
#  FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
#  DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
#  OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
#  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
#  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
#  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
#  SUCH DAMAGE.
#
#  Created by Anton Berezin  <tobez@tobez.org>
#
#  $Id$

package Prima::IniFile;

use strict;
use Carp;
use Cwd;


sub new { shift-> create(@_); }     # a shortcut

sub create
{
	my $class = shift;
	my %profile;
	%profile = @_ if scalar(@_)%2==0;
	%profile = (file => shift) if scalar(@_)%2==1;
	%profile = (%profile, @_) if scalar(@_)%2==0;
	my $self = {};
	bless( $self, $class);
	$self-> clean;
	$self-> {fileName} = $profile{-file} if exists $profile{-file};
	$self-> {fileName} = $profile{file} if exists $profile{file};
	$self-> read($self-> {fileName}, %profile) if exists $self-> {fileName};
	return $self;
}

sub DESTROY
{
	my $self = shift;
	$self-> write;
}

sub canonicalize_fname
{
	my $p = shift;
	return Cwd::abs_path($p) if -d $p;
	my $dir = $p;
	my $fn;
	if ($dir =~ s{[/\\]([^\\/]+)$}{}) {
		$fn = $1;
	} else {
		$fn = $p;
		$dir = '.';
	}
	unless ( scalar( stat $dir)) {
		$dir = "";
	} else {
		$dir = eval { Cwd::abs_path($dir) };
		$dir = "." if $@;
		$dir = "" unless -d $dir;
		$dir =~ s/(\\|\/)$//;
	}
	return "$dir/$fn";
}

sub read
{
	my ($self, $fname, %profile) = @_;
	$self-> write;             # save the old contents
	$self-> clean;
	$self-> {fileName} = canonicalize_fname($fname);
	eval
	{
		open FILE, "$fname" or do
		{
			open FILE, ">$fname" or die "Cannot create $fname: $!\n";
			close FILE;
			open FILE, "$fname" or die "Cannot open $fname: $!\n";
		};
		my @chunks;
		my %sectionChunks = ('' => [0]);
		my %sectionItems = ('' => []);
		my $currentChunk = [];
		my $items = {};
		my $chunkNum = 0;
		my $line = 0;
		push @chunks, $currentChunk;
		push @{$sectionItems{''}}, $items;
		while (<FILE>)
		{
			chomp;
			if ( /^\s*\[(.*?)\]/)         # new section?
			{
				my $section = $1;
				$currentChunk = [];
				$items = {};
				push @chunks, $currentChunk;
				$chunkNum++;
				$line = 0;
				if ( exists $sectionChunks{$section})
				{
					push @{$sectionChunks{$section}}, $chunkNum;
					push @{$sectionItems{$section}}, $items;
				}
				else
				{
					$sectionChunks{$section} = [$chunkNum];
					$sectionItems{$section} = [$items];
				}
				next;
			}
			next   if /^\s*[;#]/;      # comment
			next   unless /^\s*(.*?)\s*=/;
			# another value found
			my $item = $1;
			if ( exists $items-> {$item})
			{
				# duplicate
				push @{$items-> {$item}}, $line;
			}
			else
			{
				# first such $item in this portion of the $section
				$items-> {$item} = [$line];
			}
		}
		continue
		{
			push( @$currentChunk, $_);
			$line++;
		}
		close FILE;
		push( @{$chunks[-1]}, '') if scalar(@{$chunks[-1]}) && $chunks[-1]-> [-1] !~ /^\s*$/;
		$self-> {chunks} = [@chunks];
		$self-> {sectionChunks} = {%sectionChunks};
		$self-> {sectionItems} = {%sectionItems};

		# default values
		my $def;
		$def = $profile{default} || $profile{-default};
		# flatten hash to an array if neccessary
		$def = [%$def] if ref($def) eq q/HASH/;
		if ( ref($def) eq q/ARRAY/ && scalar(@$def)%2 == 0)
		{
			while (scalar(@$def))
			{
				my $sectName = shift @$def;
				my $sectValue = shift @$def;
				# flatten hash to an array if neccessary
				$sectValue = [%$sectValue] if ref($sectValue) eq q/HASH/;
				if ( ref($sectValue) eq q/ARRAY/ && scalar(@$sectValue)%2 == 0)
				{
					while (scalar(@$sectValue))
					{
						my $itemName = shift @$sectValue;
						my $itemValue = shift @$sectValue;
						my @defaultValues = (ref($itemValue) eq q/ARRAY/ ? (@$itemValue) : ($itemValue));
						my @vals = $self-> get_values( $sectName, $itemName);
						if (scalar(@defaultValues) > scalar(@vals))
						{
							splice @defaultValues, 0, scalar(@vals);
							$self-> add_values( $sectName, $itemName, @defaultValues);
						}
					}
				}
			}
		}
	};
	$self-> clean if $@;
	warn($@) if $@;
}

sub clean
{
	my $self = $_[0];
	$self-> {fileName} = undef;
	$self-> {changed} = undef;
	$self-> {chunks} = undef;
	$self-> {sectionChunks} = undef;
	$self-> {sectionItems} = undef;
}

sub sections
{
	my $self = $_[0];
	if ( wantarray)
	{
		return () unless defined $self-> {fileName};
		my $h = $self-> {sectionChunks};
		return sort { $h-> {$a}-> [0] <=> $h-> {$b}-> [0] } keys %$h;
	}
	else
	{
		return 0 unless defined $self-> {fileName};
		return scalar values %{$self-> {sectionChunks}};
	}
}

sub items
{
	my ($self,$section) = @_;
	my $all = ($#_ == 2) ? ($_[2]) : ( $#_ == 3 && ($_[2] eq 'all' || $_[2] eq '-all') ? $_[3] : 0);
	return wantarray ? () : 0
		unless defined($self-> {fileName}) &&
				defined($section) &&
				defined($self-> {sectionItems}-> {$section});
	my %items;
	my @items;
	if ( $all)
	{
		for ( @{$self-> {sectionChunks}-> {$section}})
		{
			# analyze every chunk once-again
			for ( @{$self-> {chunks}-> [$_]})
			{
				next   if /^\s*\[(.*?)\]/;     # section header
				next   if /^\s*[;#]/;          # comment
				next   unless /^\s*(.*?)\s*=/; # not item=value pair
				push @items, $1;
			}
		}
	}
	else
	{
		for ( @{$self-> {sectionItems}-> {$section}})
		{
			push @items, map { if (exists $items{$_}) {()} else { $items{$_}=1; $_ }} sort { $_-> {$a}-> [0] <=> $_-> {$b}-> [0] } keys %$_;
		}
	}
	return @items;
}

sub nvalues
{
	my ($self,$section,$item) = @_;
	return 0
		unless defined($self-> {fileName}) &&
				defined($section) &&
				defined($self-> {sectionItems}-> {$section}) &&
				defined($item);
	my $n = 0;
	for (@{$self-> {sectionItems}-> {$section}})
	{
		next unless exists $_-> {$item};
		$n += scalar @{$_-> {$item}}
	}
	return $n;
}

sub get_values
{
	my ($self,$section,$item) = @_;
	return wantarray ? () : undef
		unless defined($self-> {fileName}) &&
				defined($section) &&
				defined($self-> {sectionItems}-> {$section}) &&
				defined($item);
	my @vals;
	my $chunk = 0;
	for (@{$self-> {sectionItems}-> {$section}})
	{
		next unless exists $_-> {$item};
		my $txt = $self-> {chunks}-> [$self-> {sectionChunks}-> {$section}-> [$chunk]];
		for (@{$_-> {$item}})
		{
			my $line = $txt-> [$_];
			warn( "IniFile: Internal error 1\n"), next
				unless $line =~ /^\s*(.*?)\s*=(.*)$/ && $1 eq $item;
			push @vals, $2;
		}
	}
	continue
	{
		$chunk++;
	}
	return wantarray ? @vals : (scalar @vals ? $vals[0] : undef);
}

sub set_values
{
	my ($self,$section,$item,@vals) = @_;
	return unless defined($self-> {fileName}) &&
					defined($section) &&
					defined($item) &&
					scalar(@vals);
	@vals = map { defined $_ ? $_ : '' } @vals;

	$self-> {changed} = 1;

	my $chunk = 0;
	my $lastLine = -1;
	my $lastChunk = -1;
	if (!defined($self-> {sectionItems}-> {$section}))
	{
		# No such section, adding
		push @{$self-> {chunks}}, ["[$section]",''];
		$self-> {sectionChunks}-> {$section} = [scalar(@{$self-> {chunks}}) - 1];
		$self-> {sectionItems}-> {$section} = [{}];
	}
	SECTION: for (@{$self-> {sectionItems}-> {$section}})
	{
		next unless exists $_-> {$item};
		my $txt = $self-> {chunks}-> [$self-> {sectionChunks}-> {$section}-> [$chunk]];
		for (@{$_-> {$item}})
		{
			warn( "IniFile: Internal error 2\n"), next
				unless $txt-> [$_] =~ /^\s*(.*?)\s*=(.*)$/ && $1 eq $item;
			$txt-> [$_] =~ s{^(\s*.*?\s*=).*$}{$1$vals[0]};
			shift @vals;
			last SECTION unless scalar @vals;
			$lastChunk = $chunk;
			$lastLine = $_;
		}
	}
	continue
	{
		$chunk++;
	}
	return unless scalar @vals;
	if ( $lastChunk < 0)
	{
		# there was no such $item, not a single time
		$lastChunk = $chunk - 1;
		# find last non-empty line in the chunk
		my $txt = $self-> {chunks}-> [$self-> {sectionChunks}-> {$section}-> [$lastChunk]];
		$lastLine = scalar(@$txt) - 1;
		$lastLine-- while ($lastLine >= 0) && (($txt-> [$lastLine] =~ /^\s*$/) || ($txt-> [$lastLine] =~ /^\s*[;#]/));
		warn( "IniFile: Internal error 3\n"), return if $lastLine < 0;
	}
	# add the rest
	while ( scalar @vals)
	{
		$lastLine++;
		my $txt = $self-> {chunks}-> [$self-> {sectionChunks}-> {$section}-> [$lastChunk]];
		my $items = $self-> {sectionItems}-> {$section}-> [$lastChunk];
		splice @$txt, $lastLine, 0, "$item=$vals[0]";
		shift @vals;
		# modify line numbering
		for (keys %$items)
		{
			my $ary = $items-> {$_};
			for (@$ary)
			{
				$_++ if $_ >= $lastLine;
			}
		}
		if (exists $items-> {$item})
		{
			push @{$items-> {$item}}, $lastLine;
		}
		else
		{
			$items-> {$item} = [$lastLine];
		}
	}
}

sub add_values
{
	my ($self,$section,$item,@vals) = @_;
	return unless defined($self-> {fileName}) &&
					defined($section) &&
					defined($item) &&
					scalar(@vals);
	@vals = map { defined $_ ? $_ : '' } @vals;
	$self-> set_values($section,$item,$self-> get_values($section,$item),@vals);
}

sub replace_values
{
	my ($self,$section,$item,@vals) = @_;
	return unless defined($self-> {fileName}) &&
					defined($section) &&
					defined($item);
	@vals = () if $#vals == 0 && !defined $vals[0];
	@vals = map { defined $_ ? $_ : '' } @vals;
	my $nv = scalar @vals;
	$self-> {changed} = 1;
	$self-> set_values($section,$item,@vals);
	return unless defined($self-> {sectionItems}-> {$section});
	# and now circle through and delete the rest
	my $chunk = 0;
	my $n = 0;
	for (@{$self-> {sectionItems}-> {$section}})
	{
		next unless exists $_-> {$item};
		my $txt = $self-> {chunks}-> [$self-> {sectionChunks}-> {$section}-> [$chunk]];
		my $ary = $_-> {$item};
		for (my $i = 0; $i < scalar(@$ary); $i++)
		{
			if ( $n >= $nv)
			{
				# actual deletion
				my $line = $ary-> [$i];
				splice @$txt, $ary-> [$i], 1;
				splice @$ary, $i, 1;
				$i--;
				# and line numbering adjustment
				my $items = $_;
				for (keys %$items)
				{
					my $ary = $items-> {$_};
					for (@$ary)
					{
						$_-- if $_ > $line;
					}
				}
			}
			else
			{
				$n++;
			}
		}
		if (scalar(@$ary) == 0)
		{
			delete $_-> {$item};
		}
	}
	continue
	{
		$chunk++;
	}
}

package Prima::IniFile::Section::Helper::to::Tie;

sub TIEHASH
{
	my ($class, $ini, $section) = @_;
	my $self = {
		ini     => $ini,
		section => $section,
	};
	bless( $self, $class);
	return $self;
}

sub DESTROY
{
}

sub FETCH
{
	my ($self, $item) = @_;
	my @vals = $self-> {ini}-> get_values($self-> {section}, $item);
	return scalar(@vals) ? ($#vals ? [@vals] : $vals[0]) : undef;
}

sub STORE
{
	my ($self, $item, $val) = @_;
	$self-> {ini}-> replace_values($self-> {section}, $item, ref($val) eq q/ARRAY/ ? @$val : ($val));
}

sub DELETE
{
	my ($self, $item) = @_;
	$self-> {ini}-> replace_values($self-> {section}, $item);
}

sub CLEAR         # Well, dangerous
{
	my $self = $_[0];
	my @items = $self-> {ini}-> items($self-> {section});
	for (@items)
	{
		$self-> {ini}-> replace_values($self-> {section}, $_);
	}
}

sub EXISTS
{
	my ($self, $item) = @_;
	return $self-> {ini}-> nvalues($self-> {section},$item) > 0;
}

sub FIRSTKEY
{
	my $self = $_[0];
	$self-> {iterator} = [$self-> {ini}-> items($self-> {section})];
	return $self-> NEXTKEY;
}

sub NEXTKEY
{
	my $self = $_[0];
	unless ( exists $self-> {iterator} && scalar @{$self-> {iterator}})
	{
		return wantarray ? () : undef;
	}
	my $key = shift @{$self-> {iterator}};
	return wantarray ? ($key, $self-> FETCH($key)) : $key;
}

package Prima::IniFile;

sub section
{
	my %tied;
	tie %tied, q/Prima::IniFile::Section::Helper::to::Tie/, $_[0], $_[1];
	return \%tied;
}

sub write
{
	my $self = $_[0];
	return unless defined($self-> {fileName}) && $self-> {changed};
	my $fname = $self-> {fileName};
	eval {
		open FILE, ">$fname" or die "Cannot write to the $fname: $!\n";
		pop @{$self-> {chunks}-> [-1]} if scalar(@{$self-> {chunks}-> [-1]}) && $self-> {chunks}-> [-1]-> [-1] =~ /^\s*$/;
		for ( @{$self-> {chunks}})
		{
			for (@$_) { print FILE "$_\n"; }
		}
		push( @{$self-> {chunks}-> [-1]}, '') if scalar(@{$self-> {chunks}-> [-1]}) && $self-> {chunks}-> [-1]-> [-1] !~ /^\s*$/;
		close FILE;
	};
	$self-> {changed} = undef if $@;
	warn($@) if $@;
}

1;

__DATA__