#!/usr/bin/perl -w
#
# Project Builder CMS module
# CMS subroutines brought by the the Project-Builder project
# which can be easily used by pbinit scripts
#
# $Id$
#
# Copyright B. Cornec 2007
# Provided under the GPL v2

package ProjectBuilder::CMS;

use strict 'vars';
use Data::Dumper;
use English;
use File::Basename;
use POSIX qw(strftime);
use lib qw (lib);
use ProjectBuilder::Base;
use ProjectBuilder::Conf;

# Inherit from the "Exporter" module which handles exporting functions.
 
use Exporter;
 
# Export, by default, all the functions into the namespace of
# any code which uses this module.
 
our @ISA = qw(Exporter);
our @EXPORT = qw(pb_cms_init pb_cms_export pb_cms_get_uri pb_cms_copy pb_cms_checkout pb_cms_up pb_cms_checkin pb_cms_isdiff pb_cms_get_pkg pb_cms_compliant pb_cms_log pb_cms_create_authors);

=pod

=head1 NAME

ProjectBuilder::CMS, part of the project-builder.org - module dealing with configuration management system functions suitable for pbinit calls.

=head1 DESCRIPTION

This modules provides configuration management system functions suitable for pbinit calls.

=cut

# Setup environment for CMS system for URL passed
sub pb_cms_init {

my $pbinit = shift || undef;

my ($pburl) = pb_conf_get("pburl");
pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pburl->{$ENV{'PBPROJ'}}\n");
my ($scheme, $account, $host, $port, $path) = pb_get_uri($pburl->{$ENV{'PBPROJ'}});

my ($pbprojdir) = pb_conf_get_if("pbprojdir");

if ((defined $pbprojdir) && (defined $pbprojdir->{$ENV{'PBPROJ'}})) {
	$ENV{'PBPROJDIR'} = $pbprojdir->{$ENV{'PBPROJ'}};
} else {
	$ENV{'PBPROJDIR'} = "$ENV{'PBDEFDIR'}/$ENV{'PBPROJ'}";
}

# Computing the default dir for PBDIR.
# what we have is PBPROJDIR so work from that.
# Tree identical between PBCONFDIR and PBROOTDIR on one side and
# PBPROJDIR and PBDIR on the other side.

my $tmp = $ENV{'PBROOTDIR'};
$tmp =~ s|^$ENV{'PBCONFDIR'}||;

#
# Check project cms compliance
#
pb_cms_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$pburl->{$ENV{'PBPROJ'}},$pbinit);

if ($scheme =~ /^svn/) {
	# svnversion more precise than svn info
	$tmp = `(cd "$ENV{'PBDIR'}" ; svnversion .)`;
	chomp($tmp);
	$ENV{'PBREVISION'}=$tmp;
	$ENV{'PBCMSLOGFILE'}="svn.log";
} elsif (($scheme eq "file") || ($scheme eq "ftp") || ($scheme eq "http")) {
	$ENV{'PBREVISION'}="flat";
	$ENV{'PBCMSLOGFILE'}="flat.log";
} elsif ($scheme =~ /^cvs/) {
	# Way too slow
	#$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate  -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
	#chomp($ENV{'PBREVISION'});
	$ENV{'PBREVISION'}="cvs";
	$ENV{'PBCMSLOGFILE'}="cvs.log";
	$ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
} else {
	die "cms $scheme unknown";
}

return($scheme,$pburl->{$ENV{'PBPROJ'}});
}

sub pb_cms_export {

my $uri = shift;
my $source = shift;
my $destdir = shift;
my $tmp;
my $tmp1;

my @date = pb_get_date();
# If it's not flat, then we have a real uri as source
my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);

