src/perlmods/OpenSRF/Utils/SettingsParser.pm

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