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

#!/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-2016
# Eric Anderson's changes are (c) Copyright 2012 Hewlett Packard
# Provided under the GPL v2

package ProjectBuilder::CMS;

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

# Inherit from the "Exporter" module which handles exporting functions.
 
use vars qw($VERSION $REVISION @ISA @EXPORT);
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_get_pkg pb_cms_get_real_pkg pb_cms_log);
($VERSION,$REVISION) = pb_version_init();

=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_get_pkg>

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;
my $extpkgdir = shift;

# 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_get_real_pkg>

This function returns the real name of a virtual package we are working on in a CMS action.
It supports the following types: perl.
The first parameter is the virtual package name

=cut

sub pb_cms_get_real_pkg {

my $pbpkg = shift;
my $dtype = shift;
my $pbpkgreal = $pbpkg;

my @nametype = pb_conf_get_if("namingtype");
my $type = $nametype[0]->{$pbpkg};
if (defined $type) {
    if ($type eq "perl") {
        if ($dtype eq "rpm") {
            $pbpkgreal = "perl-".$pbpkg;
        } elsif ($dtype eq "deb") {
            # Only lower case allowed in Debian
            # Cf: http://www.debian.org/doc/debian-policy/ch-controlfields.html#s-f-Package
            $pbpkgreal = "lib".lc($pbpkg)."-perl";
        } elsif ($dtype eq "ebuild") {
            $pbpkgreal = $pbpkg;
        } elsif ($dtype eq "hpux") {
            $pbpkgreal = $pbpkg;
        } elsif ($dtype eq "pkg") {
            $pbpkgreal = "PB$pbpkg";
        } else {
            die "pb_cms_get_real_pkg not implemented for $dtype yet";
        }
    } else {
        die "nametype $type not implemented yet";
    }
}

pb_log(2,"pb_cms_get_real_pkg returns $pbpkgreal\n");
return($pbpkgreal);
}

=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;

pb_cms_create_authors($authors,$dest,$scheme);
my $vcscmd = pb_vcs_cmd($scheme);

if ((defined $testver) && (defined $testver->{$ENV{'PBPROJ'}}) && ($testver->{$ENV{'PBPROJ'}} =~ /true/i)) {
    if (! -f "$dest/ChangeLog") {
        open(CL,"> $dest/ChangeLog") || confess "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 (! -f "$dest/ChangeLog") {
    if ($scheme =~ /^svn/) {
        # 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);
        my $command = pb_check_req("svn2cl",1);
        if ((defined $command) && (-x $command)) {
            pb_system("$command --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
        } else {
            # To be written from pbcl
            pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
        }
    } elsif ($scheme =~ /^svk/) {
        pb_system("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVK");
    } elsif ($scheme =~ /^hg/) {
        # 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("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from Mercurial");
    } elsif ($scheme =~ /^git/) {
        # 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("$vcscmd log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from GIT");
    } elsif ($scheme =~ /^(flat)|(ftp)|(http)|(https)|(file)|(dir)\b/o) {
        pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
    } elsif ($scheme =~ /^cvs/) {
        my $tmp=basename($pkgdir);
        # CVS needs a relative path !
        # 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);
        my $command = pb_check_req("cvs2cl",1);
        if (-x $command) {
            pb_system("$command --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
        } else {
            # To be written from pbcl
            pb_system("$vcscmd log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
        }
    } else {
        die "cms $scheme unknown";
    }
}
if (! -f "$dest/ChangeLog") {
    copy("$dest/$ENV{'PBCMSLOGFILE'}","$dest/ChangeLog");
}
}

=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;