#!/usr/bin/perl
#
# A script to make widgets out of a test-suite directory checkout
# harig@opera.com - 20100716
#
use strict;
use warnings;
use Cwd;
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
use XML::TreePP;

my $debug = 1;
my $wkdir = "";
my $deep = 1; #we want recursive runs
my $ctr = 0;
my $SCDIR = cwd();
my $testsFor = "config.xml";
my @tests;
# widget name prefix
my $nprefix = "";
my $fnTestData = "";
my $tpp;
my $tdTree;
my $ncount = 0;
my $addLicense = 1;
my $overwrite = 0;
my $updatesrc = 0;
my $reXcludes = qr{^(?:.+\.wgt|CVS|\.+\w?)$};

# parse command line options and populate relevant variables
my $i = 0;
if ($#ARGV < 1) 
{
    print "\nUsage: \n-d directory containing tests (absolute or relative path) *required\n-n prefix for test widget files\n-x overwrite already existing widget in folder\n-t path to the XML file with test case id-s and widget names).\n-u Update the XML file with generated file names\n";
    exit;
}

while(my $cr = $ARGV[$i]) 
{
    if ($cr eq "-d") 
    {
	if ($ARGV[$i+1] =~ m{^((?:[a-zA-Z]:|)[\\/])?([-\w\d\.]+[/\\]?)+$} && $ARGV[$i+1] !~ m{^(?:(?:[a-zA-Z]:|)\\\/)?[*?|><;].*$})
	{
	    chop $ARGV[$i + 1] if ($ARGV[$i + 1] =~ m{[\/]$});
	    $wkdir = $ARGV[$i+1];
	    # normalise
	    $wkdir =~ s{\\}{\/}g;
	    if (substr ($wkdir , -1) eq "/")
	    {
		chop ($wkdir);
	    }
	    if ($wkdir !~ qr/^(?:[a-z]:)?\//i)
	    {
		$wkdir = $SCDIR.'/'.$wkdir;
	    }
	    $i++;
	    next;
	}
	else
	{
	    print 'Invalid directory to work; got '.$ARGV[$i+1];
	    exit;
	}
    }
    elsif ($cr eq "-t") 
    {
	if ($ARGV[$i+1] =~ m{^((?:[a-zA-Z]:|)[\\/])?([-\w\d\.]+[/\\]?)+\.xml$} && $ARGV[$i+1] !~ m{^(?:(?:[a-zA-Z]:|)\\\/)?[*?|><;].*$})
	{
	    chop $ARGV[$i + 1] if ($ARGV[$i + 1] =~ m{[\/]$});
	    $fnTestData = $ARGV[$i+1];
	    # normalise
	    $fnTestData =~ s{\\}{\/}g;
	    if ($fnTestData !~ qr/^(?:[a-z]:)?\//i)
	    {
		$fnTestData = $SCDIR.'/'.$fnTestData;
	    }
	    $i++;
	    next;
	}
	else
	{
	    print 'Invalid test data file:'.$ARGV[$i+1] . "\nWill not write the data.\n";
	    $fnTestData = "";
	}
    }
    elsif ($cr eq "-n") 
    {
	if ($ARGV[$i+1] =~ m{^[\w-]+$})
	{
	    $nprefix = $ARGV[$i + 1];
	}
    }
    elsif ($cr eq "-x") 
    {
	$overwrite = 1;
    }
    elsif ($cr eq "-u") 
    {
	$updatesrc = 1;
    }
    $i++;
}

if (-d $wkdir)
{
    push (@tests, $wkdir);
}
else
{
   die "Not able to run tests from a directory not existing.\n";
}

if (-f $fnTestData)
{
	$tpp = XML::TreePP->new();
	open my $tdfh, "<", $fnTestData or die "Could not open $fnTestData to read.\n";
	my $ss = "";
	$ss .= $_ while (<$tdfh>);
	close $tdfh;
	$tdTree = $tpp->parse($ss) if ($ss ne "");
	undef ($tdTree) if ($ss eq "");
}
else
{
    warn "Test data file does not exist.\n";
}


for my $t (@tests)
{
    mkwidgets ($t);
}

if ($updatesrc)
{
    my $fnTDout = $fnTestData;
    $fnTDout =~ s!\.xml$!-new.xml!;
    if($tpp->writefile($fnTDout, $tdTree, 'utf-8'))
    {print "New testsuite data file: $fnTDout\n";}
    else 
    {print "Failed to write updated testdata to $fnTDout\n";}
}

exit(0);

################ SUBS ######################
sub mkwidgets
{
    $ctr++;
    die 'Too much recursion, quitting here..' if ($ctr > 1000);
    my $pdir = shift;
    print 'Looking into '.$pdir." for more directories and files.\n" if ($debug);	
    # skip locales directories too
    if (-d $pdir && $pdir !~ m{locales$|\.svn$|CVS$}i)
    {
	opendir(my $dh, $pdir) or die 'Could not open the directory specified.'.$!;
	my @ls = readdir($dh);
	my $tstr = join("|", @ls);
	print "Files in the directory: $tstr \n" if ($debug);
	closedir($dh);
	# if we can see the hint file here pass this directory to the widget make method
	my $lMatch = qr/(?:|\|)${testsFor}(?:|\|)/;
	$lMatch =~ s/\./\\./g;
	if ($tstr =~ $lMatch)
	{
	    print "Found $testsFor in the directory $pdir \n" if ($debug);
	    $ncount++;
	    my $wgtName = "";
	    if ($nprefix ne "")
	    {
		$wgtName = $nprefix .'-'.$ncount .'.wgt';
	    }
	    else
	    {
		# if we have a test-suite.xml which tells us about the widget name
		# get the name from it
		if (defined($tdTree))
		{
		    my $testRef;
		    my $testNum;
		    # scoping for $1
		    {
			# reference is derived from the file path
			$pdir =~ m!/([\w-]+)/([\w+-]+)/?$!;
			print 'Test ref: 1:' . $1 . "\n"  if $debug;
			$testRef = $1 if (defined $1);
			$testNum = $2 if (defined $2);
			$testNum = "001" if(not $testNum);
		    }
		    if (defined $testRef)
		    {
			# 'test' element; 'for' attribute gives the ref.id
			for my $el (@{$tdTree->{testsuite}->{test}})
			{
			    my $src = $el->{"-src"} if (index($el->{"-src"}, $testRef . '/'. $testNum . '/') != -1); #  eq $testRef);
			    next if (not defined $src);
#			    $pdir =~ m!/([\w-]+)/([\w+-]+)/$!;
#			    print '1:' . $1 . '2:' . $2 if $debug;
#			    $wgtName = substr($testRef, 0, 5); # if (defined $1);
#			    $wgtName .= '-' . substr($testNum, 0, 4); # if (defined $2);
			    if ($updatesrc)
			    {
				$wgtName = substr($testRef, 0, 5); # if (defined $1);
				$wgtName .= '-' . substr($testNum, 0, 4); # if (defined $2);
				$wgtName =~ s![-]+!-!;
				$wgtName.= '.wgt';
				$wgtName = lc($wgtName);
				$el->{"-src"} =~ s!/[^/]+\.wgt$!/$wgtName!;
				print "Updated source is : " . $el->{"-src"} . ", widget name: " . $wgtName . "\n" if $debug;
			    }
			    else
			    {
				# the last segment of path; could be anything like foo.wgt, foo.test, or foo
				$src =~ m!^([\.\w\/-]+)/([\.\w-]+?)$!;
				next if (not defined $1 || not defined $2);
				next if (index ($pdir, substr($1, index($1, $testRef))) == -1);
				$wgtName = $2;
			    }
			    last;
			}
			print "Note: could not find the reference for this test-case directory in test-suite.xml\n[$pdir]\n" if ($wgtName eq "");
		    }
		}
		if ($wgtName eq "")
		{
		    # get the widget name using the last 2 segments of $pdir
		    $pdir =~ m!/([\w-]+)/([\w+-]+)/?$!;
		    print '1:' . $1 . '2:' . $2 if $debug;
		    $wgtName = substr($1, 0, 5) if (defined $1);
		    $wgtName .= '-' . substr($2, 0, 4) if (defined $2);
		    $wgtName =~ s![-]+!-!;
		    $wgtName.= '.wgt';
		}
		# fallback
		if ($wgtName eq "")
		{
		    $wgtName = 't-'. $ncount;
		    $wgtName.= '.wgt';
		}
	    }
	    my $mkR = getWidget($pdir, $pdir. '/' . $wgtName);
	    if (defined $mkR)
	    {
		print "Created widget - ${pdir}/${wgtName}\n" if ($mkR == 1);
		print "Using the widget in the folder - $pdir\n" if ($mkR == 2);
	    }
	    else
	    {
		warn ("Could not make widget.\n");
	    }
	}
	else
	{
	    # else try to find the hint file in sub directories
	    foreach my $cdir (@ls)
	    {
		$wkdir = $pdir.'/'.$cdir;
		if (-d $wkdir && ($cdir !~ m{^(?:\.+\w*|locales|CVS)$}))
		{
		    print "Added $cdir to the list of potential widget folders.\n" if ($debug);
		    push (@tests, $wkdir);
		}
	    }
	}
    }
    else
    {
	print STDERR "Directory given, $wkdir does not exist.\n";
    }
}

my $z;
sub getWidget
{
    my $dirin  = shift;
    my $filename = shift;
    my $base = shift;
    my $level = shift;
    $filename = $dirin ."/t.wgt" if (not defined $filename);
    $base = "" if (not defined $base);
    $level = 0 if (not defined $level);
    print "Directory-  $dirin , Filename - $filename , base - $base , level - $level\n" if ($debug);
    if (-d $dirin){
	print "Inside $dirin for a widget.\n" if $debug;
	opendir ( my $dh, $dirin ) or die "Could not open directory for reading.$!";
	my @files = grep { /^[^\.]/ } readdir($dh);
	closedir($dh);
	my $tstr = join("|", @files);
	# there is a .wgt file, use it rather than packing one
	if (!$overwrite && !$level && $tstr =~ qr{(?:|\|)[\w\.-]+\.wgt(?!\.)(?:|\|)})
	{
	    print "Has a widget in the folder, will use it\n" if $debug;
	    return 2;
	}
	if (!$level)
	{
	    $z = Archive::Zip->new();
	}
	my $i = 0;
	while (defined $files[$i] && -e $dirin.'/'.$files[$i])
	{
	    # if ($files[$i] =~ m!^(CVS|\.+\w*)$!i)
	    if ($files[$i] =~ $reXcludes)
	    {
		$i++;
		next;
	    }
	    my $ffname = $dirin.'/'.$files[$i];
	    print "File: $i, $ffname \n" if $debug;
	    if (-d $ffname)
	    {
		print "Adding sub-directory '${files[$i]}' to $filename\n"  if ($debug); 
		getWidget($ffname, $filename, ($base ? ($base .'/') : "").$files[$i], $level+1) ;
		$i++;
		next;
	    }
	    open my $fh, "<", $ffname or warn "Could not read from $files[$i]\n"; 
	    my $fcontents = "";
	    while (defined (my $line = readline($fh)))
	    {
		$fcontents .= $line;
	    }
	    close $fh;
	    my $f = $z->addString($fcontents, ($base ? ($base .'/') : "") . $files[$i]);
	    $f->desiredCompressionMethod( COMPRESSION_DEFLATED );
	    $i++;
	}
	#  Add license file.
	if (!$level && $addLicense)
	{
	    if (not -e $dirin .'/LICENSE')
	    {
		open my $lfile, ">", $dirin .'/LICENSE';
		print $lfile "Copyright and contributions: see http://dev.w3.org/2006/waf/widgets/test-suite/";
		close $lfile;
		my $license = $z->addString("Copyright and contributions: see http://dev.w3.org/2006/waf/widgets/test-suite/", "LICENSE");
		$license->desiredCompressionMethod( COMPRESSION_DEFLATED );
	    }
	}
	$z->writeToFileNamed($filename) if (!$level);
	return 1;
    }else{
	print STDERR "Argument passed to getWidget is not a directory.\n";
	return 0;
    }
}