Win32::TieRegistry::PMVersionInfo - store in Win32 Registry PM $VERSION info

	use Win32::TieRegistry::PMVersionInfo 0.2;

	my $reg = new Win32::TieRegistry::PMVersionInfo (
		file_root	=> "D:/src/pl/spc2xml/version5/",
		ignore_dirs => ["Commercial/bin/",
						"Commercial/SPC/XSLT/SourceForge",
						"Commercial/SPC/XSLT/CSS",
						"Commercial/SPC/XSLT/imgs",],
		reg_root	=> 'LMachine/Software/LittleBits/',
		strip_path	=> $strip_path,
		chat=>1,
	);
	$reg->get;
	$reg->store;

	exit;

	The first line in the file that contains the regular expression

		/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/

	will be evaluated with eval() and the value of the named variable
	after the eval() will be assigned to the VERSION attribute of the
	MakeMaker object. The following lines will be parsed o.k.:

		$VERSION = '1.00';
		*VERSION = \'1.01';
		( $VERSION ) = '$Revision: 1.222 $ ' =~ /\$Revision:\s+([^\s]+)/;
		$FOO::VERSION = '1.10';
		*FOO::VERSION = \'1.11';
		our $VERSION = 1.2.3;       # new for perl5.6.0

	but these will fail:

		my $VERSION = '1.01';
		local $VERSION = '1.02';
		local $FOO::VERSION = '1.30';

	(Putting "my" or "local" on the preceding line will work o.k.)

	Win32::TieRegistry.

package Win32::TieRegistry::PMVersionInfo;
use strict;
our $VERSION = 0.2;
our $CHAT;

use Win32::TieRegistry ( Delimiter=>"/" );
use Carp;

sub new { my ($class) = (shift);
    unless (defined $class) {
    	warn "Usage: $class->new( {key=>value} )";
    	return undef;
	}
	my %args;
	# Take parameters and place in object slots/set as instance variables
	if (ref $_[0] eq 'HASH'){	%args = %{$_[0]} }
	elsif (not ref $_[0]){		%args = @_ }
	else {
		warn "Usage: $class->new( { key=>values, } )";
		return undef;
	}
    my $self = bless {},$class;
	# Set default options that may be over-ridden
	$self->{tree} = ();
	$self->{file_root} = '';
	$self->{ignore_dirs} = [];
	$self->{reg_root} = '';
	$self->{strip_path} = '';
	$self->{filename_pattern} = '.*';
	$self->{dirname_pattern} = '.*';
	$self->{extension}		= 1;
	# Set/overwrite public slots with user's values
	foreach (keys %args) {	$self->{lc $_} = $args{$_} }
	if (exists $self->{chat} and defined $self->{chat}){
		$CHAT = 1;
	}
	if (ref $self->{ignore_dirs} ne 'ARRAY'){
		carp "Not an array ref";
	}
	# Try to create the root key if it doesn't exist
	$_ = $Registry->{ $self->{reg_root} };
	$Registry->{ $self->{reg_root} } = {} if not defined $_;
	$_ = $Registry->{ $self->{reg_root} };
	return $self;
}

sub get { my ($self,$dir) = (shift,shift);
	local *DIR;
	$dir = $self->{file_root} if not defined $dir;
	croak "No \$self->{file_root} or passed dir to parse in method 'get'" if not defined $dir or $dir eq '';

	# See if our dir, $dir, is in the ignore list, @{$self->{ignore_dirs}}
	foreach (@{$self->{ignore_dirs}}){
		warn "Ignoring $_\n" and return undef if $dir =~ /$self->{file_root}\/?$_/;
	}

	opendir DIR,$dir
		or croak("Method get couldn't open process dir to get a file: <$dir>:\n $!.")
		and return undef;
	foreach my $fn (grep !-d && /^$self->{filename_pattern}$/,readdir DIR){
		push @{$self->{tree}}, {
			path => $dir.$fn,
			version => &version_from($dir.$fn)
		};
	}
	closedir DIR;

	chdir  $dir 		or $self->croak("Method get couldn't cd to dir <$dir>: $!") and return undef;
	opendir DIR,$dir	or $self->croak("Method get couldn't open dir <$dir>: $!") and return undef;
	foreach my $next_dir (grep {-d && !/^\.\.?$/ && /^($self->{dirname_pattern})$/ } readdir DIR){
		$self->get($dir.$next_dir.'/');
	}
	closedir DIR;
	return $dir;
}

#
# PRIVATE SUBROUTINE version_from
#	accepts a path, returns the version of that file or undef.
#	Evals each line in the file until finding /([\$*])(([\w\:\']*)\bVERSION)\b.*\=/ and evaluating
#
sub version_from { my $path = shift;
	croak "version_from called without path argument" if not defined $path;
	local *IN;
	my $version = undef;
	open IN, $path;
	while (<IN>){
		my $VERSION;
		next if !/([\$*])(([\w\:\']*)\bVERSION)\b.*\=/;
		s/^\s*(local|our)\s+//;
		$_ = eval ("$_");	# Escape scoping?
		$version = $VERSION;
		last;
	}
	close IN;
	warn "$version in $path\n" if $CHAT and defined $version;
	return $version;
}

sub get_from_MANIFEST { my ($self,$manifest,$manifest_skip) = (@_);
	croak "No manifest file passed as argument" if not defined $manifest;
	croak "No such manifest file as $manifest" if not -e $manifest;
	local *IN;
	my %skip;
	if (defined $manifest_skip){
		croak "No such MANIFEST.SKIP file as $manifest_skip" if not -e $manifest_skip;
		open IN, $manifest_skip;
		while (<IN>){
			chomp;
			$skip{$_} = 1;
		}
		close IN;
	}
	open MANIFEST,$manifest or croak "Could not open $manifest";
	while (<IN>){
		chomp;
		next if exists $skip{$_};
		push @{$self->{tree}}, {
			path => $_,
			version => &version_from($_)
		};
	}
	close IN;
	return 1;
}

sub store { my ($self,$root) = (shift,shift);
	$root = $self->{reg_root} if not defined $root;
	foreach my $file (sort @{$self->{tree}}){
		if (exists $file->{version} and $file->{version} ne ''){
			# warn $file->{path},"\t",$file->{version},"\n";
			$file->{path} =~ s/^\Q$self->{strip_path}\E//i;
			$file->{path} =~ s/\.[^.]*$// if defined  $self->{extension};
			$file->{path} =~ s|\\|/|g;
			# Build the heirachy
			my $path = $root;
			foreach my $part (split m|/|,$file->{path}){
				$path .= $part.'/';
				$_ = $Registry->{ $path };
				$Registry->{ $path } = {} if not defined $_;
			}
			# Make the keys from all the values in %{$file}, except $path
			foreach (keys %{$file}){
				next if $_ eq 'path';
				$Registry->{ $root.$file->{path} } = {$_ => $file->{$_} };
			}
		} else {
			warn "No version in file '$file->{path}'\n" if $CHAT;
		}
	}
	return $root;
}




1;	# Moduel must return a true value

__END__