if ($scheme =~ /^svn/) {
	if (-d $source) {
		$tmp = $destdir;
	} else {
		$tmp = "$destdir/".basename($source);
	}
	pb_system("svn export $source $tmp","Exporting $source from SVN to $tmp");
} elsif ($scheme eq "dir") {
	pb_system("cp -a $path $destdir","Copying $uri from DIR to $destdir");
} elsif (($scheme eq "http") || ($scheme eq "ftp")) {
	my $f = basename($path);
	unlink "$ENV{'PBTMP'}/$f";
	if (-x "/usr/bin/wget") {
		pb_system("/usr/bin/wget -nv -O $ENV{'PBTMP'}/$f $uri"," ");
	} elsif (-x "/usr/bin/curl") {
		pb_system("/usr/bin/curl $uri -o $ENV{'PBTMP'}/$f","Downloading $uri with curl to $ENV{'PBTMP'}/$f\n");
	} else {
		die "Unable to download $uri.\nNo wget/curl available, please install one of those";
	}
	pb_cms_export("file://$ENV{'PBTMP'}/$f",$source,$destdir);
} elsif ($scheme eq "file") {
	use File::MimeInfo; 
	my $mm = mimetype($path);
	pb_log(2,"mimetype: $mm\n");
	pb_mkdir_p($destdir);

	# Check whether the file is well formed 
	# (containing already a directory with the project-version name)
	my ($pbwf) = pb_conf_get_if("pbwf");
	if ((defined $pbwf) && (defined $pbwf->{$ENV{'PBPROJ'}})) {
		$destdir = dirname($destdir);
	}

	if ($mm =~ /\/x-bzip-compressed-tar$/) {
		# tar+bzip2
		pb_system("cd $destdir ; tar xfj $path","Extracting $path in $destdir");
	} elsif ($mm =~ /\/x-lzma-compressed-tar$/) {
		# tar+lzma
		pb_system("cd $destdir ; tar xfY $path","Extracting $path in $destdir");
	} elsif ($mm =~ /\/x-compressed-tar$/) {
		# tar+gzip
		pb_system("cd $destdir ; tar xfz $path","Extracting $path in $destdir");
	} elsif ($mm =~ /\/x-tar$/) {
		# tar
		pb_system("cd $destdir ; tar xf $path","Extracting $path in $destdir");
	} elsif ($mm =~ /\/zip$/) {
		# zip
		pb_system("cd $destdir ; unzip $path","Extracting $path in $destdir");
	}
} elsif ($scheme =~ /^cvs/) {
	# CVS needs a relative path !
	my $dir=dirname($destdir);
	my $base=basename($destdir);
	# CVS also needs a modules name not a dir
	#if (-d $source) {
		$tmp1 = basename($source);
		#} else {
		#$tmp1 = dirname($source);
		#$tmp1 = basename($tmp1);
		#}
	my $optcvs = "";

	# If we're working on the CVS itself
	my $cvstag = basename($ENV{'PBROOTDIR'});
	my $cvsopt = "";
	if ($cvstag eq "cvs") {
		my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
		$cvsopt = "-D \"$pbdate\"";
	} else {
		# we're working on a tag which should be the last part of PBROOTDIR
		$cvsopt = "-r $cvstag";
	}
	pb_system("cd $dir ; cvs -d $account\@$host:$path export $cvsopt -d $base $tmp1","Exporting $tmp1 from $source under CVS to $destdir");
} else {
	die "cms $scheme unknown";
}
}

