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