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 under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  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.01;
  33     @ISA = qw(Exporter);
  34     @EXPORT_OK = qw(GetBorrowerAttributes CheckUniqueness SetBorrowerAttributes
  35                     extended_attributes_code_value_arrayref extended_attributes_merge);
  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 =over 4
  46
  47     use C4::Members::Attributes;
  48     my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber);
  49
  50 =back
  51
  52 =head1 FUNCTIONS
  53
  54 =head2 GetBorrowerAttributes
  55
  56 =over 4
  57
  58 my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber[, $opac_only]);
  59
  60 =back
  61
  62 Retrieve an arrayref of extended attributes associated with the
  63 patron specified by C<$borrowernumber>.  Each entry in the arrayref
  64 is a hashref containing the following keys:
  65
  66 code (attribute type code)
  67 description (attribute type description)
  68 value (attribute value)
  69 value_description (attribute value description (if associated with an authorised value))
  70 password (password, if any, associated with attribute
  71
  72 If the C<$opac_only> parameter is present and has a true value, only the attributes
  73 marked for OPAC display are returned.
  74
  75 =cut
  76
  77 sub GetBorrowerAttributes {
  78     my $borrowernumber = shift;
  79     my $opac_only = @_ ? shift : 0;
  80
  81     my $dbh = C4::Context->dbh();
  82     my $query = "SELECT code, description, attribute, lib, password
  83                  FROM borrower_attributes
  84                  JOIN borrower_attribute_types USING (code)
  85                  LEFT JOIN authorised_values ON (category = authorised_value_category AND attribute = authorised_value)
  86                  WHERE borrowernumber = ?";
  87     $query .= "\nAND opac_display = 1" if $opac_only;
  88     $query .= "\nORDER BY code, attribute";
  89     my $sth = $dbh->prepare_cached($query);
  90     $sth->execute($borrowernumber);
  91     my @results = ();
  92     while (my $row = $sth->fetchrow_hashref()) {
  93         push @results, {
  94             code              => $row->{'code'},
  95             description       => $row->{'description'},
  96             value             => $row->{'attribute'},
  97             value_description => $row->{'lib'},
  98             password          => $row->{'password'},
  99         }
 100     }
 101     return \@results;
 102 }
 103
 104 =head2 CheckUniqueness
 105
 106 =over 4
 107
 108     my $ok = CheckUniqueness($code, $value[, $borrowernumber]);
 109
 110 =back
 111
 112 Given an attribute type and value, verify if would violate
 113 a unique_id restriction if added to the patron.  The
 114 optional C<$borrowernumber> is the patron that the attribute
 115 value would be added to, if known.
 116
 117 Returns false if the C<$code> is not valid or the
 118 value would violate the uniqueness constraint.
 119
 120 =cut
 121
 122 sub CheckUniqueness {
 123     my $code = shift;
 124     my $value = shift;
 125     my $borrowernumber = @_ ? shift : undef;
 126
 127     my $attr_type = C4::Members::AttributeTypes->fetch($code);
 128
 129     return 0 unless defined $attr_type;
 130     return 1 unless $attr_type->unique_id();
 131
 132     my $dbh = C4::Context->dbh;
 133     my $sth;
 134     if (defined($borrowernumber)) {
 135         $sth = $dbh->prepare("SELECT COUNT(*)
 136                               FROM borrower_attributes
 137                               WHERE code = ?
 138                               AND attribute = ?
 139                               AND borrowernumber <> ?");
 140         $sth->execute($code, $value, $borrowernumber);
 141     } else {
 142         $sth = $dbh->prepare("SELECT COUNT(*)
 143                               FROM borrower_attributes
 144                               WHERE code = ?
 145                               AND attribute = ?");
 146         $sth->execute($code, $value);
 147     }
 148     my ($count) = $sth->fetchrow_array;
 149     return ($count == 0);
 150 }
 151
 152 =head2 SetBorrowerAttributes
 153
 154 =over 4
 155
 156     SetBorrowerAttributes($borrowernumber, [ { code => 'CODE', value => 'value', password => 'password' }, ... ] );
 157
 158 =back
 159
 160 Set patron attributes for the patron identified by C<$borrowernumber>,
 161 replacing any that existed previously.
 162
 163 =cut
 164
 165 sub SetBorrowerAttributes {
 166     my $borrowernumber = shift;
 167     my $attr_list = shift;
 168
 169     my $dbh = C4::Context->dbh;
 170     my $delsth = $dbh->prepare("DELETE FROM borrower_attributes WHERE borrowernumber = ?");
 171     $delsth->execute($borrowernumber);
 172
 173     my $sth = $dbh->prepare("INSERT INTO borrower_attributes (borrowernumber, code, attribute, password)
 174                              VALUES (?, ?, ?, ?)");
 175     foreach my $attr (@$attr_list) {
 176         $attr->{password} = undef unless exists $attr->{password};
 177         $sth->execute($borrowernumber, $attr->{code}, $attr->{value}, $attr->{password});
 178     }
 179 }
 180
 181 =head2 extended_attributes_code_value_arrayref
 182
 183 =over 4
 184
 185     my $patron_attributes = "homeroom:1150605,grade:01,extradata:foobar";
 186     my $aref = extended_attributes_code_value_arrayref($patron_attributes);
 187
 188 =back
 189
 190 Takes a comma-delimited CSV-style string argument and returns the kind of data structure that SetBorrowerAttributes wants,
 191 namely a reference to array of hashrefs like:
 192  [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
 193
 194 Caches Text::CSV parser object for efficiency.
 195
 196 =cut
 197
 198 sub extended_attributes_code_value_arrayref {
 199     my $string = shift or return;
 200     $csv or $csv = Text::CSV->new({binary => 1});  # binary needed for non-ASCII Unicode
 201     my $ok   = $csv->parse($string);  # parse field again to get subfields!
 202     my @list = $csv->fields();
 203     # TODO: error handling (check $ok)
 204     return [
 205         sort {&_sort_by_code($a,$b)}
 206         map { map { my @arr = split /:/, $_, 2; { code => $arr[0], value => $arr[1] } } $_ }
 207         @list
 208     ];
 209     # nested map because of split
 210 }
 211
 212 =head2 extended_attributes_merge
 213
 214 =over 4
 215
 216     my $old_attributes = extended_attributes_code_value_arrayref("homeroom:224,grade:04,deanslist:2007,deanslist:2008,somedata:xxx");
 217     my $new_attributes = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2009,extradata:foobar");
 218     my $merged = extended_attributes_merge($patron_attributes, $new_attributes, 1);
 219
 220     # assuming deanslist is a repeatable code, value same as:
 221     # $merged = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2007,deanslist:2008,deanslist:2009,extradata:foobar,somedata:xxx");
 222
 223 =back
 224
 225 Takes three arguments.  The first two are references to array of hashrefs, each like:
 226  [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
 227
 228 The third option specifies whether repeatable codes are clobbered or collected.  True for non-clobber.
 229
 230 Returns one reference to (merged) array of hashref.
 231
 232 Caches results of C4::Members::AttributeTypes::GetAttributeTypes_hashref(1) for efficiency.
 233
 234 =cut
 235
 236 sub extended_attributes_merge {
 237     my $old = shift or return;
 238     my $new = shift or return $old;
 239     my $keep = @_ ? shift : 0;
 240     $AttributeTypes or $AttributeTypes = C4::Members::AttributeTypes::GetAttributeTypes_hashref(1);
 241     my @merged = @$old;
 242     foreach my $att (@$new) {
 243         unless ($att->{code}) {
 244             warn "Cannot merge element: no 'code' defined";
 245             next;
 246         }
 247         unless ($AttributeTypes->{$att->{code}}) {
 248             warn "Cannot merge element: unrecognized code = '$att->{code}'";
 249             next;
 250         }
 251         unless ($AttributeTypes->{$att->{code}}->{repeatable} and $keep) {
 252             @merged = grep {$att->{code} ne $_->{code}} @merged;    # filter out any existing attributes of the same code
 253         }
 254         push @merged, $att;
 255     }
 256     return [( sort {&_sort_by_code($a,$b)} @merged )];
 257 }
 258
 259 sub _sort_by_code {
 260     my ($x, $y) = @_;
 261     defined ($x->{code}) or return -1;
 262     defined ($y->{code}) or return 1;
 263     return $x->{code} cmp $y->{code} || $x->{value} cmp $y->{value};
 264 }
 265
 266 =head1 AUTHOR
 267
 268 Koha Development Team <info@koha.org>
 269
 270 Galen Charlton <galen.charlton@liblime.com>
 271
 272 =cut
 273
 274 1;