# This function is only called with a real CMS system
sub pb_cms_get_uri {

my $scheme = shift;
my $dir = shift;

my $res = "";
my $void = "";

if ($scheme =~ /^svn/) {
	open(PIPE,"LANGUAGE=C svn info $dir |") || return("");
	while (<PIPE>) {
		($void,$res) = split(/^URL:/) if (/^URL:/);
	}
	$res =~ s/^\s*//;
	close(PIPE);
	chomp($res);
} elsif ($scheme =~ /^cvs/) {
	# This path is always the root path of CVS, but we may be below
	open(FILE,"$dir/CVS/Root") || die "$dir isn't CVS controlled";
	$res = <FILE>;
	chomp($res);
	close(FILE);
	# Find where we are in the tree
	my $rdir = $dir;
	while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
		$rdir = dirname($rdir);
	}
	die "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
	#compute our place under that root dir - should be a relative path
	$dir =~ s|^$rdir||;
	my $suffix = "";
	$suffix = "$dir" if ($dir ne "");

	my $prefix = "";
	if ($scheme =~ /ssh/) {
		$prefix = "cvs+ssh://";
	} else {
		$prefix = "cvs://";
	}
	$res = $prefix.$res.$suffix;
} else {
	die "cms $scheme unknown";
}
pb_log(2,"Found CMS info: $res\n");
return($res);
}

sub pb_cms_copy {
my $scheme = shift;
my $oldurl = shift;
my $newurl = shift;

if ($scheme =~ /^svn/) {
	pb_system("svn copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
} elsif ($scheme eq "flat") {
} elsif ($scheme =~ /^cvs/) {
} else {
	die "cms $scheme unknown";
}
}

sub pb_cms_checkout {
my $scheme = shift;
my $url = shift;
my $destination = shift;

if ($scheme =~ /^svn/) {
	pb_system("svn co $url $destination","Checking out $url to $destination ");
} elsif (($scheme eq "ftp") || ($scheme eq "http")) {
	return;
} elsif ($scheme =~ /^cvs/) {
	pb_system("cvs co $url $destination","Checking out $url to $destination ");
} else {
	die "cms $scheme unknown";
}
}

sub pb_cms_up {
my $scheme = shift;
my $dir = shift;

if ($scheme =~ /^svn/) {
	pb_system("svn up $dir","Updating $dir");
} elsif ($scheme eq "flat") {
} elsif ($scheme =~ /^cvs/) {
} else {
	die "cms $scheme unknown";
}
}

sub pb_cms_checkin {
my $scheme = shift;
my $dir = shift;

my $ver = basename($dir);
if ($scheme =~ /^svn/) {
	pb_system("svn ci -m \"updated to $ver\" $dir","Checking in $dir");
} elsif ($scheme eq "flat") {
} elsif ($scheme =~ /^cvs/) {
} else {
	die "cms $scheme unknown";
}
pb_cms_up($scheme,$dir);
}

sub pb_cms_isdiff {
my $scheme = shift;
my $dir =shift;

if ($scheme =~ /^svn/) {
	open(PIPE,"svn diff $dir |") || die "Unable to get svn diff from $dir";
	my $l = 0;
	while (<PIPE>) {
		$l++;
	}
	return($l);
} elsif ($scheme eq "flat") {
} elsif ($scheme =~ /^cvs/) {
	open(PIPE,"cvs diff $dir |") || die "Unable to get svn diff from $dir";
	my $l = 0;
	while (<PIPE>) {
		# Skipping normal messages
		next if (/^cvs diff:/);
		$l++;
	}
	return($l);
} else {
	die "cms $scheme unknown";
}
}

# 
# Return the list of packages we are working on in a CMS action
#
sub pb_cms_get_pkg {

my @pkgs = ();
my $defpkgdir = shift || undef;
my $extpkgdir = shift || undef;

# Get packages list
if (not defined $ARGV[0]) {
	@pkgs = keys %$defpkgdir if (defined $defpkgdir);
} elsif ($ARGV[0] =~ /^all$/) {
	@pkgs = keys %$defpkgdir if (defined $defpkgdir);
	push(@pkgs, keys %$extpkgdir) if (defined $extpkgdir);
} else {
	@pkgs = @ARGV;
}
pb_log(0,"Packages: ".join(',',@pkgs)."\n");
return(\@pkgs);
}

#
# Check pbconf/project cms compliance
#
sub pb_cms_compliant {

my $param = shift;
my $envar = shift;
my $defdir = shift;
my $uri = shift;
my $pbinit = shift;
my %pdir;

my ($pdir) = pb_conf_get_if($param) if (defined $param);
if (defined $pdir) {
	%pdir = %$pdir;
}


if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
	# That's always the environment variable that will be used
	$ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
} else {
	if (defined $param) {
		pb_log(1,"WARNING: no $param defined, using $defdir\n");
		pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
		pb_log(1,"         if you want to use another directory\n");
	}
	$ENV{$envar} = "$defdir";
}

# Expand potential env variable in it
eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
pb_log(2,"$envar: $ENV{$envar}\n");

my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);

