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