Attachment #35455 for bug #13607

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

Lines 737-742 our $PERL_DEPS = { Link Here

(-)a/C4/Installer/PerlDependencies.pm (+5 lines)
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;




    return to_json( $self->{data} );
}

=head 2 clear

    $json->clear();

This clears any in-progress data from the object so it can be used to create
something new. Parameters are kept, it's just the data that goes away.

=cut

sub clear {
    my $self = shift;
    $self->{data} = {};
}

=head2 content_type

    my $ct = $json->content_type();

Returns a string containing the content type of the stuff that this class
returns, suitable for passing to L<C4::JSONStream::output_with_http_headers>.
In this case, it says 'json'.

=cut

sub content_type {
    return 'json';
}

=head2 true

    my $true = $json->true();

This provides a 'true' value, as some format types need a special value.

=cut

sub true {
    return JSON::true;
}


1;




package C4::Output::XMLStream;

# Copyright 2014 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=head1 NAME

C4::Output::XMLStream - progressively build XML data

=head1 SYNOPSIS

    my $xml = C4::Output::XMLStream->new(root => 'rootnodename');
    
    $json->param( issues => [ 'yes!', 'please', 'no', { emphasis = 'NO' } ] );
    $json->param( stuff => 'realia' );
    
    print $json->output;

=head1 DESCRIPTION

This module makes it easy to progressively build up data structure that can
then be output as XML.

The XML output is very simple, as this is an analogue to JSON output. If
params are set thus:

    my $json = C4::Output::XMLStream->new(root => 'rootnodename');
    $json->param( issues => [ 'yes!', 'please', 'no', { emphasis = 'NO' } ] );
    $json->param( stuff => 'realia' );

Then the XML will be:

    <rootnodename>
        <issues>
            <array>
                <item>yes!</item>
                <item>please</item>
                <item>no</item>
                <emphasis>NO</emphasis>
            </array>
        </issues>
        <stuff>realia</stuff>
    </rootnodename>

It's wordy because it's XML. You can't set attributes on nodes, because you
can't do that in JSON. You can't have text elements and sub-elements at the
same time, because that's fiddly to express in Perl structures, and you can't
do that in JSON anyway.

If you want multiple subnodes, then do this:

    $xml->param(stuff => { one => 'a', two => 'b' });
    
The resulting order of the output is not particularly deterministic, given
this more or less emulates a hash, except the bits with arrays.

If you add a new param with the same name as an already existing one, the new
one will overwrite the old one.

=head1 FUNCTIONS

=cut

use Carp;
use Modern::Perl;
use XML::Writer;

=head2 new

    my $xml = C4::Output::XMLStream->new(root => 'rootnodename');

Creates a new instance of the C<C4::Output::XMLStream> class.

=cut

sub new {
    my $class = shift;
    my %opts = @_;
    croak "no root node specified" unless $opts{root};
    my $self = {
        data => {},
        %opts,
    };
    bless $self, $class;
    return $self;
}

=head2 param

    $xml->param(key1 => $value1, key2 => $value2, ...);

This adds the supplied key/value pairs to the object for later output. See
the Description section for details on what goes in vs. what comes out.

=cut

sub param {
    my $self = shift;

    if (@_ % 2 != 0) {
        croak "param() received an odd number of args, should be a list of hashes";
    }

    my %p = @_;
    # Merge the hashes, this'll overwrite any old values with new ones
    @{ $self->{data} }{ keys %p } = values %p;
}

=head2 output

    my $str = $xml->output();

Turns the provided params into an XML document string.

=cut

sub output {
    my $self = shift;

    my $str;
    my $writer = XML::Writer->new(OUTPUT => \$str);
    $writer->xmlDecl('UTF-8');
    $writer->startTag($self->{root});
    _add_to_xml($writer, $self->{data});
    $writer->endTag($self->{root});
    $writer->end();
    return $str;
}

=head2 clear

    $xml->clear();

This clears any in-progress data from the object so it can be used to create
something new. Parameters are kept, it's just the data that goes away.

=cut

sub clear {
    my $self = shift;
    $self->{data} = {};
}

=head2 content_type

    my $ct = $xml->content_type();

Returns a string containing the content type of the stuff that this class
returns, suitable for passing to L<C4::JSONStream::output_with_http_headers>.
In this case, it says 'xml'.

=cut

sub content_type {
    return 'xml';
}

=head2 true

    my $true = $xml->true();

This provides a 'true' value, as some format types need a special value.

=cut

sub true {
    return '1';
}


