#!/usr/bin/perl

package PP4;

our $VERSION = '1.001';


=head1 NAME

B<pp4> ( =perl power for (anything) ) -- utilize perl power for anything

=head1 SYNOPSIS

  pp4 [-f] [Option] [PerlEqFile]

  Options
    -d DIR REG:VAR:EQ
        : Read value from DIR with regular expression(REG) match and assign EQ to VAR
    -e Statement
        : execute perl Statement
    -f
        : Not read initialize file
    -g Pattern FileName
        : Read equation from pattern matched lines
    -P VAR
        : Print VAR in perl asignment equation format
    -p VAR
        : Print value of VAR
    -S FileName
        : Output File after substitution with perl vars
    -s Text
        : Output Text after substitution with perl vars
    -u
        : Usage
   
   PerlEqFile
        PerlEqFile contaions perl statements or equations to storage data to perl var.


=head1 DESCRIPTION

B<pp4> is simple and useful utility to utilize power of perl for anything.

You can simply use perl statements to define value of data
in input file to B<pp4> (the file is called as B<PerlEqFile>).

And values of perl variables could be embedded to output with the feature of B<pp4>
given through -S or -s option.

With these features of B<pp4>, you are free from worrying about data file format and
writting data handling program. You only need to decide the value name.

All powerful features of perl can be used with B<pp4>, because
B<pp4> simply evals some inputs as perl statements.
It means that you can use more complex structured data such as array of assoc array
eg. C<$Array[2]{NAME}> for input data. 
Now you dont need to design complex format for input even when your input data is complex.

=head1 Useful Features

=head2 Order of execution

Commands are given as options to B<pp4>. 
B<pp4> executes them 
in specified order as simular as B<find> utility in unix system.


=head2 Data store and Generate output

B<pp4> uses perl variables as data storage. Data could be given in B<PerlEqFile> or as argument of some B<Option>.
Any kind of perl statements can be used in B<PerlEqFile> like the following.

  $a = 1;
  foreach (0..9){
    $b[$_] = $_ * 2;
    print STDERR $_*2,"\n";
  }
  $c{'A'}{'B'} = $a + 1;


The -p, -P, -s, and -S options generate output to STDOUT with embeddig the values of data.

The C<print> command with -e option coulud be used to output data like the following.

  pp4 -e 'open(FH,">afo")||die; foreach (0..9){ print FH "$_\n";}'


=head2 Separation of B<PerlEqFile>

Multiple B<PerlEqFile> can be specified as input to B<pp4>.
Case depend data could be devided into separate files.
And you can combine some useful small perl script files as following example.

  pp4 DataFile1.eq DataFile2.eq CalcWithMethodA.sub Output.sub
  pp4 DataFile1.eq DataFile3.eq CalcWithMethodB.sub Output.sub


=head2 Pull out data from directory name

If you should carry out case study, you might prepare some directories for each case.
The names of the directories may contain the name of case or the parameters.
With the feature of C<'-d option'>, you don't need to define case parameters in a file.
You can also pull out the value from a name of directory with C<'-d option'>
as the following. 

  pp4 -d . 'Case(\d+):X:$1' -p X

When the current directory is /hoge/Case1000, this sample define data X as 1000, and print it.


=head2 Data embedded in file name

If C<$VAR> is contained in the name of B<PerlEqFile>, C<$Var> is substituted
with the value of C<$VAR> before opening the file.
It means that you can select B<PerlEqFile> with value of data.


=head1 Extensibility

Initialize file could be executed prior to other action.
If environmental variable B<PP4RC> is set, the value of it is used for initialize file name.
Otherwize C<~/.pp4rc> is used for initialize file.
When the first option to B<pp4> is '-f' or the initialize file could not be read,
initialization will be skip.

The content of the initialize file should be perl statements like B<PerlEqFile>.
When assignment to $CmdTbl{B<NewOption>} is executed at initialization,
the B<NewOption> could be used as same as predefined options of B<pp4>.

Please refer to source code of B<pp4> to learn the way to define $CmdTbl{B<NewOption>}.

=head1 PREREQUISISTES

This script uses C<Cwd> module.

=head1 AUTHOR 

Kinsan

=head1 Last Modified

Version 1.001 : 2008/8/25

=pod SCRIPT CATEGORRIES

CPAN/Administrative
Unix/System_Administrative
File Utilities

=cut


our($UserPackage)='UserPackage';

