Attachment #8523 for bug #7613

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




    
    my $dbh = C4::Context->dbh;
    
    my $batch_id = GetZ3950BatchId($filename);
    if ($batch_type eq 'z3950') {
        $batch_id = GetZ3950BatchId($filename);
    } else {
        # create a new one
        $batch_id = AddImportBatch('create_new', 'staging', 'batch', $filename, '');
    }
    my $searchisbn = $dbh->prepare("select biblioitemnumber from biblioitems where isbn=?");
    my $searchissn = $dbh->prepare("select biblioitemnumber from biblioitems where issn=?");
    # FIXME -- not sure that this kind of checking is actually needed




	@ISA    = qw(Exporter);
	@EXPORT = qw(
    GetZ3950BatchId
    GetWebserviceBatchId
    GetImportRecordMarc
    GetImportRecordMarcXML
    AddImportBatch
    GetImportBatch
    AddBiblioToBatch
    AddItemsToImportBiblio
    ModBiblioInBatch

    BatchStageMarcRecords

    CleanBatch

    GetAllImportBatches
    GetStagedWebserviceBatches
    GetImportBatchRangeDesc
    GetNumberOfNonZ3950ImportBatches
    GetImportBibliosRange

    if (defined $rowref) {
        return $rowref->[0];
    } else {
        my $batch_id = AddImportBatch( {
                overlay_action => 'create_new',
                import_status => 'staged',
                batch_type => 'z3950',
                file_name => $z3950server,
            } );
        return $batch_id;
    }
    
}

=head2 GetWebserviceBatchId

  my $batchid = GetWebserviceBatchId();

Retrieves the ID of the import batch for webservice.
If necessary, creates the import batch.

=cut

my $WEBSERVICE_BASE_QRY = <<EOQ;
SELECT import_batch_id FROM import_batches
WHERE  batch_type = 'webservice'
AND    import_status = 'staged'
EOQ
sub GetWebserviceBatchId {
    my ($params) = @_;

    my $dbh = C4::Context->dbh;
    my $sql = $WEBSERVICE_BASE_QRY;
    my @args;
    foreach my $field (qw(matcher_id overlay_action nomatch_action item_action)) {
        if (my $val = $params->{$field}) {
            $sql .= " AND $field = ?";
            push @args, $val;
        }
    }
    my $id = $dbh->selectrow_array($sql, undef, @args);
    return $id if $id;

    $params->{batch_type} = 'webservice';
    $params->{import_status} = 'staged';
    return AddImportBatch($params);
}

=head2 GetImportRecordMarc

  my ($marcblob, $encoding) = GetImportRecordMarc($import_record_id);


}

=head2 GetImportRecordMarcXML

  my $marcxml = GetImportRecordMarcXML($import_record_id);
                                $file_name, $comments);

=cut

sub GetImportRecordMarcXML {
    my ($import_record_id) = @_;

    my $dbh = C4::Context->dbh;
    my $sth = $dbh->prepare("SELECT marcxml FROM import_records WHERE import_record_id = ?");
    $sth->execute($import_record_id);
    my ($marcxml) = $sth->fetchrow();
    $sth->execute($overlay_action, $import_status, $type, $file_name, $comments);
    my $batch_id = $dbh->{'mysql_insertid'};
    $sth->finish();
    return $marcxml;

}

=head2 AddImportBatch

  my $batch_id = AddImportBatch($params_hash);

=cut

sub AddImportBatch {
    my ($params) = @_;

    my (@fields, @vals);
    foreach (qw( matcher_id template_id branchcode
                 overlay_action nomatch_action item_action
                 import_status batch_type file_name comments )) {
        if (exists $params->{$_}) {
            push @fields, $_;
            push @vals, $params->{$_};
        }
    }
    my $dbh = C4::Context->dbh;
    $dbh->do("INSERT INTO import_batches (".join( ',', @fields).")
                                  VALUES (".join( ',', map '?', @fields).")",
             undef,
             @vals);
    return $dbh->{'mysql_insertid'};
}

=head2 GetImportBatch 

        $progress_interval = 0 unless 'CODE' eq ref $progress_callback;
    } 
    
    my $batch_id = AddImportBatch( {
            overlay_action => 'create_new',
            import_status => 'staging',
            batch_type => 'batch',
            file_name => $file_name,
            comments => $comments,
        } );
    if ($parse_items) {
        SetImportBatchItemAction($batch_id, 'always_add');
    } else {

    return $results;
}

=head2 GetStagedWebserviceBatches

  my $batch_ids = GetStagedWebserviceBatches();

Returns a references to an array of batch id's
of batch_type 'webservice' that are not imported

=cut

my $PENDING_WEBSERVICE_BATCHES_QRY = <<EOQ;
SELECT import_batch_id FROM import_batches
WHERE batch_type = 'webservice'
AND import_status = 'staged'
EOQ
sub  GetStagedWebserviceBatches {
    my $dbh = C4::Context->dbh;
    return $dbh->selectcol_arrayref($PENDING_WEBSERVICE_BATCHES_QRY);
}

=head2 GetImportBatchRangeDesc

  my $results = GetImportBatchRangeDesc($offset, $results_per_group);




    return @results;
}

=head2 GetMatcherId

  my $matcher_id = C4::Matcher::GetMatcherId($code);

Returns the matcher_id of a code.

=cut

sub GetMatcherId {
    my ($code) = @_;
    my $dbh = C4::Context->dbh;
    
    my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
    return $matcher_id;
}

=head1 METHODS

=head2 new

Lines 855-861 CREATE TABLE `import_batches` ( Link Here

(-)a/installer/data/mysql/kohastructure.sql (-1 / +1 lines)
855	`nomatch_action` enum('create_new', 'ignore') NOT NULL default 'create_new',	855	`nomatch_action` enum('create_new', 'ignore') NOT NULL default 'create_new',
856	`item_action` enum('always_add', 'add_only_for_matches', 'add_only_for_new', 'ignore') NOT NULL default 'always_add',	856	`item_action` enum('always_add', 'add_only_for_matches', 'add_only_for_new', 'ignore') NOT NULL default 'always_add',
857	`import_status` enum('staging', 'staged', 'importing', 'imported', 'reverting', 'reverted', 'cleaned') NOT NULL default 'staging',	857	`import_status` enum('staging', 'staged', 'importing', 'imported', 'reverting', 'reverted', 'cleaned') NOT NULL default 'staging',
858	`batch_type` enum('batch', 'z3950') NOT NULL default 'batch',	858	`batch_type` enum('batch', 'z3950', 'webservice') NOT NULL default 'batch',
859	`file_name` varchar(100),	859	`file_name` varchar(100),
860	`comments` mediumtext,	860	`comments` mediumtext,
861	PRIMARY KEY (`import_batch_id`),	861	PRIMARY KEY (`import_batch_id`),




    SetVersion($DBversion);
}