# This is an internal class sub that recurses through the provided data adding
# each layer to the writer.
sub _add_to_xml {
    my ($writer, $data) = @_;

    my $r = ref $data;

    if ($r eq 'HASH') {
        # data is a hashref
        while (my ($k, $v) = each %$data) {
            $writer->startTag($k);
            _add_to_xml($writer, $v);
            $writer->endTag($k);
        }
    } elsif ($r eq 'ARRAY') {
        # data is an arrayref
        $writer->startTag('array');
        foreach my $v (@$data) {
            if (ref($v) eq 'HASH') {
                # we don't say "item" for these ones
                _add_to_xml($writer, $v);
            } else {
                $writer->startTag('item');
                _add_to_xml($writer, $v);
                $writer->endTag('item');
            }
        }
        $writer->endTag('array');
    } elsif ($r eq '') {
        # data is a scalar
        $writer->characters($data);
    } else {
        confess "I got some data I can't handle: $data";
    }
}

1;

=head1 AUTHORS

=over 4

=item Robin Sheat <robin@catalyst.net.nz>

=back

=cut





=head1 SYNOPSIS

my $response = C4::Output::XMLStream->new(...);
my $service = C4::Service->new( { needed_flags => { circulate => 1 },
    [ output_stream => $response ],
    [ query => CGI->new() ] } );
my ( $borrowernumber) = $service->require_params( 'borrowernumber' );

$service->return_error( 'internal', 'Frobnication failed', frobnicator => 'foo' );

$response->param( frobnicated => 'You' );

C4::Service->return_success();

=head1 DESCRIPTION

This module packages several useful functions for webservices.

=cut

use strict;
use warnings;

use Carp;
use CGI qw ( -utf8 );
use C4::Auth qw( check_api_auth );
use C4::Output qw( :ajax );
use C4::Output::JSONStream;
use JSON;

our $debug;


    $debug = $ENV{DEBUG} || 0;
}

our ( $query, $cookie );

=head1 METHODS

=head2 new

    my $service = C4::Service->new({needed_flags => { parameters => 1 }, 
        [ output_stream => C4::Output::XMLStream->new(...) ],
        [ query => CGI->new() ]});

Creates a new instance of C4::Service. It verifies that the provided flags
are met by the current session, and aborts with an exit() call if they're
not. It also accepts an instance of C4::Output::* (or something with the 
same interface) to use to generate the output. If none is provided, then
a new instance of L<C4::Output::JSONStream> is created. Similarly, a query
may also be provided. If it's not, a new CGI one will be created.

This call can't be used to log a user in by providing a userid parameter, it
can only be used to check an already existing session.

TODO: exit sucks, make a better way.
be used for both flat scripts and those that use dispatch(), and should be
passed to C<return_success()>.

=cut

sub new {
    my $class = shift;

    my %opts = %{shift()};

    my $needed_flags = $opts{needed_flags};
    croak "needed_flags is a required option" unless $needed_flags;

    my $query = $opts{query} || CGI->new();
    # We capture the userid so it doesn't upset the auth check process
    # (if we don't, the auth code will try to log in with the userid
    # param value.)
    my $userid;
    $userid = $query->param('userid');
    $query->delete('userid') if defined($userid);

    my ( $status, $cookie, $sessionID ) = check_api_auth( $query, $needed_flags );

    # Restore userid if needed
    $query->param(-name=>'userid', -value=>$userid) if defined($userid);

    my $output_stream = $opts{output_stream} || C4::Output::JSONStream->new();
    my $self = {
        needed_flags  => $needed_flags,
        query         => $query,
        output_stream => $output_stream,
        cookie        => $cookie,
    };
    bless $self, $class;
    $self->return_error('auth', $status) if ($status ne 'ok');

    return $self;
}

=head2 return_error

    $service->return_error( $type, $error, %flags );

Exit the script with HTTP status 400, and return a JSON error object.


=cut

sub return_error {
    my ( $self, $type, $error, %flags ) = @_;

    my $response = $self->{output_stream};
    $response->clear();

    $response->param( message => $error ) if ( $error );
    $response->param( type => $type, %flags );

    output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type, '400 Bad Request';

    # Someone please delete this
    exit;
}

=head2 return_multi

    $service->return_multi( \@responses, %flags );

