File Coverage

File:blib/lib/OpenSRF/Utils/SettingsParser.pm
Coverage:13.8%

linestmtbrancondsubpodtimecode
1
13
13
13
13
13
13
13
13
77
55
88
84
53
82
use strict; use warnings;
2package OpenSRF::Utils::SettingsParser;
3
13
13
13
13
89
49
99
use OpenSRF::Utils::Config;
4
13
13
13
13
128
60
132
use OpenSRF::EX qw(:try);
5
6
7
8
13
13
13
13
94
54
92
use XML::LibXML;
9
10
0
0
sub DESTROY{}
11our $log = 'OpenSRF::Utils::Logger';
12my $parser;
13my $doc;
14
15
0
0
sub new { return bless({},shift()); }
16
17
18# returns 0 if the config file could not be found or if there is a parse error
19# returns 1 if successful
20sub initialize {
21
22
0
0
        my ($self,$bootstrap_config) = @_;
23
0
0
0
        return 0 unless($self and $bootstrap_config);
24
25
0
        $parser = XML::LibXML->new();
26
0
        $parser->keep_blanks(0);
27        try {
28
0
0
                $doc = $parser->parse_file( $bootstrap_config );
29        } catch Error with {
30
0
0
                return 0;
31
0
        };
32
0
        return 1;
33}
34
35
0
0
sub _get { _get_overlay(@_) }
36
37sub _get_overlay {
38
0
0
        my( $self, $xpath ) = @_;
39
0
        my @nodes = $doc->documentElement->findnodes( $xpath );
40
41
0
        my $base = XML2perl(shift(@nodes));
42
0
        my @overlays;
43
0
        for my $node (@nodes) {
44
0
                push @overlays, XML2perl($node);
45        }
46
47
0
        for my $ol ( @overlays ) {
48
0
                $base = merge_perl($base, $ol);
49        }
50
51
0
        return $base;
52}
53
54sub _get_all {
55
0
0
        my( $self, $xpath ) = @_;
56
0
        my @nodes = $doc->documentElement->findnodes( $xpath );
57
58
0
        my @overlays;
59
0
        for my $node (@nodes) {
60
0
                push @overlays, XML2perl($node);
61        }
62
63
0
        return \@overlays;
64}
65
66sub merge_perl {
67
0
0
        my $base = shift;
68
0
        my $ol = shift;
69
70
0
0
        if (ref($ol)) {
71
0
0
                if (ref($ol) eq 'HASH') {
72
0
                        for my $key (keys %$ol) {
73
0
0
0
                                if (ref($$ol{$key}) and ref($$ol{$key}) eq ref($$base{$key})) {
74
0
                                        merge_perl($$base{$key}, $$ol{$key});
75                                } else {
76
0
                                        $$base{$key} = $$ol{$key};
77                                }
78                        }
79                } else {
80
0
                        for my $key (0 .. scalar(@$ol) - 1) {
81
0
0
0
                                if (ref($$ol[$key]) and ref($$ol[$key]) eq ref($$base[$key])) {
82
0
                                        merge_perl($$base[$key], $$ol[$key]);
83                                } else {
84
0
                                        $$base[$key] = $$ol[$key];
85                                }
86                        }
87                }
88        } else {
89
0
                $base = $ol;
90        }
91
92
0
        return $base;
93}
94
95sub _check_for_int {
96
0
0
        my $value = shift;
97
0
0
        return 0+$value if ($value =~ /^\d{1,10}$/o);
98
0
        return $value;
99}
100
101sub XML2perl {
102
0
0
        my $node = shift;
103
0
        my %output;
104
105
0
0
        return undef unless($node);
106
107
0
        for my $attr ( ($node->attributes()) ) {
108
0
0
                next unless($attr);
109
0
                $output{$attr->nodeName} = _check_for_int($attr->value);
110        }
111
112
0
        my @kids = $node->childNodes;
113
0
0
0
        if (@kids == 1 && $kids[0]->nodeType == 3) {
114
0
                        return _check_for_int($kids[0]->textContent);
115        } else {
116
0
                for my $kid ( @kids ) {
117
0
0
                        next if ($kid->nodeName eq 'comment');
118
0
0
                        if (exists $output{$kid->nodeName}) {
119
0
0
                                if (ref $output{$kid->nodeName} ne 'ARRAY') {
120
0
                                        $output{$kid->nodeName} = [$output{$kid->nodeName}, XML2perl($kid)];
121                                } else {
122
0
0
                                        push @{$output{$kid->nodeName}}, XML2perl($kid);
123                                }
124
0
                                next;
125                        }
126
0
                        $output{$kid->nodeName} = XML2perl($kid);
127                }
128        }
129
130
0
        return \%output;
131}
132
133
134# returns the full config hash for a given server
135sub get_server_config {
136
0
0
        my( $self, $server ) = @_;
137
0
        my $xpath = "/opensrf/default|/opensrf/hosts/$server";
138
0
        return $self->_get( $xpath );
139}
140
141sub get_default_config {
142
0
0
        my( $self, $server ) = @_;
143
0
        my $xpath = "/opensrf/default";
144
0
        return $self->_get( $xpath );
145}
146
147sub get_bootstrap_config {
148
0
0
        my( $self ) = @_;
149
0
        my $xpath = "/opensrf/bootstrap";
150
0
        return $self->_get( $xpath );
151}
152
153sub get_router_config {
154
0
0
        my( $self, $router ) = @_;
155
0
        my $xpath = "/opensrf/routers/$router";
156
0
        return $self->_get($xpath );
157}
158
159
160
161
1621;