$DBversion = "3.07.00.XXX";
if (C4::Context->preference("Version") < TransformToNum($DBversion)) {
    $dbh->do("ALTER TABLE import_batches MODIFY COLUMN batch_type ENUM('batch','z3950','webservice') NOT NULL default 'batch'");
    print "Upgrade to $DBversion done (Add 'webservice' to batch_type enum)\n";
    SetVersion ($DBversion);
}

=head1 FUNCTIONS

=head2 DropAllForeignKeys($table)




#!/usr/bin/perl -w

# Copyright 2012 CatalystIT
#
# 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 2 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 strict;
use warnings;

use Getopt::Long;

my ($help, $config, $daemon);

GetOptions(
    'config|c=s'    => \$config,
    'daemon|d'      => \$daemon,
    'help|?'        => \$help,
);

if($help || !$config){
    print <<EOF
$0 --config=my.conf
Parameters :
  --daemon | d  - go to background; prints pid to stdout
  --config | c  - config file
  --help | ?    - this message

Config file format:
  Lines of the form:
  name: value

  # comments are supported
  No quotes

  Parameter Names:
  host     - ip address or hostname to bind to, defaults all available
  port     - port to bind to, mandatory
  log      - log file path, stderr if omitted
  debug    - dumps requests to the log file, passwords inclusive
  koha     - koha intranet base url, eg http://librarian.koha
  user     - koha user, authentication
  password - koha user password, authentication
  match          - marc_matchers.code: ISBN or ISSN
  overlay_action - import_batches.overlay_action: replace, create_new or ignore
  nomatch_action - import_batches.nomatch_action: create_new or ignore
  item_action    - import_batches.item_action:    always_add,
                      add_only_for_matches, add_only_for_new or ignore
  import_mode    - stage or direct
  framework      - to be used if import_mode is direct

  All process related parameters (all but ip and port) have default values as
  per Koha import process.
EOF
;
    exit;
}

my $server = ImportProxyServer->new($config);

if ($daemon) {
    print $server->background;
} else {
    $server->run;
}

exit;

{
package ImportProxyServer;
       
use Carp;
use IO::Socket::INET;
# use IO::Socket::IP;
use IO::Select;
use POSIX;
use HTTP::Status qw(:constants);

use LWP::UserAgent;
use XML::Simple;

use constant CLIENT_READ_TIMEOUT     => 5;
use constant CLIENT_READ_BUFFER_SIZE => 4 * 1024;
use constant AUTH_URI       => "/cgi-bin/koha/mainpage.pl";
use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";

sub new {
    my $class = shift;
    my $config_file = shift or croak "No config file";

    my $self = {time_to_die => 0, config_file => $config_file };
    bless $self, $class;

    $self->parse_config;
    return $self;
}

sub parse_config {
    my $self = shift;

    my $config_file = $self->{config_file};

    open CONF, $config_file or die "Cannot open config file $config: $!";

    my %param;
    my $line = 0;
    while (<CONF>) {
        $line++;
        chomp;
        s/\s*#.*//o; # remove comments
        s/^\s+//o;   # trim leading spaces
        s/\s+$//o;   # trim trailing spaces
        next unless $_;
        
        my ($p, $v) = m/(\S+?):\s*(.*)/o;
        die "Invalid config line $line: $_" unless defined $v;
        $param{$p} = $v;
    }

    $self->{koha} = delete( $param{koha} )
      or die "No koha base url in config file";
    $self->{user} = delete( $param{user} )
      or die "No koha user in config file";
    $self->{password} = delete( $param{password} )
      or die "No koha user password in config file";

    $self->{host} = delete( $param{host} );
    $self->{port} = delete( $param{port} )
      or die "Port not specified";

    $self->{debug} = delete( $param{debug} );

    my $log_fh;
    close $self->{log_fh} if $self->{log_fh};
    if (my $logfile = delete $param{log}) {
        open $log_fh, ">>$logfile" or die "Cannot open $logfile for write: $!";
    } else {
        $log_fh = \*STDERR;
    }
    $self->{log_fh} = $log_fh;

    my $prefix = "";
    while ( my ($p, $v) = each %param ) {
        $prefix .= "$p: $v\n";
    }

    $self->{prefix} = $prefix;
}

sub log {
    my $self = shift;
    my $log_fh = $self->{log_fh}
      or warn "No log fh",
         return;
    my $t = localtime;
    print $log_fh map "$t: $_\n", @_;
}

sub background {
    my $self = shift;

    my $pid = fork;
    return ($pid) if $pid; # parent

    die "Couldn't fork: $!" unless defined($pid);

    POSIX::setsid() or die "Can't start a new session: $!";

    $SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
    # trap or ignore $SIG{PIPE}
    $SIG{USR1} = sub { $self->parse_config };

    $self->run;
}

sub run {
    my $self = shift;

    my $server_port = $self->{port};
    my $server_host = $self->{host};

    my $server = IO::Socket::INET->new(
        LocalHost => $server_host,
        LocalPort => $server_port,
        Type      => SOCK_STREAM,
        Proto     => "tcp",
        Listen    => 12,
        Blocking  => 1,
        ReuseAddr => 1,
    ) or die "Couldn't be a tcp server on port $server_port: $! $@";

    $self->log("Started tcp listener on $server_host:$server_port");

    $self->{ua} = _ua();

    while ("FOREVER") {
        my $client = $server->accept()
          or die "Cannot accept: $!";
        my $oldfh = select($client);
        $self->handle_request($client);
        select($oldfh);
        last if $self->{time_to_die};
    }

    close($server);
}

sub _ua {
    my $ua = LWP::UserAgent->new;
    $ua->timeout(10);
    $ua->cookie_jar({});
    return $ua;
}

sub read_request {
    my ( $self, $io ) = @_;

    my ($in, @in, $timeout);
    my $select = IO::Select->new($io) ;
    while ( "FOREVER" ) {
        if ( $select->can_read(CLIENT_READ_TIMEOUT) ){
            $io->recv($in, CLIENT_READ_BUFFER_SIZE);
            last unless $in;

            # XXX ignore after NULL
            if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
                push @in, $1;
                last;
            }
            push @in, $in;
        }
        else {
            $timeout = 1;
            last;
        }
    }

    $in = join '', @in;

    my ($xml, $user, $password, $local_user);
    my $data = $in; # copy for diagmostic purposes
    while ( my $first = substr( $data, 0, 1 ) ) {
        $first eq 'U' && do {
            ($user, $data) = _trim_identifier($data);
            next;
        };
        $first eq 'A' && do {
            ($local_user, $data) = _trim_identifier($data);
            next;
        };
        $first eq 'P' && do {
            ($password,, $data) = _trim_identifier($data);
            next;
        };
        $first eq ' ' && do {
            $data = substr( $data, 1 );
            next;
        };
        $first eq '<' && do {
            $xml = $data;
            last;
        };

        last; # unexpected input
    }

    my @details;
    push @details, "Timeout" if $timeout;
    push @details, "User: $user" if $user;
    push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password;
    push @details, "Local user: $local_user" if $local_user;
    unless ($xml) {
        $self->log("Invalid request", $in, @details);
        return;
    }

    $self->log("Request", @details);
    $self->log($in) if $self->{debug};
    return ($xml, $user, $password);
}