if ((! -d "$ENV{$envar}") || (defined $pbinit)) {
	if (defined $pbinit) {
		pb_mkdir_p("$ENV{$envar}");
	} else {
		pb_log(1,"Checking out $uri\n");
		pb_cms_checkout($scheme,$uri,$ENV{$envar});
	}
} elsif (($scheme !~ /^cvs/) || ($scheme !~ /^svn/)) {
	# Do not compare if it's not a real cms
	return;
} else {
	pb_log(1,"$uri found locally, checking content\n");
	my $cmsurl = pb_cms_get_uri($scheme,$ENV{$envar});
	my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
	if ($cmsurl ne $uri) {
		# The local content doesn't correpond to the repository
		pb_log(0,"ERROR: Inconsistency detected:\n");
		pb_log(0,"       * $ENV{$envar} refers to $cmsurl but\n");
		pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
		die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
	} else {
		pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
		# they match - do nothing - there may be local changes
	}
}
}

sub pb_cms_create_authors {

my $authors=shift;
my $dest=shift;
my $scheme=shift;

return if ($authors eq "/dev/null");
open(SAUTH,$authors) || die "Unable to open $authors";
# Save a potentially existing AUTHORS file and write instead toi AUTHORS.pb 
my $ext = "";
if (-f "$dest/AUTHORS") {
	$ext = ".pb";
}
open(DAUTH,"> $dest/AUTHORS$ext") || die "Unable to create $dest/AUTHORS$ext";
print DAUTH "Authors of the project are:\n";
print DAUTH "===========================\n";
while (<SAUTH>) {
	my ($nick,$gcos) = split(/:/);
	chomp($gcos);
	print DAUTH "$gcos";
	if (defined $scheme) {
		# Do not give a scheme for flat types
		my $endstr="";
		if ("$ENV{'PBREVISION'}" ne "flat") {
			$endstr = " under $scheme";
		}
		print DAUTH " ($nick$endstr)\n";
	} else {
		print DAUTH "\n";
	}
}
close(DAUTH);
close(SAUTH);
}

sub pb_cms_log {

my $scheme = shift;
my $pkgdir = shift;
my $dest = shift;
my $chglog = shift;
my $authors = shift;

pb_cms_create_authors($authors,$dest,$scheme);

if ($scheme =~ /^svn/) {
	if (! -f "$dest/ChangeLog") {
		if (-x "/usr/bin/svn2cl") {
			# In case we have no network, just create an empty one before to allow correct build
			open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
			close(CL);
			pb_system("/usr/bin/svn2cl --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
		} else {
			# To be written from pbcl
			pb_system("svn log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
		}
	}
} elsif (($scheme eq "file") || ($scheme eq "dir") || ($scheme eq "http") || ($scheme eq "ftp")) {
	if (! -f "$dest/ChangeLog") {
		pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
	}
} elsif ($scheme =~ /^cvs/) {
	my $tmp=basename($pkgdir);
	# CVS needs a relative path !
	if (! -f "$dest/ChangeLog") {
		if (-x "/usr/bin/cvs2cl") {
			# In case we have no network, just create an empty one before to allow correct build
			open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
			close(CL);
			pb_system("/usr/bin/cvs2cl --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
		} else {
			# To be written from pbcl
			pb_system("cvs log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
		}
	}
} else {
	die "cms $scheme unknown";
}
}

1;