View | Details | Raw Unified | Return to bug 13607
Collapse All | Expand All

(-)a/C4/Installer/PerlDependencies.pm (+5 lines)
Lines 737-742 our $PERL_DEPS = { Link Here
737
        'required' => '0',
737
        'required' => '0',
738
        'min_ver'  => '5.61',
738
        'min_ver'  => '5.61',
739
    },
739
    },
740
    'XML::Writer' => {
741
        'usage'     => 'Core',
742
        'required'  => '1',
743
        'min_ver'   => '0.611',
744
    },
740
};
745
};
741
746
742
1;
747
1;
(-)a/C4/Output/JSONStream.pm (+41 lines)
Lines 71-74 sub output { Link Here
71
    return to_json( $self->{data} );
71
    return to_json( $self->{data} );
72
}
72
}
73
73
74
=head 2 clear
75
76
    $json->clear();
77
78
This clears any in-progress data from the object so it can be used to create
79
something new. Parameters are kept, it's just the data that goes away.
80
81
=cut
82
83
sub clear {
84
    my $self = shift;
85
    $self->{data} = {};
86
}
87
88
=head2 content_type
89
90
    my $ct = $json->content_type();
91
92
Returns a string containing the content type of the stuff that this class
93
returns, suitable for passing to L<C4::JSONStream::output_with_http_headers>.
94
In this case, it says 'json'.
95
96
=cut
97
98
sub content_type {
99
    return 'json';
100
}
101
102
=head2 true
103
104
    my $true = $json->true();
105
106
This provides a 'true' value, as some format types need a special value.
107
108
=cut
109
110
sub true {
111
    return JSON::true;
112
}
113
114
74
1;
115
1;
(-)a/C4/Output/XMLStream.pm (+231 lines)
Line 0 Link Here
1
package C4::Output::XMLStream;
2
3
# Copyright 2014 Catalyst IT
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 3 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
=head1 NAME
21
22
C4::Output::XMLStream - progressively build XML data
23
24
=head1 SYNOPSIS
25
26
    my $xml = C4::Output::XMLStream->new(root => 'rootnodename');
27
    
28
    $json->param( issues => [ 'yes!', 'please', 'no', { emphasis = 'NO' } ] );
29
    $json->param( stuff => 'realia' );
30
    
31
    print $json->output;
32
33
=head1 DESCRIPTION
34
35
This module makes it easy to progressively build up data structure that can
36
then be output as XML.
37
38
The XML output is very simple, as this is an analogue to JSON output. If
39
params are set thus:
40
41
    my $json = C4::Output::XMLStream->new(root => 'rootnodename');
42
    $json->param( issues => [ 'yes!', 'please', 'no', { emphasis = 'NO' } ] );
43
    $json->param( stuff => 'realia' );
44
45
Then the XML will be:
46
47
    <rootnodename>
48
        <issues>
49
            <array>
50
                <item>yes!</item>
51
                <item>please</item>
52
                <item>no</item>
53
                <emphasis>NO</emphasis>
54
            </array>
55
        </issues>
56
        <stuff>realia</stuff>
57
    </rootnodename>
58
59
It's wordy because it's XML. You can't set attributes on nodes, because you
60
can't do that in JSON. You can't have text elements and sub-elements at the
61
same time, because that's fiddly to express in Perl structures, and you can't
62
do that in JSON anyway.
63
64
If you want multiple subnodes, then do this:
65
66
    $xml->param(stuff => { one => 'a', two => 'b' });
67
    
68
The resulting order of the output is not particularly deterministic, given
69
this more or less emulates a hash, except the bits with arrays.
70
71
If you add a new param with the same name as an already existing one, the new
72
one will overwrite the old one.
73
74
=head1 FUNCTIONS
75
76
=cut
77
78
use Carp;
79
use Modern::Perl;
80
use XML::Writer;
81
82
=head2 new
83
84
    my $xml = C4::Output::XMLStream->new(root => 'rootnodename');
85
86
Creates a new instance of the C<C4::Output::XMLStream> class.
87
88
=cut
89
90
sub new {
91
    my $class = shift;
92
    my %opts = @_;
93
    croak "no root node specified" unless $opts{root};
94
    my $self = {
95
        data => {},
96
        %opts,
97
    };
98
    bless $self, $class;
99
    return $self;
100
}
101
102
=head2 param
103
104
    $xml->param(key1 => $value1, key2 => $value2, ...);
105
106
This adds the supplied key/value pairs to the object for later output. See
107
the Description section for details on what goes in vs. what comes out.
108
109
=cut
110
111
sub param {
112
    my $self = shift;
113
114
    if (@_ % 2 != 0) {
115
        croak "param() received an odd number of args, should be a list of hashes";
116
    }
117
118
    my %p = @_;
119
    # Merge the hashes, this'll overwrite any old values with new ones
120
    @{ $self->{data} }{ keys %p } = values %p;
121
}
122
123
=head2 output
124
125
    my $str = $xml->output();
126
127
Turns the provided params into an XML document string.
128
129
=cut
130
131
sub output {
132
    my $self = shift;
133
134
    my $str;
135
    my $writer = XML::Writer->new(OUTPUT => \$str);
136
    $writer->xmlDecl('UTF-8');
137
    $writer->startTag($self->{root});
138
    _add_to_xml($writer, $self->{data});
139
    $writer->endTag($self->{root});
140
    $writer->end();
141
    return $str;
142
}
143
144
=head2 clear
145
146
    $xml->clear();
147
148
This clears any in-progress data from the object so it can be used to create
149
something new. Parameters are kept, it's just the data that goes away.
150
151
=cut
152
153
sub clear {
154
    my $self = shift;
155
    $self->{data} = {};
156
}
157
158
=head2 content_type
159
160
    my $ct = $xml->content_type();
161
162
Returns a string containing the content type of the stuff that this class
163
returns, suitable for passing to L<C4::JSONStream::output_with_http_headers>.
164
In this case, it says 'xml'.
165
166
=cut
167
168
sub content_type {
169
    return 'xml';
170
}
171
172
=head2 true
173
174
    my $true = $xml->true();