sub _trim_identifier {
    my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );

    return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) );
}

sub handle_request {
    my ( $self, $io ) = @_;

    my ($data, $user, $password) = $self->read_request($io)
      or return $self->error_response("Bad request");

    $data = $self->{prefix} . $data;

    my $ua;
    if ($self->{user}) {
        $user = $self->{user};
        $password = $self->{password};
        $ua = $self->{ua};
    }
    else {
        $ua  = _ua(); # fresh one, needs to authenticate
    }

    my $base_url = $self->{koha};
    my $resp = $ua->post( $base_url.IMPORT_SVC_URI, 'Content-Type' => 'text/plain', Content => $data );
    my $status = $resp->code;
    if ($status == HTTP_UNAUTHORIZED || $status == HTTP_FORBIDDEN) {
        my $user = $self->{user};
        my $password = $self->{password};
        $resp = $ua->post( $base_url.AUTH_URI, { userid => $user, password => $password } );
        $resp = $ua->post( $base_url.IMPORT_SVC_URI, 'Content-Type' => 'text/plain', Content => $data )
          if $resp->is_success;
    }
    unless ($resp->is_success) {
        $self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
        return $self->error_response("Unsuccessful request");
    }

    my ($koha_status, $bib, $batch_id, $error);
    if ( my $r = eval { XMLin($resp->content) } ) {
        $koha_status = $r->{status};
        $batch_id    = $r->{import_batch_id};
        $error       = $r->{error};
    }
    else {
        $koha_status = "error";
        $self->log("Response format error:\n$resp->content");
        return $self->error_response("Invalid response");
    }

    if ($koha_status eq "ok") {
        return $self->response( sprintf( "Success. Import batch id: %s", $batch_id ) );
    }

    return $self->error_response( sprintf( "%s.  Please contact administrator.", $error ) );
}

sub error_response {
    my $self = shift;
    $self->response(@_);
}

sub response {
    my $self = shift;
    printf $_[0] . "\0";
}


} # package





#!/usr/bin/perl -w

# Copyright 2012 CatalystIT
#
# 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 2 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 strict;
use warnings;
use utf8;

BEGIN {

    # find Koha's Perl modules
    # test carefully before changing this
    use FindBin;
    eval { require "$FindBin::Bin/../kohalib.pl" };
}

use Getopt::Long;
use Pod::Usage;
use C4::ImportBatch;

my ($help, $framework);

GetOptions(
    'help|?'         => \$help,
    'framework=s'    => \$framework,
);

if($help){
    print <<EOF
$0 --framework=myframework
Parameters :
--help|? This message
--framework default ""
EOF
;
    exit;
}

my $batch_ids = GetStagedWebserviceBatches() or exit;

$framework ||= '';
BatchCommitBibRecords($_, $framework) foreach @$batch_ids;




#!/usr/bin/perl

# Copyright 2012 CatalystIT Ltd
#
# 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 2 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 strict;
use warnings;

use CGI;
use C4::Auth qw/check_api_auth/;
use C4::Context;
use C4::ImportBatch;
use C4::Matcher;
use XML::Simple;
# use Carp::Always; for debugging

my $query = new CGI;
binmode STDOUT, ':encoding(UTF-8)';

my ($status, $cookie, $sessionID) = check_api_auth($query, { editcatalogue => 'edit_catalogue'} );
unless ($status eq "ok") {
    print $query->header(-type => 'text/xml', -status => '403 Forbidden');
    print XMLout({ auth_status => $status }, NoAttr => 1, RootName => 'response', XMLDecl => 1);
    exit 0;
}

my $in;
if ($query->request_method eq "POST") {
    $in = $query->param('POSTDATA');
}
if ($in) {
    my $result = import_bib($in);
    print $query->header(-type => 'text/xml');
    print XMLout($result, NoAttr => 1, RootName => 'response', XMLDecl => 1); 
} else {
    print $query->header(-type => 'text/xml', -status => '400 Bad Request');
}

exit 0;