return_multi is similar to return_success or return_error, but allows you to
return different statuses for several requests sent at once (using HTTP status

=cut

sub return_multi {
    my ( $self, $responses, @flags ) = @_;

    my $response = $self->{output_stream};
    $response->clear();

    if ( !@$responses ) {
        $self->return_success( $response );
    } else {
        my @responses_formatted;


            if ( ref( $response ) eq 'ARRAY' ) {
                my ($type, $error, @error_flags) = @$response;

                push @responses_formatted, { is_error => $response->true(), type => $type, message => $error, @error_flags };
            } else {
                push @responses_formatted, $response;
            }
        }

        $response->param( 'multi' => $response->true(), responses => \@responses_formatted, @flags );
        output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type, '207 Multi-Status';
    }

    exit;


=head2 return_success

    $service->return_success();

Print out the information in the provided C<output_stream>, then
exit with HTTP status 200. To get access to the C<output_stream>, you should
either use the one that you provided, or you should use the C<output_stream()>
accessor.

=cut

sub return_success {
    my ( $self ) = @_;

    my $response = $self->{output_stream};
    output_with_http_headers $self->{query}, $self->{cookie}, $response->output, $response->content_type;
}

=head2 output_stream

    $service->output_stream();

Provides the output stream object that is in use so that data can be added
to it.

=cut

sub output_stream {
    my $self = shift;

    return $self->{output_stream};
}

=head2 query

    $service->query();

Provides the query object that this class is using.

=cut

sub query {
    my $self = shift;

    return $self->{query};
}

=head2 require_params

    my @values = $service->require_params( @params );

Check that each of of the parameters specified in @params was sent in the
request, then return their values in that order.

=cut

sub require_params {
    my ( $self, @params ) = @_;

    my @values;

    for my $param ( @params ) {
        $self->return_error( 'params', "Missing '$param'" ) if ( !defined( $self->{query}->param( $param ) ) );
        push @values, $self->{query}->param( $param );
    }

    return @values;


=head2 dispatch

    $service->dispatch(
        [ $path_regex, \@required_params, \&handler ],
        ...
    );

=cut

sub dispatch {
    my $self = shift;

    my $query = $self->{query};
    my $path_info = $query->path_info || '/';

    ROUTE: foreach my $route ( @_ ) {

        return;
    }

    $self->return_error( 'no_handler', '' );
}

1;

Koha Development Team

Jesse Weaver <jesse.weaver@liblime.com>

Robin Sheat <robin@catalyst.net.nz>




package Koha::Borrower::Search;

# Copyright 2015 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use Modern::Perl;

use C4::Context;
use Carp;

use base 'Exporter';

our @EXPORT_OK = qw( find_borrower find_borrower_from_ext get_borrower_fields );

=head1 NAME

Koha::Borrower::Search - a simple borrower searching interface

=head1 SYNOPSIS

    use Koha::Borrower::Search qw( find_borrower find_borrower_from_ext );
    # This will raise an exception if more than one borrower matches
    my $borr_num = find_borrower('cardnumber', '123ABC');
    # This will give you a list of all the numbers
    my @borr_nums = find_borrower('surname', 'Smith');

    my $borr_num = find_borrower_from_ext('MEMBERNUM', '54321');
    my @borr_nums = find_borrower_from_ext('DEPARTMENT', 'Ministry of Silly Walks');

=head1 DESCRIPTION

This provides some functions to find borrower records.

=head1 FUNCTIONS

=head2 find_borrower

    my $borr_num = find_borrower('cardnumber', '123ABC');
    my @borr_nums = find_borrower('surname', 'Smith');

Given a column in the borrower table and a value, this will find matching
borrowers. 

If called in a scalar context, an exception will be raised if there is more
than one result, or something else goes wrong, and C<undef> will be returned if
there are no results.

If called in a list context, all borrowernumbers are returned.

=cut

sub find_borrower {
    my ( $field, $value ) = @_;

    croak "Field value may not be safe for SQL" if $field =~ /[^A-Za-z0-9]/;
    my $dbh = C4::Context->dbh();
    my $q   = "SELECT borrowernumber FROM borrowers WHERE $field=?";
    my $sth = $dbh->prepare($q);
    $sth->execute($value);
    if (wantarray) {
        my @bibs;
        while (my $row = $sth->fetchrow_arrayref) {
            push @bibs, $row->[0];
        }
        return @bibs;
    } else {
        my $row = $sth->fetchrow_arrayref();
        return undef unless $row;
        my $bib = $row->[0];
        die "Multiple borrowers match provided values\n"
        if $sth->fetchrow_arrayref();
        return $bib;
    }
}

=head2 find_borrower_from_ext

    my $borr_num = find_borrower_from_ext('MEMBERNUM', '54321');
    my @borr_nums = find_borrower_from_ext('DEPARTMENT', 'Ministry of Silly Walks');

Given the code for an extended borrower attribute, and a value, this will
find the borrowers that match.

If called in a scalar context, an exception will be raised if there is more
than one result, or something else goes wrong, and C<undef> will be returned if
there are no results.

If called in a list context, all borrowernumbers are returned.

=cut

sub find_borrower_from_ext {
    my ( $code, $value ) = @_;

    my $dbh = C4::Context->dbh();
    my $q =
'SELECT DISTINCT borrowernumber FROM borrower_attributes WHERE code=? AND attribute=?';
    my $sth = $dbh->prepare($q);
    $sth->execute( $code, $value );
    if (wantarray) {
        my @bibs;
        while (my $row = $sth->fetchrow_arrayref) {
            push @bibs, $row->[0];
        }
        return @bibs;
    } else {
        my $row = $sth->fetchrow_arrayref();
        return undef unless $row;
        my $bib = $row->[0];
        die "Multiple borrowers match provided values\n"
        if $sth->fetchrow_arrayref();
        return $bib;
    }
}

=head2 get_borrower_fields

Fetches the list of columns from the borrower table. Returns a list.

=cut

sub get_borrower_fields {
    my $dbh = C4::Context->dbh();

    my @fields;
    my $q   = 'SHOW COLUMNS FROM borrowers';
    my $sth = $dbh->prepare($q);
    $sth->execute();
    while ( my $row = $sth->fetchrow_hashref() ) {
        push @fields, $row->{Field};
    }
    return @fields;
}

1;

Lines 28-35 use C4::Form::MessagingPreferences; Link Here

(-)a/members/default_messageprefs.pl (-2 / +3 lines)
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

Lines 22-28 use warnings; Link Here

(-)a/opac/sco/sco-patron-image.pl (-2 / +4 lines)
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





=cut

our $service = C4::Service->new( { needed_flags => { parameters => 1 } } );

=head2 set_preference


    my ( $preference ) = @_;

    unless ( C4::Context->config('demo') ) {
        my $value = join( ',', $service->query()->param( 'value' ) );
        C4::Context->set_preference( $preference, $value );
        logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $preference . " | " . $value );
    }

    $service->return_success();
}

