File Coverage

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

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
15
15
15
15
574
138
1295
use strict;
21
15
15
15
15
173
199
675
use warnings;
22
23
15
15
15
15
31978
200089
803
use Text::CSV; # Don't be tempted to use Text::CSV::Unicode -- even in binary mode it fails.
24
15
15
15
15
1095
250
422
use C4::Context;
25
15
15
15
15
2410
440
731
use C4::Members::AttributeTypes;
26
27
15
15
15
15
207
92
2273
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT %EXPORT_TAGS);
28our ($csv, $AttributeTypes);
29
30BEGIN {
31    # set the version for version checking
32
15
15
90
    $VERSION = 3.01;
33
15
373
    @ISA = qw(Exporter);
34
15
128
    @EXPORT_OK = qw(GetBorrowerAttributes GetBorrowerAttributeValue CheckUniqueness SetBorrowerAttributes
35                    extended_attributes_code_value_arrayref extended_attributes_merge
36                                        SearchIdMatchingAttribute);
37
15
24297
    %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, category_code, class
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            category_code => $row->{'category_code'},
94            class => $row->{'class'},
95        }
96    }
97
0
0
    return \@results;
98}
99
100 - 106
=head2 GetAttributes

  my $attributes = C4::Members::Attributes::GetAttributes([$opac_only]);

Retrieve an arrayref of extended attribute codes

=cut
107
108sub GetAttributes {
109
0
0
0
    my ($opac_only) = @_;
110
111
0
0
    my $dbh = C4::Context->dbh();
112
0
0
    my $query = "SELECT code FROM borrower_attribute_types";
113
0
0
0
    $query .= "\nWHERE opac_display = 1" if $opac_only;
114
0
0
    $query .= "\nORDER BY code";
115
0
0
    return $dbh->selectcol_arrayref($query);
116}
117
118 - 125
=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
126
127sub GetBorrowerAttributeValue {
128
0
0
0
    my $borrowernumber = shift;
129
0
0
    my $code = shift;
130
131
0
0
    my $dbh = C4::Context->dbh();
132
0
0
    my $query = "SELECT attribute
133                 FROM borrower_attributes
134                 WHERE borrowernumber = ?
135                 AND code = ?";
136
0
0
    my $value = $dbh->selectrow_array($query, undef, $borrowernumber, $code);
137
0
0
    return $value;
138}
139
140 - 144
=head2 SearchIdMatchingAttribute

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