sub import_bib {
    my ($in) = shift;

    my $result = {};

    unless ($in) {
        $result->{'status'} = "failed";
        $result->{'error'} = "Empty request";
        return $result;
    }

    my ($inparams,  $inxml) = ($in =~ m/^(.*)?(\<\?xml .*)$/s);
    unless ($inxml) {
        $result->{'status'} = "failed";
        $result->{'error'} = "No xml in the request\n$in";
        return $result;
    }

    my %params;
    if ($inparams) {
        # params are "p1: v1\np2: v2\np3: v3..."
        chomp $inparams;
        %params = map { split /:\s*/ } split "\n", $inparams;
    }

    my $import_mode = delete $params{import_mode} || '';
    my $framework   = delete $params{framework}   || '';

    if (my $matcher_code = delete $params{matcher}) {
        $params{matcher_id} = C4::Matcher::GetMatcherId($matcher_code);
    }
    
    my $batch_id = GetWebserviceBatchId(\%params);
    unless ($batch_id) {
        $result->{'status'} = "failed";
        $result->{'error'} = "Batch create error";
        return $result;
    }

    my $marcflavour = C4::Context->preference('marcflavour') || 'MARC21';
    my $marc_record = eval {MARC::Record::new_from_xml( $inxml, "utf8", $marcflavour)};
    if ($@) {
        $result->{'status'} = "failed";
        $result->{'error'} = $@;
        return $result;
    }

    my $import_record_id = AddBiblioToBatch($batch_id, 0, $marc_record, "utf8", int(rand(99999)));
    my @import_items_ids = AddItemsToImportBiblio($batch_id, $import_record_id, $marc_record, 0);
    my $marcxml = GetImportRecordMarcXML($import_record_id);
    unless ($marcxml) {
        $result->{'status'} = "failed";
        $result->{'error'} = "database write error";
        return $result;
    }
    $marcxml =~ s/<\?xml.*?\?>//i;

    # XXX we are ignoring the result of this;
    BatchCommitBibRecords($batch_id, $framework) if lc($import_mode) eq 'direct';

    $result->{'status'} = "ok";
    $result->{'import_batch_id'} =  $batch_id;
    $result->{'marcxml'} =  $marcxml;
    return $result;
}

Lines 118-128 sub add_import_batch { Link Here

(-)a/t/db_dependent/lib/KohaTest/ImportBatch.pm (-5 / +1 lines)
118	file_name => 'foo',	118	file_name => 'foo',
119	comments => 'inserted during automated testing',	119	comments => 'inserted during automated testing',
120	};	120	};
121	my $batch_id = AddImportBatch( $test_batch->{'overlay_action'},	121	my $batch_id = AddImportBatch( $test_batch );
122	$test_batch->{'import_status'},
123	$test_batch->{'batch_type'},
124	$test_batch->{'file_name'},
125	$test_batch->{'comments'}, );
126	return $batch_id;	122	return $batch_id;
127	}	123	}
128		124




package KohaTest::ImportBatch::AddImportBatch;
use base qw( KohaTest::ImportBatch );

use strict;
use warnings;

use Test::More;

use C4::ImportBatch;
use C4::Matcher;
use C4::Biblio;


=head3 add_one

=cut

sub add_one : Test( 1 ) {
    my $self = shift;

    my $batch_id = AddImportBatch(
        'create_new',                           #overlay_action
        'staging',                              # import_status
        'batch',                                # batc_type
        'foo',                                  # file_name
        'inserted during automated testing',    # comments
    );
    ok( $batch_id, "successfully inserted batch: $batch_id" );
}

1;




        file_name      => 'foo',
        comments       => 'inserted during automated testing',
    };
    my $batch_id = AddImportBatch($batch);
      $batch->{'overlay_action'},
      $batch->{'import_status'},
      $batch->{'batch_type'},
      $batch->{'file_name'},
      $batch->{'comments'},
    );
    ok( $batch_id, "successfully inserted batch: $batch_id" );

    my $retrieved = GetImportBatch( $batch_id );
- 

Return to bug 7613

