path: root/rpmbuildupdate

#!/usr/bin/perl -w
#
# rpmbuildupdate by Julien Danjou
#
# Copyright (c) 2003-2004 by MandrakeSoft
#
# Permission to use, copy, modify, and distribute this software and its
# documentation under the terms of the GNU General Public License is hereby 
# granted. No representations are made about the suitability of this software 
# for any purpose. It is provided "as is" without express or implied warranty.
# See the GNU General Public License for more details.
#
# $Id$

# TODO
# do not hardcode sudo urpmi command ( to use --deps on cluster )
# rework configuration option
# add debian url ( like gnome or rh ) => cannot be done i think
# use more Hdlist ( see Hdlist->build() )

use strict;
use AppConfig;

use File::Copy; 
use MDK::Common::File qw(:all);
use Cwd;
use File::Spec;
use Hdlist;

my %config;

my ($log, $top, $rpm);

sub system_die {
    my ($command, $message) = @_;
    $message ||= "$command failed";
    # do not forget , return value of 1 means failure in unix
    system($command) and die $message;
}



sub file_not_found {
    my ($basename) = @_;
    ! -f $basename and return 1;
    # sometimes, the webserver return a webpage when the file is not found, instead of letting wget fails
    # see wget http://www.wesnoth.org/files/wesnoth-0.7.1.tar.bz2 
    # So if the file is a html page, then it is a error and it should be removed.
    is_html($basename) and do { rm_rf($basename); return 1 };
    return 0;
}

sub is_html {
    my ($basename) = @_;
    `file $basename` =~ /HTML/i and return 1;
    return 0;
}

sub download {
    my $wget = "wget -N -q";
    my ($url)=@_;
    my $temp = basename($url);
    print "Trying to fetch $url...\n";
    system("$wget $url;");
    -f $temp && ! is_html($temp) && $temp !~ /.bz2$/ && system_die("bzme -F $temp", "Cannot convert $temp");  
}

sub fetch {
    my ($url) = @_;
    # if you add a handler here, do not forget to add it to the body of build()
    return fetch_http($url) if $url =~ m!^(ftp|https?)://!;
    return fetch_svn($url) if $url =~ m!^svns?://!; 
}

sub fetch_svn {
    my ($url) = @_;
    my ($basename, $repos);
   
    $basename = basename($url);
    ($repos = $url) =~ s|/$basename$||;
    $repos =~ s/^svn/http/;
    die "Cannot extract revision number from the name." if $basename !~ /^(.*)-([^-]*rev)(\d\d*).tar.bz2$/;
    my ($name, $prefix, $release) = ($1, $2, $3);
    my $dir="$ENV{TMP}/rpmbuildupdate-$$"; 
    my $current_dir = cwd();
    mkdir $dir or die "Cannot create dir $dir";
    chdir $dir or die "Cannot change dir to $dir";
    system_die("svn co -r $release $repos", "svn checkout failed on $repos");
    my $basedir = basename($repos);
   
    # FIXME quite inelegant, should use a dedicated cpan module.
    my $complete_name = "$name-$prefix$release";
    move($basedir, $complete_name);
    system_die("find $complete_name -name '.svn' | xargs rm -Rf");
    system_die("tar -cjf $complete_name.tar.bz2 $complete_name", "tar failed");
    system_die("mv -f $complete_name.tar.bz2 $current_dir");
    chdir $current_dir;
}

sub fetch_http {
    my ($url) = @_;
    my $basename = basename($url);
    my $turl;

    rm_rf($basename) if $config{nobuild};
    
    download($url);
    foreach ('.tar.gz', '.tgz', '.zip') { 
	($turl = $url) =~ s/\.tar\.bz2/$_/;
	download($turl) if file_not_found($basename);
    }
    return ! file_not_found($basename);
}


sub fill_global_variable {
    my ($pkgrpm) = @_;
    $top = $config{top} || Hdlist::expand('%_topdir');
    chomp($top);
    if ($config{log}) {
	my $basename = basename($pkgrpm);
	mkdir_p("$top/log");
	my $logfile = "$top/log/${basename}.log";
	$log = " >> $logfile 2>&1";
	print "Logs are in $logfile\n";
    } else {
	$log = "";
    }
    #TODO replace with perl-hdlist
    Hdlist::add_macro("_topdir $top");
    $rpm =  qq(rpm --define  "_topdir $top");
    $config{sourcedir} =  Hdlist::expand('%_sourcedir');
    chomp( $config{sourcedir}); #"$top/SOURCES";
}