=cut
145
146sub SearchIdMatchingAttribute{
147
0
0
0
    my $filter = shift;
148
0
0
0
    $filter = [$filter] unless ref $filter;
149
150
0
0
    my $dbh = C4::Context->dbh();
151
0
0
    my $query = qq{
152SELECT DISTINCT borrowernumber
153FROM borrower_attributes
154JOIN borrower_attribute_types USING (code)
155WHERE staff_searchable = 1
156AND (} . join (" OR ", map "attribute like ?", @$filter) .qq{)};
157
0
0
    my $sth = $dbh->prepare_cached($query);
158
0
0
    $sth->execute(map "%$_%", @$filter);
159
0
0
0
0
    return [map $_->[0], @{ $sth->fetchall_arrayref }];
160}
161
162 - 174
=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
175
176sub CheckUniqueness {
177
0
0
0
    my $code = shift;
178
0
0
    my $value = shift;
179
0
0
0
    my $borrowernumber = @_ ? shift : undef;
180
181
0
0
    my $attr_type = C4::Members::AttributeTypes->fetch($code);
182
183
0
0
0
    return 0 unless defined $attr_type;
184
0
0
0
    return 1 unless $attr_type->unique_id();
185
186
0
0
    my $dbh = C4::Context->dbh;
187
0
0
    my $sth;
188
0
0
0
    if (defined($borrowernumber)) {
189
0
0
        $sth = $dbh->prepare("SELECT COUNT(*)
190                              FROM borrower_attributes
191                              WHERE code = ?
192                              AND attribute = ?
193                              AND borrowernumber <> ?");
194
0
0
        $sth->execute($code, $value, $borrowernumber);
195    } else {
196
0
0
        $sth = $dbh->prepare("SELECT COUNT(*)
197                              FROM borrower_attributes
198                              WHERE code = ?
199                              AND attribute = ?");
200
0
0
        $sth->execute($code, $value);
201    }
202
0
0
    my ($count) = $sth->fetchrow_array;
203
0
0
    return ($count == 0);
204}
205
206 - 213
=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
214
215sub SetBorrowerAttributes {
216
0
0
0
    my $borrowernumber = shift;
217
0
0
    my $attr_list = shift;
218
219
0
0
    my $dbh = C4::Context->dbh;
220
0
0
    my $delsth = $dbh->prepare("DELETE FROM borrower_attributes WHERE borrowernumber = ?");
221
0
0
    $delsth->execute($borrowernumber);
222
223
0
0
    my $sth = $dbh->prepare("INSERT INTO borrower_attributes (borrowernumber, code, attribute, password)
224                             VALUES (?, ?, ?, ?)");
225
0
0
    foreach my $attr (@$attr_list) {
226
0
0
0
        $attr->{password} = undef unless exists $attr->{password};
227
0
0
        $sth->execute($borrowernumber, $attr->{code}, $attr->{value}, $attr->{password});
228
0
0
0
        if ($sth->err) {
229
0
0
            warn sprintf('Database returned the following error: %s', $sth->errstr);
230
0
0
            return; # bail immediately on errors
231        }
232    }
233
0
0
    return 1; # borower attributes successfully set
234}
235
236 - 247
=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
248
249sub extended_attributes_code_value_arrayref {
250
4
50
4
15
    my $string = shift or return;
251
4
100
19
    $csv or $csv = Text::CSV->new({binary => 1}); # binary needed for non-ASCII Unicode
252
4
135
    my $ok = $csv->parse($string); # parse field again to get subfields!
253
4
202
    my @list = $csv->fields();
254    # TODO: error handling (check $ok)
255    return [
256
12
11
13
27
        sort {&_sort_by_code($a,$b)}
257
4
11
11
43
15
66
        map { map { my @arr = split /:/, $_, 2; { code => $arr[0], value => $arr[1] } } $_ }
258        @list
259    ];
260    # nested map because of split
261}
262
263 - 281
=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
282
283sub extended_attributes_merge {
284
4
50
4
12
    my $old = shift or return;
285
4
50
11
    my $new = shift or return $old;
286
4
100
8
    my $keep = @_ ? shift : 0;
287
4
50
10
    $AttributeTypes or $AttributeTypes = C4::Members::AttributeTypes::GetAttributeTypes_hashref(1);
288
4
8
    my @merged = @$old;
289
4
8
    foreach my $att (@$new) {
290
10
50
20
        unless ($att->{code}) {
291
0
0
            warn "Cannot merge element: no 'code' defined";
292
0
0
            next;
293        }
294
10
50
25
        unless ($AttributeTypes->{$att->{code}}) {
295
0
0
            warn "Cannot merge element: unrecognized code = '$att->{code}'";
296
0
0
            next;
297        }
298
10
100
100
47
        unless ($AttributeTypes->{$att->{code}}->{repeatable} and $keep) {
299
9
41
11
83
            @merged = grep {$att->{code} ne $_->{code}} @merged; # filter out any existing attributes of the same code
300        }
301
10
20
        push @merged, $att;
302    }
303
4
24
24
31
    return [( sort {&_sort_by_code($a,$b)} @merged )];
304}
305
306sub _sort_by_code {
307
36
36
40
    my ($x, $y) = @_;
308
36
50
62
    defined ($x->{code}) or return -1;
309
36
50
62
    defined ($y->{code}) or return 1;
310
36
67
157
    return $x->{code} cmp $y->{code} || $x->{value} cmp $y->{value};
311}
312
313 - 319
=head1 AUTHOR

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

Galen Charlton <galen.charlton@liblime.com>

=cut
320
3211;