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 |
- |