From a892f655efae77b302c9cd5978d4881eac14589c Mon Sep 17 00:00:00 2001
From: Julian Maurice <julian.maurice@biblibre.com>
Date: Fri, 30 Apr 2021 17:13:48 +0200
Subject: [PATCH] Bug 28278: Improve $KOHA_CONF parsing speed by using
 XML::LibXML
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

- Without the patch:

$ hyperfine --warmup 1 \
  'perl -MKoha::Config -e "Koha::Config->read_from_file(\$ENV{KOHA_CONF}) for (1..1000)"'

  Time (mean ± σ):      3.585 s ±  0.018 s    [User: 3.531 s, System: 0.049 s]
  Range (min … max):    3.547 s …  3.612 s    10 runs

- With the patch:

$ hyperfine --warmup 1 \
  'perl -MKoha::Config -e "Koha::Config->read_from_file(\$ENV{KOHA_CONF}) for (1..1000)"'

  Time (mean ± σ):      1.122 s ±  0.028 s    [User: 1.104 s, System: 0.014 s]
  Range (min … max):    1.095 s …  1.189 s    10 runs

Test plan:
1. Apply the first patch (the one with the unit tests) and make sure
   tests pass: `prove t/Koha/Config.t`
2. Apply the rest of the patches and verify that tests still pass:
   `prove t/Koha/Config.t`.

Signed-off-by: Victor Grousset/tuxayo <victor@tuxayo.net>
Signed-off-by: Martin Renvoize <martin.renvoize@ptfs-europe.com>

Signed-off-by: Jonathan Druart <jonathan.druart@bugs.koha-community.org>
---
 Koha/Config.pm | 67 +++++++++++++++++++++++++++++++++++++++++++-------
 1 file changed, 58 insertions(+), 9 deletions(-)

diff --git a/Koha/Config.pm b/Koha/Config.pm
index b0f36f2551..3e46e2728d 100644
--- a/Koha/Config.pm
+++ b/Koha/Config.pm
@@ -17,7 +17,7 @@ package Koha::Config;
 
 use Modern::Perl;
 
-use XML::Simple;
+use XML::LibXML ':libxml';
 
 # Default config file, if none is specified
 use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
@@ -37,21 +37,70 @@ sub read_from_file {
 
     return if not defined $file;
 
-    my $xml;
+    my $config = {};
     eval {
-        $xml = XMLin(
-            $file,
-            keyattr => ['id'],
-            forcearray => ['listen', 'server', 'serverinfo'],
-            suppressempty => ''
-        );
+        my $dom = XML::LibXML->load_xml(location => $file);
+        foreach my $childNode ($dom->documentElement->nonBlankChildNodes) {
+            $class->_read_from_dom_node($childNode, $config);
+        }
     };
 
     if ($@) {
         die "\nError reading file $file.\nTry running this again as the koha instance user (or use the koha-shell command in debian)\n\n";
     }
 
-    return $xml;
+    return $config;
+}
+
+sub _read_from_dom_node {
+    my ($class, $node, $config) = @_;
+
+    if ($node->nodeType == XML_TEXT_NODE) {
+        $config->{content} = $node->textContent;
+    } elsif ($node->nodeType == XML_ELEMENT_NODE) {
+        my $subconfig = {};
+
+        foreach my $attribute ($node->attributes) {
+            my $key = $attribute->nodeName;
+            my $value = $attribute->value;
+            $subconfig->{$key} = $value;
+        }
+
+        foreach my $childNode ($node->nonBlankChildNodes) {
+            $class->_read_from_dom_node($childNode, $subconfig);
+        }
+
+        my $key = $node->nodeName;
+        if ($node->hasAttribute('id')) {
+            my $id = $node->getAttribute('id');
+            $config->{$key} //= {};
+            $config->{$key}->{$id} = $subconfig;
+            delete $subconfig->{id};
+        } else {
+            my @keys = keys %$subconfig;
+            if (1 == scalar @keys && $keys[0] eq 'content') {
+                # An element with no attributes and no child elements becomes its text content
+                $subconfig = $subconfig->{content};
+            } elsif (0 == scalar @keys) {
+                # An empty element becomes an empty string
+                $subconfig = '';
+            }
+
+            if (exists $config->{$key}) {
+                unless (ref $config->{$key} eq 'ARRAY') {
+                    $config->{$key} = [$config->{$key}];
+                }
+                push @{ $config->{$key} }, $subconfig;
+            } else {
+                if (grep { $_ eq $key } (qw(listen server serverinfo))) {
+                    # <listen>, <server> and <serverinfo> are always arrays
+                    $config->{$key} = [$subconfig];
+                } else {
+                    $config->{$key} = $subconfig;
+                }
+            }
+        }
+    }
 }
 
 # Koha's main configuration file koha-conf.xml
-- 
2.39.5