=head2 set_preferences


sub set_preferences {
    unless ( C4::Context->config( 'demo' ) ) {
        foreach my $param ( $service->query()->param() ) {
            my ( $pref ) = ( $param =~ /pref_(.*)/ );

            next if ( !defined( $pref ) );

            my $value = join( ',', $service->query()->param( $param ) );

            C4::Context->set_preference( $pref, $value );
            logaction( 'SYSTEMPREFERENCE', 'MODIFY', undef, $pref . " | " . $value );
        }
    }

    $service->return_success();
}

$service->dispatch(
    [ 'POST /([A-Za-z0-9_-]+)', [ 'value' ], \&set_preference ],
    [ 'POST /', [], \&set_preferences ],
);




#!/usr/bin/perl

# Copyright 2015 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=head1 NAME

svc/members/delete - web service for deleting a user

=head1 SYNOPSIS

 POST /svc/members/delete

The request parameters go in the POST body.

=head1 DESCRIPTION

This allows users to be deleted on a Koha system from another service.
Information to match on is supplied as POST parameters, a user is searched for,
and any matches are deleted. The field to search on may be an extended
attribute code.

If any borrower that matches can't be deleted, for example it has charges
owing or items on issue, then nothing will be deleted. 

Deleted borrower records will be moved to the deletedborrowers table.

=head1 PARAMETERS

The request can accept a single parameter:

    fieldname=value

The fieldname is either a column in the C<borrowers> table, or the code of an
extended attribute.

=head2 Results

On success, this will return a result in XML form containing a count of the
records deleted. No records matching the search is also considered a success.

On failure, an error will be returned containing the borrower numbers that
caused the operation to fail and the reason.

=cut

use Modern::Perl;

use C4::Context;
use C4::Members;
use C4::Output::XMLStream;
use C4::Service;
use C4::VirtualShelves (); #no import

use Koha::Borrower::Search qw( find_borrower find_borrower_from_ext get_borrower_fields );

process_delete();

