1#! perl -w 2# 3# w32locatedb.pl -- Build apr-util with Berkeley DB on Win32 4# 5# Usage: perl w32locatedb.pl <type> <incdir> <libdir> 6# type: Library type to link with ('lib' or 'dll') 7# incdir: BDB includes directory (for db.h) 8# libdir: Library directory (for libdbXY[s][d].lib) 9# 10# This script falls under the Apache License. 11# See http://www.apache.org/docs/LICENSE 12 13require 5.008; 14use strict; 15use File::Spec::Functions qw(canonpath rel2abs 16 splitpath catpath splitdir catdir); 17 18######## 19# Subroutine prototypes 20sub usage(); 21sub find_srcdir(); 22sub get_lib_name($$); 23sub edit_header($$); 24sub edit_project($$); 25 26######## 27# Parse program arguments and set globals 28die usage() unless scalar @ARGV >= 3; 29 30my $type = lc($ARGV[0]); 31die "Invalid library type '$type'\n" 32 unless $type eq 'lib' or $type eq 'dll'; 33 34my $incdir = $ARGV[1]; 35die "No 'db.h' in $incdir\n" unless -f "$incdir/db.h"; 36 37my $libdir = $ARGV[2]; 38die "$libdir: $!" unless -d $libdir; 39 40my $libname = get_lib_name($type, $incdir); 41die "No '$libname.lib' in $libdir" unless -f "$libdir/$libname.lib"; 42die "No '${libname}d.lib' in $libdir" unless -f "$libdir/${libname}d.lib"; 43 44my $srcdir = find_srcdir(); 45my $apu_hw = canonpath("$srcdir/include/apu.hw"); 46my $apu_want_hw = canonpath("$srcdir/include/apu_want.hw"); 47my $apu_select_dbm_hw = canonpath("$srcdir/include/private/apu_select_dbm.hw"); 48my $aprutil_dsp = canonpath("$srcdir/aprutil.dsp"); 49my $libaprutil_dsp = canonpath("$srcdir/libaprutil.dsp"); 50die "Can't find $apu_hw" unless -f $apu_hw; 51die "Can't find $apu_want_hw" unless -f $apu_want_hw; 52die "Can't find $apu_select_dbm_hw" unless -f $apu_select_dbm_hw; 53die "Can't find $aprutil_dsp" unless -f $aprutil_dsp; 54die "Can't find $libaprutil_dsp" unless -f $libaprutil_dsp; 55 56 57######## 58# Edit the header file templates 59my $db_h = rel2abs(canonpath("$incdir/db.h")); 60$db_h =~ s/\\/\//g; 61edit_header($apu_hw, 62 [['^\s*\#\s*define\s+APU_HAVE_DB\s+0\s*$', 63 '#define APU_HAVE_DB 1']]); 64edit_header($apu_want_hw, 65 [['^\s*\#\s*include\s+\<db\.h\>\s*$', 66 "#include \"$db_h\""]]); 67edit_header($apu_select_dbm_hw, 68 [['^\s*\#\s*define\s+APU_USE_DB\s+0\s*$', 69 '#define APU_USE_DB 1'], 70 ['^\s*\#\s*include\s+\<db\.h\>\s*$', 71 "#include \"$db_h\""]]); 72 73######## 74# Edit the .dsp files 75my $libpath = rel2abs(canonpath("$libdir/$libname")); 76edit_project($aprutil_dsp, $libpath); 77edit_project($libaprutil_dsp, $libpath); 78 79 80######## 81# Print usage 82sub usage() 83{ 84 return ("Usage: perl w32locatedb.pl <type> <incdir> <libdir>\n" 85 . " type: Library type to link with ('lib' or 'dll')\n" 86 . " incdir: BDB includes directory (for db.h)\n" 87 . " libdir: Library directory (for libdbXY[s][d].lib)\n"); 88} 89 90######## 91# Calculate the (possibly relative) path to the top of the apr-util 92# source dir. 93sub find_srcdir() 94{ 95 my $srcdir = rel2abs(canonpath($0)); 96 my ($vol, $dir, $file) = splitpath($srcdir); 97 my @dirs = splitdir($dir); 98 die if scalar @dirs < 1; 99 do { $_ = pop @dirs } while ($_ eq ''); 100 return catpath($vol, catdir(@dirs), ''); 101} 102 103######## 104# Construct the name of the BDB library, based on the type and 105# version information in db.h 106sub get_lib_name($$) 107{ 108 my ($type, $incdir) = @_; 109 my $major = undef; 110 my $minor = undef; 111 my $patch = undef; 112 113 open(DBH, "< $incdir/db.h") 114 or die "Can't open $incdir/db.h: $!"; 115 while (<DBH>) { 116 chomp; 117 m/^\s*\#\s*define\s+DB_VERSION_(MAJOR|MINOR|PATCH)\s+(\d+)\s*$/; 118 next unless defined $1 and defined $2; 119 if ($1 eq 'MAJOR') { $major = $2; } 120 elsif ($1 eq 'MINOR') { $minor = $2; } 121 elsif ($1 eq 'PATCH') { $patch = $2; } 122 last if defined $major and defined $minor and defined $patch; 123 } 124 close(DBH); 125 die "Can't determine BDB version\n" 126 unless defined $major and defined $minor and defined $patch; 127 128 print "Using BDB version $major.$minor.$patch\n"; 129 130 my $libname = "libdb$major$minor"; 131 $libname .= 's' if $type eq 'lib'; 132 return $libname; 133} 134 135######## 136# Replace a file, keeping a backup copy 137sub maybe_rename_with_backup($$$) 138{ 139 my ($tmpfile, $file, $maybe) = @_; 140 if ($maybe) { 141 # Make the file writable by the owner. On Windows, this removes 142 # any read-only bits. 143 chmod((stat($file))[2] | 0600, $file); 144 rename($file, "${file}~"); 145 rename($tmpfile, $file); 146 } else { 147 print "No changes in $file\n"; 148 unlink($tmpfile); 149 } 150} 151 152######## 153# Edit a header template in-place. 154sub edit_header($$) 155{ 156 my ($file, $pairs) = @_; 157 my $tmpfile = "$file.tmp"; 158 my $substs = 0; 159 160 open(IN, "< $file") or die "Can't open $file: $!"; 161 open(TMP, "> $tmpfile") or die "Can't open $tmpfile: $!"; 162 while (<IN>) { 163 chomp; 164 foreach my $pair (@$pairs) { 165 $substs += s/${$pair}[0]/${$pair}[1]/; 166 } 167 print TMP $_, "\n"; 168 } 169 close(IN); 170 close(TMP); 171 172 maybe_rename_with_backup($tmpfile, $file, $substs > 0); 173} 174 175######## 176# Edit a project file in-place 177sub edit_project($$) 178{ 179 my ($file, $libpath) = @_; 180 my $tmpfile = "$file.tmp"; 181 my $substs = 0; 182 my ($prog, $debug) = (undef, undef); 183 184 my $libsearch = $libpath; 185 $libsearch =~ s/\\/\\\\/g; 186 187 open(IN, "< $file") or die "Can't open $file: $!"; 188 open(TMP, "> $tmpfile") or die "Can't open $tmpfile: $!"; 189 while (<IN>) { 190 chomp; 191 192 if (m/^\# TARGTYPE \"[^\"]+\" 0x([0-9A-Za-z]+)/ 193 and defined $1) { 194 $prog = 'LINK32' if $1 eq '0102'; 195 $prog = 'LIB32' if $1 eq '0104'; 196 die "Unknown project type 0x$1" unless defined $prog; 197 } elsif (defined $prog 198 and m/^\# PROP Use_Debug_Libraries ([01])/ 199 and defined $1) { 200 $debug = $1; 201 } elsif (defined $prog and defined $debug 202 and m/^\# ADD $prog (\"$libsearch)?/ 203 and not defined $1) { 204 my $fullpath = 205 ($debug eq '1' ? "${libpath}d.lib" : "$libpath.lib"); 206 $substs += s/^\# ADD $prog /\# ADD $prog \"$fullpath\" /; 207 } elsif (m/^\# ADD CPP/) { 208 $substs += s/APU_USE_SDBM/APU_USE_DB/g; 209 } 210 211 print TMP $_, "\n"; 212 } 213 close(IN); 214 close(TMP); 215 216 maybe_rename_with_backup($tmpfile, $file, $substs > 0); 217} 218