C4/Members/Attributes.pm

   1 package C4::Members::Attributes;
   2
   3 # Copyright (C) 2008 LibLime
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use strict;
  21 use warnings;
  22
  23 use Text::CSV;      # Don't be tempted to use Text::CSV::Unicode -- even in binary mode it fails.
  24 use C4::Context;
  25 use C4::Members::AttributeTypes;
  26
  27 use vars qw(@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS);
  28 our ($csv, $AttributeTypes);
  29
  30 BEGIN {
  31     @ISA = qw(Exporter);
  32     @EXPORT_OK = qw(GetBorrowerAttributes CheckUniqueness SetBorrowerAttributes
  33                     DeleteBorrowerAttribute UpdateBorrowerAttribute
  34                     extended_attributes_code_value_arrayref extended_attributes_merge
  35                     SearchIdMatchingAttribute);
  36     %EXPORT_TAGS = ( all => \@EXPORT_OK );
  37 }
  38
  39 =head1 NAME
  40
  41 C4::Members::Attributes - manage extend patron attributes
  42
  43 =head1 SYNOPSIS
  44
  45   use C4::Members::Attributes;
  46   my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber);
  47
  48 =head1 FUNCTIONS
  49
  50 =head2 GetBorrowerAttributes
  51
  52   my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber[, $opac_only]);
  53
  54 Retrieve an arrayref of extended attributes associated with the
  55 patron specified by C<$borrowernumber>.  Each entry in the arrayref
  56 is a hashref containing the following keys:
  57
  58 code (attribute type code)
  59 description (attribute type description)
  60 value (attribute value)
  61 value_description (attribute value description (if associated with an authorised value))
  62
  63 If the C<$opac_only> parameter is present and has a true value, only the attributes
  64 marked for OPAC display are returned.
  65
  66 =cut
  67
  68 sub GetBorrowerAttributes {
  69     my $borrowernumber = shift;
  70     my $opac_only = @_ ? shift : 0;
  71
  72     my $dbh = C4::Context->dbh();
  73     my $query = "SELECT code, description, attribute, lib, display_checkout, category_code, class
  74                  FROM borrower_attributes
  75                  JOIN borrower_attribute_types USING (code)
  76                  LEFT JOIN authorised_values ON (category = authorised_value_category AND attribute = authorised_value)
  77                  WHERE borrowernumber = ?";
  78     $query .= "\nAND opac_display = 1" if $opac_only;
  79     $query .= "\nORDER BY code, attribute";
  80     my $sth = $dbh->prepare_cached($query);
  81     $sth->execute($borrowernumber);
  82     my @results = ();
  83     while (my $row = $sth->fetchrow_hashref()) {
  84         push @results, {
  85             code              => $row->{'code'},
  86             description       => $row->{'description'},
  87             value             => $row->{'attribute'},
  88             value_description => $row->{'lib'},
  89             display_checkout  => $row->{'display_checkout'},
  90             category_code     => $row->{'category_code'},
  91             class             => $row->{'class'},
  92         }
  93     }
  94     $sth->finish;
  95     return \@results;
  96 }
  97
  98 =head2 SearchIdMatchingAttribute
  99
 100   my $matching_borrowernumbers = C4::Members::Attributes::SearchIdMatchingAttribute($filter);
 101
 102 =cut
 103
 104 sub SearchIdMatchingAttribute{
 105     my $filter = shift;
 106     $filter = [$filter] unless ref $filter;
 107
 108     my $dbh   = C4::Context->dbh();
 109     my $query = qq{
 110 SELECT DISTINCT borrowernumber
 111 FROM borrower_attributes
 112 JOIN borrower_attribute_types USING (code)
 113 WHERE staff_searchable = 1
 114 AND (} . join (" OR ", map "attribute like ?", @$filter) .qq{)};
 115     my $sth = $dbh->prepare_cached($query);
 116     $sth->execute(map "%$_%", @$filter);
 117     return [map $_->[0], @{ $sth->fetchall_arrayref }];
 118 }
 119
 120 =head2 CheckUniqueness
 121
 122   my $ok = CheckUniqueness($code, $value[, $borrowernumber]);
 123
 124 Given an attribute type and value, verify if would violate
 125 a unique_id restriction if added to the patron.  The
 126 optional C<$borrowernumber> is the patron that the attribute
 127 value would be added to, if known.
 128
 129 Returns false if the C<$code> is not valid or the
 130 value would violate the uniqueness constraint.
 131
 132 =cut
 133
 134 sub CheckUniqueness {
 135     my $code = shift;
 136     my $value = shift;
 137     my $borrowernumber = @_ ? shift : undef;
 138
 139     my $attr_type = C4::Members::AttributeTypes->fetch($code);
 140
 141     return 0 unless defined $attr_type;
 142     return 1 unless $attr_type->unique_id();
 143
 144     my $dbh = C4::Context->dbh;
 145     my $sth;
 146     if (defined($borrowernumber)) {
 147         $sth = $dbh->prepare("SELECT COUNT(*)
 148                               FROM borrower_attributes
 149                               WHERE code = ?
 150                               AND attribute = ?
 151                               AND borrowernumber <> ?");
 152         $sth->execute($code, $value, $borrowernumber);
 153     } else {
 154         $sth = $dbh->prepare("SELECT COUNT(*)
 155                               FROM borrower_attributes
 156                               WHERE code = ?
 157                               AND attribute = ?");
 158         $sth->execute($code, $value);
 159     }
 160     my ($count) = $sth->fetchrow_array;
 161     return ($count == 0);
 162 }
 163
 164 =head2 SetBorrowerAttributes
 165
 166   SetBorrowerAttributes($borrowernumber, [ { code => 'CODE', value => 'value' }, ... ] );
 167
 168 Set patron attributes for the patron identified by C<$borrowernumber>,
 169 replacing any that existed previously.
 170
 171 =cut
 172
 173 sub SetBorrowerAttributes {
 174     my $borrowernumber = shift;
 175     my $attr_list = shift;
 176     my $no_branch_limit = shift // 0;
 177
 178     my $dbh = C4::Context->dbh;
 179
 180     DeleteBorrowerAttributes( $borrowernumber, $no_branch_limit );
 181
 182     my $sth = $dbh->prepare("INSERT INTO borrower_attributes (borrowernumber, code, attribute)
 183                              VALUES (?, ?, ?)");
 184     foreach my $attr (@$attr_list) {
 185         $sth->execute($borrowernumber, $attr->{code}, $attr->{value});
 186         if ($sth->err) {
 187             warn sprintf('Database returned the following error: %s', $sth->errstr);
 188             return; # bail immediately on errors
 189         }
 190     }
 191     return 1; # borrower attributes successfully set
 192 }
 193
 194 =head2 DeleteBorrowerAttributes
 195
 196   DeleteBorrowerAttributes($borrowernumber);
 197
 198 Delete borrower attributes for the patron identified by C<$borrowernumber>.
 199
 200 =cut
 201
 202 sub DeleteBorrowerAttributes {
 203     my $borrowernumber = shift;
 204     my $no_branch_limit = @_ ? shift : 0;
 205     my $branch_limit = $no_branch_limit
 206         ? 0
 207         : C4::Context->userenv ? C4::Context->userenv->{"branch"} : 0;
 208
 209     my $dbh = C4::Context->dbh;
 210     my $query = q{
 211         DELETE borrower_attributes FROM borrower_attributes
 212         };
 213
 214     $query .= $branch_limit
 215         ? q{
 216             LEFT JOIN borrower_attribute_types_branches ON bat_code = code
 217             WHERE ( b_branchcode = ? OR b_branchcode IS NULL )
 218                 AND borrowernumber = ?
 219         }
 220         : q{
 221             WHERE borrowernumber = ?
 222         };
 223
 224     $dbh->do( $query, undef, $branch_limit ? $branch_limit : (), $borrowernumber );
 225 }
 226
 227 =head2 DeleteBorrowerAttribute
 228
 229   DeleteBorrowerAttribute($borrowernumber, $attribute);
 230
 231 Delete a borrower attribute for the patron identified by C<$borrowernumber> and the attribute code of C<$attribute>
 232
 233 =cut
 234
 235 sub DeleteBorrowerAttribute {
 236     my ( $borrowernumber, $attribute ) = @_;
 237
 238     my $dbh = C4::Context->dbh;
 239     my $sth = $dbh->prepare(qq{
 240         DELETE FROM borrower_attributes
 241             WHERE borrowernumber = ?
 242             AND code = ?
 243     } );
 244     $sth->execute( $borrowernumber, $attribute->{code} );
 245 }
 246
 247 =head2 UpdateBorrowerAttribute
 248
 249   UpdateBorrowerAttribute($borrowernumber, $attribute );
 250
 251 Update a borrower attribute C<$attribute> for the patron identified by C<$borrowernumber>,
 252
 253 =cut
 254
 255 sub UpdateBorrowerAttribute {
 256     my ( $borrowernumber, $attribute ) = @_;
 257
 258     DeleteBorrowerAttribute $borrowernumber, $attribute;
 259
 260     my $dbh = C4::Context->dbh;
 261     my $query = "INSERT INTO borrower_attributes SET attribute = ?, code = ?, borrowernumber = ?";
 262     my @params = ( $attribute->{attribute}, $attribute->{code}, $borrowernumber );
 263     my $sth = $dbh->prepare( $query );
 264
 265     $sth->execute( @params );
 266 }
 267
 268
 269 =head2 extended_attributes_code_value_arrayref
 270
 271    my $patron_attributes = "homeroom:1150605,grade:01,extradata:foobar";
 272    my $aref = extended_attributes_code_value_arrayref($patron_attributes);
 273
 274 Takes a comma-delimited CSV-style string argument and returns the kind of data structure that SetBorrowerAttributes wants,
 275 namely a reference to array of hashrefs like:
 276  [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
 277
 278 Caches Text::CSV parser object for efficiency.
 279
 280 =cut
 281
 282 sub extended_attributes_code_value_arrayref {
 283     my $string = shift or return;
 284     $csv or $csv = Text::CSV->new({binary => 1});  # binary needed for non-ASCII Unicode
 285     my $ok   = $csv->parse($string);  # parse field again to get subfields!
 286     my @list = $csv->fields();
 287     # TODO: error handling (check $ok)
 288     return [
 289         sort {&_sort_by_code($a,$b)}
 290         map { map { my @arr = split /:/, $_, 2; { code => $arr[0], value => $arr[1] } } $_ }
 291         @list
 292     ];
 293     # nested map because of split
 294 }
 295
 296 =head2 extended_attributes_merge
 297
 298   my $old_attributes = extended_attributes_code_value_arrayref("homeroom:224,grade:04,deanslist:2007,deanslist:2008,somedata:xxx");
 299   my $new_attributes = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2009,extradata:foobar");
 300   my $merged = extended_attributes_merge($patron_attributes, $new_attributes, 1);
 301
 302   # assuming deanslist is a repeatable code, value same as:
 303   # $merged = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2007,deanslist:2008,deanslist:2009,extradata:foobar,somedata:xxx");
 304
 305 Takes three arguments.  The first two are references to array of hashrefs, each like:
 306  [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
 307
 308 The third option specifies whether repeatable codes are clobbered or collected.  True for non-clobber.
 309
 310 Returns one reference to (merged) array of hashref.
 311
 312 Caches results of C4::Members::AttributeTypes::GetAttributeTypes_hashref(1) for efficiency.
 313
 314 =cut
 315
 316 sub extended_attributes_merge {
 317     my $old = shift or return;
 318     my $new = shift or return $old;
 319     my $keep = @_ ? shift : 0;
 320     $AttributeTypes or $AttributeTypes = C4::Members::AttributeTypes::GetAttributeTypes_hashref(1);
 321     my @merged = @$old;
 322     foreach my $att (@$new) {
 323         unless ($att->{code}) {
 324             warn "Cannot merge element: no 'code' defined";
 325             next;
 326         }
 327         unless ($AttributeTypes->{$att->{code}}) {
 328             warn "Cannot merge element: unrecognized code = '$att->{code}'";
 329             next;
 330         }
 331         unless ($AttributeTypes->{$att->{code}}->{repeatable} and $keep) {
 332             @merged = grep {$att->{code} ne $_->{code}} @merged;    # filter out any existing attributes of the same code
 333         }
 334         push @merged, $att;
 335     }
 336     return [( sort {&_sort_by_code($a,$b)} @merged )];
 337 }
 338
 339 sub _sort_by_code {
 340     my ($x, $y) = @_;
 341     defined ($x->{code}) or return -1;
 342     defined ($y->{code}) or return 1;
 343     return $x->{code} cmp $y->{code} || $x->{value} cmp $y->{value};
 344 }
 345
 346 =head1 AUTHOR
 347
 348 Koha Development Team <http://koha-community.org/>
 349
 350 Galen Charlton <galen.charlton@liblime.com>
 351
 352 =cut
 353
 354 1;