view release on metacpan or  search on metacpan

Prima/IniFile.pm  view on Meta::CPAN

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
	{
		my $f;
		open $f, "<", $fname or do
		{
			open $f, ">", $fname or die "Cannot create $fname: $!\n";
			close $f;
			open $f, "<", $fname or die "Cannot open $fname: $!\n";
		};
		binmode $f, ":utf8";
		my @chunks;
		my %sectionChunks = ('' => [0]);
		my %sectionItems = ('' => []);
		my $currentChunk = [];
		my $items = {};
		my $chunkNum = 0;
		my $line = 0;
		push @chunks, $currentChunk;
		push @{$sectionItems{''}}, $items;
		while (<$f>)
		{
			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 $f;
		push( @{$chunks[-1]}, '') if scalar(@{$chunks[-1]}) && $chunks[-1]-> [-1] !~ /^\s*$/;
		$self-> {chunks} = [@chunks];
		$self-> {sectionChunks} = {%sectionChunks};
		$self-> {sectionItems} = {%sectionItems};

		# default values
		my $def;