From 1887f3b53fbd78c0dfa114942d57df2f24b7a954 Mon Sep 17 00:00:00 2001
From: Andrew Nugged <nugged@gmail.com>
Date: Fri, 4 Jun 2021 22:32:22 +0300
Subject: [PATCH] Bug 28489: POD - CGI::Session::Serialize::yamlxs for
 CGI::Session

Signed-off-by: David Cook <dcook@prosentient.com.au>

Signed-off-by: Nick Clemens <nick@bywatersolutions.com>

Signed-off-by: Jonathan Druart <jonathan.druart@bugs.koha-community.org>
---
 C4/Auth.pm | 37 +++++++++++++++++++++++++++++++++----
 1 file changed, 33 insertions(+), 4 deletions(-)

diff --git a/C4/Auth.pm b/C4/Auth.pm
index f281def2ce..cf254ba60e 100644
--- a/C4/Auth.pm
+++ b/C4/Auth.pm
@@ -1,3 +1,32 @@
+package CGI::Session::Serialize::yamlxs;
+# Proof of concept: CGI::Session::Serialize::yamlxs for CGI::Session:
+
+use strict;
+use warnings;
+
+# hacky hack to trick CGI::Session loader for serializers not to die in its "require":
+$INC{'CGI/Session/Serialize/yamlxs.pm'} = '1';
+
+use CGI::Session::ErrorHandler;
+use YAML::XS ();
+use Encode ();
+
+$CGI::Session::Serialize::yamlxs::VERSION = '0.1';
+@CGI::Session::Serialize::yamlxs::ISA     = ( "CGI::Session::ErrorHandler" );
+
+sub freeze {
+    my ($self, $data) = @_;
+    return Encode::decode_utf8(YAML::XS::Dump($data));
+}
+
+sub thaw {
+    my ($self, $string) = @_;
+    return (YAML::XS::Load(Encode::encode_utf8($string)))[0];
+}
+# ********************************************************************
+
+
+
 package C4::Auth;
 
 # Copyright 2000-2002 Katipo Communications
@@ -1850,21 +1879,21 @@ sub _get_session_params {
     my $storage_method = C4::Context->preference('SessionStorage');
     if ( $storage_method eq 'mysql' ) {
         my $dbh = C4::Context->dbh;
-        return { dsn => "driver:MySQL;id:md5", dsn_args => { Handle => $dbh } };
+        return { dsn => "serializer:yamlxs;driver:MySQL;id:md5", dsn_args => { Handle => $dbh } };
     }
     elsif ( $storage_method eq 'Pg' ) {
         my $dbh = C4::Context->dbh;
-        return { dsn => "driver:PostgreSQL;id:md5", dsn_args => { Handle => $dbh } };
+        return { dsn => "serializer:yamlxs;driver:PostgreSQL;id:md5", dsn_args => { Handle => $dbh } };
     }
     elsif ( $storage_method eq 'memcached' && Koha::Caches->get_instance->memcached_cache ) {
         my $memcached = Koha::Caches->get_instance()->memcached_cache;
-        return { dsn => "driver:memcached;id:md5", dsn_args => { Memcached => $memcached } };
+        return { dsn => "serializer:yamlxs;driver:memcached;id:md5", dsn_args => { Memcached => $memcached } };
     }
     else {
         # catch all defaults to tmp should work on all systems
         my $dir = C4::Context::temporary_directory;
         my $instance = C4::Context->config( 'database' ); #actually for packages not exactly the instance name, but generally safer to leave it as it is
-        return { dsn => "driver:File;id:md5", dsn_args => { Directory => "$dir/cgisess_$instance" } };
+        return { dsn => "serializer:yamlxs;driver:File;id:md5", dsn_args => { Directory => "$dir/cgisess_$instance" } };
     }
 }
 
-- 
2.39.5