Bug 23057: (QA follow-up) Remove new AddReturn message ReturnOfLostItemBlocked, use...
[koha.git] / Koha / Patron.pm
1 package Koha::Patron;
2
3 # Copyright ByWater Solutions 2014
4 # Copyright PTFS Europe 2016
5 #
6 # This file is part of Koha.
7 #
8 # Koha is free software; you can redistribute it and/or modify it under the
9 # terms of the GNU General Public License as published by the Free Software
10 # Foundation; either version 3 of the License, or (at your option) any later
11 # version.
12 #
13 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
14 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
15 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License along
18 # with Koha; if not, write to the Free Software Foundation, Inc.,
19 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20
21 use Modern::Perl;
22
23 use Carp;
24 use List::MoreUtils qw( uniq );
25 use Text::Unaccent qw( unac_string );
26
27 use C4::Context;
28 use C4::Log;
29 use Koha::Checkouts;
30 use Koha::Database;
31 use Koha::DateUtils;
32 use Koha::Holds;
33 use Koha::Old::Checkouts;
34 use Koha::Patron::Categories;
35 use Koha::Patron::HouseboundProfile;
36 use Koha::Patron::HouseboundRole;
37 use Koha::Patron::Images;
38 use Koha::Patrons;
39 use Koha::Virtualshelves;
40 use Koha::Club::Enrollments;
41 use Koha::Account;
42 use Koha::Subscription::Routinglists;
43
44 use base qw(Koha::Object);
45
46 our $RESULTSET_PATRON_ID_MAPPING = {
47     Accountline          => 'borrowernumber',
48     Aqbasketuser         => 'borrowernumber',
49     Aqbudget             => 'budget_owner_id',
50     Aqbudgetborrower     => 'borrowernumber',
51     ArticleRequest       => 'borrowernumber',
52     BorrowerAttribute    => 'borrowernumber',
53     BorrowerDebarment    => 'borrowernumber',
54     BorrowerFile         => 'borrowernumber',
55     BorrowerModification => 'borrowernumber',
56     ClubEnrollment       => 'borrowernumber',
57     Issue                => 'borrowernumber',
58     ItemsLastBorrower    => 'borrowernumber',
59     Linktracker          => 'borrowernumber',
60     Message              => 'borrowernumber',
61     MessageQueue         => 'borrowernumber',
62     OldIssue             => 'borrowernumber',
63     OldReserve           => 'borrowernumber',
64     Rating               => 'borrowernumber',
65     Reserve              => 'borrowernumber',
66     Review               => 'borrowernumber',
67     SearchHistory        => 'userid',
68     Statistic            => 'borrowernumber',
69     Suggestion           => 'suggestedby',
70     TagAll               => 'borrowernumber',
71     Virtualshelfcontent  => 'borrowernumber',
72     Virtualshelfshare    => 'borrowernumber',
73     Virtualshelve        => 'owner',
74 };
75
76 =head1 NAME
77
78 Koha::Patron - Koha Patron Object class
79
80 =head1 API
81
82 =head2 Class Methods
83
84 =cut
85
86 =head3 delete
87
88 $patron->delete
89
90 Delete patron's holds, lists and finally the patron.
91
92 Lists owned by the borrower are deleted, but entries from the borrower to
93 other lists are kept.
94
95 =cut
96
97 sub delete {
98     my ($self) = @_;
99
100     my $deleted;
101     $self->_result->result_source->schema->txn_do(
102         sub {
103             # Delete Patron's holds
104             $self->holds->delete;
105
106             # Delete all lists and all shares of this borrower
107             # Consistent with the approach Koha uses on deleting individual lists
108             # Note that entries in virtualshelfcontents added by this borrower to
109             # lists of others will be handled by a table constraint: the borrower
110             # is set to NULL in those entries.
111             # NOTE:
112             # We could handle the above deletes via a constraint too.
113             # But a new BZ report 11889 has been opened to discuss another approach.
114             # Instead of deleting we could also disown lists (based on a pref).
115             # In that way we could save shared and public lists.
116             # The current table constraints support that idea now.
117             # This pref should then govern the results of other routines/methods such as
118             # Koha::Virtualshelf->new->delete too.
119             # FIXME Could be $patron->get_lists
120             $_->delete for Koha::Virtualshelves->search( { owner => $self->borrowernumber } );
121
122             $deleted = $self->SUPER::delete;
123
124             logaction( "MEMBERS", "DELETE", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
125         }
126     );
127     return $deleted;
128 }
129
130
131 =head3 category
132
133 my $patron_category = $patron->category
134
135 Return the patron category for this patron
136
137 =cut
138
139 sub category {
140     my ( $self ) = @_;
141     return Koha::Patron::Category->_new_from_dbic( $self->_result->categorycode );
142 }
143
144 =head3 guarantor
145
146 Returns a Koha::Patron object for this patron's guarantor
147
148 =cut
149
150 sub guarantor {
151     my ( $self ) = @_;
152
153     return unless $self->guarantorid();
154
155     return Koha::Patrons->find( $self->guarantorid() );
156 }
157
158 sub image {
159     my ( $self ) = @_;
160
161     return scalar Koha::Patron::Images->find( $self->borrowernumber );
162 }
163
164 sub library {
165     my ( $self ) = @_;
166     return Koha::Library->_new_from_dbic($self->_result->branchcode);
167 }
168
169 =head3 guarantees
170
171 Returns the guarantees (list of Koha::Patron) of this patron
172
173 =cut
174
175 sub guarantees {
176     my ( $self ) = @_;
177
178     return Koha::Patrons->search( { guarantorid => $self->borrowernumber } );
179 }
180
181 =head3 housebound_profile
182
183 Returns the HouseboundProfile associated with this patron.
184
185 =cut
186
187 sub housebound_profile {
188     my ( $self ) = @_;
189     my $profile = $self->_result->housebound_profile;
190     return Koha::Patron::HouseboundProfile->_new_from_dbic($profile)
191         if ( $profile );
192     return;
193 }
194
195 =head3 housebound_role
196
197 Returns the HouseboundRole associated with this patron.
198
199 =cut
200
201 sub housebound_role {
202     my ( $self ) = @_;
203
204     my $role = $self->_result->housebound_role;
205     return Koha::Patron::HouseboundRole->_new_from_dbic($role) if ( $role );
206     return;
207 }
208
209 =head3 siblings
210
211 Returns the siblings of this patron.
212
213 =cut
214
215 sub siblings {
216     my ( $self ) = @_;
217
218     my $guarantor = $self->guarantor;
219
220     return unless $guarantor;
221
222     return Koha::Patrons->search(
223         {
224             guarantorid => {
225                 '!=' => undef,
226                 '=' => $guarantor->id,
227             },
228             borrowernumber => {
229                 '!=' => $self->borrowernumber,
230             }
231         }
232     );
233 }
234
235 =head3 merge_with
236
237     my $patron = Koha::Patrons->find($id);
238     $patron->merge_with( \@patron_ids );
239
240     This subroutine merges a list of patrons into the patron record. This is accomplished by finding
241     all related patron ids for the patrons to be merged in other tables and changing the ids to be that
242     of the keeper patron.
243
244 =cut
245
246 sub merge_with {
247     my ( $self, $patron_ids ) = @_;
248
249     my @patron_ids = @{ $patron_ids };
250
251     # Ensure the keeper isn't in the list of patrons to merge
252     @patron_ids = grep { $_ ne $self->id } @patron_ids;
253
254     my $schema = Koha::Database->new()->schema();
255
256     my $results;
257
258     $self->_result->result_source->schema->txn_do( sub {
259         foreach my $patron_id (@patron_ids) {
260             my $patron = Koha::Patrons->find( $patron_id );
261
262             next unless $patron;
263
264             # Unbless for safety, the patron will end up being deleted
265             $results->{merged}->{$patron_id}->{patron} = $patron->unblessed;
266
267             while (my ($r, $field) = each(%$RESULTSET_PATRON_ID_MAPPING)) {
268                 my $rs = $schema->resultset($r)->search({ $field => $patron_id });
269                 $results->{merged}->{ $patron_id }->{updated}->{$r} = $rs->count();
270                 $rs->update({ $field => $self->id });
271             }
272
273             $patron->move_to_deleted();
274             $patron->delete();
275         }
276     });
277
278     return $results;
279 }
280
281
282
283 =head3 wants_check_for_previous_checkout
284
285     $wants_check = $patron->wants_check_for_previous_checkout;
286
287 Return 1 if Koha needs to perform PrevIssue checking, else 0.
288
289 =cut
290
291 sub wants_check_for_previous_checkout {
292     my ( $self ) = @_;
293     my $syspref = C4::Context->preference("checkPrevCheckout");
294
295     # Simple cases
296     ## Hard syspref trumps all
297     return 1 if ($syspref eq 'hardyes');
298     return 0 if ($syspref eq 'hardno');
299     ## Now, patron pref trumps all
300     return 1 if ($self->checkprevcheckout eq 'yes');
301     return 0 if ($self->checkprevcheckout eq 'no');
302
303     # More complex: patron inherits -> determine category preference
304     my $checkPrevCheckoutByCat = $self->category->checkprevcheckout;
305     return 1 if ($checkPrevCheckoutByCat eq 'yes');
306     return 0 if ($checkPrevCheckoutByCat eq 'no');
307
308     # Finally: category preference is inherit, default to 0
309     if ($syspref eq 'softyes') {
310         return 1;
311     } else {
312         return 0;
313     }
314 }
315
316 =head3 do_check_for_previous_checkout
317
318     $do_check = $patron->do_check_for_previous_checkout($item);
319
320 Return 1 if the bib associated with $ITEM has previously been checked out to
321 $PATRON, 0 otherwise.
322
323 =cut
324
325 sub do_check_for_previous_checkout {
326     my ( $self, $item ) = @_;
327
328     # Find all items for bib and extract item numbers.
329     my @items = Koha::Items->search({biblionumber => $item->{biblionumber}});
330     my @item_nos;
331     foreach my $item (@items) {
332         push @item_nos, $item->itemnumber;
333     }
334
335     # Create (old)issues search criteria
336     my $criteria = {
337         borrowernumber => $self->borrowernumber,
338         itemnumber => \@item_nos,
339     };
340
341     # Check current issues table
342     my $issues = Koha::Checkouts->search($criteria);
343     return 1 if $issues->count; # 0 || N
344
345     # Check old issues table
346     my $old_issues = Koha::Old::Checkouts->search($criteria);
347     return $old_issues->count;  # 0 || N
348 }
349
350 =head3 is_debarred
351
352 my $debarment_expiration = $patron->is_debarred;
353
354 Returns the date a patron debarment will expire, or undef if the patron is not
355 debarred
356
357 =cut
358
359 sub is_debarred {
360     my ($self) = @_;
361
362     return unless $self->debarred;
363     return $self->debarred
364       if $self->debarred =~ '^9999'
365       or dt_from_string( $self->debarred ) > dt_from_string;
366     return;
367 }
368
369 =head3 is_expired
370
371 my $is_expired = $patron->is_expired;
372
373 Returns 1 if the patron is expired or 0;
374
375 =cut
376
377 sub is_expired {
378     my ($self) = @_;
379     return 0 unless $self->dateexpiry;
380     return 0 if $self->dateexpiry =~ '^9999';
381     return 1 if dt_from_string( $self->dateexpiry ) < dt_from_string->truncate( to => 'day' );
382     return 0;
383 }
384
385 =head3 is_going_to_expire
386
387 my $is_going_to_expire = $patron->is_going_to_expire;
388
389 Returns 1 if the patron is going to expired, depending on the NotifyBorrowerDeparture pref or 0
390
391 =cut
392
393 sub is_going_to_expire {
394     my ($self) = @_;
395
396     my $delay = C4::Context->preference('NotifyBorrowerDeparture') || 0;
397
398     return 0 unless $delay;
399     return 0 unless $self->dateexpiry;
400     return 0 if $self->dateexpiry =~ '^9999';
401     return 1 if dt_from_string( $self->dateexpiry )->subtract( days => $delay ) < dt_from_string->truncate( to => 'day' );
402     return 0;
403 }
404
405 =head3 update_password
406
407 my $updated = $patron->update_password( $userid, $password );
408
409 Update the userid and the password of a patron.
410 If the userid already exists, returns and let DBIx::Class warns
411 This will add an entry to action_logs if BorrowersLog is set.
412
413 =cut
414
415 sub update_password {
416     my ( $self, $userid, $password ) = @_;
417     eval { $self->userid($userid)->store; };
418     return if $@; # Make sure the userid is not already in used by another patron
419     $self->update(
420         {
421             password       => $password,
422             login_attempts => 0,
423         }
424     );
425     logaction( "MEMBERS", "CHANGE PASS", $self->borrowernumber, "" ) if C4::Context->preference("BorrowersLog");
426     return 1;
427 }
428
429 =head3 renew_account
430
431 my $new_expiry_date = $patron->renew_account
432
433 Extending the subscription to the expiry date.
434
435 =cut
436
437 sub renew_account {
438     my ($self) = @_;
439     my $date;
440     if ( C4::Context->preference('BorrowerRenewalPeriodBase') eq 'combination' ) {
441         $date = ( dt_from_string gt dt_from_string( $self->dateexpiry ) ) ? dt_from_string : dt_from_string( $self->dateexpiry );
442     } else {
443         $date =
444             C4::Context->preference('BorrowerRenewalPeriodBase') eq 'dateexpiry'
445             ? dt_from_string( $self->dateexpiry )
446             : dt_from_string;
447     }
448     my $expiry_date = $self->category->get_expiry_date($date);
449
450     $self->dateexpiry($expiry_date);
451     $self->date_renewed( dt_from_string() );
452     $self->store();
453
454     $self->add_enrolment_fee_if_needed;
455
456     logaction( "MEMBERS", "RENEW", $self->borrowernumber, "Membership renewed" ) if C4::Context->preference("BorrowersLog");
457     return dt_from_string( $expiry_date )->truncate( to => 'day' );
458 }
459
460 =head3 has_overdues
461
462 my $has_overdues = $patron->has_overdues;
463
464 Returns the number of patron's overdues
465
466 =cut
467
468 sub has_overdues {
469     my ($self) = @_;
470     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
471     return $self->_result->issues->search({ date_due => { '<' => $dtf->format_datetime( dt_from_string() ) } })->count;
472 }
473
474 =head3 track_login
475
476     $patron->track_login;
477     $patron->track_login({ force => 1 });
478
479     Tracks a (successful) login attempt.
480     The preference TrackLastPatronActivity must be enabled. Or you
481     should pass the force parameter.
482
483 =cut
484
485 sub track_login {
486     my ( $self, $params ) = @_;
487     return if
488         !$params->{force} &&
489         !C4::Context->preference('TrackLastPatronActivity');
490     $self->lastseen( dt_from_string() )->store;
491 }
492
493 =head3 move_to_deleted
494
495 my $is_moved = $patron->move_to_deleted;
496
497 Move a patron to the deletedborrowers table.
498 This can be done before deleting a patron, to make sure the data are not completely deleted.
499
500 =cut
501
502 sub move_to_deleted {
503     my ($self) = @_;
504     my $patron_infos = $self->unblessed;
505     delete $patron_infos->{updated_on}; #This ensures the updated_on date in deletedborrowers will be set to the current timestamp
506     return Koha::Database->new->schema->resultset('Deletedborrower')->create($patron_infos);
507 }
508
509 =head3 article_requests
510
511 my @requests = $borrower->article_requests();
512 my $requests = $borrower->article_requests();
513
514 Returns either a list of ArticleRequests objects,
515 or an ArtitleRequests object, depending on the
516 calling context.
517
518 =cut
519
520 sub article_requests {
521     my ( $self ) = @_;
522
523     $self->{_article_requests} ||= Koha::ArticleRequests->search({ borrowernumber => $self->borrowernumber() });
524
525     return $self->{_article_requests};
526 }
527
528 =head3 article_requests_current
529
530 my @requests = $patron->article_requests_current
531
532 Returns the article requests associated with this patron that are incomplete
533
534 =cut
535
536 sub article_requests_current {
537     my ( $self ) = @_;
538
539     $self->{_article_requests_current} ||= Koha::ArticleRequests->search(
540         {
541             borrowernumber => $self->id(),
542             -or          => [
543                 { status => Koha::ArticleRequest::Status::Pending },
544                 { status => Koha::ArticleRequest::Status::Processing }
545             ]
546         }
547     );
548
549     return $self->{_article_requests_current};
550 }
551
552 =head3 article_requests_finished
553
554 my @requests = $biblio->article_requests_finished
555
556 Returns the article requests associated with this patron that are completed
557
558 =cut
559
560 sub article_requests_finished {
561     my ( $self, $borrower ) = @_;
562
563     $self->{_article_requests_finished} ||= Koha::ArticleRequests->search(
564         {
565             borrowernumber => $self->id(),
566             -or          => [
567                 { status => Koha::ArticleRequest::Status::Completed },
568                 { status => Koha::ArticleRequest::Status::Canceled }
569             ]
570         }
571     );
572
573     return $self->{_article_requests_finished};
574 }
575
576 =head3 add_enrolment_fee_if_needed
577
578 my $enrolment_fee = $patron->add_enrolment_fee_if_needed;
579
580 Add enrolment fee for a patron if needed.
581
582 =cut
583
584 sub add_enrolment_fee_if_needed {
585     my ($self) = @_;
586     my $enrolment_fee = $self->category->enrolmentfee;
587     if ( $enrolment_fee && $enrolment_fee > 0 ) {
588         # insert fee in patron debts
589         C4::Accounts::manualinvoice( $self->borrowernumber, '', '', 'A', $enrolment_fee );
590     }
591     return $enrolment_fee || 0;
592 }
593
594 =head3 checkouts
595
596 my $checkouts = $patron->checkouts
597
598 =cut
599
600 sub checkouts {
601     my ($self) = @_;
602     my $checkouts = $self->_result->issues;
603     return Koha::Checkouts->_new_from_dbic( $checkouts );
604 }
605
606 =head3 pending_checkouts
607
608 my $pending_checkouts = $patron->pending_checkouts
609
610 This method will return the same as $self->checkouts, but with a prefetch on
611 items, biblio and biblioitems.
612
613 It has been introduced to replaced the C4::Members::GetPendingIssues subroutine
614
615 It should not be used directly, prefer to access fields you need instead of
616 retrieving all these fields in one go.
617
618
619 =cut
620
621 sub pending_checkouts {
622     my( $self ) = @_;
623     my $checkouts = $self->_result->issues->search(
624         {},
625         {
626             order_by => [
627                 { -desc => 'me.timestamp' },
628                 { -desc => 'issuedate' },
629                 { -desc => 'issue_id' }, # Sort by issue_id should be enough
630             ],
631             prefetch => { item => { biblio => 'biblioitems' } },
632         }
633     );
634     return Koha::Checkouts->_new_from_dbic( $checkouts );
635 }
636
637 =head3 old_checkouts
638
639 my $old_checkouts = $patron->old_checkouts
640
641 =cut
642
643 sub old_checkouts {
644     my ($self) = @_;
645     my $old_checkouts = $self->_result->old_issues;
646     return Koha::Old::Checkouts->_new_from_dbic( $old_checkouts );
647 }
648
649 =head3 get_overdues
650
651 my $overdue_items = $patron->get_overdues
652
653 Return the overdue items
654
655 =cut
656
657 sub get_overdues {
658     my ($self) = @_;
659     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
660     return $self->checkouts->search(
661         {
662             'me.date_due' => { '<' => $dtf->format_datetime(dt_from_string) },
663         },
664         {
665             prefetch => { item => { biblio => 'biblioitems' } },
666         }
667     );
668 }
669
670 =head3 get_routing_lists
671
672 my @routinglists = $patron->get_routing_lists
673
674 Returns the routing lists a patron is subscribed to.
675
676 =cut
677
678 sub get_routing_lists {
679     my ($self) = @_;
680     my $routing_list_rs = $self->_result->subscriptionroutinglists;
681     return Koha::Subscription::Routinglists->_new_from_dbic($routing_list_rs);
682 }
683
684 =head3 get_age
685
686 my $age = $patron->get_age
687
688 Return the age of the patron
689
690 =cut
691
692 sub get_age {
693     my ($self)    = @_;
694     my $today_str = dt_from_string->strftime("%Y-%m-%d");
695     return unless $self->dateofbirth;
696     my $dob_str   = dt_from_string( $self->dateofbirth )->strftime("%Y-%m-%d");
697
698     my ( $dob_y,   $dob_m,   $dob_d )   = split /-/, $dob_str;
699     my ( $today_y, $today_m, $today_d ) = split /-/, $today_str;
700
701     my $age = $today_y - $dob_y;
702     if ( $dob_m . $dob_d > $today_m . $today_d ) {
703         $age--;
704     }
705
706     return $age;
707 }
708
709 =head3 account
710
711 my $account = $patron->account
712
713 =cut
714
715 sub account {
716     my ($self) = @_;
717     return Koha::Account->new( { patron_id => $self->borrowernumber } );
718 }
719
720 =head3 holds
721
722 my $holds = $patron->holds
723
724 Return all the holds placed by this patron
725
726 =cut
727
728 sub holds {
729     my ($self) = @_;
730     my $holds_rs = $self->_result->reserves->search( {}, { order_by => 'reservedate' } );
731     return Koha::Holds->_new_from_dbic($holds_rs);
732 }
733
734 =head3 old_holds
735
736 my $old_holds = $patron->old_holds
737
738 Return all the historical holds for this patron
739
740 =cut
741
742 sub old_holds {
743     my ($self) = @_;
744     my $old_holds_rs = $self->_result->old_reserves->search( {}, { order_by => 'reservedate' } );
745     return Koha::Old::Holds->_new_from_dbic($old_holds_rs);
746 }
747
748 =head3 notice_email_address
749
750   my $email = $patron->notice_email_address;
751
752 Return the email address of patron used for notices.
753 Returns the empty string if no email address.
754
755 =cut
756
757 sub notice_email_address{
758     my ( $self ) = @_;
759
760     my $which_address = C4::Context->preference("AutoEmailPrimaryAddress");
761     # if syspref is set to 'first valid' (value == OFF), look up email address
762     if ( $which_address eq 'OFF' ) {
763         return $self->first_valid_email_address;
764     }
765
766     return $self->$which_address || '';
767 }
768
769 =head3 first_valid_email_address
770
771 my $first_valid_email_address = $patron->first_valid_email_address
772
773 Return the first valid email address for a patron.
774 For now, the order  is defined as email, emailpro, B_email.
775 Returns the empty string if the borrower has no email addresses.
776
777 =cut
778
779 sub first_valid_email_address {
780     my ($self) = @_;
781
782     return $self->email() || $self->emailpro() || $self->B_email() || q{};
783 }
784
785 =head3 get_club_enrollments
786
787 =cut
788
789 sub get_club_enrollments {
790     my ( $self, $return_scalar ) = @_;
791
792     my $e = Koha::Club::Enrollments->search( { borrowernumber => $self->borrowernumber(), date_canceled => undef } );
793
794     return $e if $return_scalar;
795
796     return wantarray ? $e->as_list : $e;
797 }
798
799 =head3 get_enrollable_clubs
800
801 =cut
802
803 sub get_enrollable_clubs {
804     my ( $self, $is_enrollable_from_opac, $return_scalar ) = @_;
805
806     my $params;
807     $params->{is_enrollable_from_opac} = $is_enrollable_from_opac
808       if $is_enrollable_from_opac;
809     $params->{is_email_required} = 0 unless $self->first_valid_email_address();
810
811     $params->{borrower} = $self;
812
813     my $e = Koha::Clubs->get_enrollable($params);
814
815     return $e if $return_scalar;
816
817     return wantarray ? $e->as_list : $e;
818 }
819
820 =head3 account_locked
821
822 my $is_locked = $patron->account_locked
823
824 Return true if the patron has reach the maximum number of login attempts (see pref FailedLoginAttempts).
825 Otherwise return false.
826 If the pref is not set (empty string, null or 0), the feature is considered as disabled.
827
828 =cut
829
830 sub account_locked {
831     my ($self) = @_;
832     my $FailedLoginAttempts = C4::Context->preference('FailedLoginAttempts');
833     return ( $FailedLoginAttempts
834           and $self->login_attempts
835           and $self->login_attempts >= $FailedLoginAttempts )? 1 : 0;
836 }
837
838 =head3 can_see_patron_infos
839
840 my $can_see = $patron->can_see_patron_infos( $patron );
841
842 Return true if the patron (usually the logged in user) can see the patron's infos for a given patron
843
844 =cut
845
846 sub can_see_patron_infos {
847     my ( $self, $patron ) = @_;
848     return $self->can_see_patrons_from( $patron->library->branchcode );
849 }
850
851 =head3 can_see_patrons_from
852
853 my $can_see = $patron->can_see_patrons_from( $branchcode );
854
855 Return true if the patron (usually the logged in user) can see the patron's infos from a given library
856
857 =cut
858
859 sub can_see_patrons_from {
860     my ( $self, $branchcode ) = @_;
861     my $can = 0;
862     if ( $self->branchcode eq $branchcode ) {
863         $can = 1;
864     } elsif ( $self->has_permission( { borrowers => 'view_borrower_infos_from_any_libraries' } ) ) {
865         $can = 1;
866     } elsif ( my $library_groups = $self->library->library_groups ) {
867         while ( my $library_group = $library_groups->next ) {
868             if ( $library_group->parent->has_child( $branchcode ) ) {
869                 $can = 1;
870                 last;
871             }
872         }
873     }
874     return $can;
875 }
876
877 =head3 libraries_where_can_see_patrons
878
879 my $libraries = $patron-libraries_where_can_see_patrons;
880
881 Return the list of branchcodes(!) of libraries the patron is allowed to see other patron's infos.
882 The branchcodes are arbitrarily returned sorted.
883 We are supposing here that the object is related to the logged in patron (use of C4::Context::only_my_library)
884
885 An empty array means no restriction, the patron can see patron's infos from any libraries.
886
887 =cut
888
889 sub libraries_where_can_see_patrons {
890     my ( $self ) = @_;
891     my $userenv = C4::Context->userenv;
892
893     return () unless $userenv; # For tests, but userenv should be defined in tests...
894
895     my @restricted_branchcodes;
896     if (C4::Context::only_my_library) {
897         push @restricted_branchcodes, $self->branchcode;
898     }
899     else {
900         unless (
901             $self->has_permission(
902                 { borrowers => 'view_borrower_infos_from_any_libraries' }
903             )
904           )
905         {
906             my $library_groups = $self->library->library_groups({ ft_hide_patron_info => 1 });
907             if ( $library_groups->count )
908             {
909                 while ( my $library_group = $library_groups->next ) {
910                     my $parent = $library_group->parent;
911                     if ( $parent->has_child( $self->branchcode ) ) {
912                         push @restricted_branchcodes, $parent->children->get_column('branchcode');
913                     }
914                 }
915             }
916
917             @restricted_branchcodes = ( $self->branchcode ) unless @restricted_branchcodes;
918         }
919     }
920
921     @restricted_branchcodes = grep { defined $_ } @restricted_branchcodes;
922     @restricted_branchcodes = uniq(@restricted_branchcodes);
923     @restricted_branchcodes = sort(@restricted_branchcodes);
924     return @restricted_branchcodes;
925 }
926
927 sub has_permission {
928     my ( $self, $flagsrequired ) = @_;
929     return unless $self->userid;
930     # TODO code from haspermission needs to be moved here!
931     return C4::Auth::haspermission( $self->userid, $flagsrequired );
932 }
933
934 =head3 is_adult
935
936 my $is_adult = $patron->is_adult
937
938 Return true if the patron has a category with a type Adult (A) or Organization (I)
939
940 =cut
941
942 sub is_adult {
943     my ( $self ) = @_;
944     return $self->category->category_type =~ /^(A|I)$/ ? 1 : 0;
945 }
946
947 =head3 is_child
948
949 my $is_child = $patron->is_child
950
951 Return true if the patron has a category with a type Child (C)
952
953 =cut
954 sub is_child {
955     my( $self ) = @_;
956     return $self->category->category_type eq 'C' ? 1 : 0;
957 }
958
959 =head3 has_valid_userid
960
961 my $patron = Koha::Patrons->find(42);
962 $patron->userid( $new_userid );
963 my $has_a_valid_userid = $patron->has_valid_userid
964
965 my $patron = Koha::Patron->new( $params );
966 my $has_a_valid_userid = $patron->has_valid_userid
967
968 Return true if the current userid of this patron is valid/unique, otherwise false.
969
970 Note that this should be done in $self->store instead and raise an exception if needed.
971
972 =cut
973
974 sub has_valid_userid {
975     my ($self) = @_;
976
977     return 0 unless $self->userid;
978
979     return 0 if ( $self->userid eq C4::Context->config('user') );    # DB user
980
981     my $already_exists = Koha::Patrons->search(
982         {
983             userid => $self->userid,
984             (
985                 $self->in_storage
986                 ? ( borrowernumber => { '!=' => $self->borrowernumber } )
987                 : ()
988             ),
989         }
990     )->count;
991     return $already_exists ? 0 : 1;
992 }
993
994 =head3 generate_userid
995
996 my $patron = Koha::Patron->new( $params );
997 my $userid = $patron->generate_userid
998
999 Generate a userid using the $surname and the $firstname (if there is a value in $firstname).
1000
1001 Return the generate userid ($firstname.$surname if there is a $firstname, or $surname if there is no value in $firstname) plus offset (0 if the $userid is unique, or a higher numeric value if not unique).
1002
1003 # Note: Should we set $self->userid with the generated value?
1004 # Certainly yes, but we AddMember and ModMember will be rewritten
1005
1006 =cut
1007
1008 sub generate_userid {
1009     my ($self) = @_;
1010     my $userid;
1011     my $offset = 0;
1012     my $existing_userid = $self->userid;
1013     my $firstname = $self->firstname // q{};
1014     my $surname = $self->surname // q{};
1015     #The script will "do" the following code and increment the $offset until the generated userid is unique
1016     do {
1017       $firstname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1018       $surname =~ s/[[:digit:][:space:][:blank:][:punct:][:cntrl:]]//g;
1019       $userid = lc(($firstname)? "$firstname.$surname" : $surname);
1020       $userid = unac_string('utf-8',$userid);
1021       $userid .= $offset unless $offset == 0;
1022       $self->userid( $userid );
1023       $offset++;
1024      } while (! $self->has_valid_userid );
1025
1026      # Resetting to the previous value as the callers do not expect
1027      # this method to modify the userid attribute
1028      # This will be done later (move of AddMember and ModMember)
1029      $self->userid( $existing_userid );
1030
1031      return $userid;
1032
1033 }
1034
1035 =head2 Internal methods
1036
1037 =head3 _type
1038
1039 =cut
1040
1041 sub _type {
1042     return 'Borrower';
1043 }
1044
1045 =head1 AUTHOR
1046
1047 Kyle M Hall <kyle@bywatersolutions.com>
1048 Alex Sassmannshausen <alex.sassmannshausen@ptfs-europe.com>
1049
1050 =cut
1051
1052 1;