sub Eval($)
{
	my(@a) = @_;
	my($s) = join('',@a);
	my($ret) = eval("{package $UserPackage;$s;}");

	if($@){
		print STDERR "Error in eval: $@\n";
	 	print STDERR "Source :\n$s\n";
	}
	# print STDERR "Eval: $s -> $ret\n"; # Debug
	return($ret);
}

sub Tilde2HomeDir($)
{
	my($name) = @_;
	my(@ent);

	# print STDERR "name = $name in Tilde2HomdeDir\n";

	if($name eq '~'){
		return($ENV{HOME}) if(length($ENV{HOME}) > 0);
		@ent = getpwuid($>); # $> : Effective User Id
	}else{
		@ent = getpwnam(substr($name,1));
	}
	return($ent[7]);
}


sub ReadFile($)
{
	my($fname) = @_;

	# print STDERR "ReadFile : fname=$fname\n";
	
	if($fname =~ /\$/){ # When fname include '$'
		$fname = SubstStr($fname);
	}
	$fname =~ s{^(~[^/]*)}{Tilde2HomeDir($1)}ex;

	local $/;
	open(my $fin,'<', $fname) || die "File($fname) open failed in ReadFile()\n";
	my $s = <$fin>;
	close($fin);
	return($s);
}


sub ReadEq($)
{
	Eval(ReadFile($_[0]));
}

sub ReadEqWithGrep($$)
{
	my($pat,$fname) = @_;

	# print STDERR "ReadEqWithGrep : fname=$fname\n";

	my($s);
	foreach(split( /\n/, ReadFile($fname))){
		$s .= $_ if(s/^$pat//o);
	}
	Eval($s);
}

sub SubstStr($)
{
	my($s) = @_;

	print STDERR "SubstStr: $s\n";

	my($c) = <<'EndOfC';
	$s =~ s< \\(.)											# $1
			| \${( [_a-zA-Z]\w*(?:\[[^]]+\]|{[^}]+})* )}	# $2
			| \$ ( [_a-zA-Z]\w*(?:\[[^]]+\]|{[^}]+})* ) 	# $3
	       >
		   {
			if(length($1)>0){
				$1;
			}elsif(length($2)>0){
				eval('$' . $2);
			}elsif(length($3)>0){
				eval('$' . $3);
			}
	 	   }xge;
EndOfC
	eval("{package $UserPackage;\n$c;\n}\n");

	if($@){
		print STDERR "Error at eval in SubStr(): $@\n";
	 	print STDERR "Str :\n$_[0]\n";
	}
	return($s);
}

# sub SubstAssocArray(\%)
sub SubstAssocArray
{
	my($x)=@_;
	my($s)='';

	# print STDERR "SubstAssocArray : Start\n";
	foreach $k (keys %$x){
		$s .= '$_' . $k . '="' . $x->{$k} . "\";\n";
	}
	Eval($s);

	foreach $k (keys %$x){
		$x->{$k} = SubstStr($x->{$k});
	}
	# print STDERR "SubstAssocArray : End\n";
	return($x);
}


sub SubstFile($)
{
	my($fname) = @_;
	if($fname =~ /\$/){ # When fname include '$'
		$fname = SubstStr($fname);
	}
	open(IN,$fname) || die "File($fname) open failed\n";
	while(<IN>){
		print SubstStr($_);
	}
	close(IN);
}

sub File2Array
{
	my($f) = @_;
	my(@a) = ();
	open(IN,'<', $f) || die("File($f) open failed\n");
	while(<IN>){
		chomp; s/^\s+//; s/\s+$//;
		next if(length($_) <= 0);
		push(@a,$_);
	}
	close(IN);
	return(@a);
}

use Cwd;

sub dir2var {
	my($dir,@p) = @_;
	my($r,$v,$e);
	
	if($dir eq '.'){
		$dir = getcwd();
	}

	foreach $a (@p){
		($r,$v,$e) = split(/:/,$a);
		if($dir =~ /$r/){
			Eval('$' . $v . "='" . Eval($e) . "';");
		}else{
			die "Can not find var($v) from dir. name($dir)\n";
		}
	}
}

sub PrintVar
{
	my($vname,$flag) = @_;
	my($V) = Eval( '$' . $vname );
	# print STDERR "vname,flag,V = $vname,$flag,$V\n";
	if($flag){
		print "\$$vname='$V';\n";
	}else{
		print "$V\n";
	}
}

