ucw/perl/UCW/Configure.pm

   1 #       Perl module for UCW Configure Scripts
   2 #
   3 #       (c) 2005--2008 Martin Mares <mj@ucw.cz>
   4 #
   5 #       This software may be freely distributed and used according to the terms
   6 #       of the GNU Lesser General Public License.
   7
   8 package UCW::Configure;
   9
  10 use strict;
  11 use warnings;
  12
  13 BEGIN {
  14         # The somewhat hairy Perl export mechanism
  15         use Exporter();
  16         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  17         $VERSION = 1.0;
  18         @ISA = qw(Exporter);
  19         @EXPORT = qw(&Init &Log &Notice &Warn &Fail &IsSet &IsGiven &Set &UnSet &Append &Override &Get &Test &Include &Finish &FindFile &TryFindFile &TryCmd &PkgConfig &TrivConfig &DebugDump &PostConfig &AtWrite);
  20         @EXPORT_OK = qw();
  21         %EXPORT_TAGS = ();
  22 }
  23
  24 our %vars;
  25 our %overriden;
  26 our @postconfigs;
  27 our @atwrites;
  28
  29 sub DebugDump() {
  30         print "VARS:\n";
  31         print "$_: $vars{$_}\n" foreach( keys %vars );
  32 }
  33
  34 sub Log($) {
  35         print @_;
  36 }
  37
  38 sub Notice($) {
  39         print @_ if $vars{"VERBOSE"};
  40 }
  41
  42 sub Warn($) {
  43         print "WARNING: ", @_;
  44 }
  45
  46 sub Fail($) {
  47         Log("ERROR: " . (shift @_) . "\n");
  48         exit 1;
  49 }
  50
  51 sub IsSet($) {
  52         my ($x) = @_;
  53         return exists $vars{$x};
  54 }
  55
  56 sub IsGiven($) {
  57         my ($x) = @_;
  58         return exists $overriden{$x};
  59 }
  60
  61 sub Get($) {
  62         my ($x) = @_;
  63         return $vars{$x};
  64 }
  65
  66 sub Set($;$) {
  67         my ($x,$y) = @_;
  68         $y=1 unless defined $y;
  69         $vars{$x}=$y unless $overriden{$x};
  70 }
  71
  72 sub UnSet($) {
  73         my ($x) = @_;
  74         delete $vars{$x} unless $overriden{$x};
  75 }
  76
  77 sub Append($$) {
  78         my ($x,$y) = @_;
  79         Set($x, (IsSet($x) ? (Get($x) . " $y") : $y));
  80 }
  81
  82 sub Override($;$) {
  83         my ($x,$y) = @_;
  84         $y=1 unless defined $y;
  85         $vars{$x}=$y;
  86         $overriden{$x} = 1;
  87 }
  88
  89 sub Test($$$) {
  90         my ($var,$msg,$sub) = @_;
  91         Log "$msg ... ";
  92         if (!IsSet($var)) {
  93                 Set $var, &$sub();
  94         }
  95         Log Get($var) . "\n";
  96 }
  97
  98 sub TryFindFile($) {
  99         my ($f) = @_;
 100         if (-f $f) {
 101                 return $f;
 102         } elsif ($f !~ /^\// && -f (Get("SRCDIR")."/$f")) {
 103                 return Get("SRCDIR")."/$f";
 104         } else {
 105                 return undef;
 106         }
 107 }
 108
 109 sub FindFile($) {
 110         my ($f) = @_;
 111         my $F;
 112         defined ($F = TryFindFile($f)) or Fail "Cannot find file $f";
 113         return $F;
 114 }
 115
 116 sub Init($$) {
 117         my ($srcdir,$defconfig) = @_;
 118         sub usage($) {
 119                 my ($dc) = @_;
 120                 print STDERR "Usage: [<srcdir>/]configure " . (defined $dc ? "[" : "") . "<config-name>" . (defined $dc ? "]" : "") .
 121                         " [<option>[=<value>] | -<option>] ...\n";
 122                 exit 1;
 123         }
 124         Set('CONFIG' => $defconfig) if defined $defconfig;
 125         if (@ARGV) {
 126                 usage($defconfig) if $ARGV[0] eq "--help";
 127                 if (!defined($defconfig) || $ARGV[0] !~ /^-?[A-Z][A-Z0-9_]*(=|$)/) {
 128                         # This does not look like an option, so read it as a file name
 129                         Set('CONFIG' => shift @ARGV);
 130                 }
 131         }
 132         Set("SRCDIR", $srcdir);
 133
 134         foreach my $x (@ARGV) {
 135                 if ($x =~ /^(\w+)=(.*)/) {
 136                         Override($1 => $2);
 137                 } elsif ($x =~ /^-(\w+)$/) {
 138                         Override($1 => 0);
 139                         delete $vars{$1};
 140                 } elsif ($x =~ /^(\w+)$/) {
 141                         Override($1 => 1);
 142                 } else {
 143                         print STDERR "Invalid option $x\n";
 144                         exit 1;
 145                 }
 146         }
 147
 148         defined Get("CONFIG") or usage($defconfig);
 149         if (!TryFindFile(Get("CONFIG"))) {
 150                 TryFindFile(Get("CONFIG")."/config") or Fail "Cannot find configuration " . Get("CONFIG");
 151                 Override("CONFIG" => Get("CONFIG")."/config");
 152         }
 153 }
 154
 155 sub Include($) {
 156         my ($f) = @_;
 157         $f = FindFile($f);
 158         Notice "Loading configuration $f\n";
 159         require $f;
 160 }
 161
 162 sub PostConfig(&) {
 163         unshift @postconfigs, $_[0];
 164 }
 165
 166 sub AtWrite(&) {
 167         unshift @atwrites, $_[0];
 168 }
 169
 170 sub Finish() {
 171         for my $post (@postconfigs) {
 172                 &$post();
 173         }
 174
 175         print "\n";
 176
 177         if (Get("SRCDIR") ne ".") {
 178                 Log "Preparing for compilation from directory " . Get("SRCDIR") . " to obj/ ... ";
 179                 -l "src" and unlink "src";
 180                 symlink Get("SRCDIR"), "src" or Fail "Cannot link source directory to src: $!";
 181                 Override("SRCDIR" => "src");
 182                 -l "Makefile" and unlink "Makefile";
 183                 -f "Makefile" and Fail "Makefile already exists";
 184                 symlink "src/Makefile", "Makefile" or Fail "Cannot link Makefile: $!";
 185         } else {
 186                 Log "Preparing for compilation from current directory to obj/ ... ";
 187         }
 188         if (-d "obj") {
 189                 `rm -rf obj`; Fail "Cannot delete old obj directory" if $?;
 190         }
 191         -d "obj" or mkdir("obj", 0777) or Fail "Cannot create obj directory: $!";
 192         -d "obj/ucw" or mkdir("obj/ucw", 0777) or Fail "Cannot create obj/ucw directory: $!";
 193         Log "done\n";
 194
 195         Log "Generating config.mk ... ";
 196         open X, ">obj/config.mk" or Fail $!;
 197         print X "# Generated automatically by $0, please don't touch manually.\n";
 198         foreach my $x (sort keys %vars) {
 199                 print X "$x=$vars{$x}\n";
 200         }
 201         print X "s=\${SRCDIR}\n";
 202         print X "o=obj\n";
 203         close X;
 204         Log "done\n";
 205
 206         for my $wr (@atwrites) {
 207                 &$wr();
 208         }
 209 }
 210
 211 sub TryCmd($) {
 212         my ($cmd) = @_;
 213         my $res = `$cmd`;
 214         defined $res or return;
 215         chomp $res;
 216         return $res unless $?;
 217         return;
 218 }
 219
 220 sub maybe_manually($) {
 221         my ($n) = @_;
 222         if (IsGiven($n)) {
 223                 if (Get("$n")) { Log "YES (set manually)\n"; }
 224                 else { Log "NO (set manually)\n"; }
 225                 return 1;
 226         }
 227         return 0;
 228 }
 229
 230 sub PkgConfig($@) {
 231         my $pkg = shift @_;
 232         my %opts = @_;
 233         my $upper = $pkg; $upper =~ tr/a-z/A-Z/; $upper =~ s/[^0-9A-Z]+/_/g;
 234         Log "Checking for package $pkg ... ";
 235         maybe_manually("CONFIG_HAVE_$upper") and return Get("CONFIG_HAVE_$upper");
 236         my $ver = TryCmd("pkg-config --modversion $pkg 2>/dev/null");
 237         if (!defined $ver) {
 238                 Log("NONE\n");
 239                 return 0;
 240         }
 241         if (defined($opts{minversion})) {
 242                 my $min = $opts{minversion};
 243                 if (!defined TryCmd("pkg-config --atleast-version=$min $pkg")) {
 244                         Log("NO: version $ver is too old (need >= $min)\n");
 245                         return 0;
 246                 }
 247         }
 248         Log("YES: version $ver\n");
 249         Set("CONFIG_HAVE_$upper" => 1);
 250         Set("CONFIG_VER_$upper" => $ver);
 251         my $cf = TryCmd("pkg-config --cflags $pkg");
 252         Set("${upper}_CFLAGS" => $cf) if defined $cf;
 253         my $lf = TryCmd("pkg-config --libs $pkg");
 254         Set("${upper}_LIBS" => $lf) if defined $lf;
 255         return 1;
 256 }
 257
 258 sub ver_norm($) {
 259         my ($v) = @_;
 260         return join(".", map { sprintf("%05s", $_) } split(/\./, $v));
 261 }
 262
 263 sub TrivConfig($@) {
 264         my $pkg = shift @_;
 265         my %opts = @_;
 266         my $upper = $pkg; $upper =~ tr/a-z/A-Z/; $upper =~ s/[^0-9A-Z]+/_/g;
 267         Log "Checking for package $pkg ... ";
 268         maybe_manually("CONFIG_HAVE_$upper") and return Get("CONFIG_HAVE_$upper");
 269         my $pc = $opts{script};
 270         my $ver = TryCmd("$pc --version 2>/dev/null");
 271         if (!defined $ver) {
 272                 Log("NONE\n");
 273                 return 0;
 274         }
 275         if (defined($opts{minversion})) {
 276                 my $min = $opts{minversion};
 277                 if (ver_norm($ver) lt ver_norm($min)) {
 278                         Log("NO: version $ver is too old (need >= $min)\n");
 279                         return 0;
 280                 }
 281         }
 282         Log("YES: version $ver\n");
 283         Set("CONFIG_HAVE_$upper" => 1);
 284         Set("CONFIG_VER_$upper" => $ver);
 285
 286         my $want = $opts{want};
 287         defined $want or $want = ["cflags", "libs"];
 288         for my $w (@$want) {
 289                 my $uw = $w; $uw =~ tr/a-z-/A-Z_/;
 290                 my $cf = TryCmd("$pc --$w");
 291                 Set("${upper}_${uw}" => $cf) if defined $cf;
 292         }
 293         return 1;
 294 }
 295
 296 1;  # OK