perl/UCW/Configure.pm

   1 #       Perl module for UCW Configure Scripts
   2 #
   3 #       (c) 2005--2010 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 use IO::File;
  13
  14 BEGIN {
  15         # The somewhat hairy Perl export mechanism
  16         use Exporter();
  17         our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  18         $VERSION = 1.0;
  19         @ISA = qw(Exporter);
  20         @EXPORT = qw(&Init &Log &Notice &Warn &Fail &IsSet &IsGiven &Set &UnSet &Append &Override &Get &Test &TestBool &Include &Finish &FindFile &TryFindFile &DebugDump &PostConfig &AtWrite);
  21         @EXPORT_OK = qw();
  22         %EXPORT_TAGS = ();
  23 }
  24
  25 our %vars;
  26 our %overriden;
  27 our @postconfigs;
  28 our @atwrites;
  29
  30 sub DebugDump() {
  31         print "VARS:\n";
  32         print "$_: $vars{$_}\n" foreach( keys %vars );
  33 }
  34
  35 sub Log($) {
  36         print @_;
  37         STDOUT->flush;
  38 }
  39
  40 sub Notice($) {
  41         print @_ if $vars{"VERBOSE"};
  42         STDOUT->flush;
  43 }
  44
  45 sub Warn($) {
  46         print "WARNING: ", @_;
  47         STDOUT->flush;
  48 }
  49
  50 sub Fail($) {
  51         Log("ERROR: " . (shift @_) . "\n");
  52         exit 1;
  53 }
  54
  55 sub IsSet($) {
  56         my ($x) = @_;
  57         return exists $vars{$x};
  58 }
  59
  60 sub IsGiven($) {
  61         my ($x) = @_;
  62         return exists $overriden{$x};
  63 }
  64
  65 sub Get($) {
  66         my ($x) = @_;
  67         return $vars{$x};
  68 }
  69
  70 sub Set($;$) {
  71         my ($x,$y) = @_;
  72         $y=1 unless defined $y;
  73         $vars{$x}=$y unless $overriden{$x};
  74 }
  75
  76 sub UnSet($) {
  77         my ($x) = @_;
  78         delete $vars{$x} unless $overriden{$x};
  79 }
  80
  81 sub Append($$) {
  82         my ($x,$y) = @_;
  83         Set($x, (IsSet($x) ? (Get($x) . " $y") : $y));
  84 }
  85
  86 sub Override($;$) {
  87         my ($x,$y) = @_;
  88         $y=1 unless defined $y;
  89         $vars{$x}=$y;
  90         $overriden{$x} = 1;
  91 }
  92
  93 sub Test($$$) {
  94         my ($var,$msg,$sub) = @_;
  95         Log "$msg ... ";
  96         if (IsSet($var)) {
  97                 Log Get($var) . " (preset)\n";
  98         } else {
  99                 my $val = &$sub();
 100                 Set($var, $val);
 101                 Log "$val\n";
 102         }
 103 }
 104
 105 sub TestBool($$$) {
 106         my ($var,$msg,$sub) = @_;
 107         Log "$msg ... ";
 108         if (IsSet($var) || IsGiven($var)) {
 109                 Log ((Get($var) ? "yes" : "no") . " (set)\n");
 110         } else {
 111                 my ($val, $comment) = &$sub();
 112                 if ($val) {
 113                         Set($var);
 114                 } else {
 115                         UnSet($var);
 116                 }
 117                 Log (($val ? "yes" : "no") . "\n");
 118         }
 119 }
 120
 121 sub TryFindFile($) {
 122         my ($f) = @_;
 123         if ($f =~ m{^/}) {
 124                 return (-f $f) ? $f : undef;
 125         } elsif (-f $f) {
 126                 return "./$f";
 127         } elsif (-f (Get("SRCDIR")."/$f")) {
 128                 return Get("SRCDIR")."/$f";
 129         } else {
 130                 return undef;
 131         }
 132 }
 133
 134 sub FindFile($) {
 135         my ($f) = @_;
 136         my $F;
 137         defined ($F = TryFindFile($f)) or Fail "Cannot find file $f";
 138         return $F;
 139 }
 140
 141 sub Init($$) {
 142         my ($srcdir,$defconfig) = @_;
 143         sub usage($) {
 144                 my ($dc) = @_;
 145                 print STDERR "Usage: [<srcdir>/]configure " . (defined $dc ? "[" : "") . "<config-name>" . (defined $dc ? "]" : "") .
 146                         " [<option>[=<value>] | -<option>] ...\n";
 147                 exit 1;
 148         }
 149         Set('CONFIG' => $defconfig) if defined $defconfig;
 150         if (@ARGV) {
 151                 usage($defconfig) if $ARGV[0] eq "--help";
 152                 if (!defined($defconfig) || $ARGV[0] !~ /^-?[A-Z][A-Z0-9_]*(=|$)/) {
 153                         # This does not look like an option, so read it as a file name
 154                         Set('CONFIG' => shift @ARGV);
 155                 }
 156         }
 157         Set("SRCDIR", $srcdir);
 158
 159         foreach my $x (@ARGV) {
 160                 if ($x =~ /^(\w+)=(.*)/) {
 161                         Override($1 => $2);
 162                 } elsif ($x =~ /^-(\w+)$/) {
 163                         Override($1 => 0);
 164                         delete $vars{$1};
 165                 } elsif ($x =~ /^(\w+)$/) {
 166                         Override($1 => 1);
 167                 } else {
 168                         print STDERR "Invalid option $x\n";
 169                         exit 1;
 170                 }
 171         }
 172
 173         defined Get("CONFIG") or usage($defconfig);
 174         if (!TryFindFile(Get("CONFIG"))) {
 175                 TryFindFile(Get("CONFIG")."/config") or Fail "Cannot find configuration " . Get("CONFIG");
 176                 Override("CONFIG" => Get("CONFIG")."/config");
 177         }
 178 }
 179
 180 sub Include($) {
 181         my ($f) = @_;
 182         $f = FindFile($f);
 183         Notice "Loading configuration $f\n";
 184         require $f;
 185 }
 186
 187 sub PostConfig(&) {
 188         unshift @postconfigs, $_[0];
 189 }
 190
 191 sub AtWrite(&) {
 192         unshift @atwrites, $_[0];
 193 }
 194
 195 sub Finish() {
 196         for my $post (@postconfigs) {
 197                 &$post();
 198         }
 199
 200         print "\n";
 201
 202         if (Get("SRCDIR") ne ".") {
 203                 Log "Preparing for compilation from directory " . Get("SRCDIR") . " to obj/ ... ";
 204                 -l "src" and unlink "src";
 205                 symlink Get("SRCDIR"), "src" or Fail "Cannot link source directory to src: $!";
 206                 Override("SRCDIR" => "src");
 207                 -l "Makefile" and unlink "Makefile";
 208                 -f "Makefile" and Fail "Makefile already exists";
 209                 symlink "src/Makefile", "Makefile" or Fail "Cannot link Makefile: $!";
 210         } else {
 211                 Log "Preparing for compilation from current directory to obj/ ... ";
 212         }
 213         if (-d "obj") {
 214                 `rm -rf obj`; Fail "Cannot delete old obj directory" if $?;
 215         }
 216         -d "obj" or mkdir("obj", 0777) or Fail "Cannot create obj directory: $!";
 217         -d "obj/ucw" or mkdir("obj/ucw", 0777) or Fail "Cannot create obj/ucw directory: $!";
 218         Log "done\n";
 219
 220         Log "Generating config.mk ... ";
 221         open X, ">obj/config.mk" or Fail $!;
 222         print X "# Generated automatically by $0, please don't touch manually.\n";
 223         foreach my $x (sort keys %vars) {
 224                 print X "$x=$vars{$x}\n";
 225         }
 226         print X "s=\${SRCDIR}\n";
 227         print X "o=obj\n";
 228         close X;
 229         Log "done\n";
 230
 231         for my $wr (@atwrites) {
 232                 &$wr();
 233         }
 234 }
 235
 236 1;  # OK