File Coverage

File:C4/Members/Attributes.pm
Coverage:46.4%

linestmtbrancondsubtimecode
1package 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
17# with Koha; if not, write to the Free Software Foundation, Inc.,
18# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20
26
26
26
26
40650
109
804
use strict;
21
26
26
26
26
203
131
953
use warnings;
22
23
26
26
26
26
91419
254186
976
use Text::CSV; # Don't be tempted to use Text::CSV::Unicode -- even in binary mode it fails.
24
26
26
26
26
2144
369
698
use C4::Context;
25
26
26
26
26
4819
231
1296
use C4::Members::AttributeTypes;
26
27
26
26
26
26
402
193
4104
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT %EXPORT_TAGS);
28our ($csv, $AttributeTypes);
29
30BEGIN {
31    # set the version for version checking
32
26
26
199
    $VERSION = 3.01;
33
26
435
    @ISA = qw(Exporter);
34
26
349
    @EXPORT_OK = qw(GetBorrowerAttributes GetBorrowerAttributeValue CheckUniqueness SetBorrowerAttributes
35                    extended_attributes_code_value_arrayref extended_attributes_merge
36                                        SearchIdMatchingAttribute);
37
26
32832
    %EXPORT_TAGS = ( all => \@EXPORT_OK );
38}
39
40 - 68
=head1 NAME

C4::Members::Attributes - manage extend patron attributes

=head1 SYNOPSIS

  use C4::Members::Attributes;
  my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber);

=head1 FUNCTIONS

=head2 GetBorrowerAttributes

  my $attributes = C4::Members::Attributes::GetBorrowerAttributes($borrowernumber[, $opac_only]);

Retrieve an arrayref of extended attributes associated with the
patron specified by C<$borrowernumber>.  Each entry in the arrayref
is a hashref containing the following keys:

