source: ProjectBuilder/devel/pb/lib/ProjectBuilder/CMS.pm@ 500

#!/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 File::Copy;
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_add);

=pod

=head1 NAME

ProjectBuilder::CMS, part of the project-builder.org

=head1 DESCRIPTION

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

=head1 USAGE

=over 4

=item B<pb_cms_init>

This function setup the environment for the CMS system related to the URL given by the pburl configuration parameter.
The potential parameter indicates whether we should inititate the context or not.
It sets up environement variables (PBPROJDIR, PBDIR, PBREVISION, PBCMSLOGFILE) 

=cut

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'}});
}

=item B<pb_cms_export>

This function exports a CMS content to a directory.
The first parameter is the URL of the CMS content.
The second parameter is the directory in which it is locally exposed (result of a checkout). If undef, then use the original CMS content.
The third parameter is the directory where we want to deliver it (result of export).

=cut

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 (defined $source) {
        if (-d $source) {
            $tmp = $destdir;
        } else {
            $tmp = "$destdir/".basename($source);
        }
        pb_system("svn export $source $tmp","Exporting $source from SVN to $tmp");
    } else {
        pb_system("svn export $uri $destdir","Exporting $uri from SVN to $destdir");
    }
} 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);

    if (defined $source) {
        # 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");
    } else {
        # simple file: copy it (patch e.g.)
        copy($path,$destdir);
    }
} elsif ($scheme =~ /^cvs/) {
    # CVS needs a relative path !
    my $dir=dirname($destdir);
    my $base=basename($destdir);
    if (defined $source) {
        # CVS also needs a modules name not a dir
        $tmp1 = basename($source);
    } else {
        # Probably not right, should be checked, but that way I'll notice it :-)
        $tmp1 = $uri;
    }
    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";
}
}

=item B<pb_cms_get_uri>

This function is only called with a real CMS system and gives the URL stored in the checked out directory.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the directory in which it is locally exposed (result of a checkout).

=cut

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);
}

=item B<pb_cms_copy>

This function copies a CMS content to another.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the URL of the original CMS content.
The third parameter is the URL of the destination CMS content.

Only coded for SVN now.

=cut

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";
}
}

=item B<pb_cms_checkout>

This function checks a CMS content out to a directory.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the URL of the CMS content.
The third parameter is the directory where we want to deliver it (result of export).

=cut

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 ");
} elsif ($scheme =~ /^file/) {
    pb_cms_export($url,undef,$destination);
} else {
    die "cms $scheme unknown";
}
}

=item B<pb_cms_up>

This function updates a local directory with the CMS content.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the directory to update.

=cut

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/) {
    pb_system("cvs up $dir","Updating $dir");
} else {
    die "cms $scheme unknown";
}
}

=item B<pb_cms_checkin>

This function updates a CMS content from a local directory.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the directory to update from.
The third parameter indicates if we are in a new version creation (undef) or in a new project creation (1)

=cut

sub pb_cms_checkin {
my $scheme = shift;
my $dir = shift;
my $pbinit = shift || undef;

my $ver = basename($dir);
my $msg = "updated to $ver";
$msg = "Project $ENV{PBPROJ} creation" if (defined $pbinit);

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

=item B<pb_cms_add>

This function adds to a CMS content from a local directory.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the directory/file to add.

=cut

sub pb_cms_add {
my $scheme = shift;
my $f = shift;

if ($scheme =~ /^svn/) {
    pb_system("svn add $f","Adding $f to SVN");
} elsif ($scheme eq "flat") {
} elsif ($scheme =~ /^cvs/) {
    pb_system("cvs add $f","Adding $f to CVS");
} else {
    die "cms $scheme unknown";
}
pb_cms_up($scheme,$f);
}

=item B<pb_cms_isdiff>

This function returns a integer indicating the number f differences between the CMS content and the local directory where it's checked out.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the directory to consider.

=cut

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";
}
}

=item B<pb_cms_getpkg>

This function returns the list of packages we are working on in a CMS action.
The first parameter is the default list of packages from the configuration file.
The second parameter is the optional list of packages from the configuration file.

=cut

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);
}

=item B<pb_cms_compliant>

This function checks the compliance of the project and the pbconf directory.
The first parameter is the key name of the value that needs to be read in the configuration file.
The second parameter is the environment variable this key will populate.
The third parameter is the location of the pbconf dir.
The fourth parameter is the URI of the CMS content related to the pbconf dir.
The fifth parameter indicates whether we should inititate the context or not.

=cut

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
    }
}
}

=item B<pb_cms_create_authors>

This function creates a AUTHORS files for the project. It call it AUTHORS.pb if an AUTHORS file already exists.
The first parameter is the source file for authors information.
The second parameter is the directory where to create the final AUTHORS file.
The third parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)

=cut

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 to 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);
}

=item B<pb_cms_log>

This function creates a ChangeLog file for the project.
The first parameter is the schema of the CMS systems (svn, cvs, svn+ssh, ...)
The second parameter is the directory where the CMS content was checked out.
The third parameter is the directory where to create the final ChangeLog file.
The fourth parameter is unused.
The fifth parameter is the source file for authors information.

It may use a tool like svn2cl or cvs2cl to generate it if present, or the log file from the CMS if not.

=cut


sub pb_cms_log {

my $scheme = shift;
my $pkgdir = shift;
my $dest = shift;
my $chglog = shift;
my $authors = shift;
my $testver = shift || undef;

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

if ((defined $testver) && (defined $testver->{$ENV{'PBPROJ'}}) && ($testver->{$ENV{'PBPROJ'}} =~ /true/i)) {
    if (! -f "$dest/ChangeLog") {
        open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
        # We need a minimal version for debian type of build
        print CL "\n";
        print CL "\n";
        print CL "\n";
        print CL "\n";
        print CL "1990-01-01  none\n";
        print CL "\n";
        print CL "        * test version\n";
        print CL "\n";
        close(CL);
        pb_log(0,"Generating fake ChangeLog for test version\n");
        open(CL,"> $dest/$ENV{'PBCMSLOGFILE'}") || die "Unable to create $dest/$ENV{'PBCMSLOGFILE'}";
        close(CL);
    }
}

if ($scheme =~ /^svn/) {
    if (! -f "$dest/ChangeLog") {
        # 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);
        if (-x "/usr/bin/svn2cl") {
            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") {
        # 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);
        if (-x "/usr/bin/cvs2cl") {
            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";
}
}

=back 

=head1 WEB SITES

The main Web site of the project is available at L<http://www.project-builder.org/>. Bug reports should be filled using the trac instance of the project at L<http://trac.project-builder.org/>.

=head1 USER MAILING LIST

None exists for the moment.

=head1 AUTHORS

The Project-Builder.org team L<http://trac.project-builder.org/> lead by Bruno Cornec L<mailto:bruno@project-builder.org>.

=head1 COPYRIGHT

Project-Builder.org is distributed under the GPL v2.0 license
described in the file C<COPYING> included with the distribution.

=cut

1;