175
176
This provides a 'true' value, as some format types need a special value.
177
178
=cut
179
180
sub true {
181
    return '1';
182
}
183
184
185
# This is an internal class sub that recurses through the provided data adding
186
# each layer to the writer.
187
sub _add_to_xml {
188
    my ($writer, $data) = @_;
189
190
    my $r = ref $data;
191
192
    if ($r eq 'HASH') {
193
        # data is a hashref
194
        while (my ($k, $v) = each %$data) {
195
            $writer->startTag($k);
196
            _add_to_xml($writer, $v);
197
            $writer->endTag($k);
198
        }
199
    } elsif ($r eq 'ARRAY') {
200
        # data is an arrayref
201
        $writer->startTag('array');
202
        foreach my $v (@$data) {
203
            if (ref($v) eq 'HASH') {
204
                # we don't say "item" for these ones
205
                _add_to_xml($writer, $v);
206
            } else {
207
                $writer->startTag('item');
208
                _add_to_xml($writer, $v);
209
                $writer->endTag('item');
210
            }
211
        }
212
        $writer->endTag('array');
213
    } elsif ($r eq '') {
214
        # data is a scalar
215
        $writer->characters($data);
216
    } else {
217
        confess "I got some data I can't handle: $data";
218
    }
219
}
220
221
1;
222
223
=head1 AUTHORS
224
225
=over 4
226
227
=item Robin Sheat <robin@catalyst.net.nz>
228
229
=back
230
231
=cut
(-)a/C4/Service.pm (-46 / +111 lines)
Lines 23-51 C4::Service - functions for JSON webservices. Link Here
23
23
24
=head1 SYNOPSIS
24
=head1 SYNOPSIS
25
25
26
my ( $query, $response) = C4::Service->init( { circulate => 1 } );
26
my $response = C4::Output::XMLStream->new(...);
27
my ( $borrowernumber) = C4::Service->require_params( 'borrowernumber' );
27
my $service = C4::Service->new( { needed_flags => { circulate => 1 },
28
    [ output_stream => $response ],
29
    [ query => CGI->new() ] } );
30
my ( $borrowernumber) = $service->require_params( 'borrowernumber' );
28
31
29
C4::Service->return_error( 'internal', 'Frobnication failed', frobnicator => 'foo' );
32
$service->return_error( 'internal', 'Frobnication failed', frobnicator => 'foo' );
30
33
31
$response->param( frobnicated => 'You' );
34
$response->param( frobnicated => 'You' );
32
35
33
C4::Service->return_success( $response );
36
C4::Service->return_success();
34
37
35
=head1 DESCRIPTION
38
=head1 DESCRIPTION
36
39
37
This module packages several useful functions for JSON webservices.
40
This module packages several useful functions for webservices.
38
41
39
=cut
42
=cut
40
43
41
use strict;
44
use strict;
42
use warnings;
45
use warnings;
43
46
47
use Carp;
44
use CGI qw ( -utf8 );
48
use CGI qw ( -utf8 );
45
use C4::Auth qw( check_api_auth );
49
use C4::Auth qw( check_api_auth );
46
use C4::Output qw( :ajax );
50
use C4::Output qw( :ajax );
47
use C4::Output::JSONStream;
51
use C4::Output::JSONStream;
48
use JSON;
49
52
50
our $debug;
53
our $debug;
51
54
Lines 53-94 BEGIN { Link Here
53
    $debug = $ENV{DEBUG} || 0;
56
    $debug = $ENV{DEBUG} || 0;
54
}
57
}
55
58
56
our ( $query, $cookie );
57
58
=head1 METHODS
59
=head1 METHODS
59
60
60
=head2 init
61
=head2 new
61
62
62
   our ( $query, $response ) = C4::Service->init( %needed_flags );
63
    my $service = C4::Service->new({needed_flags => { parameters => 1 }, 
64
        [ output_stream => C4::Output::XMLStream->new(...) ],
65
        [ query => CGI->new() ]});
63
66
64
Initialize the service and check for the permissions in C<%needed_flags>.
67
Creates a new instance of C4::Service. It verifies that the provided flags
68
are met by the current session, and aborts with an exit() call if they're
69
not. It also accepts an instance of C4::Output::* (or something with the 
70
same interface) to use to generate the output. If none is provided, then
71
a new instance of L<C4::Output::JSONStream> is created. Similarly, a query
72
may also be provided. If it's not, a new CGI one will be created.
65
73
66
Also, check that the user is authorized and has a current session, and return an
74
This call can't be used to log a user in by providing a userid parameter, it
67
'auth' error if not.
75
can only be used to check an already existing session.
68
76
69
init() returns a C<CGI> object and a C<C4::Output::JSONStream>. The latter can
77
TODO: exit sucks, make a better way.
70
be used for both flat scripts and those that use dispatch(), and should be
71
passed to C<return_success()>.
72
78
73
=cut
79
=cut
74
80
75
sub init {
81
sub new {
76
    my ( $class, %needed_flags ) = @_;
82
    my $class = shift;
83
84
    my %opts = %{shift()};
77
85
78
    our $query = new CGI;
86
    my $needed_flags = $opts{needed_flags};
87
    croak "needed_flags is a required option" unless $needed_flags;
79
88
80
    my ( $status, $cookie_, $sessionID ) = check_api_auth( $query, \%needed_flags );
89
    my $query = $opts{query} || CGI->new();
90
    # We capture the userid so it doesn't upset the auth check process
91
    # (if we don't, the auth code will try to log in with the userid
92
    # param value.)
93
    my $userid;
94
    $userid = $query->param('userid');
95
    $query->delete('userid') if defined($userid);
81
96
82
    our $cookie = $cookie_; # I have no desire to offend the Perl scoping gods
97
    my ( $status, $cookie, $sessionID ) = check_api_auth( $query, $needed_flags );
83
98
84
    $class->return_error( 'auth', $status ) if ( $status ne 'ok' );
99
    # Restore userid if needed
100
    $query->param(-name=>'userid', -value=>$userid) if defined($userid);
85
101
86
    return ( $query, new C4::Output::JSONStream );
102
    my $output_stream = $opts{output_stream} || C4::Output::JSONStream->new();
103
    my $self = {
104
        needed_flags  => $needed_flags,
105
        query         => $query,
106
        output_stream => $output_stream,
107
        cookie        => $cookie,
108
    };
109
    bless $self, $class;
110
    $self->return_error('auth', $status) if ($status ne 'ok');
111
112
    return $self;
87
}
113
}
88
114
89
=head2 return_error
115
=head2 return_error
90
116
91
    C4::Service->return_error( $type, $error, %flags );
117
    $service->return_error( $type, $error, %flags );
92
118
93
Exit the script with HTTP status 400, and return a JSON error object.
119
Exit the script with HTTP status 400, and return a JSON error object.
94
120
Lines 106-125 param => value pairs. Link Here
106
=cut
132
=cut
107
133
108
sub return_error {
134
sub return_error {
109
    my ( $class, $type, $error, %flags ) = @_;
135
    my ( $self, $type, $error, %flags ) = @_;
110
136
111
    my $response = new C4::Output::JSONStream;
137
    my $response = $self->{output_stream};
138
    $response->clear();
112
139
113
    $response->param( message => $error ) if ( $error );
140
    $response->param( message => $error ) if ( $error );
114
    $response->param( type => $type, %flags );
141
    $response->param( type => $type, %flags );
115
142
116
    output_with_http_headers $query, $cookie, $response->output, 'json', '400 Bad Request';
143
    output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type, '400 Bad Request';
144
145
    # Someone please delete this
117
    exit;
146
    exit;
118
}
147
}
119
148
120
=head2 return_multi
149
=head2 return_multi
121
150
122
    C4::Service->return_multi( \@responses, %flags );
