1 package C4::Members::Attributes;
3 # Copyright (C) 2008 LibLime
5 # This file is part of Koha.
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.
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.
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>.
23 use Text::CSV; # Don't be tempted to use Text::CSV::Unicode -- even in binary mode it fails.
25 use C4::Members::AttributeTypes;
27 use vars qw(@ISA @EXPORT_OK @EXPORT %EXPORT_TAGS);
28 our ($csv, $AttributeTypes);
32 @EXPORT_OK = qw(GetBorrowerAttributes GetBorrowerAttributeValue CheckUniqueness SetBorrowerAttributes
33 DeleteBorrowerAttribute UpdateBorrowerAttribute
34 extended_attributes_code_value_arrayref extended_attributes_merge
35 SearchIdMatchingAttribute);
36 %EXPORT_TAGS = ( all => \@EXPORT_OK );
41 C4::Members::Attributes - manage extend patron attributes
45 use C4::Members::Attributes;
46 my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber);
50 =head2 GetBorrowerAttributes
52 my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber[, $opac_only]);
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:
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 password (password, if any, associated with attribute
64 If the C<$opac_only> parameter is present and has a true value, only the attributes
65 marked for OPAC display are returned.
69 sub GetBorrowerAttributes {
70 my $borrowernumber = shift;
71 my $opac_only = @_ ? shift : 0;
73 my $dbh = C4::Context->dbh();
74 my $query = "SELECT code, description, attribute, lib, password, display_checkout, category_code, class
75 FROM borrower_attributes
76 JOIN borrower_attribute_types USING (code)
77 LEFT JOIN authorised_values ON (category = authorised_value_category AND attribute = authorised_value)
78 WHERE borrowernumber = ?";
79 $query .= "\nAND opac_display = 1" if $opac_only;
80 $query .= "\nORDER BY code, attribute";
81 my $sth = $dbh->prepare_cached($query);
82 $sth->execute($borrowernumber);
84 while (my $row = $sth->fetchrow_hashref()) {
86 code => $row->{'code'},
87 description => $row->{'description'},
88 value => $row->{'attribute'},
89 value_description => $row->{'lib'},
90 password => $row->{'password'},
91 display_checkout => $row->{'display_checkout'},
92 category_code => $row->{'category_code'},
93 class => $row->{'class'},
102 my $attributes = C4::Members::Attributes::GetAttributes([$opac_only]);
104 Retrieve an arrayref of extended attribute codes
109 my ($opac_only) = @_;
111 my $dbh = C4::Context->dbh();
112 my $query = "SELECT code FROM borrower_attribute_types";
113 $query .= "\nWHERE opac_display = 1" if $opac_only;
114 $query .= "\nORDER BY code";
115 return $dbh->selectcol_arrayref($query);
118 =head2 GetBorrowerAttributeValue
120 my $value = C4::Members::Attributes::GetBorrowerAttributeValue($borrowernumber, $attribute_code);
122 Retrieve the value of an extended attribute C<$attribute_code> associated with the
123 patron specified by C<$borrowernumber>.
127 sub GetBorrowerAttributeValue {
128 my $borrowernumber = shift;
131 my $dbh = C4::Context->dbh();
132 my $query = "SELECT attribute
133 FROM borrower_attributes
134 WHERE borrowernumber = ?
136 my $value = $dbh->selectrow_array($query, undef, $borrowernumber, $code);
140 =head2 SearchIdMatchingAttribute
142 my $matching_borrowernumbers = C4::Members::Attributes::SearchIdMatchingAttribute($filter);
146 sub SearchIdMatchingAttribute{
148 $filter = [$filter] unless ref $filter;
150 my $dbh = C4::Context->dbh();
152 SELECT DISTINCT borrowernumber
153 FROM borrower_attributes
154 JOIN borrower_attribute_types USING (code)
155 WHERE staff_searchable = 1
156 AND (} . join (" OR ", map "attribute like ?", @$filter) .qq{)};
157 my $sth = $dbh->prepare_cached($query);
158 $sth->execute(map "%$_%", @$filter);
159 return [map $_->[0], @{ $sth->fetchall_arrayref }];
162 =head2 CheckUniqueness
164 my $ok = CheckUniqueness($code, $value[, $borrowernumber]);
166 Given an attribute type and value, verify if would violate
167 a unique_id restriction if added to the patron. The
168 optional C<$borrowernumber> is the patron that the attribute
169 value would be added to, if known.
171 Returns false if the C<$code> is not valid or the
172 value would violate the uniqueness constraint.
176 sub CheckUniqueness {
179 my $borrowernumber = @_ ? shift : undef;
181 my $attr_type = C4::Members::AttributeTypes->fetch($code);
183 return 0 unless defined $attr_type;
184 return 1 unless $attr_type->unique_id();
186 my $dbh = C4::Context->dbh;
188 if (defined($borrowernumber)) {
189 $sth = $dbh->prepare("SELECT COUNT(*)
190 FROM borrower_attributes
193 AND borrowernumber <> ?");
194 $sth->execute($code, $value, $borrowernumber);
196 $sth = $dbh->prepare("SELECT COUNT(*)
197 FROM borrower_attributes
200 $sth->execute($code, $value);
202 my ($count) = $sth->fetchrow_array;
203 return ($count == 0);
206 =head2 SetBorrowerAttributes
208 SetBorrowerAttributes($borrowernumber, [ { code => 'CODE', value => 'value', password => 'password' }, ... ] );
210 Set patron attributes for the patron identified by C<$borrowernumber>,
211 replacing any that existed previously.
215 sub SetBorrowerAttributes {
216 my $borrowernumber = shift;
217 my $attr_list = shift;
218 my $no_branch_limit = shift // 0;
220 my $dbh = C4::Context->dbh;
222 DeleteBorrowerAttributes( $borrowernumber, $no_branch_limit );
224 my $sth = $dbh->prepare("INSERT INTO borrower_attributes (borrowernumber, code, attribute, password)
225 VALUES (?, ?, ?, ?)");
226 foreach my $attr (@$attr_list) {
227 $attr->{password} = undef unless exists $attr->{password};
228 $sth->execute($borrowernumber, $attr->{code}, $attr->{value}, $attr->{password});
230 warn sprintf('Database returned the following error: %s', $sth->errstr);
231 return; # bail immediately on errors
234 return 1; # borrower attributes successfully set
237 =head2 DeleteBorrowerAttributes
239 DeleteBorrowerAttributes($borrowernumber);
241 Delete borrower attributes for the patron identified by C<$borrowernumber>.
245 sub DeleteBorrowerAttributes {
246 my $borrowernumber = shift;
247 my $no_branch_limit = @_ ? shift : 0;
248 my $branch_limit = $no_branch_limit
250 : C4::Context->userenv ? C4::Context->userenv->{"branch"} : 0;
252 my $dbh = C4::Context->dbh;
254 DELETE borrower_attributes FROM borrower_attributes
257 $query .= $branch_limit
259 LEFT JOIN borrower_attribute_types_branches ON bat_code = code
260 WHERE b_branchcode = ? OR b_branchcode IS NULL
261 AND borrowernumber = ?
264 WHERE borrowernumber = ?
267 $dbh->do( $query, undef, $branch_limit ? $branch_limit : (), $borrowernumber );
270 =head2 DeleteBorrowerAttribute
272 DeleteBorrowerAttribute($borrowernumber, $attribute);
274 Delete a borrower attribute for the patron identified by C<$borrowernumber> and the attribute code of C<$attribute>
277 sub DeleteBorrowerAttribute {
278 my ( $borrowernumber, $attribute ) = @_;
280 my $dbh = C4::Context->dbh;
281 my $sth = $dbh->prepare(qq{
282 DELETE FROM borrower_attributes
283 WHERE borrowernumber = ?
286 $sth->execute( $borrowernumber, $attribute->{code} );
289 =head2 UpdateBorrowerAttribute
291 UpdateBorrowerAttribute($borrowernumber, $attribute );
293 Update a borrower attribute C<$attribute> for the patron identified by C<$borrowernumber>,
296 sub UpdateBorrowerAttribute {
297 my ( $borrowernumber, $attribute ) = @_;
299 DeleteBorrowerAttribute $borrowernumber, $attribute;
301 my $dbh = C4::Context->dbh;
302 my $query = "INSERT INTO borrower_attributes SET attribute = ?, code = ?, borrowernumber = ?";
303 my @params = ( $attribute->{attribute}, $attribute->{code}, $borrowernumber );
304 if ( defined $attribute->{password} ) {
305 $query .= ", password = ?";
306 push @params, $attribute->{password};
308 my $sth = $dbh->prepare( $query );
310 $sth->execute( @params );
314 =head2 extended_attributes_code_value_arrayref
316 my $patron_attributes = "homeroom:1150605,grade:01,extradata:foobar";
317 my $aref = extended_attributes_code_value_arrayref($patron_attributes);
319 Takes a comma-delimited CSV-style string argument and returns the kind of data structure that SetBorrowerAttributes wants,
320 namely a reference to array of hashrefs like:
321 [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
323 Caches Text::CSV parser object for efficiency.
327 sub extended_attributes_code_value_arrayref {
328 my $string = shift or return;
329 $csv or $csv = Text::CSV->new({binary => 1}); # binary needed for non-ASCII Unicode
330 my $ok = $csv->parse($string); # parse field again to get subfields!
331 my @list = $csv->fields();
332 # TODO: error handling (check $ok)
334 sort {&_sort_by_code($a,$b)}
335 map { map { my @arr = split /:/, $_, 2; { code => $arr[0], value => $arr[1] } } $_ }
338 # nested map because of split
341 =head2 extended_attributes_merge
343 my $old_attributes = extended_attributes_code_value_arrayref("homeroom:224,grade:04,deanslist:2007,deanslist:2008,somedata:xxx");
344 my $new_attributes = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2009,extradata:foobar");
345 my $merged = extended_attributes_merge($patron_attributes, $new_attributes, 1);
347 # assuming deanslist is a repeatable code, value same as:
348 # $merged = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2007,deanslist:2008,deanslist:2009,extradata:foobar,somedata:xxx");
350 Takes three arguments. The first two are references to array of hashrefs, each like:
351 [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
353 The third option specifies whether repeatable codes are clobbered or collected. True for non-clobber.
355 Returns one reference to (merged) array of hashref.
357 Caches results of C4::Members::AttributeTypes::GetAttributeTypes_hashref(1) for efficiency.
361 sub extended_attributes_merge {
362 my $old = shift or return;
363 my $new = shift or return $old;
364 my $keep = @_ ? shift : 0;
365 $AttributeTypes or $AttributeTypes = C4::Members::AttributeTypes::GetAttributeTypes_hashref(1);
367 foreach my $att (@$new) {
368 unless ($att->{code}) {
369 warn "Cannot merge element: no 'code' defined";
372 unless ($AttributeTypes->{$att->{code}}) {
373 warn "Cannot merge element: unrecognized code = '$att->{code}'";
376 unless ($AttributeTypes->{$att->{code}}->{repeatable} and $keep) {
377 @merged = grep {$att->{code} ne $_->{code}} @merged; # filter out any existing attributes of the same code
381 return [( sort {&_sort_by_code($a,$b)} @merged )];
386 defined ($x->{code}) or return -1;
387 defined ($y->{code}) or return 1;
388 return $x->{code} cmp $y->{code} || $x->{value} cmp $y->{value};
393 Koha Development Team <http://koha-community.org/>
395 Galen Charlton <galen.charlton@liblime.com>