Bug 12026: [Followup] Rebasing

[koha_ffzg] / C4 / Auth_with_shibboleth.pm

diff --git a/C4/Auth_with_shibboleth.pm b/C4/Auth_with_shibboleth.pm
index f9555fb..1a68c96 100644 (file)
--- a/C4/Auth_with_shibboleth.pm
+++ b/C4/Auth_with_shibboleth.pm
@@ -21,15 +21,17 @@ use Modern::Perl;
 
 use C4::Debug;
 use C4::Context;
+use Koha::AuthUtils qw(get_script_name);
 use Koha::Database;
+use C4::Members qw( AddMember_Auto );
+use C4::Members::Messaging;
 use Carp;
 use CGI;
 
-use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $debug);
 
 BEGIN {
     require Exporter;
-    $VERSION = 3.03;           # set the version for version checking
     $debug   = $ENV{DEBUG};
     @ISA     = qw(Exporter);
     @EXPORT =
@@ -58,7 +60,7 @@ sub logout_shib {
 sub login_shib_url {
     my ($query) = @_;
 
-    my $param = _get_uri() . $query->script_name();
+    my $param = _get_uri() . get_script_name();
     if ( $query->query_string() ) {
         $param = $param . '%3F' . $query->query_string();
     }
@@ -102,18 +104,49 @@ sub checkpw_shib {
         return ( 1, $borrower->get_column('cardnumber'), $borrower->get_column('userid') );
     }
 
-    # If we reach this point, the user is not a valid koha user
-    $debug
-      and warn
-      "User with $config->{matchpoint} of $match is not a valid Koha user";
-    return 0;
+    if ( $config->{'autocreate'} ) {
+        return _autocreate( $config, $match );
+    } else {
+        # If we reach this point, the user is not a valid koha user
+        $debug and warn "User $userid is not a valid Koha user";
+        return 0;
+    }
+}
+
+sub _autocreate {
+    my ( $config, $match ) = @_;
+
+    my %borrower = ( $shibbolethMatchField => $match );
+
+    while ( my ( $key, $entry ) = each %{$config->{'mapping'}} ) {
+        $borrower{$key} = ( $entry->{'is'} && $ENV{ $entry->{'is'} } ) || $entry->{'content'} || '';
+    }
+
+    %borrower = AddMember_Auto( %borrower );
+    C4::Members::Messaging::SetMessagingPreferencesFromDefaults( { borrowernumber => $borrower{'borrowernumber'}, categorycode => $borrower{'categorycode'} } );
+
+    return ( 1, $borrower{'cardnumber'}, $borrower{'userid'} );
 }
 
 sub _get_uri {
 
     my $protocol = "https://";
 
-    my $return = $protocol . C4::Context->preference('OPACBaseURL');
+    my $uri = C4::Context->preference('OPACBaseURL') // '';
+    if ($uri eq '') {
+        $debug and warn 'OPACBaseURL not set!';
+    }
+    if ($uri =~ /(.*):\/\/(.*)/) {
+        my $oldprotocol = $1;
+        if ($oldprotocol ne 'https') {
+            $debug
+                and warn
+                  'Shibboleth requires OPACBaseURL to use the https protocol!';
+        }
+        $uri = $2;
+    }
+
+    my $return = $protocol . $uri;
     return $return;
 }
 
@@ -259,10 +292,18 @@ Returns the shibboleth login attribute should it be found present in the http se
 
 =head2 checkpw_shib
 
-Given a database handle and a shib_login attribute, this routine checks for a matching local user and if found returns true, their cardnumber and their userid.  If a match is not found, then this returns false.
+Given a shib_login attribute, this routine checks for a matching local user and if found returns true, their cardnumber and their userid.  If a match is not found, then this returns false.
 
   my ( $retval, $retcard, $retuserid ) = C4::Auth_with_shibboleth::checkpw_shib( $shib_login );
 
+=head2 _autocreate
+
+  my ( $retval, $retcard, $retuserid ) = _autocreate( $config, $match );
+
+Given a database handle, a shibboleth attribute reference and a userid this internal routine will add the given user to koha and return their user credentials
+
+This routine is NOT exported
+
 =head1 SEE ALSO
 
 =cut