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))
63 If the C<$opac_only> parameter is present and has a true value, only the attributes
64 marked for OPAC display are returned.
68 sub GetBorrowerAttributes
{
69 my $borrowernumber = shift;
70 my $opac_only = @_ ?
shift : 0;
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);
83 while (my $row = $sth->fetchrow_hashref()) {
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'},
98 =head2 GetBorrowerAttributeValue
100 my $value = C4::Members::Attributes::GetBorrowerAttributeValue($borrowernumber, $attribute_code);
102 Retrieve the value of an extended attribute C<$attribute_code> associated with the
103 patron specified by C<$borrowernumber>.
107 sub GetBorrowerAttributeValue
{
108 my $borrowernumber = shift;
111 my $dbh = C4
::Context
->dbh();
112 my $query = "SELECT attribute
113 FROM borrower_attributes
114 WHERE borrowernumber = ?
116 my $value = $dbh->selectrow_array($query, undef, $borrowernumber, $code);
120 =head2 SearchIdMatchingAttribute
122 my $matching_borrowernumbers = C4::Members::Attributes::SearchIdMatchingAttribute($filter);
126 sub SearchIdMatchingAttribute
{
128 $filter = [$filter] unless ref $filter;
130 my $dbh = C4
::Context
->dbh();
132 SELECT DISTINCT borrowernumber
133 FROM borrower_attributes
134 JOIN borrower_attribute_types USING
(code
)
135 WHERE staff_searchable
= 1
136 AND
(} . join (" OR ", map "attribute like ?", @
$filter) .qq{)};
137 my $sth = $dbh->prepare_cached($query);
138 $sth->execute(map "%$_%", @
$filter);
139 return [map $_->[0], @
{ $sth->fetchall_arrayref }];
142 =head2 CheckUniqueness
144 my $ok = CheckUniqueness($code, $value[, $borrowernumber]);
146 Given an attribute type and value, verify if would violate
147 a unique_id restriction if added to the patron. The
148 optional C<$borrowernumber> is the patron that the attribute
149 value would be added to, if known.
151 Returns false if the C<$code> is not valid or the
152 value would violate the uniqueness constraint.
156 sub CheckUniqueness
{
159 my $borrowernumber = @_ ?
shift : undef;
161 my $attr_type = C4
::Members
::AttributeTypes
->fetch($code);
163 return 0 unless defined $attr_type;
164 return 1 unless $attr_type->unique_id();
166 my $dbh = C4
::Context
->dbh;
168 if (defined($borrowernumber)) {
169 $sth = $dbh->prepare("SELECT COUNT(*)
170 FROM borrower_attributes
173 AND borrowernumber <> ?");
174 $sth->execute($code, $value, $borrowernumber);
176 $sth = $dbh->prepare("SELECT COUNT(*)
177 FROM borrower_attributes
180 $sth->execute($code, $value);
182 my ($count) = $sth->fetchrow_array;
183 return ($count == 0);
186 =head2 SetBorrowerAttributes
188 SetBorrowerAttributes($borrowernumber, [ { code => 'CODE', value => 'value' }, ... ] );
190 Set patron attributes for the patron identified by C<$borrowernumber>,
191 replacing any that existed previously.
195 sub SetBorrowerAttributes
{
196 my $borrowernumber = shift;
197 my $attr_list = shift;
198 my $no_branch_limit = shift // 0;
200 my $dbh = C4
::Context
->dbh;
202 DeleteBorrowerAttributes
( $borrowernumber, $no_branch_limit );
204 my $sth = $dbh->prepare("INSERT INTO borrower_attributes (borrowernumber, code, attribute)
206 foreach my $attr (@
$attr_list) {
207 $sth->execute($borrowernumber, $attr->{code
}, $attr->{value
});
209 warn sprintf('Database returned the following error: %s', $sth->errstr);
210 return; # bail immediately on errors
213 return 1; # borrower attributes successfully set
216 =head2 DeleteBorrowerAttributes
218 DeleteBorrowerAttributes($borrowernumber);
220 Delete borrower attributes for the patron identified by C<$borrowernumber>.
224 sub DeleteBorrowerAttributes
{
225 my $borrowernumber = shift;
226 my $no_branch_limit = @_ ?
shift : 0;
227 my $branch_limit = $no_branch_limit
229 : C4
::Context
->userenv ? C4
::Context
->userenv->{"branch"} : 0;
231 my $dbh = C4
::Context
->dbh;
233 DELETE borrower_attributes FROM borrower_attributes
236 $query .= $branch_limit
238 LEFT JOIN borrower_attribute_types_branches ON bat_code = code
239 WHERE ( b_branchcode = ? OR b_branchcode IS NULL )
240 AND borrowernumber = ?
243 WHERE borrowernumber = ?
246 $dbh->do( $query, undef, $branch_limit ?
$branch_limit : (), $borrowernumber );
249 =head2 DeleteBorrowerAttribute
251 DeleteBorrowerAttribute($borrowernumber, $attribute);
253 Delete a borrower attribute for the patron identified by C<$borrowernumber> and the attribute code of C<$attribute>
257 sub DeleteBorrowerAttribute
{
258 my ( $borrowernumber, $attribute ) = @_;
260 my $dbh = C4
::Context
->dbh;
261 my $sth = $dbh->prepare(qq{
262 DELETE FROM borrower_attributes
263 WHERE borrowernumber
= ?
266 $sth->execute( $borrowernumber, $attribute->{code
} );
269 =head2 UpdateBorrowerAttribute
271 UpdateBorrowerAttribute($borrowernumber, $attribute );
273 Update a borrower attribute C<$attribute> for the patron identified by C<$borrowernumber>,
277 sub UpdateBorrowerAttribute
{
278 my ( $borrowernumber, $attribute ) = @_;
280 DeleteBorrowerAttribute
$borrowernumber, $attribute;
282 my $dbh = C4
::Context
->dbh;
283 my $query = "INSERT INTO borrower_attributes SET attribute = ?, code = ?, borrowernumber = ?";
284 my @params = ( $attribute->{attribute
}, $attribute->{code
}, $borrowernumber );
285 my $sth = $dbh->prepare( $query );
287 $sth->execute( @params );
291 =head2 extended_attributes_code_value_arrayref
293 my $patron_attributes = "homeroom:1150605,grade:01,extradata:foobar";
294 my $aref = extended_attributes_code_value_arrayref($patron_attributes);
296 Takes a comma-delimited CSV-style string argument and returns the kind of data structure that SetBorrowerAttributes wants,
297 namely a reference to array of hashrefs like:
298 [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
300 Caches Text::CSV parser object for efficiency.
304 sub extended_attributes_code_value_arrayref
{
305 my $string = shift or return;
306 $csv or $csv = Text
::CSV
->new({binary
=> 1}); # binary needed for non-ASCII Unicode
307 my $ok = $csv->parse($string); # parse field again to get subfields!
308 my @list = $csv->fields();
309 # TODO: error handling (check $ok)
311 sort {&_sort_by_code
($a,$b)}
312 map { map { my @arr = split /:/, $_, 2; { code
=> $arr[0], value
=> $arr[1] } } $_ }
315 # nested map because of split
318 =head2 extended_attributes_merge
320 my $old_attributes = extended_attributes_code_value_arrayref("homeroom:224,grade:04,deanslist:2007,deanslist:2008,somedata:xxx");
321 my $new_attributes = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2009,extradata:foobar");
322 my $merged = extended_attributes_merge($patron_attributes, $new_attributes, 1);
324 # assuming deanslist is a repeatable code, value same as:
325 # $merged = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2007,deanslist:2008,deanslist:2009,extradata:foobar,somedata:xxx");
327 Takes three arguments. The first two are references to array of hashrefs, each like:
328 [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]
330 The third option specifies whether repeatable codes are clobbered or collected. True for non-clobber.
332 Returns one reference to (merged) array of hashref.
334 Caches results of C4::Members::AttributeTypes::GetAttributeTypes_hashref(1) for efficiency.
338 sub extended_attributes_merge
{
339 my $old = shift or return;
340 my $new = shift or return $old;
341 my $keep = @_ ?
shift : 0;
342 $AttributeTypes or $AttributeTypes = C4
::Members
::AttributeTypes
::GetAttributeTypes_hashref
(1);
344 foreach my $att (@
$new) {
345 unless ($att->{code
}) {
346 warn "Cannot merge element: no 'code' defined";
349 unless ($AttributeTypes->{$att->{code
}}) {
350 warn "Cannot merge element: unrecognized code = '$att->{code}'";
353 unless ($AttributeTypes->{$att->{code
}}->{repeatable
} and $keep) {
354 @merged = grep {$att->{code
} ne $_->{code
}} @merged; # filter out any existing attributes of the same code
358 return [( sort {&_sort_by_code
($a,$b)} @merged )];
363 defined ($x->{code
}) or return -1;
364 defined ($y->{code
}) or return 1;
365 return $x->{code
} cmp $y->{code
} || $x->{value
} cmp $y->{value
};
370 Koha Development Team <http://koha-community.org/>
372 Galen Charlton <galen.charlton@liblime.com>