sub process_delete {
    my $xml = C4::Output::XMLStream->new(root => 'response');
    my $service = C4::Service->new( { needed_flags => { borrowers => 1 }, output_stream => $xml } );

    my $query = $service->query();
    my @supplied_fields = $query->param();
    # We only allow one supplied field.
    $service->return_error('parameters', 'Only one field to search for is permitted', status=>'failed') if @supplied_fields > 1;
    $service->return_error('parameters', 'A field and value to match against must be provided', status=>'failed') unless @supplied_fields;

    my $fieldname = $supplied_fields[0];
    my $fieldvalue = $query->param($fieldname);

    # Figure out if we need to check the borrower fields or the extended attribs
    my @borrower_fields = get_borrower_fields();
    my @attrib_types = get_extended_attribs();
    my $is_borrower_field = grep { $_ eq $fieldname } @borrower_fields;
    if (!$is_borrower_field && !grep { $_ eq $fieldname} @attrib_types) {
        $service->return_error('parameters', "Invalid parameter provided: $fieldname");
    }

    # Now find who this belongs to
    my @borr_nums;
    eval {
        if ($is_borrower_field) {
            @borr_nums = find_borrower($fieldname, $fieldvalue);
        } else {
            @borr_nums = find_borrower_from_ext($fieldname, $fieldvalue);
        }
    };
    if ($@) {
        $service->return_error('searchfailed', $@, status=>'failed');
    }
    unless (@borr_nums) {
        # no results, automatic success
        $service->output_stream->param(deletedcount => 0);
        $service->output_stream->param(status => 'ok');
        $service->return_success();
        return;
    }

    # Check for charges, issues
    my (@borr_issues, @borr_charges);
    foreach my $b (@borr_nums) {
        my $issues = scalar @{ GetPendingIssues($b) };
        my ($borr_data) = GetMemberDetails($b, '');

        push @borr_issues, $b if $issues;
        push @borr_charges, $b if $borr_data->{flags}->{'CHARGES'};
    }

    if (@borr_issues || @borr_charges) {
        $service->return_error(
            'constraints', 'Non-returned issues or uncleared charges',
            status  => 'failed',
            issues  => join( ',', @borr_issues ),
            charges => join( ',', @borr_charges )
        );
        return;
    }

    # All good, so let's delete
    foreach my $b (@borr_nums) {
        MoveMemberToDeleted($b);
        C4::VirtualShelves::HandleDelBorrower($b);
        DelMember($b);
    }
    $service->output_stream->param(deletedcount => scalar @borr_nums);
    $service->output_stream->param(status => 'ok');
    $service->return_success();
}

=head2 get_extended_attribs

Fetch all the extended attributes from the system. Returns a list.

=cut

sub get_extended_attribs {
    return map { $_->{code} } C4::Members::AttributeTypes::GetAttributeTypes();
}





#!/usr/bin/perl

# Copyright 2015 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

=head1 NAME

svc/members/upsert - web service for inserting and updating user details

=head1 SYNOPSIS

 POST /svc/members/upsert

The request paramters go in the POST body.

=head1 DESCRIPTION

This allows user data to be added and updated on a Koha system from another
service. User data is supplied, and if it matches an existing user, that user
is updated. If not, then a new user is created. A field to match on must be
provided. For example, this might be an ID of the user in an employee
management system. It may be an extended attribute.

=head1 PARAMETERS

The request can contain any field from the borrowers table, and any extended
attribute name. It must also contain 'matchField' which specifies the field
to use to see if the user already exists.

To clear a field, provide an empty parameter for it. If the parameter doesn't
exist, then the field will be left alone.

Dates must be in YYYY-MM-DD form.

Boolean values must be 1 (for true) or 0 (for false.)

A borrowernumber field may be provided and used for matching. It will be
ignored when it comes to creating or updating however.

If the matchField parameters returns more than one value, an error will be
raised. Care should be taken to ensure that it is unique.

=head2 Results