151
    $service->return_multi( \@responses, %flags );
123
152
124
return_multi is similar to return_success or return_error, but allows you to
153
return_multi is similar to return_success or return_error, but allows you to
125
return different statuses for several requests sent at once (using HTTP status
154
return different statuses for several requests sent at once (using HTTP status
Lines 139-150 structure verbatim. Link Here
139
=cut
168
=cut
140
169
141
sub return_multi {
170
sub return_multi {
142
    my ( $class, $responses, @flags ) = @_;
171
    my ( $self, $responses, @flags ) = @_;
143
172
144
    my $response = new C4::Output::JSONStream;
173
    my $response = $self->{output_stream};
174
    $response->clear();
145
175
146
    if ( !@$responses ) {
176
    if ( !@$responses ) {
147
        $class->return_success( $response );
177
        $self->return_success( $response );
148
    } else {
178
    } else {
149
        my @responses_formatted;
179
        my @responses_formatted;
150
180
Lines 152-165 sub return_multi { Link Here
152
            if ( ref( $response ) eq 'ARRAY' ) {
182
            if ( ref( $response ) eq 'ARRAY' ) {
153
                my ($type, $error, @error_flags) = @$response;
183
                my ($type, $error, @error_flags) = @$response;
154
184
155
                push @responses_formatted, { is_error => JSON::true, type => $type, message => $error, @error_flags };
185
                push @responses_formatted, { is_error => $response->true(), type => $type, message => $error, @error_flags };
156
            } else {
186
            } else {
157
                push @responses_formatted, $response;
187
                push @responses_formatted, $response;
158
            }
188
            }
159
        }
189
        }
160
190
161
        $response->param( 'multi' => JSON::true, responses => \@responses_formatted, @flags );
191
        $response->param( 'multi' => $response->true(), responses => \@responses_formatted, @flags );
162
        output_with_http_headers $query, $cookie, $response->output, 'json', '207 Multi-Status';
192
        output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type, '207 Multi-Status';
163
    }
193
    }
164
194
165
    exit;
195
    exit;
Lines 167-188 sub return_multi { Link Here
167
197
168
=head2 return_success
198
=head2 return_success
169
199
170
    C4::Service->return_success( $response );
200
    $service->return_success();
171
201
172
Print out the information in the C<C4::Output::JSONStream> C<$response>, then
202
Print out the information in the provided C<output_stream>, then
173
exit with HTTP status 200.
203
exit with HTTP status 200. To get access to the C<output_stream>, you should
204
either use the one that you provided, or you should use the C<output_stream()>
205
accessor.
174
206
175
=cut
207
=cut
176
208
177
sub return_success {
209
sub return_success {
178
    my ( $class, $response ) = @_;
210
    my ( $self ) = @_;
179
211
180
    output_with_http_headers $query, $cookie, $response->output, 'json';
212
    my $response = $self->{output_stream};
213
    output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type;
214
}
215
216
=head2 output_stream
217
218
    $service->output_stream();
219
220
Provides the output stream object that is in use so that data can be added
221
to it.
222
223
=cut
224
225
sub output_stream {
226
    my $self = shift;
227
228
    return $self->{output_stream};
229
}
230
231
=head2 query
232
233
    $service->query();
234
235
Provides the query object that this class is using.
236
237
=cut
238
239
sub query {
240
    my $self = shift;
241
242
    return $self->{query};
181
}
243
}
182
244
183
=head2 require_params
245
=head2 require_params
184
246
185
    my @values = C4::Service->require_params( @params );
247
    my @values = $service->require_params( @params );
186
248
187
Check that each of of the parameters specified in @params was sent in the
249
Check that each of of the parameters specified in @params was sent in the
188
request, then return their values in that order.
250
request, then return their values in that order.
Lines 192-204 If a required parameter is not found, send a 'param' error to the browser. Link Here
192
=cut
254
=cut
193
255
194
sub require_params {
256
sub require_params {
195
    my ( $class, @params ) = @_;
257
    my ( $self, @params ) = @_;
196
258
197
    my @values;
259
    my @values;
198
260
199
    for my $param ( @params ) {
261
    for my $param ( @params ) {
200
        $class->return_error( 'params', "Missing '$param'" ) if ( !defined( $query->param( $param ) ) );
262
        $self->return_error( 'params', "Missing '$param'" ) if ( !defined( $self->{query}->param( $param ) ) );
201
        push @values, $query->param( $param );
263
        push @values, $self->{query}->param( $param );
202
    }
264
    }
203
265
204
    return @values;
266
    return @values;
Lines 206-212 sub require_params { Link Here
206
268
207
=head2 dispatch
269
=head2 dispatch
208
270
209
    C4::Service->dispatch(
271
    $service->dispatch(
210
        [ $path_regex, \@required_params, \&handler ],
272
        [ $path_regex, \@required_params, \&handler ],
211
        ...
273
        ...
212
    );
274
    );
Lines 233-240 with the argument '123'. Link Here
233
=cut
295
=cut
234
296
235
sub dispatch {
297
sub dispatch {
236
    my $class = shift;
298
    my $self = shift;
237
299
300
    my $query = $self->{query};
238
    my $path_info = $query->path_info || '/';
301
    my $path_info = $query->path_info || '/';
239
302
240
    ROUTE: foreach my $route ( @_ ) {
303
    ROUTE: foreach my $route ( @_ ) {
Lines 251-257 sub dispatch { Link Here
251
        return;
314
        return;
252
    }
315
    }
253
316
254
    $class->return_error( 'no_handler', '' );
317
    $self->return_error( 'no_handler', '' );
255
}
318
}
256
319
257
1;
320
1;
Lines 263-265 __END__ Link Here
263
Koha Development Team
326
Koha Development Team
264
327
265
Jesse Weaver <jesse.weaver@liblime.com>
328
Jesse Weaver <jesse.weaver@liblime.com>
329
330
Robin Sheat <robin@catalyst.net.nz>
(-)a/Koha/Borrower/Search.pm (+149 lines)
Line 0 Link Here
1
package Koha::Borrower::Search;
2
3
# Copyright 2015 Catalyst IT
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 3 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
use Modern::Perl;
21
22
use C4::Context;
23
use Carp;
24
25
use base 'Exporter';
26
27
our @EXPORT_OK = qw( find_borrower find_borrower_from_ext get_borrower_fields );
28
29
=head1 NAME
30
31
Koha::Borrower::Search - a simple borrower searching interface
32
33
=head1 SYNOPSIS
34
35
    use Koha::Borrower::Search qw( find_borrower find_borrower_from_ext );
36
    # This will raise an exception if more than one borrower matches
37
    my $borr_num = find_borrower('cardnumber', '123ABC');
38
    # This will give you a list of all the numbers
39
    my @borr_nums = find_borrower('surname', 'Smith');
40
41
    my $borr_num = find_borrower_from_ext('MEMBERNUM', '54321');
42
    my @borr_nums = find_borrower_from_ext('DEPARTMENT', 'Ministry of Silly Walks');
43
44
=head1 DESCRIPTION
45
46
This provides some functions to find borrower records.
47
48
=head1 FUNCTIONS
49
50
=head2 find_borrower
51
52
    my $borr_num = find_borrower('cardnumber', '123ABC');
53
    my @borr_nums = find_borrower('surname', 'Smith');
54
55
Given a column in the borrower table and a value, this will find matching
56
borrowers. 
57
58
If called in a scalar context, an exception will be raised if there is more
59
than one result, or something else goes wrong, and C<undef> will be returned if
60
there are no results.
61
62
If called in a list context, all borrowernumbers are returned.
63
64
=cut
65
66
sub find_borrower {
67
    my ( $field, $value ) = @_;
68
69
    croak "Field value may not be safe for SQL" if $field =~ /[^A-Za-z0-9]/;
70
    my $dbh = C4::Context->dbh();
71
    my $q   = "SELECT borrowernumber FROM borrowers WHERE $field=?";
72
    my $sth = $dbh->prepare($q);
73
    $sth->execute($value);
74
    if (wantarray) {
75
        my @bibs;
76
        while (my $row = $sth->fetchrow_arrayref) {
77
            push @bibs, $row->[0];
78
        }
79
        return @bibs;
80
    } else {
81
        my $row = $sth->fetchrow_arrayref();
82
        return undef unless $row;
83
        my $bib = $row->[0];
84
        die "Multiple borrowers match provided values\n"
85
        if $sth->fetchrow_arrayref();
86
        return $bib;
87
    }
88
}
89
90
=head2 find_borrower_from_ext
91
92
    my $borr_num = find_borrower_from_ext('MEMBERNUM', '54321');
93
    my @borr_nums = find_borrower_from_ext('DEPARTMENT', 'Ministry of Silly Walks');
94
95
Given the code for an extended borrower attribute, and a value, this will
96
find the borrowers that match.
97
98
If called in a scalar context, an exception will be raised if there is more
99
than one result, or something else goes wrong, and C<undef> will be returned if
100
there are no results.
101
102
If called in a list context, all borrowernumbers are returned.
103
104
=cut
105
106
sub find_borrower_from_ext {
107
    my ( $code, $value ) = @_;
108
109
    my $dbh = C4::Context->dbh();
110
    my $q =
111
'SELECT DISTINCT borrowernumber FROM borrower_attributes WHERE code=? AND attribute=?';
112
    my $sth = $dbh->prepare($q);
113
    $sth->execute( $code, $value );
114
    if (wantarray) {
115
        my @bibs;
116
        while (my $row = $sth->fetchrow_arrayref) {
117
            push @bibs, $row->[0];
118
        }
119
        return @bibs;
120
    } else {
121
        my $row = $sth->fetchrow_arrayref();
122
        return undef unless $row;
123
        my $bib = $row->[0];
124
        die "Multiple borrowers match provided values\n"
125
        if $sth->fetchrow_arrayref();
126
        return $bib;
127
    }
128
}
129
130
=head2 get_borrower_fields
131
132
Fetches the list of columns from the borrower table. Returns a list.
133
134
=cut
135
136
sub get_borrower_fields {
137
    my $dbh = C4::Context->dbh();
138
139
    my @fields;
140
    my $q   = 'SHOW COLUMNS FROM borrowers';
141
    my $sth = $dbh->prepare($q);
142
    $sth->execute();
143
    while ( my $row = $sth->fetchrow_hashref() ) {
144
        push @fields, $row->{Field};
145
    }
146
    return @fields;
147
}
148
149
1;
(-)a/members/default_messageprefs.pl (-2 / +3 lines)
Lines 28-35 use C4::Form::MessagingPreferences; Link Here
28
# update the prefs if operator is creating a new patron and has
28
# update the prefs if operator is creating a new patron and has
29
# changed the patron category from its original value.
29
# changed the patron category from its original value.
30
30
31
my ($query, $response) = C4::Service->init(borrowers => 1);
31
my $service = C4::Service->new({needed_flags => { borrowers => 1 }});
32
my $response = $service->output_stream();
32
my ($categorycode) = C4::Service->require_params('categorycode');
33
my ($categorycode) = C4::Service->require_params('categorycode');
33
C4::Form::MessagingPreferences::set_form_values({ categorycode => $categorycode }, $response);
34
C4::Form::MessagingPreferences::set_form_values({ categorycode => $categorycode }, $response);
34
C4::Service->return_success( $response );
35
C4::Service->return_success();
35
36
(-)a/opac/sco/sco-patron-image.pl (-2 / +4 lines)
Lines 22-28 use warnings; Link Here
22
use C4::Service;
22
use C4::Service;
23
use C4::Members;
23
use C4::Members;
24
24
25
my ($query, $response) = C4::Service->init(circulate => 'circulate_remaining_permissions');
25
my $service = C4::Service->init(
26
    { needed_flags => { circulate => 'circulate_remaining_permissions' } } );
27
my $query = $service->query();
26
28
27
unless (C4::Context->preference('WebBasedSelfCheck')) {
29
unless (C4::Context->preference('WebBasedSelfCheck')) {
28
    print $query->header(status => '403 Forbidden - web-based self-check not enabled');
30
    print $query->header(status => '403 Forbidden - web-based self-check not enabled');
Lines 33-39 unless (C4::Context->preference('ShowPatronImageInWebBasedSelfCheck')) { Link Here
33
    exit;
35
    exit;
34
}
36
}
35
37
36
my ($borrowernumber) = C4::Service->require_params('borrowernumber');
38
my ($borrowernumber) = $service->require_params('borrowernumber');
37
39
38
my ($imagedata, $dberror) = GetPatronImage($borrowernumber);
40
my ($imagedata, $dberror) = GetPatronImage($borrowernumber);
39
41
(-)a/svc/config/systempreferences (-7 / +7 lines)
Lines 42-48 batches. Link Here
42
42
43
=cut
43
=cut
44
44
45
our ( $query, $response ) = C4::Service->init( parameters => 1 );
45
our $service = C4::Service->new( { needed_flags => { parameters => 1 } } );
46
46
47
=head2 set_preference
47
=head2 set_preference
48
48
Lines 62-73 sub set_preference { Link Here
62
    my ( $preference ) = @_;
62
    my ( $preference ) = @_;
63
63
64
    unless ( C4::Context->config('demo') ) {
64
    unless ( C4::Context->config('demo') ) {
65
        my $value = join( ',', $query->param( 'value' ) );
65
        my $value = join( ',', $service->query()->param( 'value' ) );
66
        C4::Context->set_preference( $preference, $value );
66
        C4::Context->set_preference( $preference, $value );
67
        logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $preference . " | " . $value );
67
        logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $preference . " | " . $value );
68
    }
68
    }
69
69
70
    C4::Service->return_success( $response );
70
    $service->return_success();
71
}
71
}
72
72
73
=head2 set_preferences
73
=head2 set_preferences
Lines 90-111 pref_virtualshelves=0 Link Here
90
90
91
sub set_preferences {
91
sub set_preferences {
92
    unless ( C4::Context->config( 'demo' ) ) {
92
    unless ( C4::Context->config( 'demo' ) ) {
93
        foreach my $param ( $query->param() ) {
93
        foreach my $param ( $service->query()->param() ) {
94
            my ( $pref ) = ( $param =~ /pref_(.*)/ );
94
            my ( $pref ) = ( $param =~ /pref_(.*)/ );
95
95
96
            next if ( !defined( $pref ) );
96
            next if ( !defined( $pref ) );
97
97
98
            my $value = join( ',', $query->param( $param ) );
98
            my $value = join( ',', $service->query()->param( $param ) );
99
99
100
            C4::Context->set_preference( $pref, $value );
100
            C4::Context->set_preference( $pref, $value );
101
            logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $pref . " | " . $value );
101
            logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $pref . " | " . $value );
102
        }
102
        }
103
    }
103
    }
104
104
105
    C4::Service->return_success( $response );
105
    $service->return_success();
106
}
106
}
107
107
108
C4::Service->dispatch(
108
$service->dispatch(
109
    [ 'POST /([A-Za-z0-9_-]+)', [ 'value' ], \&set_preference ],
109
    [ 'POST /([A-Za-z0-9_-]+)', [ 'value' ], \&set_preference ],
110
    [ 'POST /', [], \&set_preferences ],
110
    [ 'POST /', [], \&set_preferences ],
111
);
111
);
(-)a/svc/members/delete (+154 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
3
# Copyright 2015 Catalyst IT
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 3 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
=head1 NAME
21
22
svc/members/delete - web service for deleting a user
23
24
=head1 SYNOPSIS
25
26
 POST /svc/members/delete
27
28
The request parameters go in the POST body.
29
30
=head1 DESCRIPTION
31
32
This allows users to be deleted on a Koha system from another service.
33
Information to match on is supplied as POST parameters, a user is searched for,
34
and any matches are deleted. The field to search on may be an extended
35
attribute code.
36
37
If any borrower that matches can't be deleted, for example it has charges
38
owing or items on issue, then nothing will be deleted. 
39
40
Deleted borrower records will be moved to the deletedborrowers table.
41
42
=head1 PARAMETERS
43
44
The request can accept a single parameter:
45
46
    fieldname=value
47
48
The fieldname is either a column in the C<borrowers> table, or the code of an
49
extended attribute.
50
51
=head2 Results
52
53
On success, this will return a result in XML form containing a count of the
54
records deleted. No records matching the search is also considered a success.
55
56
On failure, an error will be returned containing the borrower numbers that
57
caused the operation to fail and the reason.
58
59
=cut
60
61
use Modern::Perl;
62
63
use C4::Context;
64
use C4::Members;
65
use C4::Output::XMLStream;
66
use C4::Service;
67
use C4::VirtualShelves (); #no import
68
69
use Koha::Borrower::Search qw( find_borrower find_borrower_from_ext get_borrower_fields );
70
71
process_delete();
72
73
sub process_delete {
74
    my $xml = C4::Output::XMLStream->new(root => 'response');
75
    my $service = C4::Service->new( { needed_flags => { borrowers => 1 }, output_stream => $xml } );
76
77
    my $query = $service->query();
78
    my @supplied_fields = $query->param();
79
    # We only allow one supplied field.
80
    $service->return_error('parameters', 'Only one field to search for is permitted', status=>'failed') if @supplied_fields > 1;
81
    $service->return_error('parameters', 'A field and value to match against must be provided', status=>'failed') unless @supplied_fields;
82
83
    my $fieldname = $supplied_fields[0];
84
    my $fieldvalue = $query->param($fieldname);
85
86
    # Figure out if we need to check the borrower fields or the extended attribs
87
    my @borrower_fields = get_borrower_fields();
88
    my @attrib_types = get_extended_attribs();
89
    my $is_borrower_field = grep { $_ eq $fieldname } @borrower_fields;
90
    if (!$is_borrower_field && !grep { $_ eq $fieldname} @attrib_types) {
91
        $service->return_error('parameters', "Invalid parameter provided: $fieldname");
92
    }
93
94
    # Now find who this belongs to
95
    my @borr_nums;
96
    eval {
97
        if ($is_borrower_field) {
98
            @borr_nums = find_borrower($fieldname, $fieldvalue);
99
        } else {
100
            @borr_nums = find_borrower_from_ext($fieldname, $fieldvalue);
101
        }
102
    };
103
    if ($@) {
104
        $service->return_error('searchfailed', $@, status=>'failed');
105
    }
106
    unless (@borr_nums) {
107
        # no results, automatic success
108
        $service->output_stream->param(deletedcount => 0);
109
        $service->output_stream->param(status => 'ok');
110
        $service->return_success();
111
        return;
112
    }
113
114
    # Check for charges, issues
115
    my (@borr_issues, @borr_charges);
116
    foreach my $b (@borr_nums) {
117
        my $issues = scalar @{ GetPendingIssues($b) };
118
        my ($borr_data) = GetMemberDetails($b, '');
119
120
        push @borr_issues, $b if $issues;
121
        push @borr_charges, $b if $borr_data->{flags}->{'CHARGES'};
122
    }
123
124
    if (@borr_issues || @borr_charges) {
125
        $service->return_error(
126
            'constraints', 'Non-returned issues or uncleared charges',
127
            status  => 'failed',
128
            issues  => join( ',', @borr_issues ),
129
            charges => join( ',', @borr_charges )
130
        );
131
        return;
132
    }
133
134
    # All good, so let's delete
135
    foreach my $b (@borr_nums) {
136
        MoveMemberToDeleted($b);
137
        C4::VirtualShelves::HandleDelBorrower($b);
138
        DelMember($b);
139
    }
140
    $service->output_stream->param(deletedcount => scalar @borr_nums);
141
    $service->output_stream->param(status => 'ok');
142
    $service->return_success();
143
}
144
145
=head2 get_extended_attribs
146
147
Fetch all the extended attributes from the system. Returns a list.
148
149
=cut
150
151
sub get_extended_attribs {
152
    return map { $_->{code} } C4::Members::AttributeTypes::GetAttributeTypes();
153
}
154
(-)a/svc/members/upsert (+317 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
3
# Copyright 2015 Catalyst IT
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 3 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
=head1 NAME
21
22
svc/members/upsert - web service for inserting and updating user details
23
24
=head1 SYNOPSIS
25
26
 POST /svc/members/upsert
27
28
The request paramters go in the POST body.
29
30
=head1 DESCRIPTION
31
32
This allows user data to be added and updated on a Koha system from another
33
service. User data is supplied, and if it matches an existing user, that user
34
is updated. If not, then a new user is created. A field to match on must be
35
provided. For example, this might be an ID of the user in an employee
36
management system. It may be an extended attribute.
37
38
=head1 PARAMETERS
39
40
The request can contain any field from the borrowers table, and any extended
41
attribute name. It must also contain 'matchField' which specifies the field
42
to use to see if the user already exists.
43
44
To clear a field, provide an empty parameter for it. If the parameter doesn't
45
exist, then the field will be left alone.
46
47
Dates must be in YYYY-MM-DD form.
48
49
Boolean values must be 1 (for true) or 0 (for false.)
50
51
A borrowernumber field may be provided and used for matching. It will be
52
ignored when it comes to creating or updating however.
53
54
If the matchField parameters returns more than one value, an error will be
55
raised. Care should be taken to ensure that it is unique.
56
57
=head2 Results
58
59
On success, this will return a result in XML form containing the
60
borrowernumber of the record (whether it's newly created or just updated) and
61
a 'createOrUpdate' element that contains either 'create' or 'update',
62
depending on what operation ended up happening.
63
64
On error, an error response is returned. This may be because a matchField
65
was provided that didn't match anything, or because the matchField
66
produced multiple results. Or probably many other things.
67
68
=cut
69
70
use Modern::Perl;
71
72
use C4::Context;
73
use C4::Members;
74
use C4::Members::AttributeTypes;
75
use C4::Output::XMLStream;
76
use C4::Service;
77
78
use Koha::Borrower::Search
79
  qw( find_borrower find_borrower_from_ext get_borrower_fields );
80
81
process_upsert();
82
83
sub process_upsert {
84
    my $xml = C4::Output::XMLStream->new( root => 'response' );
85
    my $service = C4::Service->new(
86
        { needed_flags => { borrowers => 1 }, output_stream => $xml } );
87
88
    my $query           = $service->query();
89
    my @supplied_fields = $query->param();
90
    my @borrower_fields = get_borrower_fields();
91
    my @attrib_types    = get_extended_attribs();
92
    my $match_field     = $query->param('matchField');
93
94
    # Make a mapping of these so we can do fast lookups
95
    my %borrower_fields = map { $_ => 1 } @borrower_fields;
96
    my %attrib_types    = map { $_ => 1 } @attrib_types;
97
98
    $service->return_error(
99
        'parameters',
100
        'No matchField provided',
101
        status => 'failed'
102
    ) unless $match_field;
103
    my $is_borrower_field;    # for matchField, as opposed to an ext attribute
104
    $is_borrower_field = $borrower_fields{$match_field} // 0;
105
    if ( !$is_borrower_field ) {
106
        $service->return_error(
107
            'parameters',
108
            'Provided matchField doesn\'t match a valid field',
109
            status => 'failed'
110
        ) unless $attrib_types{$match_field};
111
    }
112
    my $match_value = $query->param($match_field);
113
    $service->return_error(
114
        'parameters',
115
        'The field specified by matchField wasn\'t provided.',
116
        status => 'failed'
117
    ) unless $match_value;
118
119
    # verify we are only given valid fields, at the same time make a mapping
120
    # of them.
121
    my ( %supplied_data_borr, %supplied_data_ext );
122
    foreach my $f (@supplied_fields) {
123
        next if $f eq 'matchField';
124
        $service->return_error( 'parameters', "Invalid parameter provided: $f" )
125
          unless $borrower_fields{$f} || $attrib_types{$f};
126
        if ( $borrower_fields{$f} ) {
127
            $supplied_data_borr{$f} = $query->param($f);
128
        }
129
        else {
130
            $supplied_data_ext{$f} = $query->param($f);
131
        }
132
    }
133
134
    # Sanity checks and data extraction over, find our borrower.
135
    my $borr_num;
136
    eval {
137
        if ($is_borrower_field) {
138
            $borr_num = find_borrower( $match_field, $match_value );
139
        }
140
        else {
141
            $borr_num = find_borrower_from_ext( $match_field, $match_value );
142
        }
143
    };
144
    if ($@) {
145
        $service->return_error( 'borrower', $@, status => 'failed' );
146
    }
147
148
    # Now we know if we're creating a new user, or updating an existing one.
149
    my $change_type;
150
    eval {
151
        if ($borr_num) {
152
            update_borrower( $borr_num, \%supplied_data_borr,
153
                \%supplied_data_ext );
154
            $change_type = 'update';
155
        }
156
        else {
157
            $borr_num =
158
              create_borrower( \%supplied_data_borr, \%supplied_data_ext );
159
            $change_type = 'create';
160
        }
161
    };
162
    if ($@) {
163
        $service->return_error( 'data', $@, status => 'failed' );
164
    }
165
166
    $service->output_stream->param( 'borrowernumber', $borr_num );
167
    $service->output_stream->param( 'createOrUpdate', $change_type );
168
    $service->output_stream->param( 'status',         'ok' );
169
    $service->return_success();
170
}
171
172
=head2 get_extended_attribs
173
174
Fetch all the extended attributes from the system. Returns a list.
175
176
=cut
177
178
sub get_extended_attribs {
179
    return map { $_->{code} } C4::Members::AttributeTypes::GetAttributeTypes();
180
}
181
182
=head2 update_borrower
183
184
    update_borrower($borr_num, \%borrower_fields, \%ext_attrib_fields);
185
186
This takes a borrower number, a hashref containing the fields and values for
187
the borrower, and a hashref containing the fields and values for the extended
188
attributes. It will update the borrower to set its fields to the values
189
supplied.
190
191
A supplied borrowernumber will be ignored.
192
193
=cut
194
195
sub update_borrower {
196
    my ( $borr_num, $borr_fields, $ext_fields ) = @_;
197
198
    # For the first phase, we build an update query for the borrower
199
    my ( @f_borr, @v_borr );
200
    while ( my ( $f, $v ) = each %$borr_fields ) {
201
        next if $f =~ /^borrowernumber$/i;
202
        die "Invalid fieldname provided (update): $f\n" if $f =~ /[^A-Za-z0-9]/;
203
        push @f_borr, $f;
204
        push @v_borr, $v;
205
    }
206
    my $q_borr =
207
        'UPDATE borrowers SET '
208
      . ( join ',', map { $_ . '=?' } @f_borr )
209
      . ' WHERE borrowernumber=?';
210
211
    # Now queries to sort out the extended fields
212
    my @f_ext = keys %$ext_fields;
213
    my @v_ext = values %$ext_fields;
214
    my $q_ext_del =
215
      'DELETE FROM borrower_attributes WHERE borrowernumber=? AND code IN ('
216
      . ( join ',', map { '?' } @f_ext ) . ')';
217
    my $q_ext_add =
218
'INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (?, ?, ?)';
219
220
    my $dbh = C4::Context->dbh();
221
222
    # Finally, run these all inside a transaction.
223
    eval {
224
        local $dbh->{RaiseError} = 1;
225
        $dbh->begin_work;
226
227
        my $sth;
228
229
        if (@f_borr) {
230
            $sth = $dbh->prepare($q_borr);
231
            $sth->execute( @v_borr, $borr_num );
232
        }
233
234
        $sth = $dbh->prepare($q_ext_del);
235
        $sth->execute( $borr_num, @f_ext ) if @f_ext;
236
237
        $sth = $dbh->prepare($q_ext_add);
238
        while ( my ( $f, $v ) = each %$ext_fields ) {
239
            next if $v eq '';
240
            $sth->execute( $borr_num, $f, $v );
241
        }
242
243
        $dbh->commit;
244
    };
245
    if ($@) {
246
        $dbh->rollback;
247
        die "Failed to update borrower record: $@\n";
248
    }
249
    return $borr_num;
250
}
251
252
=head2 create_borrower
253
254
    my $borr_num = create_borrower(\%borrower_fields, \%ext_attrib_fields);
255
256
This creates a new borrower using the supplied data.
257
258
A supplied borrowernumber will be ignored.
259
260
The borrowernumber of the new borrower will be returned.
261
262
=cut
263
264
sub create_borrower {
265
    my ( $borr_fields, $ext_fields ) = @_;
266
267
    my @criticals = qw(surname branchcode categorycode);
268
269
    # Check we have the ones we need
270
    foreach my $c (@criticals) {
271
        die "Critical field missing (create): $c\n" unless $borr_fields->{$c};
272
    }
273
274
    # Borrower fields
275
    my ( @f_borr, @v_borr );
276
    while ( my ( $f, $v ) = each %$borr_fields ) {
277
        die "Invalid fieldname provided: $f\n" if $f =~ /[^A-Za-z0-9]/;
278
        push @f_borr, $f;
279
        push @v_borr, $v;
280
    }
281
    my $q_borr =
282
        'INSERT INTO borrowers ('
283
      . ( join ',', @f_borr )
284
      . ') VALUES ('
285
      . ( join ',', map { '?' } @f_borr ) . ')';
286
287
    # Extended attributes
288
    my @f_ext = keys %$ext_fields;
289
    my @v_ext = values %$ext_fields;
290
    my $q_ext_add =
291
'INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (?, ?, ?)';
292
293
    my $dbh = C4::Context->dbh();
294
295
    # Finally, run these all inside a transaction.
296
    my $borr_num;
297
    eval {
298
        local $dbh->{RaiseError} = 1;
299
        $dbh->begin_work;
300
301
        my $sth = $dbh->prepare($q_borr);
302
        $sth->execute(@v_borr);
303
        $borr_num = $dbh->last_insert_id( undef, undef, undef, undef );
304
305
        $sth = $dbh->prepare($q_ext_add);
306
        while ( my ( $f, $v ) = each %$ext_fields ) {
307
            $sth->execute( $borr_num, $f, $v );
308
        }
309
310
        $dbh->commit;
311
    };
312
    if ($@) {
313
        $dbh->rollback;
314
        die "Failed to create borrower record: $@\n";
315
    }
316
    return $borr_num;
317
}
(-)a/t/Output_JSONStream.t (-1 / +10 lines)
Lines 6-12 Link Here
6
use strict;
6
use strict;
7
use warnings;
7
use warnings;
8
8
9
use Test::More tests => 10;
9
use Test::More tests => 12;
10
11
use JSON;
10
12
11
BEGIN {
13
BEGIN {
12
        use_ok('C4::Output::JSONStream');
14
        use_ok('C4::Output::JSONStream');
Lines 30-32 eval{$json->param( die => ['yes','sure','now'])}; Link Here
30
ok(!$@,'Does not die.');
32
ok(!$@,'Does not die.');
31
eval{$json->param( die => ['yes','sure','now'], die2 =>)};
33
eval{$json->param( die => ['yes','sure','now'], die2 =>)};
32
ok($@,'Dies.');
34
ok($@,'Dies.');
35
36
$json->clear();
37
is($json->output,'{}',"Making sure that clearing it clears it.");
38
39
is($json->content_type, 'json', 'Correct content type is returned');
40
41
is($json->true, JSON::True, 'True is true.');
(-)a/t/Output_XMLStream.t (+70 lines)
Line 0 Link Here
1
# Copyright 2014 Catalyst IT
2
#
3
# This file is part of Koha.
4
#
5
# Koha is free software; you can redistribute it and/or modify it under the
6
# terms of the GNU General Public License as published by the Free Software
7
# Foundation; either version 3 of the License, or (at your option) any later
8
# version.
9
#
10
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
11
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13
#
14
# You should have received a copy of the GNU General Public License along
15
# with Koha; if not, write to the Free Software Foundation, Inc.,
16
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
17
18
use Modern::Perl;
19
use Test::More tests => 15;
20
21
BEGIN {
22
    use_ok('C4::Output::XMLStream');
23
}
24
25
my $xml = C4::Output::XMLStream->new(root => 'root');
26
27
is(trim($xml->output), '<?xml version="1.0" encoding="UTF-8"?>
28
<root></root>
29
', 'Making sure that blank XML can be output');
30
31
$xml->param( issues => [ 'yes!', 'please', 'no' ] );
32
is(trim($xml->output),'<?xml version="1.0" encoding="UTF-8"?>
33
<root><issues><array><item>yes!</item><item>please</item><item>no</item></array></issues></root>
34
',"Making sure XML output has added what we told it to.");
35
36
$xml->param( stuff => ['realia'] );
37
like($xml->output,qr|<stuff><array><item>realia</item></array></stuff>|,"Making sure XML output has added more params correctly.");
38
like($xml->output,qr|<issues><array><item>yes!</item><item>please</item><item>no</item></array></issues>|,"Making sure the old data is still in there");
39
40
$xml->param( stuff => ['fun','love'] );
41
like($xml->output,qr|<stuff><array><item>fun</item><item>love</item></array></stuff>|,"Making sure XML output can overwrite params");
42
like($xml->output,qr|<issues><array><item>yes!</item><item>please</item><item>no</item></array></issues>|,"Making sure the old data is still in there");
43
44
$xml->param( halibut => { cod => 'bass' } );
45
like($xml->output,qr|<halibut><cod>bass</cod></halibut>|,"Adding of hashes works");
46
like($xml->output,qr|<issues><array><item>yes!</item><item>please</item><item>no</item></array></issues>|,"Making sure the old data is still in there");
47
48
49
eval{$xml->param( die )};
50
ok($@,'Dies');
51
52
eval{$xml->param( die => ['yes','sure','now'])};
53
ok(!$@,'Dosent die.');
54
55
eval{$xml->param( die => ['yes','sure','now'], die2 =>)};
56
ok($@,'Dies.');
57
58
$xml->clear();
59
is(trim($xml->output), '<?xml version="1.0" encoding="UTF-8"?>
60
<root></root>
61
', 'Making sure that clearing it clears it.');
62
63
is($xml->content_type, 'xml', 'Correct content type is returned');
64
65
is($xml->true, '1', 'True is true.');
66
67
sub trim {
68
    $_ = shift;
69
    s/^\s*(.*?)\s*$/$1/r;
70
}
(-)a/t/Service.t (+71 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
3
# Copyright 2015 Catalyst IT
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 3 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
use Modern::Perl;
21
22
use DBD::Mock;
23
use Test::MockModule;
24
25
use Test::More tests => 3;
26
27
my $module_context = new Test::MockModule('C4::Context');
28
my $_dbh;
29
$module_context->mock(
30
    '_new_dbh',
31
    sub {
32
        my $dbh = $_dbh // DBI->connect('DBI:Mock:', '', '') || die "Cannot create handle: $DBI::errstr\n";
33
        $_dbh = $dbh;
34
        return $dbh;
35
    }
36
);
37
38
# We need to mock the Auth process so that we can pretend we have a valid session
39
my $module_auth = new Test::MockModule('C4::Auth');
40
$module_auth->mock(
41
    'check_api_auth',
42
    sub {
43
        return ('ok', '', '');
44
    }
45
);
46
47
# Instead of actually outputting to stdout, we catch things on the way past
48
my @_out_params;
49
my $module_output = new Test::MockModule('C4::Output');
50
$module_output->mock(
51
    'output_with_http_headers',
52
    sub {
53
        @_out_params = @_;
54
    }
55
);
56
57
use_ok('C4::Output::XMLStream');
58
use_ok('C4::Service');
59
60
# Do a simple round trip test of data in to data out
61
my $xml_stream = C4::Output::XMLStream->new(root => 'test');
62
63
my $service = C4::Service->new( { needed_flags => { borrowers => 1 } ,
64
        output_stream => $xml_stream });
65
66
$service->output_stream->param( foo => 'bar' );
67
68
$service->return_success();
69
like($_out_params[2], qr|<test><foo>bar</foo></test>|, 'XML output generated');
70
71
(-)a/t/db_dependent/Borrower_Search.t (+79 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
3
# Copyright 2015 Catalyst IT
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 3 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
use C4::Context;
21
22
use Test::More tests => 10;
23
24
use_ok('Koha::Borrower::Search');
25
26
my $dbh = C4::Context->dbh;
27
$dbh->{RaiseError} = 1;
28
$dbh->{AutoCommit} = 0;
29
30
# Insert some borrower detail to fetch later
31
$dbh->do(q|INSERT INTO branches (branchcode) VALUES ('TBRANCH')|);
32
$dbh->do(q|INSERT INTO categories (categorycode) VALUES ('TCAT')|);
33
$dbh->do(q|INSERT INTO borrowers (borrowernumber,cardnumber,branchcode,categorycode,surname) VALUES (200000,'test123','TBRANCH','TCAT','Surname1'), (200001,'test124','TBRANCH','TCAT','Surname2'),(200002,'test125','TBRANCH','TCAT','Surname3')|);
34
35
# An ext attribute
36
$dbh->do(q|INSERT INTO borrower_attribute_types (code, description) VALUES ('TEXTATTR', 'Test Ext Attrib')|);
37
$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200000, 'TEXTATTR', 'TESTING')|);
38
$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200001, 'TEXTATTR', 'TESTING')|);
39
$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200002, 'TEXTATTR', 'TESTING2')|);
40
41
# And now the actual testing
42
43
# Check to make sure a couple of the columns come through.
44
my @cols = Koha::Borrower::Search::get_borrower_fields();
45
ok((grep{$_ eq 'cardnumber'} @cols), 'Borrower field 1');
46
ok((grep{$_ eq 'lost'} @cols), 'Borrower field 2');
47
ok((grep{$_ eq 'userid'} @cols), 'Borrower field 3');
48
49
# Find a borrower by a value
50
my $num = Koha::Borrower::Search::find_borrower(surname => 'Surname2');
51
is($num, 200001, 'Fetch single borrower by field');
52
53
my @nums = Koha::Borrower::Search::find_borrower(branchcode => 'TBRANCH');
54
is_deeply(\@nums, [200000, 200001, 200002], 'Fetch multiple borrowers by field');
55
56
# Find by ext attr
57
$num = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING2');
58
is ($num, 200002, 'Fetch single borrower by ext attr');
59
60
my @nums = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING');
61
is_deeply(\@nums, [200000, 200001], 'Fetch multiple borrowers by ext attr');
62
63
# Check that they correctly fail
64
65
my $fail = 1;
66
eval {
67
    $num = Koha::Borrower::Search::find_borrower(branchcode => 'TBRANCH');
68
    $fail = 0;
69
};
70
is($fail, 1, 'Raised exception for multiple results by field');
71
72
$fail = 1;
73
eval {
74
    $nums = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING');
75
    $fail = 0;
76
};
77
is($fail, 1, 'Raised exception for multiple results by ext attr');
78
79
$dbh->rollback;
(-)a/t/db_dependent/Service.t (-15 lines)
Lines 1-14 Link Here
1
#!/usr/bin/perl
2
#
3
# This Koha test module is a stub!  
4
# Add more tests here!!!
5
6
use strict;
7
use warnings;
8
9
use Test::More tests => 1;
10
11
BEGIN {
12
        use_ok('C4::Service');
13
}
14
15
- 

Return to bug 13607