Lines 76-88 sub ImportBreeding { Link Here

(-)a/C4/Breeding.pm (-7 / +1 lines)
76		76
77	my $dbh = C4::Context->dbh;	77	my $dbh = C4::Context->dbh;
78		78
79	my $batch_id = 0;	79	my $batch_id = GetZ3950BatchId($filename);
80	if ($batch_type eq 'z3950') {
81	$batch_id = GetZ3950BatchId($filename);
82	} else {
83	# create a new one
84	$batch_id = AddImportBatch('create_new', 'staging', 'batch', $filename, '');
85	}
86	my $searchisbn = $dbh->prepare("select biblioitemnumber from biblioitems where isbn=?");	80	my $searchisbn = $dbh->prepare("select biblioitemnumber from biblioitems where isbn=?");
87	my $searchissn = $dbh->prepare("select biblioitemnumber from biblioitems where issn=?");	81	my $searchissn = $dbh->prepare("select biblioitemnumber from biblioitems where issn=?");
88	# FIXME -- not sure that this kind of checking is actually needed	82	# FIXME -- not sure that this kind of checking is actually needed

Lines 35-44 BEGIN { Link Here

(-)a/C4/ImportBatch.pm (-13 / +103 lines)
35	@ISA = qw(Exporter);	35	@ISA = qw(Exporter);
36	@EXPORT = qw(	36	@EXPORT = qw(
37	GetZ3950BatchId	37	GetZ3950BatchId
		38	GetWebserviceBatchId
38	GetImportRecordMarc	39	GetImportRecordMarc
		40	GetImportRecordMarcXML
39	AddImportBatch	41	AddImportBatch
40	GetImportBatch	42	GetImportBatch
41	AddBiblioToBatch	43	AddBiblioToBatch
		44	AddItemsToImportBiblio
42	ModBiblioInBatch	45	ModBiblioInBatch
43		46
44	BatchStageMarcRecords	47	BatchStageMarcRecords
Lines 48-53 BEGIN { Link Here
48	CleanBatch	51	CleanBatch
49		52
50	GetAllImportBatches	53	GetAllImportBatches
		54	GetStagedWebserviceBatches
51	GetImportBatchRangeDesc	55	GetImportBatchRangeDesc
52	GetNumberOfNonZ3950ImportBatches	56	GetNumberOfNonZ3950ImportBatches
53	GetImportBibliosRange	57	GetImportBibliosRange
Lines 105-116 sub GetZ3950BatchId { Link Here
105	if (defined $rowref) {	109	if (defined $rowref) {
106	return $rowref->[0];	110	return $rowref->[0];
107	} else {	111	} else {
108	my $batch_id = AddImportBatch('create_new', 'staged', 'z3950', $z3950server, '');	112	my $batch_id = AddImportBatch( {
		113	overlay_action => 'create_new',
		114	import_status => 'staged',
		115	batch_type => 'z3950',
		116	file_name => $z3950server,
		117	} );
109	return $batch_id;	118	return $batch_id;
110	}	119	}
111		120
112	}	121	}
113		122
		123	=head2 GetWebserviceBatchId
		124
		125	my $batchid = GetWebserviceBatchId();
		126
		127	Retrieves the ID of the import batch for webservice.
		128	If necessary, creates the import batch.
		129
		130	=cut
		131
		132	my $WEBSERVICE_BASE_QRY = <<EOQ;
		133	SELECT import_batch_id FROM import_batches
		134	WHERE batch_type = 'webservice'
		135	AND import_status = 'staged'
		136	EOQ
		137	sub GetWebserviceBatchId {
		138	my ($params) = @_;
		139
		140	my $dbh = C4::Context->dbh;
		141	my $sql = $WEBSERVICE_BASE_QRY;
		142	my @args;
		143	foreach my $field (qw(matcher_id overlay_action nomatch_action item_action)) {
		144	if (my $val = $params->{$field}) {
		145	$sql .= " AND $field = ?";
		146	push @args, $val;
		147	}
		148	}
		149	my $id = $dbh->selectrow_array($sql, undef, @args);
		150	return $id if $id;
		151
		152	$params->{batch_type} = 'webservice';
		153	$params->{import_status} = 'staged';
		154	return AddImportBatch($params);
		155	}
		156
114	=head2 GetImportRecordMarc	157	=head2 GetImportRecordMarc
115		158
116	my ($marcblob, $encoding) = GetImportRecordMarc($import_record_id);	159	my ($marcblob, $encoding) = GetImportRecordMarc($import_record_id);
Lines 129-154 sub GetImportRecordMarc { Link Here
129		172
130	}	173	}
131		174
132	=head2 AddImportBatch	175	=head2 GetImportRecordMarcXML
133		176
134	my $batch_id = AddImportBatch($overlay_action, $import_status, $type,	177	my $marcxml = GetImportRecordMarcXML($import_record_id);
135	$file_name, $comments);
136		178
137	=cut	179	=cut
138		180
139	sub AddImportBatch {	181	sub GetImportRecordMarcXML {
140	my ($overlay_action, $import_status, $type, $file_name, $comments) = @_;	182	my ($import_record_id) = @_;
141		183
142	my $dbh = C4::Context->dbh;	184	my $dbh = C4::Context->dbh;
143	my $sth = $dbh->prepare("INSERT INTO import_batches (overlay_action, import_status, batch_type,	185	my $sth = $dbh->prepare("SELECT marcxml FROM import_records WHERE import_record_id = ?");
144	file_name, comments)	186	$sth->execute($import_record_id);
145	VALUES (?, ?, ?, ?, ?)");	187	my ($marcxml) = $sth->fetchrow();
146	$sth->execute($overlay_action, $import_status, $type, $file_name, $comments);
147	my $batch_id = $dbh->{'mysql_insertid'};
148	$sth->finish();	188	$sth->finish();
		189	return $marcxml;
		190
		191	}
		192
		193	=head2 AddImportBatch
149		194
150	return $batch_id;	195	my $batch_id = AddImportBatch($params_hash);
		196
		197	=cut
151		198
		199	sub AddImportBatch {
		200	my ($params) = @_;
		201
		202	my (@fields, @vals);
		203	foreach (qw( matcher_id template_id branchcode
		204	overlay_action nomatch_action item_action
		205	import_status batch_type file_name comments )) {
		206	if (exists $params->{$_}) {
		207	push @fields, $_;
		208	push @vals, $params->{$_};
		209	}
		210	}
		211	my $dbh = C4::Context->dbh;
		212	$dbh->do("INSERT INTO import_batches (".join( ',', @fields).")
		213	VALUES (".join( ',', map '?', @fields).")",
		214	undef,
		215	@vals);
		216	return $dbh->{'mysql_insertid'};
152	}	217	}
153		218
154	=head2 GetImportBatch	219	=head2 GetImportBatch
Lines 237-243 sub BatchStageMarcRecords { Link Here
237	$progress_interval = 0 unless 'CODE' eq ref $progress_callback;	302	$progress_interval = 0 unless 'CODE' eq ref $progress_callback;
238	}	303	}
239		304
240	my $batch_id = AddImportBatch('create_new', 'staging', 'batch', $file_name, $comments);	305	my $batch_id = AddImportBatch( {
		306	overlay_action => 'create_new',
		307	import_status => 'staging',
		308	batch_type => 'batch',
		309	file_name => $file_name,
		310	comments => $comments,
		311	} );
241	if ($parse_items) {	312	if ($parse_items) {
242	SetImportBatchItemAction($batch_id, 'always_add');	313	SetImportBatchItemAction($batch_id, 'always_add');
243	} else {	314	} else {
Lines 700-705 sub GetAllImportBatches { Link Here
700	return $results;	771	return $results;
701	}	772	}
702		773
		774	=head2 GetStagedWebserviceBatches
		775
		776	my $batch_ids = GetStagedWebserviceBatches();
		777
		778	Returns a references to an array of batch id's
		779	of batch_type 'webservice' that are not imported
		780
		781	=cut
		782
		783	my $PENDING_WEBSERVICE_BATCHES_QRY = <<EOQ;
		784	SELECT import_batch_id FROM import_batches
		785	WHERE batch_type = 'webservice'
		786	AND import_status = 'staged'
		787	EOQ
		788	sub GetStagedWebserviceBatches {
		789	my $dbh = C4::Context->dbh;
		790	return $dbh->selectcol_arrayref($PENDING_WEBSERVICE_BATCHES_QRY);
		791	}
		792
703	=head2 GetImportBatchRangeDesc	793	=head2 GetImportBatchRangeDesc
704		794
705	my $results = GetImportBatchRangeDesc($offset, $results_per_group);	795	my $results = GetImportBatchRangeDesc($offset, $results_per_group);

Lines 4994-4999 if ( C4::Context->preference("Version") lt TransformToNum($DBversion) ) { Link Here

(-)a/installer/data/mysql/updatedatabase.pl (+10 lines)
4994	SetVersion($DBversion);	4994	SetVersion($DBversion);
4995	}	4995	}
4996		4996
		4997
		4998
		4999
		5000	$DBversion = "3.07.00.XXX";
		5001	if (C4::Context->preference("Version") < TransformToNum($DBversion)) {
		5002	$dbh->do("ALTER TABLE import_batches MODIFY COLUMN batch_type ENUM('batch','z3950','webservice') NOT NULL default 'batch'");
		5003	print "Upgrade to $DBversion done (Add 'webservice' to batch_type enum)\n";
		5004	SetVersion ($DBversion);
		5005	}
		5006
4997	=head1 FUNCTIONS	5007	=head1 FUNCTIONS
4998		5008
4999	=head2 DropAllForeignKeys($table)	5009	=head2 DropAllForeignKeys($table)

Lines 95-100 sub GetMatcherList { Link Here

(-)a/C4/Matcher.pm (+16 lines)
95	return @results;	95	return @results;
96	}	96	}
97		97
		98	=head2 GetMatcherId
		99
		100	my $matcher_id = C4::Matcher::GetMatcherId($code);
		101
		102	Returns the matcher_id of a code.
		103
		104	=cut
		105
		106	sub GetMatcherId {
		107	my ($code) = @_;
		108	my $dbh = C4::Context->dbh;
		109
		110	my $matcher_id = $dbh->selectrow_array("SELECT matcher_id FROM marc_matchers WHERE code = ?", undef, $code);
		111	return $matcher_id;
		112	}
		113
98	=head1 METHODS	114	=head1 METHODS
99		115
100	=head2 new	116	=head2 new

Line 0 Link Here

(-)a/misc/bin/connexion_import_daemon.pl (+364 lines)
		1	#!/usr/bin/perl -w
		2
		3	# Copyright 2012 CatalystIT
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along
		17	# with Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19
		20	use strict;
		21	use warnings;
		22
		23	use Getopt::Long;
		24
		25	my ($help, $config, $daemon);
		26
		27	GetOptions(
		28	'config\|c=s' => \$config,
		29	'daemon\|d' => \$daemon,
		30	'help\|?' => \$help,
		31	);
		32
		33	if($help \|\| !$config){
		34	print <<EOF
		35	$0 --config=my.conf
		36	Parameters :
		37	--daemon \| d - go to background; prints pid to stdout
		38	--config \| c - config file
		39	--help \| ? - this message
		40
		41	Config file format:
		42	Lines of the form:
		43	name: value
		44
		45	# comments are supported
		46	No quotes
		47
		48	Parameter Names:
		49	host - ip address or hostname to bind to, defaults all available
		50	port - port to bind to, mandatory
		51	log - log file path, stderr if omitted
		52	debug - dumps requests to the log file, passwords inclusive
		53	koha - koha intranet base url, eg http://librarian.koha
		54	user - koha user, authentication
		55	password - koha user password, authentication
		56	match - marc_matchers.code: ISBN or ISSN
		57	overlay_action - import_batches.overlay_action: replace, create_new or ignore
		58	nomatch_action - import_batches.nomatch_action: create_new or ignore
		59	item_action - import_batches.item_action: always_add,
		60	add_only_for_matches, add_only_for_new or ignore
		61	import_mode - stage or direct
		62	framework - to be used if import_mode is direct
		63
		64	All process related parameters (all but ip and port) have default values as
65	per Koha import process.
66	EOF
67	;
68	exit;
69	}
70
71	my $server = ImportProxyServer->new($config);
72
73	if ($daemon) {
74	print $server->background;
75	} else {
76	$server->run;
77	}
78
79	exit;
80
81	{
82	package ImportProxyServer;
83
84	use Carp;
85	use IO::Socket::INET;
86	# use IO::Socket::IP;
87	use IO::Select;
88	use POSIX;
89	use HTTP::Status qw(:constants);
90
91	use LWP::UserAgent;
92	use XML::Simple;
93
94	use constant CLIENT_READ_TIMEOUT => 5;
95	use constant CLIENT_READ_BUFFER_SIZE => 4 * 1024;
96	use constant AUTH_URI => "/cgi-bin/koha/mainpage.pl";
97	use constant IMPORT_SVC_URI => "/cgi-bin/koha/svc/import_bib";
98
99	sub new {
100	my $class = shift;
101	my $config_file = shift or croak "No config file";
102
103	my $self = {time_to_die => 0, config_file => $config_file };
104	bless $self, $class;
105
106	$self->parse_config;
107	return $self;
108	}
109
110	sub parse_config {
111	my $self = shift;
112
113	my $config_file = $self->{config_file};
114
115	open CONF, $config_file or die "Cannot open config file $config: $!";
116
117	my %param;
118	my $line = 0;
119	while (<CONF>) {
120	$line++;
121	chomp;
122	s/\s#.//o; # remove comments
123	s/^\s+//o; # trim leading spaces
124	s/\s+$//o; # trim trailing spaces
125	next unless $_;
126
127	my ($p, $v) = m/(\S+?):\s(.)/o;
128	die "Invalid config line $line: $_" unless defined $v;
129	$param{$p} = $v;
130	}
131
132	$self->{koha} = delete( $param{koha} )
133	or die "No koha base url in config file";
134	$self->{user} = delete( $param{user} )
135	or die "No koha user in config file";
136	$self->{password} = delete( $param{password} )
137	or die "No koha user password in config file";
138
139	$self->{host} = delete( $param{host} );
140	$self->{port} = delete( $param{port} )
141	or die "Port not specified";
142
143	$self->{debug} = delete( $param{debug} );
144
145	my $log_fh;
146	close $self->{log_fh} if $self->{log_fh};
147	if (my $logfile = delete $param{log}) {
148	open $log_fh, ">>$logfile" or die "Cannot open $logfile for write: $!";
149	} else {
150	$log_fh = \*STDERR;
151	}
152	$self->{log_fh} = $log_fh;
153
154	my $prefix = "";
155	while ( my ($p, $v) = each %param ) {
156	$prefix .= "$p: $v\n";
157	}
158
159	$self->{prefix} = $prefix;
160	}
161
162	sub log {
163	my $self = shift;
164	my $log_fh = $self->{log_fh}
165	or warn "No log fh",
166	return;
167	my $t = localtime;
168	print $log_fh map "$t: $_\n", @_;
169	}
170
171	sub background {
172	my $self = shift;
173
174	my $pid = fork;
175	return ($pid) if $pid; # parent
176
177	die "Couldn't fork: $!" unless defined($pid);
178
179	POSIX::setsid() or die "Can't start a new session: $!";
180
181	$SIG{INT} = $SIG{TERM} = $SIG{HUP} = sub { $self->{time_to_die} = 1 };
182	# trap or ignore $SIG{PIPE}
183	$SIG{USR1} = sub { $self->parse_config };
184
185	$self->run;
186	}
187
188	sub run {
189	my $self = shift;
190
191	my $server_port = $self->{port};
192	my $server_host = $self->{host};
193
194	my $server = IO::Socket::INET->new(
195	LocalHost => $server_host,
196	LocalPort => $server_port,
197	Type => SOCK_STREAM,
198	Proto => "tcp",
199	Listen => 12,
200	Blocking => 1,
201	ReuseAddr => 1,
202	) or die "Couldn't be a tcp server on port $server_port: $! $@";
203
204	$self->log("Started tcp listener on $server_host:$server_port");
205
206	$self->{ua} = _ua();
207
208	while ("FOREVER") {
209	my $client = $server->accept()
210	or die "Cannot accept: $!";
211	my $oldfh = select($client);
212	$self->handle_request($client);
213	select($oldfh);
214	last if $self->{time_to_die};
215	}
216
217	close($server);
218	}
219
220	sub _ua {
221	my $ua = LWP::UserAgent->new;
222	$ua->timeout(10);
223	$ua->cookie_jar({});
224	return $ua;
225	}
226
227	sub read_request {
228	my ( $self, $io ) = @_;
229
230	my ($in, @in, $timeout);
231	my $select = IO::Select->new($io) ;
232	while ( "FOREVER" ) {
233	if ( $select->can_read(CLIENT_READ_TIMEOUT) ){
234	$io->recv($in, CLIENT_READ_BUFFER_SIZE);
235	last unless $in;
236
237	# XXX ignore after NULL
238	if ( $in =~ m/^(.*)\000/so ) { # null received, EOT
239	push @in, $1;
240	last;
241	}
242	push @in, $in;
243	}
244	else {
245	$timeout = 1;
246	last;
247	}
248	}
249
250	$in = join '', @in;
251
252	my ($xml, $user, $password, $local_user);
253	my $data = $in; # copy for diagmostic purposes
254	while ( my $first = substr( $data, 0, 1 ) ) {
255	$first eq 'U' && do {
256	($user, $data) = _trim_identifier($data);
257	next;
258	};
259	$first eq 'A' && do {
260	($local_user, $data) = _trim_identifier($data);
261	next;
262	};
263	$first eq 'P' && do {
264	($password,, $data) = _trim_identifier($data);
265	next;
266	};
267	$first eq ' ' && do {
268	$data = substr( $data, 1 );
269	next;
270	};
271	$first eq '<' && do {
272	$xml = $data;
273	last;
274	};
275
276	last; # unexpected input
277	}
278
279	my @details;
280	push @details, "Timeout" if $timeout;
281	push @details, "User: $user" if $user;
282	push @details, "Password: " . ( $self->{debug} ? $password : ("x" x length($password)) ) if $password;
283	push @details, "Local user: $local_user" if $local_user;
284	unless ($xml) {
285	$self->log("Invalid request", $in, @details);
286	return;
287	}
288
289	$self->log("Request", @details);
290	$self->log($in) if $self->{debug};
291	return ($xml, $user, $password);
292	}
293
294	sub _trim_identifier {
295	my ($a, $len) = unpack "cc", substr( $_[0], 0, 2 );
296
297	return ( substr( $_[0], 2, $len ), substr( $_[0], 2 + $len ) );
298	}
299
300	sub handle_request {
301	my ( $self, $io ) = @_;
302
303	my ($data, $user, $password) = $self->read_request($io)
304	or return $self->error_response("Bad request");
305
306	$data = $self->{prefix} . $data;
307
308	my $ua;
309	if ($self->{user}) {
310	$user = $self->{user};
311	$password = $self->{password};
312	$ua = $self->{ua};
313	}
314	else {
315	$ua = _ua(); # fresh one, needs to authenticate
316	}
317
318	my $base_url = $self->{koha};
319	my $resp = $ua->post( $base_url.IMPORT_SVC_URI, 'Content-Type' => 'text/plain', Content => $data );
320	my $status = $resp->code;
321	if ($status == HTTP_UNAUTHORIZED \|\| $status == HTTP_FORBIDDEN) {
322	my $user = $self->{user};
323	my $password = $self->{password};
324	$resp = $ua->post( $base_url.AUTH_URI, { userid => $user, password => $password } );
325	$resp = $ua->post( $base_url.IMPORT_SVC_URI, 'Content-Type' => 'text/plain', Content => $data )
326	if $resp->is_success;
327	}
328	unless ($resp->is_success) {
329	$self->log("Unsuccessful request", $resp->request->as_string, $resp->as_string);
330	return $self->error_response("Unsuccessful request");
331	}
332
333	my ($koha_status, $bib, $batch_id, $error);
334	if ( my $r = eval { XMLin($resp->content) } ) {
335	$koha_status = $r->{status};
336	$batch_id = $r->{import_batch_id};
337	$error = $r->{error};
338	}
339	else {
340	$koha_status = "error";
341	$self->log("Response format error:\n$resp->content");
342	return $self->error_response("Invalid response");
343	}
344
345	if ($koha_status eq "ok") {
346	return $self->response( sprintf( "Success. Import batch id: %s", $batch_id ) );
347	}
348
349	return $self->error_response( sprintf( "%s. Please contact administrator.", $error ) );
350	}
351
352	sub error_response {
353	my $self = shift;
354	$self->response(@_);
355	}
356
357	sub response {
358	my $self = shift;
359	printf $_[0] . "\0";
360	}
361
362
363	} # package
364

Line 0 Link Here

(-)a/misc/cronjobs/import_webservice_batch.pl (+57 lines)
	1	#!/usr/bin/perl -w
	2
	3	# Copyright 2012 CatalystIT
	4	#
	5	# This file is part of Koha.
	6	#
	7	# Koha is free software; you can redistribute it and/or modify it under the
	8	# terms of the GNU General Public License as published by the Free Software
	9	# Foundation; either version 2 of the License, or (at your option) any later
	10	# version.
	11	#
	12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
	13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
	14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
	15	#
	16	# You should have received a copy of the GNU General Public License along
	17	# with Koha; if not, write to the Free Software Foundation, Inc.,
	18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
	19
	20	use strict;
	21	use warnings;
	22	use utf8;
	23
	24	BEGIN {
	25
	26	# find Koha's Perl modules
	27	# test carefully before changing this
	28	use FindBin;
	29	eval { require "$FindBin::Bin/../kohalib.pl" };
	30	}
	31
	32	use Getopt::Long;
	33	use Pod::Usage;
	34	use C4::ImportBatch;
	35
	36	my ($help, $framework);
	37
	38	GetOptions(
	39	'help\|?' => \$help,
	40	'framework=s' => \$framework,
	41	);
	42
	43	if($help){
	44	print <<EOF
	45	$0 --framework=myframework
	46	Parameters :
	47	--help\|? This message
	48	--framework default ""
	49	EOF
	50	;
	51	exit;
	52	}
	53
	54	my $batch_ids = GetStagedWebserviceBatches() or exit;
	55
	56	$framework \|\|= '';
	57	BatchCommitBibRecords($_, $framework) foreach @$batch_ids;

Line 0 Link Here

(-)a/svc/import_bib (+120 lines)
		1	#!/usr/bin/perl
		2
		3	# Copyright 2012 CatalystIT Ltd
		4	#
		5	# This file is part of Koha.
		6	#
		7	# Koha is free software; you can redistribute it and/or modify it under the
		8	# terms of the GNU General Public License as published by the Free Software
		9	# Foundation; either version 2 of the License, or (at your option) any later
		10	# version.
		11	#
		12	# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
		13	# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
		14	# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
		15	#
		16	# You should have received a copy of the GNU General Public License along
		17	# with Koha; if not, write to the Free Software Foundation, Inc.,
		18	# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
		19	#
		20
		21	use strict;
		22	use warnings;
		23
		24	use CGI;
		25	use C4::Auth qw/check_api_auth/;
		26	use C4::Context;
		27	use C4::ImportBatch;
		28	use C4::Matcher;
		29	use XML::Simple;
		30	# use Carp::Always; for debugging
		31
		32	my $query = new CGI;
		33	binmode STDOUT, ':encoding(UTF-8)';
		34
		35	my ($status, $cookie, $sessionID) = check_api_auth($query, { editcatalogue => 'edit_catalogue'} );
		36	unless ($status eq "ok") {
		37	print $query->header(-type => 'text/xml', -status => '403 Forbidden');
		38	print XMLout({ auth_status => $status }, NoAttr => 1, RootName => 'response', XMLDecl => 1);
		39	exit 0;
		40	}
		41
		42	my $in;
		43	if ($query->request_method eq "POST") {
		44	$in = $query->param('POSTDATA');
		45	}
		46	if ($in) {
		47	my $result = import_bib($in);
		48	print $query->header(-type => 'text/xml');
		49	print XMLout($result, NoAttr => 1, RootName => 'response', XMLDecl => 1);
		50	} else {
		51	print $query->header(-type => 'text/xml', -status => '400 Bad Request');
		52	}
		53
		54	exit 0;
		55
		56	sub import_bib {
		57	my ($in) = shift;
		58
		59	my $result = {};
		60
		61	unless ($in) {
		62	$result->{'status'} = "failed";
		63	$result->{'error'} = "Empty request";
		64	return $result;
65	}
66
67	my ($inparams, $inxml) = ($in =~ m/^(.)?(\<\?xml .)$/s);
68	unless ($inxml) {
69	$result->{'status'} = "failed";
70	$result->{'error'} = "No xml in the request\n$in";
71	return $result;
72	}
73
74	my %params;
75	if ($inparams) {
76	# params are "p1: v1\np2: v2\np3: v3..."
77	chomp $inparams;
78	%params = map { split /:\s*/ } split "\n", $inparams;
79	}
80
81	my $import_mode = delete $params{import_mode} \|\| '';
82	my $framework = delete $params{framework} \|\| '';
83
84	if (my $matcher_code = delete $params{matcher}) {
85	$params{matcher_id} = C4::Matcher::GetMatcherId($matcher_code);
86	}
87
88	my $batch_id = GetWebserviceBatchId(\%params);
89	unless ($batch_id) {
90	$result->{'status'} = "failed";
91	$result->{'error'} = "Batch create error";
92	return $result;
93	}
94
95	my $marcflavour = C4::Context->preference('marcflavour') \|\| 'MARC21';
96	my $marc_record = eval {MARC::Record::new_from_xml( $inxml, "utf8", $marcflavour)};
97	if ($@) {
98	$result->{'status'} = "failed";
99	$result->{'error'} = $@;
100	return $result;
101	}
102
103	my $import_record_id = AddBiblioToBatch($batch_id, 0, $marc_record, "utf8", int(rand(99999)));
104	my @import_items_ids = AddItemsToImportBiblio($batch_id, $import_record_id, $marc_record, 0);
105	my $marcxml = GetImportRecordMarcXML($import_record_id);
106	unless ($marcxml) {
107	$result->{'status'} = "failed";
108	$result->{'error'} = "database write error";
109	return $result;
110	}
111	$marcxml =~ s/<\?xml.*?\?>//i;
112
113	# XXX we are ignoring the result of this;
114	BatchCommitBibRecords($batch_id, $framework) if lc($import_mode) eq 'direct';
115
116	$result->{'status'} = "ok";
117	$result->{'import_batch_id'} = $batch_id;
118	$result->{'marcxml'} = $marcxml;
119	return $result;
120	}

Lines 1-31 Link Here

(-)a/t/db_dependent/lib/KohaTest/ImportBatch/AddImportBatch.pm (-31 lines)
1	package KohaTest::ImportBatch::AddImportBatch;
2	use base qw( KohaTest::ImportBatch );
3
4	use strict;
5	use warnings;
6
7	use Test::More;
8
9	use C4::ImportBatch;
10	use C4::Matcher;
11	use C4::Biblio;
12
13
14	=head3 add_one
15
16	=cut
17
18	sub add_one : Test( 1 ) {
19	my $self = shift;
20
21	my $batch_id = AddImportBatch(
22	'create_new', #overlay_action
23	'staging', # import_status
24	'batch', # batc_type
25	'foo', # file_name
26	'inserted during automated testing', # comments
27	);
28	ok( $batch_id, "successfully inserted batch: $batch_id" );
29	}
30
31	1;