code (attribute type code)
description (attribute type description)
value (attribute value)
value_description (attribute value description (if associated with an authorised value))
password (password, if any, associated with attribute

If the C<$opac_only> parameter is present and has a true value, only the attributes
marked for OPAC display are returned.

=cut
69
70sub GetBorrowerAttributes {
71
0
0
0
    my $borrowernumber = shift;
72
0
0
0
    my $opac_only = @_ ? shift : 0;
73
74
0
0
    my $dbh = C4::Context->dbh();
75
0
0
    my $query = "SELECT code, description, attribute, lib, password, display_checkout
76                 FROM borrower_attributes
77                 JOIN borrower_attribute_types USING (code)
78                 LEFT JOIN authorised_values ON (category = authorised_value_category AND attribute = authorised_value)
79                 WHERE borrowernumber = ?";
80
0
0
0
    $query .= "\nAND opac_display = 1" if $opac_only;
81
0
0
    $query .= "\nORDER BY code, attribute";
82
0
0
    my $sth = $dbh->prepare_cached($query);
83
0
0
    $sth->execute($borrowernumber);
84
0
0
    my @results = ();
85
0
0
    while (my $row = $sth->fetchrow_hashref()) {
86
0
0
        push @results, {
87            code => $row->{'code'},
88            description => $row->{'description'},
89            value => $row->{'attribute'},
90            value_description => $row->{'lib'},
91            password => $row->{'password'},
92            display_checkout => $row->{'display_checkout'},
93        }
94    }
95
0
0
    return \@results;
96}
97
98 - 105
=head2 GetBorrowerAttributeValue

  my $value = C4::Members::Attributes::GetBorrowerAttributeValue($borrowernumber, $attribute_code);

Retrieve the value of an extended attribute C<$attribute_code> associated with the
patron specified by C<$borrowernumber>.

=cut
106
107sub GetBorrowerAttributeValue {
108
0
0
0
    my $borrowernumber = shift;
109
0
0
    my $code = shift;
110
111
0
0
    my $dbh = C4::Context->dbh();
112
0
0
    my $query = "SELECT attribute
113                 FROM borrower_attributes
114                 WHERE borrowernumber = ?
115                 AND code = ?";
116
0
0
    my $value = $dbh->selectrow_array($query, undef, $borrowernumber, $code);
117
0
0
    return $value;
118}
119
120 - 124
=head2 SearchIdMatchingAttribute

  my $matching_borrowernumbers = C4::Members::Attributes::SearchIdMatchingAttribute($filter);

=cut
125
126sub SearchIdMatchingAttribute{
127
0
0
0
    my $filter = shift;
128
0
0
0
    $filter = [$filter] unless ref $filter;
129
130
0
0
    my $dbh = C4::Context->dbh();
131
0
0
    my $query = qq{
132SELECT DISTINCT borrowernumber
133FROM borrower_attributes
134JOIN borrower_attribute_types USING (code)
135WHERE staff_searchable = 1
136AND (} . join (" OR ", map "attribute like ?", @$filter) .qq{)};
137
0
0
    my $sth = $dbh->prepare_cached($query);
138
0
0
    $sth->execute(map "%$_%", @$filter);
139
0
0
0
0
    return [map $_->[0], @{ $sth->fetchall_arrayref }];
140}
141
142 - 154
=head2 CheckUniqueness

  my $ok = CheckUniqueness($code, $value[, $borrowernumber]);

Given an attribute type and value, verify if would violate
a unique_id restriction if added to the patron.  The
optional C<$borrowernumber> is the patron that the attribute
value would be added to, if known.

Returns false if the C<$code> is not valid or the
value would violate the uniqueness constraint.

=cut
155
156sub CheckUniqueness {
157
0
0
0
    my $code = shift;
158
0
0
    my $value = shift;
159
0
0
0
    my $borrowernumber = @_ ? shift : undef;
160
161
0
0
    my $attr_type = C4::Members::AttributeTypes->fetch($code);
162
163
0
0
0
    return 0 unless defined $attr_type;
164
0
0
0
    return 1 unless $attr_type->unique_id();
165
166
0
0
    my $dbh = C4::Context->dbh;
167
0
0
    my $sth;
168
0
0
0
    if (defined($borrowernumber)) {
169
0
0
        $sth = $dbh->prepare("SELECT COUNT(*)
170                              FROM borrower_attributes
171                              WHERE code = ?
172                              AND attribute = ?
173                              AND borrowernumber <> ?");
174
0
0
        $sth->execute($code, $value, $borrowernumber);
175    } else {
176
0
0
        $sth = $dbh->prepare("SELECT COUNT(*)
177                              FROM borrower_attributes
178                              WHERE code = ?
179                              AND attribute = ?");
180
0
0
        $sth->execute($code, $value);
181    }
182
0
0
    my ($count) = $sth->fetchrow_array;
183
0
0
    return ($count == 0);
184}
185
186 - 193
=head2 SetBorrowerAttributes 

  SetBorrowerAttributes($borrowernumber, [ { code => 'CODE', value => 'value', password => 'password' }, ... ] );

Set patron attributes for the patron identified by C<$borrowernumber>,
replacing any that existed previously.

=cut
194
195sub SetBorrowerAttributes {
196
0
0
0
    my $borrowernumber = shift;
197
0
0
    my $attr_list = shift;
198
199
0
0
    my $dbh = C4::Context->dbh;
200
0
0
    my $delsth = $dbh->prepare("DELETE FROM borrower_attributes WHERE borrowernumber = ?");
201
0
0
    $delsth->execute($borrowernumber);
202
203
0
0
    my $sth = $dbh->prepare("INSERT INTO borrower_attributes (borrowernumber, code, attribute, password)
204                             VALUES (?, ?, ?, ?)");
205
0
0
    foreach my $attr (@$attr_list) {
206
0
0
0
        $attr->{password} = undef unless exists $attr->{password};
207
0
0
        $sth->execute($borrowernumber, $attr->{code}, $attr->{value}, $attr->{password});
208
0
0
0
        if ($sth->err) {
209
0
0
            warn sprintf('Database returned the following error: %s', $sth->errstr);
210
0
0
            return; # bail immediately on errors
211        }
212    }
213
0
0
    return 1; # borower attributes successfully set
214}
215
216 - 227
=head2 extended_attributes_code_value_arrayref 

   my $patron_attributes = "homeroom:1150605,grade:01,extradata:foobar";
   my $aref = extended_attributes_code_value_arrayref($patron_attributes);

Takes a comma-delimited CSV-style string argument and returns the kind of data structure that SetBorrowerAttributes wants, 
namely a reference to array of hashrefs like:
 [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]

Caches Text::CSV parser object for efficiency.

=cut
228
229sub extended_attributes_code_value_arrayref {
230
8
50
8
745904
    my $string = shift or return;
231
8
100
39
    $csv or $csv = Text::CSV->new({binary => 1}); # binary needed for non-ASCII Unicode
232
8
296
    my $ok = $csv->parse($string); # parse field again to get subfields!
233
8
436
    my @list = $csv->fields();
234    # TODO: error handling (check $ok)
235    return [
236
24
22
46
52
        sort {&_sort_by_code($a,$b)}
237
8
22
22
93
25
118
        map { map { my @arr = split /:/, $_, 2; { code => $arr[0], value => $arr[1] } } $_ }
238        @list
239    ];
240    # nested map because of split
241}
242
243 - 261
=head2 extended_attributes_merge

  my $old_attributes = extended_attributes_code_value_arrayref("homeroom:224,grade:04,deanslist:2007,deanslist:2008,somedata:xxx");
  my $new_attributes = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2009,extradata:foobar");
  my $merged = extended_attributes_merge($patron_attributes, $new_attributes, 1);

  # assuming deanslist is a repeatable code, value same as:
  # $merged = extended_attributes_code_value_arrayref("homeroom:115,grade:05,deanslist:2007,deanslist:2008,deanslist:2009,extradata:foobar,somedata:xxx");

Takes three arguments.  The first two are references to array of hashrefs, each like:
 [ { code => 'CODE', value => 'value' }, { code => 'CODE2', value => 'othervalue' } ... ]

The third option specifies whether repeatable codes are clobbered or collected.  True for non-clobber.

Returns one reference to (merged) array of hashref.

Caches results of C4::Members::AttributeTypes::GetAttributeTypes_hashref(1) for efficiency.

=cut
262
263sub extended_attributes_merge {
264
8
50
8
46
    my $old = shift or return;
265
8
50
29
    my $new = shift or return $old;
266
8
100
24
    my $keep = @_ ? shift : 0;
267
8
50
28
    $AttributeTypes or $AttributeTypes = C4::Members::AttributeTypes::GetAttributeTypes_hashref(1);
268
8
23
    my @merged = @$old;
269
8
19
    foreach my $att (@$new) {
270
20
50
60
        unless ($att->{code}) {
271
0
0
            warn "Cannot merge element: no 'code' defined";
272
0
0
            next;
273        }
274
20
50
68
        unless ($AttributeTypes->{$att->{code}}) {
275
0
0
            warn "Cannot merge element: unrecognized code = '$att->{code}'";
276
0
0
            next;
277        }
278
20
100
100
102
        unless ($AttributeTypes->{$att->{code}}->{repeatable} and $keep) {
279
18
82
51
295
            @merged = grep {$att->{code} ne $_->{code}} @merged; # filter out any existing attributes of the same code
280        }
281
20
79
        push @merged, $att;
282    }
283
8
48
48
104
    return [( sort {&_sort_by_code($a,$b)} @merged )];
284}
285
286sub _sort_by_code {
287
72
72
125
    my ($x, $y) = @_;
288
72
50
166
    defined ($x->{code}) or return -1;
289
72
50
157
    defined ($y->{code}) or return 1;
290
72
67
359
    return $x->{code} cmp $y->{code} || $x->{value} cmp $y->{value};
291}
292
293 - 299
=head1 AUTHOR

Koha Development Team <http://koha-community.org/>

Galen Charlton <galen.charlton@liblime.com>

=cut
300
3011;