Changeset 405 in ProjectBuilder for devel/pb/bin


Ignore:
Timestamp:
Apr 20, 2008, 1:59:47 PM (17 years ago)
Author:
Bruno Cornec
Message:

Split again function in modules to allow for usage with pbinit and easier reuse.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • devel/pb/bin/pb

    r397 r405  
    1818use File::stat;
    1919use File::Temp qw(tempdir);
    20 use Date::Manip;
    2120use POSIX qw(strftime);
    2221use lib qw (lib);
    23 use ProjectBuilder::Distribution;
    2422use ProjectBuilder::Version;
    2523use ProjectBuilder::Base;
     24use ProjectBuilder::Conf;
     25use ProjectBuilder::Distribution;
     26use ProjectBuilder::CMS;
     27use ProjectBuilder::Filter;
    2628
    2729# Global variables
    … …  
    14541456    # Adds pb_distro_init from ProjectBuilder::Distribution
    14551457    foreach my $d (@INC) {
    1456         my $f = "$d/ProjectBuilder/Distribution.pm";
    1457         if (-f "$f") {
    1458             open(PBD,"$f") || die "Unable to open $f";
    1459             while (<PBD>) {
    1460                 next if (/^package/);
    1461                 next if (/^use Exporter/);
    1462                 next if (/^\@our /);
    1463                 print SCRIPT $_;
    1464             }
    1465             close(PBD);
    1466             last;
     1458        my @f = ("$d/ProjectBuilder/Base.pm","$d/ProjectBuilder/Distribution.pm");
     1459        foreach my $f (@f) {
     1460            if (-f "$f") {
     1461                open(PBD,"$f") || die "Unable to open $f";
     1462                while (<PBD>) {
     1463                    next if (/^package/);
     1464                    next if (/^use Exporter/);
     1465                    next if (/^use ProjectBuilder::Base/);
     1466                    next if (/^our \@/);
     1467                    print SCRIPT $_;
     1468                }
     1469                close(PBD);
     1470            }
    14671471        }
    14681472    }
    … …  
    24252429}
    24262430
    2427 # Function which returns a pointer on a table
    2428 # corresponding to a set of values queried in the conf file
    2429 # and test the returned vaue as they need to exist in that case
    2430 sub pb_conf_get {
    2431 
    2432 my @param = @_;
    2433 my @return = pb_conf_get_if(@param);
    2434 
    2435 die "No params found for $ENV{'PBPROJ'}" if (not @return);
    2436 
    2437 foreach my $i (0..$#param) {
    2438     die "No $param[$i] defined for $ENV{'PBPROJ'}" if (not defined $return[$i]);
    2439 }
    2440 return(@return);
    2441 }
    2442 
    2443 # Function which returns a pointer on a table
    2444 # corresponding to a set of values queried in the conf file
    2445 # Those value may be undef if they do not exist
    2446 sub pb_conf_get_if {
    2447 
    2448 my @param = @_;
    2449 
    2450 # Everything is returned via ptr1
    2451 my @ptr1 = ();
    2452 my @ptr2 = ();
    2453 @ptr1 = pb_conf_read_if("$ENV{'PBETC'}", @param) if (defined $ENV{'PBETC'});
    2454 @ptr2 = pb_conf_read_if("$ENV{'PBROOTDIR'}/$ENV{'PBPROJ'}.pb", @param) if ((defined $ENV{'PBROOTDIR'}) and (defined $ENV{'PBPROJ'}));
    2455 
    2456 my $p1;
    2457 my $p2;
    2458 
    2459 pb_log(2,"DEBUG: pb_conf_get param1: ".Dumper(@ptr1)."\n");
    2460 pb_log(2,"DEBUG: pb_conf_get param2: ".Dumper(@ptr2)."\n");
    2461 
    2462 foreach my $i (0..$#param) {
    2463     $p1 = $ptr1[$i];
    2464     $p2 = $ptr2[$i];
    2465     # Always try to take the param from the home dir conf file in priority
    2466     # in order to mask what could be defined under the CMS to allow for overloading
    2467     if (not defined $p2) {
    2468         # No ref in CMS project conf file so use the home dir one.
    2469         $p1->{$ENV{'PBPROJ'}} = $p1->{'default'} if ((not defined $p1->{$ENV{'PBPROJ'}}) && (defined $p1->{'default'}));
    2470     } else {
    2471         # Ref found in CMS project conf file
    2472         if (not defined $p1) {
    2473             # No ref in home dir project conf file so use the CMS one.
    2474             $p2->{$ENV{'PBPROJ'}} = $p2->{'default'} if ((not defined $p2->{$ENV{'PBPROJ'}}) && (defined $p2->{'default'}));
    2475             $p1 = $p2;
    2476         } else {
    2477             # Both are defined - handling the overloading
    2478             if (not defined $p1->{'default'}) {
    2479                 if (defined $p2->{'default'}) {
    2480                     $p1->{'default'} = $p2->{'default'};
    2481                 }
    2482             }
    2483 
    2484             if (not defined $p1->{$ENV{'PBPROJ'}}) {
    2485                 if (defined $p2->{$ENV{'PBPROJ'}}) {
    2486                     $p1->{$ENV{'PBPROJ'}} = $p2->{$ENV{'PBPROJ'}} if (defined $p2->{$ENV{'PBPROJ'}});
    2487                 } else {
    2488                     $p1->{$ENV{'PBPROJ'}} = $p1->{'default'} if (defined $p1->{'default'});
    2489                 }
    2490             }
    2491             # Now copy back into p1 all p2 content which doesn't exist in p1
    2492             # p1 content (local) always has priority over p2 (project)
    2493             foreach my $k (keys %$p2) {
    2494                 $p1->{$k} = $p2->{$k} if (not defined $p1->{$k});
    2495             }
    2496         }
    2497     }
    2498     $ptr1[$i] = $p1;
    2499 }
    2500 pb_log(2,"DEBUG: pb_conf_get param ptr1: ".Dumper(@ptr1)."\n");
    2501 return(@ptr1);
    2502 }
    2503 
    2504 # Setup environment for CMS system for URL passed
    2505 sub pb_cms_init {
    2506 
    2507 my $pbinit = shift || undef;
    2508 
    2509 my ($pburl) = pb_conf_get("pburl");
    2510 pb_log(2,"DEBUG: Project URL of $ENV{'PBPROJ'}: $pburl->{$ENV{'PBPROJ'}}\n");
    2511 my ($scheme, $account, $host, $port, $path) = pb_get_uri($pburl->{$ENV{'PBPROJ'}});
    2512 
    2513 my ($pbprojdir) = pb_conf_get_if("pbprojdir");
    2514 
    2515 if ((defined $pbprojdir) && (defined $pbprojdir->{$ENV{'PBPROJ'}})) {
    2516     $ENV{'PBPROJDIR'} = $pbprojdir->{$ENV{'PBPROJ'}};
    2517 } else {
    2518     $ENV{'PBPROJDIR'} = "$ENV{'PBDEFDIR'}/$ENV{'PBPROJ'}";
    2519 }
    2520 
    2521 # Computing the default dir for PBDIR.
    2522 # what we have is PBPROJDIR so work from that.
    2523 # Tree identical between PBCONFDIR and PBROOTDIR on one side and
    2524 # PBPROJDIR and PBDIR on the other side.
    2525 
    2526 my $tmp = $ENV{'PBROOTDIR'};
    2527 $tmp =~ s|^$ENV{'PBCONFDIR'}||;
    2528 
    2529 #
    2530 # Check project cms compliance
    2531 #
    2532 pb_cms_compliant(undef,'PBDIR',"$ENV{'PBPROJDIR'}/$tmp",$pburl->{$ENV{'PBPROJ'}},$pbinit);
    2533 
    2534 if ($scheme =~ /^svn/) {
    2535     # svnversion more precise than svn info
    2536     $tmp = `(cd "$ENV{'PBDIR'}" ; svnversion .)`;
    2537     chomp($tmp);
    2538     $ENV{'PBREVISION'}=$tmp;
    2539     $ENV{'PBCMSLOGFILE'}="svn.log";
    2540 } elsif (($scheme eq "file") || ($scheme eq "ftp") || ($scheme eq "http")) {
    2541     $ENV{'PBREVISION'}="flat";
    2542     $ENV{'PBCMSLOGFILE'}="flat.log";
    2543 } elsif ($scheme =~ /^cvs/) {
    2544     # Way too slow
    2545     #$ENV{'PBREVISION'}=`(cd "$ENV{'PBROOTDIR'}" ; cvs rannotate  -f . 2>&1 | awk '{print \$1}' | grep -E '^[0-9]' | cut -d. -f2 |sort -nu | tail -1)`;
    2546     #chomp($ENV{'PBREVISION'});
    2547     $ENV{'PBREVISION'}="cvs";
    2548     $ENV{'PBCMSLOGFILE'}="cvs.log";
    2549     $ENV{'CVS_RSH'} = "ssh" if ($scheme =~ /ssh/);
    2550 } else {
    2551     die "cms $scheme unknown";
    2552 }
    2553 
    2554 return($scheme,$pburl->{$ENV{'PBPROJ'}});
    2555 }
    2556 
    2557 sub pb_cms_export {
    2558 
    2559 my $uri = shift;
    2560 my $source = shift;
    2561 my $destdir = shift;
    2562 my $tmp;
    2563 my $tmp1;
    2564 
    2565 my @date = pb_get_date();
    2566 # If it's not flat, then we have a real uri as source
    2567 my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
    2568 
    2569 if ($scheme =~ /^svn/) {
    2570     if (-d $source) {
    2571         $tmp = $destdir;
    2572     } else {
    2573         $tmp = "$destdir/".basename($source);
    2574     }
    2575     pb_system("svn export $source $tmp","Exporting $source from SVN to $tmp");
    2576 } elsif ($scheme eq "dir") {
    2577     pb_system("cp -a $path $destdir","Copying $uri from DIR to $destdir");
    2578 } elsif (($scheme eq "http") || ($scheme eq "ftp")) {
    2579     my $f = basename($path);
    2580     unlink "$ENV{'PBTMP'}/$f";
    2581     if (-x "/usr/bin/wget") {
    2582         pb_system("/usr/bin/wget -nv -O $ENV{'PBTMP'}/$f $uri"," ");
    2583     } elsif (-x "/usr/bin/curl") {
    2584         pb_system("/usr/bin/curl $uri -o $ENV{'PBTMP'}/$f","Downloading $uri with curl to $ENV{'PBTMP'}/$f\n");
    2585     } else {
    2586         die "Unable to download $uri.\nNo wget/curl available, please install one of those";
    2587     }
    2588     pb_cms_export("file://$ENV{'PBTMP'}/$f",$source,$destdir);
    2589 } elsif ($scheme eq "file") {
    2590     use File::MimeInfo;
    2591     my $mm = mimetype($path);
    2592     pb_log(2,"mimetype: $mm\n");
    2593     pb_mkdir_p($destdir);
    2594 
    2595     # Check whether the file is well formed
    2596     # (containing already a directory with the project-version name)
    2597     my ($pbwf) = pb_conf_get_if("pbwf");
    2598     if ((defined $pbwf) && (defined $pbwf->{$ENV{'PBPROJ'}})) {
    2599         $destdir = dirname($destdir);
    2600     }
    2601 
    2602     if ($mm =~ /\/x-bzip-compressed-tar$/) {
    2603         # tar+bzip2
    2604         pb_system("cd $destdir ; tar xfj $path","Extracting $path in $destdir");
    2605     } elsif ($mm =~ /\/x-lzma-compressed-tar$/) {
    2606         # tar+lzma
    2607         pb_system("cd $destdir ; tar xfY $path","Extracting $path in $destdir");
    2608     } elsif ($mm =~ /\/x-compressed-tar$/) {
    2609         # tar+gzip
    2610         pb_system("cd $destdir ; tar xfz $path","Extracting $path in $destdir");
    2611     } elsif ($mm =~ /\/x-tar$/) {
    2612         # tar
    2613         pb_system("cd $destdir ; tar xf $path","Extracting $path in $destdir");
    2614     } elsif ($mm =~ /\/zip$/) {
    2615         # zip
    2616         pb_system("cd $destdir ; unzip $path","Extracting $path in $destdir");
    2617     }
    2618 } elsif ($scheme =~ /^cvs/) {
    2619     # CVS needs a relative path !
    2620     my $dir=dirname($destdir);
    2621     my $base=basename($destdir);
    2622     # CVS also needs a modules name not a dir
    2623     #if (-d $source) {
    2624         $tmp1 = basename($source);
    2625         #} else {
    2626         #$tmp1 = dirname($source);
    2627         #$tmp1 = basename($tmp1);
    2628         #}
    2629     my $optcvs = "";
    2630 
    2631     # If we're working on the CVS itself
    2632     my $cvstag = basename($ENV{'PBROOTDIR'});
    2633     my $cvsopt = "";
    2634     if ($cvstag eq "cvs") {
    2635         my $pbdate = strftime("%Y-%m-%d %H:%M:%S", @date);
    2636         $cvsopt = "-D \"$pbdate\"";
    2637     } else {
    2638         # we're working on a tag which should be the last part of PBROOTDIR
    2639         $cvsopt = "-r $cvstag";
    2640     }
    2641     pb_system("cd $dir ; cvs -d $account\@$host:$path export $cvsopt -d $base $tmp1","Exporting $tmp1 from $source under CVS to $destdir");
    2642 } else {
    2643     die "cms $scheme unknown";
    2644 }
    2645 }
    2646 
    2647 
    2648 sub pb_create_authors {
    2649 
    2650 my $authors=shift;
    2651 my $dest=shift;
    2652 my $scheme=shift;
    2653 
    2654 return if ($authors eq "/dev/null");
    2655 open(SAUTH,$authors) || die "Unable to open $authors";
    2656 # Save a potentially existing AUTHORS file and write instead toi AUTHORS.pb
    2657 my $ext = "";
    2658 if (-f "$dest/AUTHORS") {
    2659     $ext = ".pb";
    2660 }
    2661 open(DAUTH,"> $dest/AUTHORS$ext") || die "Unable to create $dest/AUTHORS$ext";
    2662 print DAUTH "Authors of the project are:\n";
    2663 print DAUTH "===========================\n";
    2664 while (<SAUTH>) {
    2665     my ($nick,$gcos) = split(/:/);
    2666     chomp($gcos);
    2667     print DAUTH "$gcos";
    2668     if (defined $scheme) {
    2669         # Do not give a scheme for flat types
    2670         my $endstr="";
    2671         if ("$ENV{'PBREVISION'}" ne "flat") {
    2672             $endstr = " under $scheme";
    2673         }
    2674         print DAUTH " ($nick$endstr)\n";
    2675     } else {
    2676         print DAUTH "\n";
    2677     }
    2678 }
    2679 close(DAUTH);
    2680 close(SAUTH);
    2681 }
    2682 
    2683 sub pb_cms_log {
    2684 
    2685 my $scheme = shift;
    2686 my $pkgdir = shift;
    2687 my $dest = shift;
    2688 my $chglog = shift;
    2689 my $authors = shift;
    2690 
    2691 pb_create_authors($authors,$dest,$scheme);
    2692 
    2693 if ($scheme =~ /^svn/) {
    2694     if (! -f "$dest/ChangeLog") {
    2695         if (-x "/usr/bin/svn2cl") {
    2696             # In case we have no network, just create an empty one before to allow correct build
    2697             open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
    2698             close(CL);
    2699             pb_system("/usr/bin/svn2cl --group-by-day --authors=$authors -i -o $dest/ChangeLog $pkgdir","Generating ChangeLog from SVN with svn2cl");
    2700         } else {
    2701             # To be written from pbcl
    2702             pb_system("svn log -v $pkgdir > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from SVN");
    2703         }
    2704     }
    2705 } elsif (($scheme eq "file") || ($scheme eq "dir") || ($scheme eq "http") || ($scheme eq "ftp")) {
    2706     if (! -f "$dest/ChangeLog") {
    2707         pb_system("echo ChangeLog for $pkgdir > $dest/ChangeLog","Empty ChangeLog file created");
    2708     }
    2709 } elsif ($scheme =~ /^cvs/) {
    2710     my $tmp=basename($pkgdir);
    2711     # CVS needs a relative path !
    2712     if (! -f "$dest/ChangeLog") {
    2713         if (-x "/usr/bin/cvs2cl") {
    2714             # In case we have no network, just create an empty one before to allow correct build
    2715             open(CL,"> $dest/ChangeLog") || die "Unable to create $dest/ChangeLog";
    2716             close(CL);
    2717             pb_system("/usr/bin/cvs2cl --group-by-day -U $authors -f $dest/ChangeLog $pkgdir","Generating ChangeLog from CVS with cvs2cl");
    2718         } else {
    2719             # To be written from pbcl
    2720             pb_system("cvs log $tmp > $dest/$ENV{'PBCMSLOGFILE'}","Extracting log info from CVS");
    2721         }
    2722     }
    2723 } else {
    2724     die "cms $scheme unknown";
    2725 }
    2726 }
    2727 
    2728 # This function is only called with a real CMS system
    2729 sub pb_cms_get_uri {
    2730 
    2731 my $scheme = shift;
    2732 my $dir = shift;
    2733 
    2734 my $res = "";
    2735 my $void = "";
    2736 
    2737 if ($scheme =~ /^svn/) {
    2738     open(PIPE,"LANGUAGE=C svn info $dir |") || return("");
    2739     while (<PIPE>) {
    2740         ($void,$res) = split(/^URL:/) if (/^URL:/);
    2741     }
    2742     $res =~ s/^\s*//;
    2743     close(PIPE);
    2744     chomp($res);
    2745 } elsif ($scheme =~ /^cvs/) {
    2746     # This path is always the root path of CVS, but we may be below
    2747     open(FILE,"$dir/CVS/Root") || die "$dir isn't CVS controlled";
    2748     $res = <FILE>;
    2749     chomp($res);
    2750     close(FILE);
    2751     # Find where we are in the tree
    2752     my $rdir = $dir;
    2753     while ((! -d "$rdir/CVSROOT") && ($rdir ne "/")) {
    2754         $rdir = dirname($rdir);
    2755     }
    2756     die "Unable to find a CVSROOT dir in the parents of $dir" if (! -d "$rdir/CVSROOT");
    2757     #compute our place under that root dir - should be a relative path
    2758     $dir =~ s|^$rdir||;
    2759     my $suffix = "";
    2760     $suffix = "$dir" if ($dir ne "");
    2761 
    2762     my $prefix = "";
    2763     if ($scheme =~ /ssh/) {
    2764         $prefix = "cvs+ssh://";
    2765     } else {
    2766         $prefix = "cvs://";
    2767     }
    2768     $res = $prefix.$res.$suffix;
    2769 } else {
    2770     die "cms $scheme unknown";
    2771 }
    2772 pb_log(2,"Found CMS info: $res\n");
    2773 return($res);
    2774 }
    2775 
    2776 sub pb_cms_copy {
    2777 my $scheme = shift;
    2778 my $oldurl = shift;
    2779 my $newurl = shift;
    2780 
    2781 if ($scheme =~ /^svn/) {
    2782     pb_system("svn copy -m \"Creation of $newurl from $oldurl\" $oldurl $newurl","Copying $oldurl to $newurl ");
    2783 } elsif ($scheme eq "flat") {
    2784 } elsif ($scheme =~ /^cvs/) {
    2785 } else {
    2786     die "cms $scheme unknown";
    2787 }
    2788 }
    2789 
    2790 sub pb_cms_checkout {
    2791 my $scheme = shift;
    2792 my $url = shift;
    2793 my $destination = shift;
    2794 
    2795 if ($scheme =~ /^svn/) {
    2796     pb_system("svn co $url $destination","Checking out $url to $destination ");
    2797 } elsif (($scheme eq "ftp") || ($scheme eq "http")) {
    2798     return;
    2799 } elsif ($scheme =~ /^cvs/) {
    2800     pb_system("cvs co $url $destination","Checking out $url to $destination ");
    2801 } else {
    2802     die "cms $scheme unknown";
    2803 }
    2804 }
    2805 
    2806 sub pb_cms_up {
    2807 my $scheme = shift;
    2808 my $dir = shift;
    2809 
    2810 if ($scheme =~ /^svn/) {
    2811     pb_system("svn up $dir","Updating $dir");
    2812 } elsif ($scheme eq "flat") {
    2813 } elsif ($scheme =~ /^cvs/) {
    2814 } else {
    2815     die "cms $scheme unknown";
    2816 }
    2817 }
    2818 
    2819 sub pb_cms_checkin {
    2820 my $scheme = shift;
    2821 my $dir = shift;
    2822 
    2823 my $ver = basename($dir);
    2824 if ($scheme =~ /^svn/) {
    2825     pb_system("svn ci -m \"updated to $ver\" $dir","Checking in $dir");
    2826 } elsif ($scheme eq "flat") {
    2827 } elsif ($scheme =~ /^cvs/) {
    2828 } else {
    2829     die "cms $scheme unknown";
    2830 }
    2831 pb_cms_up($scheme,$dir);
    2832 }
    2833 
    2834 sub pb_cms_isdiff {
    2835 my $scheme = shift;
    2836 my $dir =shift;
    2837 
    2838 if ($scheme =~ /^svn/) {
    2839     open(PIPE,"svn diff $dir |") || die "Unable to get svn diff from $dir";
    2840     my $l = 0;
    2841     while (<PIPE>) {
    2842         $l++;
    2843     }
    2844     return($l);
    2845 } elsif ($scheme eq "flat") {
    2846 } elsif ($scheme =~ /^cvs/) {
    2847     open(PIPE,"cvs diff $dir |") || die "Unable to get svn diff from $dir";
    2848     my $l = 0;
    2849     while (<PIPE>) {
    2850         # Skipping normal messages
    2851         next if (/^cvs diff:/);
    2852         $l++;
    2853     }
    2854     return($l);
    2855 } else {
    2856     die "cms $scheme unknown";
    2857 }
    2858 }
    2859 
    2860 # Get all filters to apply
    2861 # They're cumulative from less specific to most specific
    2862 # suffix is .pbf
    2863 
    2864 sub pb_get_filters {
    2865 
    2866 my @ffiles;
    2867 my ($ffile00, $ffile0, $ffile1, $ffile2, $ffile3);
    2868 my ($mfile00, $mfile0, $mfile1, $mfile2, $mfile3);
    2869 my $pbpkg = shift || die "No package specified";
    2870 my $dtype = shift || "";
    2871 my $dfam = shift || "";
    2872 my $ddir = shift || "";
    2873 my $dver = shift || "";
    2874 my $ptr = undef; # returned value pointer on the hash of filters
    2875 my %h;
    2876 
    2877 # Global filter files first, then package specificities
    2878 if (-d "$ENV{'PBROOTDIR'}/pbfilter") {
    2879     $mfile00 = "$ENV{'PBROOTDIR'}/pbfilter/all.pbf" if (-f "$ENV{'PBROOTDIR'}/pbfilter/all.pbf");
    2880     $mfile0 = "$ENV{'PBROOTDIR'}/pbfilter/$dtype.pbf" if (-f "$ENV{'PBROOTDIR'}/pbfilter/$dtype.pbf");
    2881     $mfile1 = "$ENV{'PBROOTDIR'}/pbfilter/$dfam.pbf" if (-f "$ENV{'PBROOTDIR'}/pbfilter/$dfam.pbf");
    2882     $mfile2 = "$ENV{'PBROOTDIR'}/pbfilter/$ddir.pbf" if (-f "$ENV{'PBROOTDIR'}/pbfilter/$ddir.pbf");
    2883     $mfile3 = "$ENV{'PBROOTDIR'}/pbfilter/$ddir-$dver.pbf" if (-f "$ENV{'PBROOTDIR'}/pbfilter/$ddir-$dver.pbf");
    2884 
    2885     push @ffiles,$mfile00 if (defined $mfile00);
    2886     push @ffiles,$mfile0 if (defined $mfile0);
    2887     push @ffiles,$mfile1 if (defined $mfile1);
    2888     push @ffiles,$mfile2 if (defined $mfile2);
    2889     push @ffiles,$mfile3 if (defined $mfile3);
    2890 }
    2891 
    2892 if (-d "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter") {
    2893     $ffile00 = "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/all.pbf" if (-f "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/all.pbf");
    2894     $ffile0 = "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$dtype.pbf" if (-f "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$dtype.pbf");
    2895     $ffile1 = "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$dfam.pbf" if (-f "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$dfam.pbf");
    2896     $ffile2 = "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$ddir.pbf" if (-f "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$ddir.pbf");
    2897     $ffile3 = "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$ddir-$dver.pbf" if (-f "$ENV{'PBROOTDIR'}/$pbpkg/pbfilter/$ddir-$dver.pbf");
    2898 
    2899     push @ffiles,$ffile00 if (defined $ffile00);
    2900     push @ffiles,$ffile0 if (defined $ffile0);
    2901     push @ffiles,$ffile1 if (defined $ffile1);
    2902     push @ffiles,$ffile2 if (defined $ffile2);
    2903     push @ffiles,$ffile3 if (defined $ffile3);
    2904 }
    2905 if (@ffiles) {
    2906     pb_log(2,"DEBUG ffiles: ".Dumper(\@ffiles)."\n");
    2907 
    2908     foreach my $f (@ffiles) {
    2909         open(CONF,$f) || next;
    2910         while(<CONF>)  {
    2911             if (/^\s*([A-z0-9-_]+)\s+([[A-z0-9-_]+)\s*=\s*(.+)$/) {
    2912                 $h{$1}{$2}=$3;
    2913             }
    2914         }
    2915         close(CONF);
    2916 
    2917         $ptr = $h{"filter"};
    2918         pb_log(2,"DEBUG f:".Dumper($ptr)."\n");
    2919     }
    2920 }
    2921 return($ptr);
    2922 }
    2923 
    2924 # Function which applies filter on pb build files
    2925 sub pb_filter_file_pb {
    2926 
    2927 my $f=shift;
    2928 my $ptr=shift;
    2929 my %filter=%$ptr;
    2930 my $destfile=shift;
    2931 my $dtype=shift;
    2932 my $pbsuf=shift;
    2933 my $pbproj=shift;
    2934 my $pbpkg=shift;
    2935 my $pbver=shift;
    2936 my $pbtag=shift;
    2937 my $pbrev=shift;
    2938 my $pbdate=shift;
    2939 my $defpkgdir = shift;
    2940 my $extpkgdir = shift;
    2941 my $pbpackager = shift;
    2942 my $chglog = shift || undef;
    2943 
    2944 pb_log(2,"DEBUG: From $f to $destfile\n");
    2945 pb_mkdir_p(dirname($destfile)) if (! -d dirname($destfile));
    2946 open(DEST,"> $destfile") || die "Unable to create $destfile";
    2947 open(FILE,"$f") || die "Unable to open $f: $!";
    2948 while (<FILE>) {
    2949     my $line = $_;
    2950     foreach my $s (keys %filter) {
    2951         # Process single variables
    2952         pb_log(2,"DEBUG filter{$s}: $filter{$s}\n");
    2953         my $tmp = $filter{$s};
    2954         next if (not defined $tmp);
    2955         # Expand variables if any single one found
    2956         pb_log(2,"DEBUG tmp: $tmp\n");
    2957         if ($tmp =~ /\$/) {
    2958             eval { $tmp =~ s/(\$\w+)/$1/eeg };
    2959         # special case for ChangeLog only for pb
    2960         } elsif (($s =~ /^PBLOG$/) && ($line =~ /^PBLOG$/)) {
    2961             my $p = $defpkgdir->{$pbpkg};
    2962             $p = $extpkgdir->{$pbpkg} if (not defined $p);
    2963             pb_changelog($dtype, $pbpkg, $pbver, $pbtag, $pbsuf, $p, \*DEST, $tmp, $chglog);
    2964             $tmp = "";
    2965         }
    2966         $line =~ s|$s|$tmp|;
    2967     }
    2968     print DEST $line;
    2969 }
    2970 close(FILE);
    2971 close(DEST);
    2972 }
    2973 
    2974 # Function which applies filter on files (external call)
    2975 sub pb_filter_file_inplace {
    2976 
    2977 my $ptr=shift;
    2978 my %filter=%$ptr;
    2979 my $destfile=shift;
    2980 my $pbproj=shift;
    2981 my $pbpkg=shift;
    2982 my $pbver=shift;
    2983 my $pbtag=shift;
    2984 my $pbrev=shift;
    2985 my $pbdate=shift;
    2986 my $pbpackager=shift;
    2987 
    2988 my $cp = "$ENV{'PBTMP'}/".basename($destfile);
    2989 copy($destfile,$cp) || die "Unable to create $cp";
    2990 
    2991 pb_filter_file($cp,$ptr,$destfile,$pbproj,$pbpkg,$pbver,$pbtag,$pbrev,$pbdate,$pbpackager);
    2992 unlink $cp;
    2993 }
    2994 
    2995 # Function which applies filter on files (external call)
    2996 sub pb_filter_file {
    2997 
    2998 my $f=shift;
    2999 my $ptr=shift;
    3000 my %filter=%$ptr;
    3001 my $destfile=shift;
    3002 my $pbproj=shift;
    3003 my $pbpkg=shift;
    3004 my $pbver=shift;
    3005 my $pbtag=shift;
    3006 my $pbrev=shift;
    3007 my $pbdate=shift;
    3008 my $pbpackager=shift;
    3009 
    3010 pb_log(2,"DEBUG: From $f to $destfile\n");
    3011 pb_mkdir_p(dirname($destfile)) if (! -d dirname($destfile));
    3012 open(DEST,"> $destfile") || die "Unable to create $destfile";
    3013 open(FILE,"$f") || die "Unable to open $f: $!";
    3014 while (<FILE>) {
    3015     my $line = $_;
    3016     foreach my $s (keys %filter) {
    3017         # Process single variables
    3018         pb_log(2,"DEBUG filter{$s}: $filter{$s}\n");
    3019         my $tmp = $filter{$s};
    3020         next if (not defined $tmp);
    3021         # Expand variables if any single one found
    3022         if ($tmp =~ /\$/) {
    3023             eval { $tmp =~ s/(\$\w+)/$1/eeg };
    3024         }
    3025         $line =~ s|$s|$tmp|;
    3026     }
    3027     print DEST $line;
    3028 }
    3029 close(FILE);
    3030 close(DEST);
    3031 }
    3032 
    30332431#
    3034 # Return the list of packages we are working on in a CMS action
    3035 #
    3036 sub pb_cms_get_pkg {
     2432# Return the list of packages we are working on in a non CMS action
     2433#
     2434sub pb_get_pkg {
    30372435
    30382436my @pkgs = ();
    3039 my $defpkgdir = shift || undef;
    3040 my $extpkgdir = shift || undef;
    3041 
    3042 # Get packages list
    3043 if (not defined $ARGV[0]) {
    3044     @pkgs = keys %$defpkgdir if (defined $defpkgdir);
    3045 } elsif ($ARGV[0] =~ /^all$/) {
    3046     @pkgs = keys %$defpkgdir if (defined $defpkgdir);
    3047     push(@pkgs, keys %$extpkgdir) if (defined $extpkgdir);
    3048 } else {
    3049     @pkgs = @ARGV;
    3050 }
     2437
     2438my ($var) = pb_conf_read("$ENV{'PBDESTDIR'}/$ENV{'PBPROJVER'}-$ENV{'PBPROJTAG'}.pb","pbpkg");
     2439@pkgs = keys %$var;
     2440
    30512441pb_log(0,"Packages: ".join(',',@pkgs)."\n");
    30522442return(\@pkgs);
    30532443}
    30542444
    3055 #
    3056 # Return the list of packages we are working on in a non CMS action
    3057 #
    3058 sub pb_get_pkg {
    3059 
    3060 my @pkgs = ();
    3061 
    3062 my ($var) = pb_conf_read("$ENV{'PBDESTDIR'}/$ENV{'PBPROJVER'}-$ENV{'PBPROJTAG'}.pb","pbpkg");
    3063 @pkgs = keys %$var;
    3064 
    3065 pb_log(0,"Packages: ".join(',',@pkgs)."\n");
    3066 return(\@pkgs);
    3067 }
    3068 
    3069 #
    3070 # Check pbconf/project cms compliance
    3071 #
    3072 sub pb_cms_compliant {
    3073 
    3074 my $param = shift;
    3075 my $envar = shift;
    3076 my $defdir = shift;
    3077 my $uri = shift;
    3078 my $pbinit = shift;
    3079 my %pdir;
    3080 
    3081 my ($pdir) = pb_conf_get_if($param) if (defined $param);
    3082 if (defined $pdir) {
    3083     %pdir = %$pdir;
    3084 }
    3085 
    3086 
    3087 if ((defined $pdir) && (%pdir) && (defined $pdir{$ENV{'PBPROJ'}})) {
    3088     # That's always the environment variable that will be used
    3089     $ENV{$envar} = $pdir{$ENV{'PBPROJ'}};
    3090 } else {
    3091     if (defined $param) {
    3092         pb_log(1,"WARNING: no $param defined, using $defdir\n");
    3093         pb_log(1,"         Please create a $param reference for project $ENV{'PBPROJ'} in $ENV{'PBETC'}\n");
    3094         pb_log(1,"         if you want to use another directory\n");
    3095     }
    3096     $ENV{$envar} = "$defdir";
    3097 }
    3098 
    3099 # Expand potential env variable in it
    3100 eval { $ENV{$envar} =~ s/(\$ENV.+\})/$1/eeg };
    3101 pb_log(2,"$envar: $ENV{$envar}\n");
    3102 
    3103 my ($scheme, $account, $host, $port, $path) = pb_get_uri($uri);
    3104 
    3105 if ((! -d "$ENV{$envar}") || (defined $pbinit)) {
    3106     if (defined $pbinit) {
    3107         pb_mkdir_p("$ENV{$envar}");
    3108     } else {
    3109         pb_log(1,"Checking out $uri\n");
    3110         pb_cms_checkout($scheme,$uri,$ENV{$envar});
    3111     }
    3112 } elsif (($scheme !~ /^cvs/) || ($scheme !~ /^svn/)) {
    3113     # Do not compare if it's not a real cms
    3114     return;
    3115 } else {
    3116     pb_log(1,"$uri found locally, checking content\n");
    3117     my $cmsurl = pb_cms_get_uri($scheme,$ENV{$envar});
    3118     my ($scheme2, $account2, $host2, $port2, $path2) = pb_get_uri($cmsurl);
    3119     if ($cmsurl ne $uri) {
    3120         # The local content doesn't correpond to the repository
    3121         pb_log(0,"ERROR: Inconsistency detected:\n");
    3122         pb_log(0,"       * $ENV{$envar} refers to $cmsurl but\n");
    3123         pb_log(0,"       * $ENV{'PBETC'} refers to $uri\n");
    3124         die "Project $ENV{'PBPROJ'} is not Project-Builder compliant.";
    3125     } else {
    3126         pb_log(1,"Content correct - doing nothing - you may want to update your repository however\n");
    3127         # they match - do nothing - there may be local changes
    3128     }
    3129 }
    3130 }
    3131 
    3132 sub pb_changelog {
    3133 
    3134 my $dtype = shift;
    3135 my $pkg = shift;
    3136 my $pbver = shift;
    3137 my $pbtag = shift;
    3138 my $dsuf = shift;
    3139 my $path = shift;
    3140 my $OUTPUT = shift;
    3141 my $doit = shift;
    3142 my $chglog = shift || undef;
    3143 
    3144 my $log = "";
    3145 
    3146 # For date handling
    3147 $ENV{LANG}="C";
    3148 
    3149 if ((not (defined $dtype)) || ($dtype eq "") ||
    3150         (not (defined $pkg)) || ($pkg eq "") ||
    3151         (not (defined $pbver)) || ($pbver eq "") ||
    3152         (not (defined $pbtag)) || ($pbtag eq "") ||
    3153         (not (defined $dsuf)) || ($dsuf eq "") ||
    3154         (not (defined $path)) || ($path eq "") ||
    3155         (not (defined $OUTPUT)) || ($OUTPUT eq "") ||
    3156         (not (defined $doit)) || ($doit eq "")) {
    3157     print $OUTPUT "\n";
    3158     return;
    3159 }
    3160 
    3161 if (((not defined $chglog) || (! -f $chglog)) && ($doit eq "yes")) {
    3162     #pb_log(2,"No ChangeLog file ($chglog) for $pkg\n";
    3163     print $OUTPUT "\n";
    3164     return;
    3165 }
    3166 
    3167 my $date;
    3168 my $ndate;
    3169 my $n2date;
    3170 my $ver;
    3171 my $ver2;
    3172 my ($pbpackager) = pb_conf_get("pbpackager");
    3173 
    3174 if (not defined $pbpackager->{$ENV{'PBPROJ'}}) {
    3175     $pbpackager->{$ENV{'PBPROJ'}} = "undefined\@noproject.noorg";
    3176 }
    3177 
    3178 # If we don't need to do it, or don't have it fake something
    3179 if (((not defined $chglog) || (! -f $chglog)) && ($doit ne "yes")) {
    3180     my @date = pb_get_date();
    3181     $date = strftime("%Y-%m-%d", @date);
    3182     $ndate = UnixDate($date,"%a", "%b", "%d", "%Y");
    3183     $n2date = &UnixDate($date,"%a, %d %b %Y %H:%M:%S %z");
    3184     if (($dtype eq "rpm") || ($dtype eq "fc")) {
    3185         $ver2 = "$pbver-$pbtag$dsuf";
    3186         print $OUTPUT "* $ndate $pbpackager->{$ENV{'PBPROJ'}} $ver2\n";
    3187         print $OUTPUT "- Updated to $pbver\n";
    3188         }
    3189     if ($dtype eq "deb") {
    3190         print $OUTPUT "$pkg ($pbver) unstable; urgency=low\n";
    3191         print $OUTPUT "\n";
    3192         print $OUTPUT " -- $pbpackager->{$ENV{'PBPROJ'}}  $n2date\n\n\n";
    3193         }
    3194     return;
    3195 }
    3196 
    3197 open(INPUT,"$chglog") || die "Unable to open $chglog (read)";
    3198 
    3199 # Skip first 4 lines
    3200 my $tmp = <INPUT>;
    3201 $tmp = <INPUT>;
    3202 $tmp = <INPUT>;
    3203 if ($dtype eq "announce") {
    3204     print $OUTPUT $tmp;
    3205 }
    3206 $tmp = <INPUT>;
    3207 if ($dtype eq "announce") {
    3208     print $OUTPUT $tmp;
    3209 }
    3210 
    3211 my $first=1;
    3212 
    3213 # Handle each block separated by newline
    3214 while (<INPUT>) {
    3215     ($ver, $date) = split(/ /);
    3216     $ver =~ s/^v//;
    3217     chomp($date);
    3218     $date =~ s/\(([0-9-]+)\)/$1/;
    3219     #pb_log(2,"**$date**\n";
    3220     $ndate = UnixDate($date,"%a", "%b", "%d", "%Y");
    3221     $n2date = &UnixDate($date,"%a, %d %b %Y %H:%M:%S %z");
    3222     #pb_log(2,"**$ndate**\n";
    3223 
    3224     if (($dtype eq "rpm") || ($dtype eq "fc")) {
    3225         if ($ver !~ /-/) {
    3226             if ($first eq 1) {
    3227                 $ver2 = "$ver-$pbtag$dsuf";
    3228                 $first=0;
    3229             } else {
    3230                 $ver2 = "$ver-1$dsuf";
    3231             }
    3232         } else {
    3233             $ver2 = "$ver$dsuf";
    3234         }
    3235         print $OUTPUT "* $ndate $pbpackager->{$ENV{'PBPROJ'}} $ver2\n";
    3236         print $OUTPUT "- Updated to $ver\n";
    3237         }
    3238     if ($dtype eq "deb") {
    3239         print $OUTPUT "$pkg ($ver) unstable; urgency=low\n";
    3240         print $OUTPUT "\n";
    3241         }
    3242 
    3243     $tmp = <INPUT>;
    3244     while ($tmp !~ /^$/) {
    3245         if ($dtype eq "deb") {
    3246             $tmp =~ s/^- //;
    3247             print $OUTPUT "  * $tmp";
    3248         } elsif ($dtype eq "rpm") {
    3249             print $OUTPUT "$tmp";
    3250         } else {
    3251             print $OUTPUT "$tmp";
    3252         }
    3253         last if (eof(INPUT));
    3254         $tmp = <INPUT>;
    3255     }
    3256     print $OUTPUT "\n";
    3257 
    3258     if ($dtype eq "deb") {
    3259         # Cf: http://www.debian.org/doc/debian-policy/ch-source.html#s-dpkgchangelog
    3260         print $OUTPUT " -- $pbpackager->{$ENV{'PBPROJ'}}  $n2date\n\n\n";
    3261         }
    3262 
    3263     last if (eof(INPUT));
    3264     last if ($dtype eq "announce");
    3265 }
    3266 close(INPUT);
    3267 }
    326824451;
Note: See TracChangeset for help on using the changeset viewer.