sub build_from_spec {
    my ($spec_path, $newversion) = @_;
    #TODO replace with perl-hdlist binding
    my $rpm_tag = (split(/\n/,`rpm -q  $config{rpmoption}  --queryformat  '%{NAME} %{VERSION} %{RELEASE}\n' --specfile $spec_path`))[0];
    my ($pkg, $version, $release) = split(/ /, $rpm_tag);
    fill_global_variable($pkg);
    $spec_path = File::Spec->rel2abs($spec_path);
    
    chdir($config{sourcedir}) or die "Unable to chdir to $config{sourcedir}";
    build($spec_path,$pkg,$version,$release,$newversion);
}

sub build_from_repository {
    my ($pkg, $newversion) = @_;
    my $pkgrpm;

    foreach my $srpm_dir (split(/,/, $config{srpms})) {
	opendir(MP, $srpm_dir) or die "$srpm_dir is not a directory";
	my @rpms = readdir(MP);
	foreach (@rpms) {
	    if (/^\Q$pkg\E-[^-]+-[^-]+\.\w+\.rpm/) {
		$pkgrpm = "$srpm_dir/$_";
		last;
	    }
	}
	closedir(MP);
	last if $pkgrpm;
    }	
    unless ($pkgrpm) {
	print "Package $pkg has no source, skipping.\n\n";
	return;
    }
    build_from_src($pkgrpm,$newversion);
}

sub build_from_src {
    my ($pkgrpm, $newversion) = @_;

    $pkgrpm = File::Spec->rel2abs($pkgrpm);
    fill_global_variable($pkgrpm);
    my $found = 0;
    my ($name, $version, $release);
   
    chdir($config{sourcedir}) or die "Unable to chdir to $config{sourcedir}";
    
    my $pkgrpm_basename = basename($pkgrpm);
    if ($pkgrpm_basename =~ /^(.*)-([^-]+)-([^-]+)\.\w+\.rpm/) {
	$name    = $1;
	$version = $2;
	$release = $3;
    } else {
	die "Cannot parse the name of rpm $pkgrpm_basename";
    }
    
    if ($config{deps}) {
	system_die("sudo /usr/sbin/urpmi --auto --force $pkgrpm $log");
    }
    
    # TODO log, check return
    my ($spec_path) = Hdlist::installsrpm($pkgrpm);
    build($spec_path, $name, $version, $release, $newversion);
}
    
