|
Lines 1-179
Link Here
|
| 1 |
# Copyright 2008 LibLime |
|
|
| 2 |
# |
| 3 |
# This file is part of Koha. |
| 4 |
# |
| 5 |
# Koha is free software; you can redistribute it and/or modify it under the |
| 6 |
# terms of the GNU General Public License as published by the Free Software |
| 7 |
# Foundation; either version 2 of the License, or (at your option) any later |
| 8 |
# version. |
| 9 |
# |
| 10 |
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY |
| 11 |
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR |
| 12 |
# A PARTICULAR PURPOSE. See the GNU General Public License for more details. |
| 13 |
# |
| 14 |
# You should have received a copy of the GNU General Public License along |
| 15 |
# with Koha; if not, write to the Free Software Foundation, Inc., |
| 16 |
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
| 17 |
# |
| 18 |
|
| 19 |
use strict; |
| 20 |
use warnings; |
| 21 |
|
| 22 |
use Sys::Hostname; |
| 23 |
use Socket; |
| 24 |
use Getopt::Long; |
| 25 |
use Pod::Usage; |
| 26 |
use Data::Dumper; |
| 27 |
|
| 28 |
# These variables get set from command line options |
| 29 |
my ( $fname ); |
| 30 |
GetOptions( 'file=s', \$fname ) |
| 31 |
or pod2usage(); |
| 32 |
|
| 33 |
|
| 34 |
=head1 NAME |
| 35 |
|
| 36 |
rewrite-test-config.PL - helper for the Koha packager and installer |
| 37 |
|
| 38 |
=head1 SYNOPSIS |
| 39 |
|
| 40 |
perl rewrite-test-config.PL configurationfile |
| 41 |
|
| 42 |
=head1 DESCRIPTION |
| 43 |
|
| 44 |
This helper script replaces keywords in the |
| 45 |
configuration file with value either supplied through |
| 46 |
the environment |
| 47 |
|
| 48 |
I intend to make this part of hte normal make process eventually. |
| 49 |
|
| 50 |
=head2 KEYWORDS |
| 51 |
|
| 52 |
The following configuration keywords are available: |
| 53 |
|
| 54 |
=head1 EXAMPLES |
| 55 |
|
| 56 |
=cut |
| 57 |
|
| 58 |
my $configfile = 'test-config.txt'; |
| 59 |
my $configuration = read_config_file( $configfile ); |
| 60 |
|
| 61 |
# Override configuration from the environment |
| 62 |
foreach my $key (keys %$configuration) { |
| 63 |
if (defined($ENV{$key})) { |
| 64 |
$configuration->{$key} = $ENV{$key}; |
| 65 |
} |
| 66 |
} |
| 67 |
|
| 68 |
$configuration = add_underscores( $configuration ); |
| 69 |
my %configuration = replace_test_params( $configuration ); |
| 70 |
|
| 71 |
my $file = read_file($fname); |
| 72 |
$file =~ s/__.*?__/exists $configuration{$&} ? $configuration{$&} : $&/seg; |
| 73 |
|
| 74 |
# At this point, file is in 'blib' and by default |
| 75 |
# has mode a-w. Therefore, must change permission |
| 76 |
# to make it writable. Note that stat and chmod |
| 77 |
# (the Perl functions) should work on Win32 |
| 78 |
my $old_perm; |
| 79 |
$old_perm = (stat $fname)[2] & 07777; |
| 80 |
my $new_perm = $old_perm | 0200; |
| 81 |
chmod $new_perm, $fname; |
| 82 |
|
| 83 |
open(OUTPUT,">$fname") || die "Can't open $fname for write: $!"; |
| 84 |
print OUTPUT $file; |
| 85 |
close(OUTPUT); |
| 86 |
|
| 87 |
chmod $old_perm, $fname; |
| 88 |
|
| 89 |
=head2 read_config_file |
| 90 |
|
| 91 |
takes the filename pointing to the configuration file that the |
| 92 |
top-level Makefile wrote |
| 93 |
|
| 94 |
returns a hashref that contains the configuration determined by |
| 95 |
that file. |
| 96 |
|
| 97 |
=cut |
| 98 |
|
| 99 |
sub read_config_file { |
| 100 |
my $config_file = shift; |
| 101 |
if ( not -e $config_file ) { |
| 102 |
die "unable to find configuration file: $config_file"; |
| 103 |
} |
| 104 |
my $config; |
| 105 |
if ( open( my $confighandle, '<', $config_file ) ) { |
| 106 |
while ( my $line = <$confighandle> ) { |
| 107 |
chomp $line; |
| 108 |
next if ( $line eq '' ); |
| 109 |
next if ( $line =~ /^\s*#/ ); |
| 110 |
my ( $var, $value ) = split( /\s*=\s*/, $line ); |
| 111 |
$config->{ $var } = $value; |
| 112 |
} |
| 113 |
} else { |
| 114 |
warn "unable to open configuration file: $config_file"; |
| 115 |
return; |
| 116 |
} |
| 117 |
return $config; |
| 118 |
} |
| 119 |
|
| 120 |
=head2 add_underscores |
| 121 |
|
| 122 |
=cut |
| 123 |
|
| 124 |
sub add_underscores { |
| 125 |
my $config = shift; |
| 126 |
|
| 127 |
my $newconfig; |
| 128 |
foreach my $key ( keys %$config ) { |
| 129 |
$newconfig->{ '__' . $key . '__' } = $config->{ $key }; |
| 130 |
} |
| 131 |
return $newconfig; |
| 132 |
} |
| 133 |
|
| 134 |
|
| 135 |
=head2 replace_test_params |
| 136 |
|
| 137 |
=cut |
| 138 |
|
| 139 |
sub replace_test_params { |
| 140 |
my $config = shift; |
| 141 |
|
| 142 |
my $testconfig; |
| 143 |
foreach my $key ( keys %$config ) { |
| 144 |
if ( $key =~ /^__TEST_/ ) { |
| 145 |
my $newkey = $key; |
| 146 |
$newkey =~ s/^__TEST_/__/; |
| 147 |
$testconfig->{ $newkey } = $config->{ $key }; |
| 148 |
} |
| 149 |
} |
| 150 |
# override variables with the "TEST_" variety. |
| 151 |
my %newconfig = ( %$config, %$testconfig ); |
| 152 |
return %newconfig; |
| 153 |
} |
| 154 |
|
| 155 |
# Idea taken from perlfaq5 |
| 156 |
sub read_file { |
| 157 |
local(*INPUT,$/); |
| 158 |
open(INPUT,$_[0]) || die "Can't open $_[0] for read"; |
| 159 |
my $file = <INPUT>; |
| 160 |
return $file; |
| 161 |
} |
| 162 |
|
| 163 |
__END__ |
| 164 |
|
| 165 |
|
| 166 |
=head1 SEE ALSO |
| 167 |
|
| 168 |
Makefile.PL, ExtUtils::MakeMaker(3) |
| 169 |
|
| 170 |
=head1 ACKNOWLEDGEMENTS |
| 171 |
|
| 172 |
based on rewrite-config.PL by MJ Ray. |
| 173 |
|
| 174 |
=head1 AUTHOR |
| 175 |
|
| 176 |
Andrew Moore <andrew.moore@liblime.com> |
| 177 |
|
| 178 |
=cut |
| 179 |
|
| 180 |
- |