src/perl/lib/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 sub _check_for_int {
  96         my $value = shift;
  97         return 0+$value if ($value =~ /^\d{1,10}$/o);
  98         return $value;
  99 }
 100
 101 sub XML2perl {
 102         my $node = shift;
 103         my %output;
 104
 105         return undef unless($node);
 106
 107         for my $attr ( ($node->attributes()) ) {
 108                 next unless($attr);
 109                 $output{$attr->nodeName} = _check_for_int($attr->value);
 110         }
 111
 112         my @kids = $node->childNodes;
 113         if (@kids == 1 && $kids[0]->nodeType == 3) {
 114                         return _check_for_int($kids[0]->textContent);
 115         } else {
 116                 for my $kid ( @kids ) {
 117                         next if ($kid->nodeName eq 'comment');
 118                         if (exists $output{$kid->nodeName}) {
 119                                 if (ref $output{$kid->nodeName} ne 'ARRAY') {
 120                                         $output{$kid->nodeName} = [$output{$kid->nodeName}, XML2perl($kid)];
 121                                 } else {
 122                                         push @{$output{$kid->nodeName}}, XML2perl($kid);
 123                                 }
 124                                 next;
 125                         }
 126                         $output{$kid->nodeName} = XML2perl($kid);
 127                 }
 128         }
 129
 130         return \%output;
 131 }
 132
 133
 134 # returns the full config hash for a given server
 135 sub get_server_config {
 136         my( $self, $server ) = @_;
 137         my $xpath = "/opensrf/default|/opensrf/hosts/$server";
 138         return $self->_get( $xpath );
 139 }
 140
 141 sub get_default_config {
 142         my( $self, $server ) = @_;
 143         my $xpath = "/opensrf/default";
 144         return $self->_get( $xpath );
 145 }
 146
 147 sub get_bootstrap_config {
 148         my( $self ) = @_;
 149         my $xpath = "/opensrf/bootstrap";
 150         return $self->_get( $xpath );
 151 }
 152
 153 sub get_router_config {
 154         my( $self, $router ) = @_;
 155         my $xpath = "/opensrf/routers/$router";
 156         return $self->_get($xpath );
 157 }
 158
 159
 160
 161
 162 1;