On success, this will return a result in XML form containing the
borrowernumber of the record (whether it's newly created or just updated) and
a 'createOrUpdate' element that contains either 'create' or 'update',
depending on what operation ended up happening.

On error, an error response is returned. This may be because a matchField
was provided that didn't match anything, or because the matchField
produced multiple results. Or probably many other things.

=cut

use Modern::Perl;

use C4::Context;
use C4::Members;
use C4::Members::AttributeTypes;
use C4::Output::XMLStream;
use C4::Service;

use Koha::Borrower::Search
  qw( find_borrower find_borrower_from_ext get_borrower_fields );

process_upsert();

sub process_upsert {
    my $xml = C4::Output::XMLStream->new( root => 'response' );
    my $service = C4::Service->new(
        { needed_flags => { borrowers => 1 }, output_stream => $xml } );

    my $query           = $service->query();
    my @supplied_fields = $query->param();
    my @borrower_fields = get_borrower_fields();
    my @attrib_types    = get_extended_attribs();
    my $match_field     = $query->param('matchField');

    # Make a mapping of these so we can do fast lookups
    my %borrower_fields = map { $_ => 1 } @borrower_fields;
    my %attrib_types    = map { $_ => 1 } @attrib_types;

    $service->return_error(
        'parameters',
        'No matchField provided',
        status => 'failed'
    ) unless $match_field;
    my $is_borrower_field;    # for matchField, as opposed to an ext attribute
    $is_borrower_field = $borrower_fields{$match_field} // 0;
    if ( !$is_borrower_field ) {
        $service->return_error(
            'parameters',
            'Provided matchField doesn\'t match a valid field',
            status => 'failed'
        ) unless $attrib_types{$match_field};
    }
    my $match_value = $query->param($match_field);
    $service->return_error(
        'parameters',
        'The field specified by matchField wasn\'t provided.',
        status => 'failed'
    ) unless $match_value;

    # verify we are only given valid fields, at the same time make a mapping
    # of them.
    my ( %supplied_data_borr, %supplied_data_ext );
    foreach my $f (@supplied_fields) {
        next if $f eq 'matchField';
        $service->return_error( 'parameters', "Invalid parameter provided: $f" )
          unless $borrower_fields{$f} || $attrib_types{$f};
        if ( $borrower_fields{$f} ) {
            $supplied_data_borr{$f} = $query->param($f);
        }
        else {
            $supplied_data_ext{$f} = $query->param($f);
        }
    }

    # Sanity checks and data extraction over, find our borrower.
    my $borr_num;
    eval {
        if ($is_borrower_field) {
            $borr_num = find_borrower( $match_field, $match_value );
        }
        else {
            $borr_num = find_borrower_from_ext( $match_field, $match_value );
        }
    };
    if ($@) {
        $service->return_error( 'borrower', $@, status => 'failed' );
    }

    # Now we know if we're creating a new user, or updating an existing one.
    my $change_type;
    eval {
        if ($borr_num) {
            update_borrower( $borr_num, \%supplied_data_borr,
                \%supplied_data_ext );
            $change_type = 'update';
        }
        else {
            $borr_num =
              create_borrower( \%supplied_data_borr, \%supplied_data_ext );
            $change_type = 'create';
        }
    };
    if ($@) {
        $service->return_error( 'data', $@, status => 'failed' );
    }

    $service->output_stream->param( 'borrowernumber', $borr_num );
    $service->output_stream->param( 'createOrUpdate', $change_type );
    $service->output_stream->param( 'status',         'ok' );
    $service->return_success();
}

=head2 get_extended_attribs

Fetch all the extended attributes from the system. Returns a list.

=cut

sub get_extended_attribs {
    return map { $_->{code} } C4::Members::AttributeTypes::GetAttributeTypes();
}

=head2 update_borrower

    update_borrower($borr_num, \%borrower_fields, \%ext_attrib_fields);

This takes a borrower number, a hashref containing the fields and values for
the borrower, and a hashref containing the fields and values for the extended
attributes. It will update the borrower to set its fields to the values
supplied.

A supplied borrowernumber will be ignored.

=cut

sub update_borrower {
    my ( $borr_num, $borr_fields, $ext_fields ) = @_;

    # For the first phase, we build an update query for the borrower
    my ( @f_borr, @v_borr );
    while ( my ( $f, $v ) = each %$borr_fields ) {
        next if $f =~ /^borrowernumber$/i;
        die "Invalid fieldname provided (update): $f\n" if $f =~ /[^A-Za-z0-9]/;
        push @f_borr, $f;
        push @v_borr, $v;
    }
    my $q_borr =
        'UPDATE borrowers SET '
      . ( join ',', map { $_ . '=?' } @f_borr )
      . ' WHERE borrowernumber=?';

    # Now queries to sort out the extended fields
    my @f_ext = keys %$ext_fields;
    my @v_ext = values %$ext_fields;
    my $q_ext_del =
      'DELETE FROM borrower_attributes WHERE borrowernumber=? AND code IN ('
      . ( join ',', map { '?' } @f_ext ) . ')';
    my $q_ext_add =
'INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (?, ?, ?)';

    my $dbh = C4::Context->dbh();

    # Finally, run these all inside a transaction.
    eval {
        local $dbh->{RaiseError} = 1;
        $dbh->begin_work;

        my $sth;

        if (@f_borr) {
            $sth = $dbh->prepare($q_borr);
            $sth->execute( @v_borr, $borr_num );
        }

        $sth = $dbh->prepare($q_ext_del);
        $sth->execute( $borr_num, @f_ext ) if @f_ext;

        $sth = $dbh->prepare($q_ext_add);
        while ( my ( $f, $v ) = each %$ext_fields ) {
            next if $v eq '';
            $sth->execute( $borr_num, $f, $v );
        }

        $dbh->commit;
    };
    if ($@) {
        $dbh->rollback;
        die "Failed to update borrower record: $@\n";
    }
    return $borr_num;
}

=head2 create_borrower

    my $borr_num = create_borrower(\%borrower_fields, \%ext_attrib_fields);

This creates a new borrower using the supplied data.

A supplied borrowernumber will be ignored.

The borrowernumber of the new borrower will be returned.

=cut

sub create_borrower {
    my ( $borr_fields, $ext_fields ) = @_;

    my @criticals = qw(surname branchcode categorycode);

    # Check we have the ones we need
    foreach my $c (@criticals) {
        die "Critical field missing (create): $c\n" unless $borr_fields->{$c};
    }

    # Borrower fields
    my ( @f_borr, @v_borr );
    while ( my ( $f, $v ) = each %$borr_fields ) {
        die "Invalid fieldname provided: $f\n" if $f =~ /[^A-Za-z0-9]/;
        push @f_borr, $f;
        push @v_borr, $v;
    }
    my $q_borr =
        'INSERT INTO borrowers ('
      . ( join ',', @f_borr )
      . ') VALUES ('
      . ( join ',', map { '?' } @f_borr ) . ')';

    # Extended attributes
    my @f_ext = keys %$ext_fields;
    my @v_ext = values %$ext_fields;
    my $q_ext_add =
'INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (?, ?, ?)';

    my $dbh = C4::Context->dbh();

    # Finally, run these all inside a transaction.
    my $borr_num;
    eval {
        local $dbh->{RaiseError} = 1;
        $dbh->begin_work;

        my $sth = $dbh->prepare($q_borr);
        $sth->execute(@v_borr);
        $borr_num = $dbh->last_insert_id( undef, undef, undef, undef );

        $sth = $dbh->prepare($q_ext_add);
        while ( my ( $f, $v ) = each %$ext_fields ) {
            $sth->execute( $borr_num, $f, $v );
        }

        $dbh->commit;
    };
    if ($@) {
        $dbh->rollback;
        die "Failed to create borrower record: $@\n";
    }
    return $borr_num;
}

Lines 6-12 Link Here

(-)a/t/Output_JSONStream.t (-1 / +10 lines)
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.');




# Copyright 2014 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use Modern::Perl;
use Test::More tests => 15;

BEGIN {
    use_ok('C4::Output::XMLStream');
}

my $xml = C4::Output::XMLStream->new(root => 'root');

is(trim($xml->output), '<?xml version="1.0" encoding="UTF-8"?>
<root></root>
', 'Making sure that blank XML can be output');

$xml->param( issues => [ 'yes!', 'please', 'no' ] );
is(trim($xml->output),'<?xml version="1.0" encoding="UTF-8"?>
<root><issues><array><item>yes!</item><item>please</item><item>no</item></array></issues></root>
',"Making sure XML output has added what we told it to.");

$xml->param( stuff => ['realia'] );
like($xml->output,qr|<stuff><array><item>realia</item></array></stuff>|,"Making sure XML output has added more params correctly.");
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");

$xml->param( stuff => ['fun','love'] );
like($xml->output,qr|<stuff><array><item>fun</item><item>love</item></array></stuff>|,"Making sure XML output can overwrite params");
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");

$xml->param( halibut => { cod => 'bass' } );
like($xml->output,qr|<halibut><cod>bass</cod></halibut>|,"Adding of hashes works");
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");


eval{$xml->param( die )};
ok($@,'Dies');

eval{$xml->param( die => ['yes','sure','now'])};
ok(!$@,'Dosent die.');

eval{$xml->param( die => ['yes','sure','now'], die2 =>)};
ok($@,'Dies.');

$xml->clear();
is(trim($xml->output), '<?xml version="1.0" encoding="UTF-8"?>
<root></root>
', 'Making sure that clearing it clears it.');

is($xml->content_type, 'xml', 'Correct content type is returned');

is($xml->true, '1', 'True is true.');

sub trim {
    $_ = shift;
    s/^\s*(.*?)\s*$/$1/r;
}




#!/usr/bin/perl

# Copyright 2015 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use Modern::Perl;

use DBD::Mock;
use Test::MockModule;

use Test::More tests => 3;

my $module_context = new Test::MockModule('C4::Context');
my $_dbh;
$module_context->mock(
    '_new_dbh',
    sub {
        my $dbh = $_dbh // DBI->connect('DBI:Mock:', '', '') || die "Cannot create handle: $DBI::errstr\n";
        $_dbh = $dbh;
        return $dbh;
    }
);

# We need to mock the Auth process so that we can pretend we have a valid session
my $module_auth = new Test::MockModule('C4::Auth');
$module_auth->mock(
    'check_api_auth',
    sub {
        return ('ok', '', '');
    }
);

# Instead of actually outputting to stdout, we catch things on the way past
my @_out_params;
my $module_output = new Test::MockModule('C4::Output');
$module_output->mock(
    'output_with_http_headers',
    sub {
        @_out_params = @_;
    }
);

use_ok('C4::Output::XMLStream');
use_ok('C4::Service');

# Do a simple round trip test of data in to data out
my $xml_stream = C4::Output::XMLStream->new(root => 'test');

my $service = C4::Service->new( { needed_flags => { borrowers => 1 } ,
        output_stream => $xml_stream });

$service->output_stream->param( foo => 'bar' );

$service->return_success();
like($_out_params[2], qr|<test><foo>bar</foo></test>|, 'XML output generated');






#!/usr/bin/perl

# Copyright 2015 Catalyst IT
#
# This file is part of Koha.
#
# Koha is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation; either version 3 of the License, or (at your option) any later
# version.
#
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Koha; if not, write to the Free Software Foundation, Inc.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

use C4::Context;

use Test::More tests => 10;

use_ok('Koha::Borrower::Search');

my $dbh = C4::Context->dbh;
$dbh->{RaiseError} = 1;
$dbh->{AutoCommit} = 0;

# Insert some borrower detail to fetch later
$dbh->do(q|INSERT INTO branches (branchcode) VALUES ('TBRANCH')|);
$dbh->do(q|INSERT INTO categories (categorycode) VALUES ('TCAT')|);
$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')|);

# An ext attribute
$dbh->do(q|INSERT INTO borrower_attribute_types (code, description) VALUES ('TEXTATTR', 'Test Ext Attrib')|);
$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200000, 'TEXTATTR', 'TESTING')|);
$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200001, 'TEXTATTR', 'TESTING')|);
$dbh->do(q|INSERT INTO borrower_attributes (borrowernumber, code, attribute) VALUES (200002, 'TEXTATTR', 'TESTING2')|);