##########################
# PP4 command table      #
##########################
%CmdTbl = (
	'f' => { cmd => sub () { print STDERR "Error : -f option should be first option\n"; return(-1) },
			 argc => 0, arg => '', desc => 'Not read initialize file' },
	'e'	=> { cmd => sub () { Eval($_[0]);		return(1) }, 
			 argc => 1, arg => 'Statement',	desc =>'execute perl Statement' },
	'S'	=> { cmd => sub () { SubstFile($_[0]);	return(1) }, 
			 argc => 1, arg => 'FileName',	desc =>'Output File after substitution with perl vars' },
	's'	=> { cmd => sub () { print SubstStr($_[0]),"\n";	return(1) }, 
			 argc => 1, arg => 'Text',	desc =>'Output Text after substitution with perl vars' },
	'g'	=> { cmd => sub () { ReadEqWithGrep($_[0], $_[1]); return(2) }, 
			 argc => 2, arg => 'Pattern FileName',	desc =>'Read equation from pattern matched lines' },
	'p'	=> { cmd => sub () { PrintVar($_[0],0);	return(1) }, 
			 argc => 1, arg => 'VAR',	desc =>'Print value of VAR' },
	'P'	=> { cmd => sub () { PrintVar($_[0],1);	return(1) }, 
			 argc => 1, arg => 'VAR',	desc =>'Print VAR in perl asignment equation format' },
	'd'	=> { cmd => sub () { dir2var($_[0],$_[1]);	return(2) }, 
			 argc => 2, arg => 'DIR REG:VAR:EQ',	desc =>'Read value from DIR with regular expression(REG) match and assign EQ to VAR' },
	'u'	=> { cmd => sub () { Usage();			return(-1) }, 
			 argc => 0, arg => '',	desc =>'Usage' },
);
# Alias to longer option name
$CmdTbl{'-eval'} =		$CmdTbl{'e'};
$CmdTbl{'-substfile'} =	$CmdTbl{'S'};
$CmdTbl{'-subststr'} =	$CmdTbl{'s'};
$CmdTbl{'-printvar'} =	$CmdTbl{'p'};
$CmdTbl{'-printvaraseq'} =	$CmdTbl{'P'};
$CmdTbl{'-dir2var'} =	$CmdTbl{'d'};
$CmdTbl{'-usage'} =	$CmdTbl{'u'};

##########################
# Usage                  #
##########################
sub Usage
{
	print <<'EndOfUsage1';
pp4: perl power for (anything)

Usage: pp4 [-f] [Option] [PerlEqFile]
  Option:
EndOfUsage1

	my($c);
	foreach $c (sort {"\U$a\E" cmp "\U$b\E"} keys %CmdTbl){
		next if($c =~ /^-/);
		print "\t-$c ", $CmdTbl{$c}{arg}, "\n";
		print "\t\t: ", $CmdTbl{$c}{desc}, "\n";
	}
	foreach $c (sort {"\U$a\E" cmp "\U$b\E"} keys %CmdTbl){
		next if($c !~ /^-/);
		print "\t-$c ", $CmdTbl{$c}{arg}, "\n";
		print "\t\t: ", $CmdTbl{$c}{desc}, "\n";
	}

	print <<'EndOfUsage2';
  PerlEqFile:
    PerlEqFile contaions perl statements or equations to storage data to perl var.

EndOfUsage2
}


##########################
######## Main ############
##########################
my($i)=0;

if($ARGV[0] eq '-f'){
	shift(@ARGV);
}else{ # Read initialize file
	my($fn);
	if(length($ENV{'PP4RC'}) > 0){
		$fn = $ENV{'PP4RC'};
	}else{
		# $fn = $ENV{HOME} . '/.pp4rc';
		$fn = Tilde2HomeDir('~') . '/.pp4rc';
	}
	# print STDERR "init!:$fn\n";
	ReadEq($fn) if(-e $fn);
}

if($#ARGV < 0){
	ReadEq('-');
	exit(0);
}

while($#ARGV >= 0){
	if($ARGV[0] =~ /^-(.*)/){
		my($opt) = $1;
		shift(@ARGV);
		if(!exists($CmdTbl{$opt})){
			Usage(); exit(0);
		}
		if($#ARGV+1 < $CmdTbl{$opt}{argc} ){
			print STDERR "Error: Not enough argument for option -$opt\n\n";
			Usage(); exit(0);
		}

		my($ac) = $CmdTbl{$opt}{cmd}(@ARGV);
		# print STDERR "opt=$opt, ac=$ac\n"; exit(2);
		exit(1) if($ac < 0);
		splice(@ARGV, 0, $ac);
	}else{
		ReadEq($ARGV[0]);
		shift(@ARGV);
	}
}