File Coverage

blib/lib/DeltaX/Config.pm
Criterion Covered Total %
statement 101 127 79.5
branch 33 60 55.0
condition 8 12 66.6
subroutine 8 9 88.8
pod 3 3 100.0
total 153 211 72.5


line stmt bran cond sub pod time code
1             #-----------------------------------------------------------------
2             package DeltaX::Config;
3             #-----------------------------------------------------------------
4             # $Id: Config.pm,v 1.2 2003/10/30 15:51:44 spicak Exp $
5             #
6             # (c) DELTA E.S., 2002 - 2003
7             # This package is free software; you can use it under "Artistic License" from
8             # Perl.
9             #-----------------------------------------------------------------
10             $DeltaX::Config::VERSION = '1.0';
11              
12 1     1   531 use strict;
  1         2  
  1         33  
13 1     1   5 use Carp;
  1         1  
  1         2708  
14              
15             #-----------------------------------------------------------------
16             sub new {
17             #-----------------------------------------------------------------
18             # CONSTRUCTOR
19             #
20 4     4 1 86 my $pkg = shift;
21 4         6 my $self = {};
22 4         10 bless ($self, $pkg);
23              
24 4         19 $self->{filename} = '';
25 4         8 $self->{db} = '';
26 4         7 $self->{app} = '';
27 4         8 $self->{db_table} = 'app_lang';
28 4         8 $self->{lang} = 'CZ';
29              
30 4 50       12 croak ("$pkg created with odd number of parameters - should be of the form option => value")
31             if (@_ % 2);
32 4         15 for (my $x = 0; $x <= $#_; $x += 2) {
33 12 50       22 if (exists $self->{$_[$x]}) {
34 12         44 $self->{$_[$x]} = $_[$x+1];
35             }
36             else {
37 0         0 $self->{special}{$_[$x]} = $_[$x+1];
38             }
39             }
40              
41 4         9 $self->{error} = '';
42              
43 4 0 33     11 croak ("$pkg: You must set db handle or filename!")
44             if (! $self->{filename} and ! $self->{db});
45 4 50 33     13 croak ("$pkg: You must set application name for db handle!")
46             if ($self->{db} and ! $self->{app});
47              
48 4         10 return $self;
49             }
50             # END OF new()
51              
52             #-----------------------------------------------------------------
53             sub read {
54             #-----------------------------------------------------------------
55             #
56 4     4 1 29 my $self = shift;
57              
58 4 50       9 if ($self->{filename}) {
59 4         14 return $self->_read_file();
60             }
61 0 0       0 if ($self->{db}) {
62 0         0 return $self->_read_db();
63             }
64              
65 0         0 return undef;
66              
67             }
68             # END OF read()
69              
70             #-----------------------------------------------------------------
71             sub _read_file {
72             #-----------------------------------------------------------------
73             #
74 4     4   5 my $self = shift;
75              
76 4         10 local(*INF);
77 4 50       166 if (! open INF, $self->{filename}) {
78 0         0 $self->{error} = "cannot read file '".$self->{filename}."': $!";
79 0         0 return undef;
80             }
81              
82 4         6 my %ret;
83             my $place;
84 4         6 my $prev_line = '';
85 4         72 while () {
86 19         34 chomp;
87              
88 19 100       34 if ($prev_line) {
89             # zrusime mezery na zacatku
90 2         8 s/^[ \t]*//g;
91 2         4 $_ = $prev_line . ' '. $_;
92 2         5 $prev_line = '';
93             }
94              
95 19 100       35 if (! $_) { next; }
  4         10  
96              
97 15 100       43 if (/^[ ]*#/) {
98 4         16 s/[ ]*#[ ]*//g;
99 4 100       20 if (/^!(.*)$/) {
100 2         7 my $tmp = $self->_special($1);
101 2 50       8 return undef unless defined $tmp;
102 2         2 foreach my $key (keys %{$tmp}) {
  2         7  
103 2 50       20 $ret{$key} = $tmp->{$key} unless exists $ret{$key};
104             }
105             }
106             }
107             else {
108 11         18 s/#.*$//g;
109              
110             # zrusime mezery na zacatku a na konci
111 11         48 s/^[ \t]*//g;
112 11         73 s/[ \t]*$//g;
113              
114             # pokud je nakonci zpetne lomitko, zapamatujeme si to a pridame k
115             # pristimu radku
116 11 100       32 if (/\\$/) {
117 2         8 $prev_line = substr($_, 0, -1);
118             # zrusime mezery na konci
119 2         14 $prev_line =~ s/[ \t]*$//g;
120 2         7 next;
121             }
122              
123 9         26 my ($key, $val) = split(/=/, $_, 2);
124 9 50       22 $key = '' if !defined $key;
125 9 50       15 $val = '' if !defined $val;
126 9         33 $key =~ s/^[ ]*//g;
127 9         46 $key =~ s/[ ]*$//g;
128 9         32 $val =~ s/^[ ]*//g;
129 9         45 $val =~ s/[ ]*$//g;
130 9 50       21 if (length($key) < 1) { next; }
  0         0  
131             # untaint!
132 9 50       34 if ($key =~ /^([-\w.]+)$/) {
133 9         20 $key = $1;
134             }
135             else {
136 0         0 $self->{error} = "Invalid key '$key' in file!";
137 0         0 return undef;
138             }
139              
140 9         31 my $tmp = '$ret{\''.join("'}{'", split(/\./, $key)).'\'}';
141 9         5082 $place = eval "\\($tmp)";
142 9         79 $$place = $val;
143             }
144             }
145              
146 4         68 close INF;
147              
148 4         23 return \%ret;
149              
150             }
151             # END OF _read_file()
152              
153             #-----------------------------------------------------------------
154             sub get_error {
155             #-----------------------------------------------------------------
156             #
157 0     0 1 0 my $self = shift;
158              
159 0         0 return $self->{error};
160             }
161             # END OF get_error()
162              
163             #-----------------------------------------------------------------
164             sub _special {
165             #-----------------------------------------------------------------
166             #
167 2     2   3 my $self = shift;
168 2         6 my $token = shift;
169              
170 2         9 $token =~ s/^\s*//g;
171            
172 2 100       11 if ($token =~ /^include/) {
173 1         4 $token =~ /^include\s+(\S+)\s*$/;
174 1         5 return $self->_include($1);
175             }
176 1 50       5 if ($token =~ /^import/) {
177 1         4 $token =~ /^import\s+(\S+)\s*$/;
178 1         4 my $tmp = $self->_include($1);
179 1 50       4 if ($tmp) {
180 1         1 my %tmp;
181 1         3 my $key = $1;
182 1 50       7 $key = substr($key, 0, rindex($key, '.')) if (rindex($key, '.') > 0);
183 1         3 $tmp{$key} = $tmp;
184 1         3 return \%tmp;
185             }
186             else {
187 0         0 return undef;
188             }
189             }
190              
191 0         0 $token =~ /^(\S+)\s*(.*)$/s;
192 0         0 my @args;
193 0 0       0 if ($2) { @args = split(/,/, $2); }
  0         0  
194             # other special command
195 0 0       0 if (! exists $self->{special}{$1}) {
196 0         0 $self->{error} = "unknown directive '$1'";
197 0         0 return undef;
198             }
199 0         0 return $self->{special}{$1}->(@args);
200              
201             }
202             # END OF _special
203              
204             #-----------------------------------------------------------------
205             sub _include {
206             #-----------------------------------------------------------------
207             #
208 2     2   5 my $self = shift;
209 2         4 my $arg = shift;
210              
211             # relative path!
212 2 50       7 if ($arg !~ /^\//) {
213 2 50       12 if ($self->{filename} =~ /^(.*)\/[^\/]*$/) {
214 2 50       8 if ($self->{special}{'include'}) {
215 0         0 $arg = $self->{special}{'include'}->($arg);
216             } else {
217 2         8 $arg = "$1/$arg";
218             }
219             }
220             }
221 2 50       7 if (!$arg) {
222 0         0 $self->{error} = "include: no file found";
223 0         0 return undef;
224             }
225              
226 2         11 my @spec;
227 2         3 foreach my $s (sort keys %{$self->{special}}) {
  2         8  
228 0         0 push @spec, $s, $self->{special}{$s};
229             }
230 2         4 foreach my $s (keys %{$self}) {
  2         6  
231 14 100 100     98 push @spec, $s, $self->{$s}
      100        
232             unless ($s eq 'filename' or $s eq 'special' or $s eq 'error');
233             }
234 2         12 my $inc = new DeltaX::Config(filename=>$arg, @spec);
235 2         8 my $ret = $inc->read();
236 2 50       7 if (! defined $ret) {
237 0         0 $self->{error} = "include: unable to read '$arg': ". $inc->get_error();
238 0         0 return undef;
239             }
240 2         7 return $ret;
241             }
242             # END OF _include()
243              
244             #-----------------------------------------------------------------
245             sub DESTROY {
246             #-----------------------------------------------------------------
247             #
248 4     4   38 my $self = shift;
249              
250             }
251             # END OF DESTROY()
252              
253             1;