# And now the actual testing

# Check to make sure a couple of the columns come through.
my @cols = Koha::Borrower::Search::get_borrower_fields();
ok((grep{$_ eq 'cardnumber'} @cols), 'Borrower field 1');
ok((grep{$_ eq 'lost'} @cols), 'Borrower field 2');
ok((grep{$_ eq 'userid'} @cols), 'Borrower field 3');

# Find a borrower by a value
my $num = Koha::Borrower::Search::find_borrower(surname => 'Surname2');
is($num, 200001, 'Fetch single borrower by field');

my @nums = Koha::Borrower::Search::find_borrower(branchcode => 'TBRANCH');
is_deeply(\@nums, [200000, 200001, 200002], 'Fetch multiple borrowers by field');

# Find by ext attr
$num = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING2');
is ($num, 200002, 'Fetch single borrower by ext attr');

my @nums = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING');
is_deeply(\@nums, [200000, 200001], 'Fetch multiple borrowers by ext attr');

# Check that they correctly fail

my $fail = 1;
eval {
    $num = Koha::Borrower::Search::find_borrower(branchcode => 'TBRANCH');
    $fail = 0;
};
is($fail, 1, 'Raised exception for multiple results by field');

$fail = 1;
eval {
    $nums = Koha::Borrower::Search::find_borrower_from_ext(TEXTATTR => 'TESTING');
    $fail = 0;
};
is($fail, 1, 'Raised exception for multiple results by ext attr');