sub build {
    my ($spec_path, $pkg, $version, $release, $newversion) = @_;
    my ($message, $spec, @url, %specvars);
    my ($newrelease, $release_prefix) = ($1,$2) if $release =~ /^(.*\d+)(\D*)$/g;
    my $hdlist_spec = Hdlist::specnew($spec_path) or die "Unable to parse spec $spec_path\n"; 

    if ($newversion) {
	print "===> Building $pkg $newversion\n";
    } else {    
	print "===> Rebuilding $pkg\n";
    }

    
    if (! defined($newversion)) {
	$newversion = $version; 
	my @tmp = split(/\./,$newrelease);
	$tmp[-1]++;
	$newrelease = join('.',@tmp) . $release_prefix;
	$message = $config{message} || '- Rebuild';
    } else {
	$message = $config{message} || '- New release %%VERSION';
	$newrelease = "1$release_prefix";
    }
    $newrelease = $config{release} if $config{release};

    
    my $SPECFILE;
    if (!open($SPECFILE, $spec_path)) {
	print STDERR "Unable to open spec file $spec_path.\n";
	return;
    }

    my $tar_ball='';
    
    while (<$SPECFILE>) {
	# Doing a s/// version
	s/(\%define\s+version\s+)$version/$1$newversion/;
	s/(\%define\s+release\s+)$release/$1$newrelease/;
	s/Version:(\s+)$version/Version:$1$newversion/i;
	s/Release:(\s+)$release/Release:$1$newrelease/i;
        
        # TODO factorisation
        # case of %define release %mkrel 2
        if ( /^(.*\s\%mkrel\s+)(\d+)(.*)$/ )
        {
            $_ = "$1" . ((( $version eq $newversion ) ? $2 : 0 ) + 1 ) . "$3\n";
        }
       
        # case of %define release %mkrel %rel
        # and %define rel 2
        if ( /^(\%define\s+rel\s+)(\d+)(.*)$/ )
        {
            $_ = "$1" . ((( $version eq $newversion ) ? $2 : 0 ) + 1 ) . "$3\n";
        }
        
        
	eval $config{execute} if $config{execute};
	
	$spec .= $_;

	if (/^Source[0-9]*:\s+(\S+)/i) {
	    my $source = $1;
	    if ($source =~ /(?:ftp|svns?|https?):\/\/\S+/) {
		push(@url, $source);
	    } else {
		$tar_ball= $source unless $tar_ball;
	    };
	}
	
	# For %vars !
	$specvars{$1} = $2 if /\%define\s+(\S+?)\s+(\S+)/g;
	foreach my $i ('url', 'name', 'version', 'release') {
	    $specvars{$i} = $1 if !$specvars{$i} && /$i\s*:\s+(\S+)/gi;
	}
	 
	if (/^\%changelog/) {
	    $message =~ s/\%\%VERSION/$newversion/;
	    my @l = getpwuid($<);
	    my $packager = Hdlist::expand('%packager');
	    chomp($packager);
	    # if macro is undefined
	    $packager =~ s/\%packager//g;
	    my $email = $packager ? $packager : $l[6] . ($ENV{EMAIL} ? " <$ENV{EMAIL}>" : " <$l[0]\@mandrakesoft.com>");
	    $spec .= "* " . `LC_TIME=C date '+%a %b %d %Y'|tr -d '\n'` . " $email $newversion-$newrelease\n";
	    $spec .= "$message\n\n";
	}

    }
    close($SPECFILE);


    if (!$url[0]) { 
	print "URL of sources was not found ! Trying to guess it with url tag ...\n";
	
	my $url = $specvars{url};
	# add jabberstudio, collabnet, http://www.sourcefubar.net/, http://sarovar.org/
	my @sf_like = ( {
	    download => 'http://prdownloads.sourceforge.net/$1/$2' ,
	    regexp => 'http://(.*)\.(?:sourceforge|sf)\.net/?(.*)'
	},
	{ # to test
	    download => 'http://download.gna.org/$1/$2',
	    regexp => 'https?://gna.org/projects/([^/]*)/(.*)'
	},
	{
	    download => 'http://download.berlios.de/$1/$2' ,
	    regexp => 'http://(.*)\.berlios.de/(.*)'
	},
	{ # to test , and to merge with regular savanah ?
	    download => 'http://savannah.nongnu.org/download//$1/$2',
	    regexp => 'https?://savannah.nongnu.org/projects/([^/]*)/(.*)'
	},
	{ # to test
	    download => 'http://savannah.gnu.org/download//$1/$2',
	    regexp => 'https?://savannah.gnu.org/projects/([^/]*)/(.*)'
	}
	);
	
	# http://jabberstudio.org/files/ejogger/
	# http://jabberstudio.org/projects/ejogger/project/view.php	
	foreach my $sf (@sf_like) {
	    if  ($url =~ m/$sf->{regexp}/) {
		$sf->{download} =~ s/^/"/;
		$sf->{download} =~  s/$/"/;
		$url =~ s/$sf->{regexp}/"$sf->{download}"/eeg;
	    }    
	}
	
	push(@url, "$url/$tar_ball")
    }
    my $found = 0;

    foreach (@url) {
	# Replace variable from spec (%blabla)
        while (/\%[^(]?/) {
	    s/\%\{?(\w+)\}?/$specvars{$1}/g;
	    s/\%\{name\}/$pkg/g;
	    s/\%\{version\}/$newversion/g;
	}

	my $basename = basename($_);
	rm_rf("$config{sourcedir}/$basename") if $config{nobuild};
	
	# GNOME: add the major version to the URL automatically
	# for example: ftp://ftp://ftp.gnome.org/pub/GNOME/sources/ORbit2/ORbit2-2.10.0.tar.bz2
	# is rewritten in ftp://ftp.gnome.org/pub/GNOME/sources/ORbit2/2.10/ORbit2-2.10.0.tar.bz2
	if (m!ftp.gnome.org/pub/GNOME/sources/!) {
	    (my $major = $newversion) =~ s/([^.]+\.[^.]+).*/$1/;
	    s!(.*/)(.*)!$1$major/$2!;
	}
	
	# download from Fedora rpms
	if (/ftp\.redhat\.com/) {
	    opendir(MP, $config{fedora}) or die "$config{fedora} is not a directory";
	    my @rpmsrh = readdir(MP);
	    
	    my $pkgrpmrh;

	    foreach (@rpmsrh) {
		if (/^\Q$pkg\E-[^-]+-[^-]+\.\w+\.rpm/) {
		    $pkgrpmrh = $_;
		    last;
		}
	    }
	    
	    closedir(MP);

	    print "Trying from fedora($basename): $config{fedora}/$pkgrpmrh\n";
	    system_die("cd $config{sourcedir}; rpm2cpio $config{fedora}/$pkgrpmrh | cpio -id $basename", "Rpm extraction failed");
	    if (! -f "$config{sourcedir}/$basename") {
		(my $bname = $basename) =~ s/bz2/gz/;
		print "Trying from fedora($bname): $config{fedora}/$pkgrpmrh\n";
		system("cd $config{sourcedir}; rpm2cpio $config{fedora}/$pkgrpmrh | cpio -id $bname; bzme -F $bname", "rpm recompression failed");
	    }
	}
	# download from sourceforge mirrors
	if (m!http://prdownloads.sourceforge.net!) {
	    foreach my $site ("http://ovh.dl.sourceforge.net/sourceforge/",
			      "http://heanet.dl.sourceforge.net/sourceforge/",
			      "http://aleron.dl.sourceforge.net/sourceforge/",
			      "http://keihanna.dl.sourceforge.net/sourceforge/",
			      "http://belnet.dl.sourceforge.net/sourceforge/",
			      "http://unc.dl.sourceforge.net/sourceforge/",
			      "http://twtelecom.dl.sourceforge.net/sourceforge/",
			      )
	    {
		(my $dest = $_) =~ s!http://prdownloads.sourceforge.net/!$site!;
		last if fetch_http($dest);
	    }
	}
	# download specified url
	if (! -f "$config{sourcedir}/$basename") {
	    fetch($_);
	}
	$found++ if -e $basename;
	chmod(0644, "$config{sourcedir}/$basename");
    }

    # some specs have no source ( php )
    $found++ if ! $tar_ball;

    unless ($found) {
	print "Unable to download file: URL is not valid ! :-(\n\n";
	return;
    }


    
    unless ($config{noupdate}) {
	# TODO use output ? 	
	open($SPECFILE, ">$spec_path") or die "Unable to open $pkg.spec";
	print $SPECFILE $spec;
	close($SPECFILE);
    }

    unless ($config{nobuild}) {
	if (system("$rpm -ba $config{rpmoption} $spec_path $log")) {
	    print "Binary build fails: building source only\n";
	    system("$rpm -bs $config{rpmoption} --nodeps $spec_path $log");
	}   
    }   	
    if ($config{execafterbuild})
    {
        my @rpms_upload;
        push(@rpms_upload, $hdlist_spec->srcrpm);
        foreach ($hdlist_spec->binrpm())
        {
            -f $_ or next;
            push(@rpms_upload, $_);
        }
        system("$config{execafterbuild} @rpms_upload");
    }
}

sub wget_check {
    my $wgetv = `wget --version`;
    $wgetv =~ /Wget/ or die "You need `wget' binary for FTP/HTTP download\n";
}

sub parse_argv {
    my $conf = AppConfig->new({ CASE => 1, ERROR => \&usage });
    
    $conf->define("rpmmon", {
	ARGS     => "=s",
	ALIAS    => "r",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("release", {
	ARGS     => "=s",
	DEFAULT  => "",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("srpms", {
	ARGS     => "=s",
	ALIAS    => "m",
	DEFAULT  => "/mnt/BIG/distrib/cooker/SRPMS/",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("rpmoption", {
	ARGS     => "=s",
	DEFAULT  => "",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("fedora", {
	ARGS     => "=s",
	ALIAS    => "h",
	DEFAULT  => "/mnt/BIG/distrib/fedora/development/SRPMS/",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("deps", {
	ALIAS    => "d",
	DEFAULT  => 0,
	ARGCOUNT => AppConfig::ARGCOUNT_NONE
    });

    $conf->define("nosource", {
	ALIAS    => "n",
	DEFAULT  => 0,
	ARGCOUNT => AppConfig::ARGCOUNT_NONE
    });

    $conf->define("noupdate", {
	DEFAULT  => 0,
	ARGCOUNT => AppConfig::ARGCOUNT_NONE
    });	
    
    $conf->define("top", {
	ARGS     => "=t",
	ALIAS    => "h",
	DEFAULT  => 0,
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("nobuild", {
	ALIAS    => "c",
	DEFAULT  => 0,
	ARGCOUNT => AppConfig::ARGCOUNT_NONE
    });

    $conf->define("log", {
	ALIAS    => "l",
	DEFAULT  => 0,
	ARGCOUNT => AppConfig::ARGCOUNT_NONE
    });

    $conf->define("changelog", {
	ARGS     => "=s",
	# default is defined at the beggining of build
	# as it depend if this is a new version or a simple rebuild
	DEFAULT  => "",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });	

    $conf->define("execute", {
	ARGS     => "=s",
	DEFAULT  => "",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });

    $conf->define("execafterbuild", {
	ARGS     => "=s",
	DEFAULT  => "",
	ARGCOUNT => AppConfig::ARGCOUNT_ONE
    });
 
    
    foreach my $f ('/etc/rpmbuildupdate.conf', "$ENV{HOME}/.rpmbuildupdaterc") {	
	-f $f && $conf->file($f);
    }	
    $conf->args;
    $config{rpmmon} = $conf->get("rpmmon");
    $config{deps} = $conf->get("deps");
    $config{srpms} = $conf->get("srpms");
    $config{release} = $conf->get("release");
    $config{noupdate} = $conf->get("noupdate");
    $config{nosource} = $conf->get("nosource");
    $config{fedora} = $conf->get("fedora");
    $config{top} = $conf->get("top");
    $config{nobuild} = $conf->get("nobuild");
    $config{message} = $conf->get("changelog");
    $config{rpmoption} = $conf->get("rpmoption");
    $config{log} = $conf->get("log");
    $config{execute} = $conf->get("execute");
    $config{execafterbuild} = $conf->get("execafterbuild");

}

sub usage {
    my $id = '$Id$';
    print <<EOF;
rpmbuildupdate v0.5 helps you build up to date RPMs.
cvs version : $id

By Julien Danjou, Michael Scherer, Guillaume Rousse

Copyright (c) 2003-2004 by MandrakeSoft.
This is free software under the GPL License.
Usage: rpmbuildupdate [options] [pkg] [newversion]

 --rpmmon <file>: parse output of rpmmon from file
 --srpms <path_to_srpms>: specify SRPMS path, separate folder with a comma
 --rpmoption <rpm option>: use this option when rebuilding ( --with , mainly )
 --release <mdk_release>: release version of package (default: 1mdk)
 --changelog <changelog message>: use a alternate message. \%\%VERSION is replace by version
 --deps: install builds dependencies
 --log: log builds
 --nosource: do not install source from (urpmi x.src.rpm)
 --noupdate: do not touch to the spec file
 --top <dir>: specify rpm top dir (default: `rpm --eval \%_topdir`)
 --nobuild|-c: do not build the package. Only download files.
 --execute <command>: execute an arbitrary perl command for each line of the spec file
 --execafterbuild <command>: execute a shell command after the build, with the source and binary rpm as argument
EOF
    exit 0;
}

sub parse_rpmmon {
    my ($f) = @_;
    -f $f or die "Error: $f is not a file.\n";
    
    open(my $RPMMON, $f);
    while (<$RPMMON>) {
	build_from_repository($1, $3) if /^\s+(\S+)\s+(\S+)\s+(\S+)$/ && ! /Package/; 
	build_from_repository($2, $4) if /^(\S+)\s+(\S+)\s+(\S+)\s+(\S+)$/ && ! /Package/; 
    }
    close($RPMMON);
}

sub check_dir {
    my ($list) = @_;
    foreach my $dir (split(/,/, $list)) {
	-d $dir or die $dir . " is not a directory.\n";
    }	
}

sub main {
    parse_argv;
    wget_check;
    if ($config{rpmmon}) {
	print($config{srpms});
	parse_rpmmon($config{rpmmon})
    } else  {
	my ($name, $version);
	if ($ARGV[0]) {
	    $name    = $ARGV[0];
	    $version = $ARGV[1];
	    if (-f $name) {
		build_from_spec($name, $version) if $name =~ /.spec$/;
		build_from_src($name, $version) if $name =~ /.(?:no)?src.rpm$/;
	    } else {
		check_dir($config{srpms});
		build_from_repository($name, $version)
	    }
	} else {
	    usage;
	}
    }
}

main;