$dbh->rollback;




#!/usr/bin/perl
#
# This Koha test module is a stub!  
# Add more tests here!!!

use strict;
use warnings;

use Test::More tests => 1;

BEGIN {
        use_ok('C4::Service');
}

- 

Return to bug 13607

Lines 71-74 sub output { Link Here

(-)a/C4/Output/JSONStream.pm (+41 lines)
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;

Lines 42-48 batches. Link Here

(-)a/svc/config/systempreferences (-7 / +7 lines)
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	);

Line 0 Link Here

(-)a/C4/Output/XMLStream.pm (+231 lines)
		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

Lines 23-51 C4::Service - functions for JSON webservices. Link Here

(-)a/C4/Service.pm (-46 / +111 lines)
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>

Line 0 Link Here

(-)a/Koha/Borrower/Search.pm (+149 lines)
		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;

Line 0 Link Here

(-)a/svc/members/delete (+154 lines)
		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

Line 0 Link Here

(-)a/svc/members/upsert (+317 lines)
		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	}

Line 0 Link Here

(-)a/t/Output_XMLStream.t (+70 lines)
		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	}

Line 0 Link Here

(-)a/t/Service.t (+71 lines)
		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

Line 0 Link Here

(-)a/t/db_dependent/Borrower_Search.t (+79 lines)
		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;

Lines 1-14 Link Here

(-)a/t/db_dependent/Service.t (-15 lines)
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	-